diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,24 @@ +## 0.2 [2022.08.11] +* The `libffi` library now uses `bracket` internally and should now be + exception-safe. +* There is a now a `ghc-bundled-libffi` `cabal` flag that makes this library + statically link against GHC's bundled copy of `libffi` rather than attempt to + link against the system `libffi`. On the vast majority of GHCs, this is the + most reasonable option, as linking against the system `libffi` is inherently + fragile. As a result, `+ghc-bundled-libffi` is now the defalut setting. See + the [`README`](https://github.com/remiturk/libffi/blob/master/README.md#notes-on-ghcs-bundling-of-libffi) + for more discussion on this point. +* The definition of `Arg` has changed: + + ```diff + -newtype Arg = Arg { unArg :: IO (Ptr CType, Ptr CValue, IO ()) } + +newtype Arg = Arg { unArg :: forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a } + ``` +* The definition of `RetType` has changed: + ```diff + -data RetType a = RetType (Ptr CType) ((Ptr CValue -> IO ()) -> IO a) + +newtype RetType a = RetType { unRetType :: (Ptr CType -> Ptr CValue -> IO ()) -> IO a } + ``` + +## 0.1 [2009.03.17] +* Initial release. diff --git a/Foreign/LibFFI/Base.hs b/Foreign/LibFFI/Base.hs --- a/Foreign/LibFFI/Base.hs +++ b/Foreign/LibFFI/Base.hs @@ -1,50 +1,41 @@ -{- | This module defines the basic libffi machinery. You will need this to create support for new ffi types. -} +{-# LANGUAGE Rank2Types #-} +{- | This module defines the basic libffi machinery. + You will need this to create support for new ffi types. -} module Foreign.LibFFI.Base where import Control.Monad -import Data.List -import Data.Char -import Data.Int -import Data.Word - -import Foreign.C.Types +import Control.Exception import Foreign.Ptr import Foreign.Storable -import Foreign.C.String import Foreign.Marshal -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BSU import Foreign.LibFFI.Internal import Foreign.LibFFI.FFITypes -newtype Arg = Arg { unArg :: IO (Ptr CType, Ptr CValue, IO ()) } +newtype Arg = Arg { unArg :: forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a } customPointerArg :: (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg -customPointerArg newA freeA a = Arg $ do - p <- newA a - pp <- new p - return (ffi_type_pointer, castPtr pp, free pp >> freeA p) +customPointerArg newA freeA a = Arg $ \withArg -> + bracket (newA a) freeA $ \p -> + with p $ \pp -> + withArg ffi_type_pointer (castPtr pp) mkStorableArg :: Storable a => Ptr CType -> a -> Arg -mkStorableArg cType a = Arg $ do - p <- malloc - poke p a - return (cType, castPtr p, free p) +mkStorableArg cType a = Arg $ \withArg -> + with a $ \p -> + withArg cType (castPtr p) -data RetType a = RetType (Ptr CType) ((Ptr CValue -> IO ()) -> IO a) +newtype RetType a = RetType { unRetType :: (Ptr CType -> Ptr CValue -> IO ()) -> IO a } instance Functor RetType where fmap f = withRetType (return . f) withRetType :: (a -> IO b) -> RetType a -> RetType b -withRetType f (RetType cType withPoke) - = RetType cType (withPoke >=> f) +withRetType f (RetType withPoke) = RetType $ withPoke >=> f mkStorableRetType :: Storable a => Ptr CType -> RetType a mkStorableRetType cType - = RetType cType - (\write -> alloca $ \ptr -> write (castPtr ptr) >> peek ptr) + = RetType $ \write -> alloca $ \cValue -> write cType (castPtr cValue) >> peek cValue newStorableStructArgRet :: Storable a => [Ptr CType] -> IO (a -> Arg, RetType a, IO ()) newStorableStructArgRet cTypes = do @@ -59,14 +50,22 @@ return (ffi_type, free ffi_type >> free elements) callFFI :: FunPtr a -> RetType b -> [Arg] -> IO b -callFFI funPtr (RetType cRetType withRet) args - = allocaBytes sizeOf_cif $ \cif -> do - (cTypes, cValues, frees) <- unzip3 `liftM` mapM unArg args - withArray cTypes $ \cTypesPtr -> do - status <- ffi_prep_cif cif ffi_default_abi (genericLength args) cRetType cTypesPtr - unless (status == ffi_ok) $ - error "callFFI: ffi_prep_cif failed" - withArray cValues $ \cValuesPtr -> do - ret <- withRet (\cRet -> ffi_call cif funPtr cRet cValuesPtr) - sequence_ frees - return ret +callFFI funPtr (RetType actRet) args + = allocaBytes sizeOf_cif $ \cif -> + allocaArray n $ \cTypesPtr -> + allocaArray n $ \cValuesPtr -> + let + doCall = actRet $ \cRetType cRetValue -> do + status <- ffi_prep_cif cif ffi_default_abi (fromIntegral n) cRetType cTypesPtr + unless (status == ffi_ok) $ + error "callFFI: ffi_prep_cif failed" + ffi_call cif funPtr cRetValue cValuesPtr + addArg (i, Arg actArg) goArgs + = actArg $ \cType cValue -> do + pokeElemOff cTypesPtr i cType + pokeElemOff cValuesPtr i cValue + goArgs + in + foldr addArg doCall $ zip [0..] args + where + n = length args diff --git a/Foreign/LibFFI/Types.hs b/Foreign/LibFFI/Types.hs --- a/Foreign/LibFFI/Types.hs +++ b/Foreign/LibFFI/Types.hs @@ -6,12 +6,10 @@ argCUInt, argCLong, argCULong, - argInt, argInt8, argInt16, argInt32, argInt64, - argWord, argWord8, argWord16, argWord32, @@ -38,12 +36,10 @@ retCUInt, retCLong, retCULong, - retInt, retInt8, retInt16, retInt32, retInt64, - retWord, retWord8, retWord16, retWord32, @@ -93,8 +89,6 @@ argCULong = mkStorableArg ffi_type_ulong -- | Note that on e.g. x86_64, Int \/= CInt -argInt :: Int -> Arg -argInt = mkStorableArg ffi_type_hs_int argInt8 :: Int8 -> Arg argInt8 = mkStorableArg ffi_type_sint8 argInt16 :: Int16 -> Arg @@ -104,8 +98,6 @@ argInt64 :: Int64 -> Arg argInt64 = mkStorableArg ffi_type_sint64 -argWord :: Word -> Arg -argWord = mkStorableArg ffi_type_hs_word argWord8 :: Word8 -> Arg argWord8 = mkStorableArg ffi_type_uint8 argWord16 :: Word16 -> Arg @@ -131,7 +123,7 @@ argCUChar = mkStorableArg ffi_type_uchar argCWchar :: CWchar -> Arg -argCWchar = mkStorableArg ffi_type_schar +argCWchar = mkStorableArg ffi_type_wchar argPtr :: Ptr a -> Arg argPtr = mkStorableArg ffi_type_pointer @@ -153,7 +145,7 @@ argConstByteString = customPointerArg (flip BSU.unsafeUseAsCString return) (const $ return ()) retVoid :: RetType () -retVoid = RetType ffi_type_void (\write -> write nullPtr >> return ()) +retVoid = RetType (\write -> write ffi_type_void nullPtr >> return ()) retCInt :: RetType CInt retCInt = mkStorableRetType ffi_type_sint @@ -164,8 +156,6 @@ retCULong :: RetType CULong retCULong = mkStorableRetType ffi_type_ulong -retInt :: RetType Int -retInt = mkStorableRetType ffi_type_hs_int retInt8 :: RetType Int8 retInt8 = mkStorableRetType ffi_type_sint8 retInt16 :: RetType Int16 @@ -175,8 +165,6 @@ retInt64 :: RetType Int64 retInt64 = mkStorableRetType ffi_type_sint64 -retWord :: RetType Word -retWord = mkStorableRetType ffi_type_hs_word retWord8 :: RetType Word8 retWord8 = mkStorableRetType ffi_type_uint8 retWord16 :: RetType Word16 @@ -202,7 +190,7 @@ retCUChar = mkStorableRetType ffi_type_uchar retCWchar :: RetType CWchar -retCWchar = mkStorableRetType ffi_type_schar +retCWchar = mkStorableRetType ffi_type_wchar retFunPtr :: RetType a -> RetType (FunPtr a) retFunPtr _ = mkStorableRetType ffi_type_pointer diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,85 @@ +# `libffi` +[![Hackage](https://img.shields.io/hackage/v/libffi.svg)][Hackage: libffi] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/libffi.svg)](http://packdeps.haskellers.com/reverse/libffi) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Linux build](https://github.com/remiturk/libffi/workflows/Haskell-CI/badge.svg)](https://github.com/remiturk/libffi/actions?query=workflow%3AHaskell-CI) + +[Hackage: libffi]: + http://hackage.haskell.org/package/libffi + "libffi package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" + +A binding to `libffi`, allowing C functions of types only known at runtime to be called from Haskell. + +# Notes on GHC's bundling of `libffi` + +This library makes a somewhat unusual choice: by default, it does not +explicitly declare a dependency against the `libffi` C library. This is because +most binary distributions of GHC—that is, GHCs configured without the +`--with-system-libffi` option—bundle their own copies of `libffi`. One of these +copies is statically linked, and another of these copies is dynamically linked. +Moreover, whenever GHC compiles an executable, it will always pass the +necessary flags to link against its static copy of `libffi`, as the GHC runtime +system depends on it. + +When GHC bundles its own copies of `libffi`, if you were to declare, say, an +`extra-libraries: ffi` dependency, then it would not behave in the way that you +would expect. This is because: + +1. The linker flags to link against GHC's static copy of `libffi` always come + first in the final linking step when compiling an executable. As a result, + declaring an `extra-libraries: ffi` dependency won't make much of a + difference, since GHC will always statically link against its own copy of + `libffi` anyway due to the order of linker flags. + +2. Moreover, declaring an `extra-libraries: ffi` dependency can have the + unfortunate side effect of declaring an _unused_ dynamic dependency against + `libffi`. Even worse is the fact that the version of dynamically linked + `libffi` that comes with your operating system may differ from the version + of dynamiclly linked `libffi` that GHC bundles. When the version numbers + differ, this can lead to the compiled executable failing at runtime with + mysterious errors such as: + + ``` + error while loading shared libraries: libffi.so.7: cannot open shared object file: No such file or directory + ``` + + For more information on this point, see + [GHC#15397](https://gitlab.haskell.org/ghc/ghc/-/issues/15397). + +Observation (2) means that when GHC is configured with `--with-system-libffi`, +it is inherently fragile to use `extra-libraries: ffi`. This is an unfortunate +situation, but there is not much that one can do about this short of fixing +GHC#15397 upstream. A workaround would be to configure GHC with +`--with-system-libffi`, but practically speaking, the vast majority of GHC +binary distributions do not configure this way. This includes all versions of +GHC that `ghcup` distributes, so unless we want to exclude most GHC users, we +need some kind of workaround for this issue. + +Our workaround is to rely on observation (1). That is, because GHC always +passes flags to the linker to link against its own static copy of `libffi`, we +can always assume that GHC will handle the `libffi` dependency for us. As a +result, the default behavior for this library is to enable the +`+ghc-bundled-libffi` flag, which means that the library will not declare an +external dependency on `libffi` at all. This is rather unusual, but then again, +GHC bundling its own copies of `libffi` is also unusual. (To our knowledge, +this is the _only_ C library that GHC bundles in this fashion.) + +We have tested out `+ghc-bundled-libffi` on Windows, macOS, and Linux, and it +works as expected. If you encounter any linking oddities with +`+ghc-bundled-libffi`, please file an issue. + +It is worth re-emphasizing that `+ghc-bundled-libffi` will only work if you are +using a binary distribution of GHC that was not configured with the +`--with-system-libffi` option. If you _are_ using such a GHC, then you will +need to use `-ghc-bundle-libffi` (note the minus sign) to disable the flag and +link against your operating system's copy of `libffi`. Unfortunately, `cabal` +does not provide a way to detect whether GHC was configured with +`--with-system-libffi` or not, so the burden is on users to enable or disable +`ghc-bundle-libffi` as appropriate. diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,17 +0,0 @@ -- things are not exception-safe right now -- new api based on something like: - - mkFun :: Fun a -> IO a - - argBool :: Fun a -> Fun (Bool -> a) - argInt :: Fun a -> Fun (Int -> a) - - retBool :: Fun (IO Bool) - retInt :: Fun (IO Int) - - mkFun (argInt . argInt $ retBool) :: IO (Int -> Int -> IO Bool) - - Then, mkFun would call ffi_prep_cif, and the function it returns would call ffi_call, - which could be much more efficient. - However, I don't currently see how to implement mkFun without the function it returns - having to traverse the Fun GADT on each call. diff --git a/examples/CCall.hs b/examples/CCall.hs deleted file mode 100644 --- a/examples/CCall.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Main where - -import Control.Applicative hiding (Alternative(..), many) -import Control.Monad.State.Strict -import Control.Exception hiding (try) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.List -import Data.Int -import Data.Word -import Data.Char -import Text.ParserCombinators.Parsec -import System.IO -import System.Posix.DynamicLinker -import Foreign.C.Types -import Foreign.Ptr -import Foreign.LibFFI -import Prelude hiding (catch) - -instance Applicative (GenParser tok st) where - pure = return - (<*>) = ap - -pRead :: Read a => CharParser st a -pRead = do - s <- getInput - case reads s of - [] -> fail "no reads result" - [(a, s')] -> setInput s' >> return a - _ -> fail "ambiguous reads result" - -data Val = I CInt - | IL CLong - | I8 Int8 - | I16 Int16 - | I32 Int32 - | I64 Int64 - - | U CUInt - | UL CULong - | U8 Word8 - | U16 Word16 - | U32 Word32 - | U64 Word64 - - | Z CSize - - | F CFloat - | D CDouble - - | P (Ptr ()) - | S String - deriving (Eq, Show) - -valToArg val = case val of - I x -> argCInt x - IL x -> argCLong x - I8 x -> argInt8 x - I16 x -> argInt16 x - I32 x -> argInt32 x - I64 x -> argInt64 x - U x -> argCUInt x - UL x -> argCULong x - U8 x -> argWord8 x - U16 x -> argWord16 x - U32 x -> argWord32 x - U64 x -> argWord64 x - Z x -> argCSize x - F x -> argCFloat x - D x -> argCDouble x - P x -> argPtr x - S x -> argString x - -pIdent :: CharParser st String -pIdent = liftM2 (:) (char '_' <|> letter) (many $ char '_' <|> alphaNum) "identifier" - -pArg :: CharParser (Map String Val) Val -pArg = liftM S pRead - <|> do - i <- pRead :: CharParser st Integer - t <- many alphaNum - case t of - "" -> return $ I $ fromIntegral i - "i" -> return $ I $ fromIntegral i - "l" -> return $ IL $ fromIntegral i - "i8" -> return $ I8 $ fromIntegral i - "i16" -> return $ I16 $ fromIntegral i - "i32" -> return $ I32 $ fromIntegral i - "i64" -> return $ I64 $ fromIntegral i - "u" -> return $ U $ fromIntegral i - "ul" -> return $ UL $ fromIntegral i - "u8" -> return $ U8 $ fromIntegral i - "u16" -> return $ U16 $ fromIntegral i - "u32" -> return $ U32 $ fromIntegral i - "u64" -> return $ U64 $ fromIntegral i - "p" -> return $ P $ plusPtr nullPtr $ fromIntegral i - "z" -> return $ Z $ fromIntegral i - _ -> fail "invalid type" - <|> do - x <- pRead :: CharParser st Double - t <- many alphaNum - case t of - "" -> return $ D $ realToFrac x - "s" -> return $ F $ realToFrac x - _ -> fail "invalid type" - <|> do - ident <- pIdent - env <- getState - case Map.lookup ident env of - Nothing -> fail "no such identifier" - Just v -> return v - -pRet :: CharParser st (Maybe (RetType Val)) -pRet = do - t <- many1 alphaNum - case t of - "v" -> return Nothing - "i" -> return $ Just $ fmap I retCInt - "l" -> return $ Just $ fmap IL retCLong - "i8" -> return $ Just $ fmap I8 retInt8 - "i16" -> return $ Just $ fmap I16 retInt16 - "i32" -> return $ Just $ fmap I32 retInt32 - "i64" -> return $ Just $ fmap I64 retInt64 - "u" -> return $ Just $ fmap U retCUInt - "ul" -> return $ Just $ fmap UL retCULong - "u8" -> return $ Just $ fmap U8 retWord8 - "u16" -> return $ Just $ fmap U16 retWord16 - "u32" -> return $ Just $ fmap U32 retWord32 - "u64" -> return $ Just $ fmap U64 retWord64 - "p" -> return $ Just $ fmap P (retPtr retVoid) - "z" -> return $ Just $ fmap Z retCSize - "f" -> return $ Just $ fmap F retCFloat - "d" -> return $ Just $ fmap D retCDouble - "s" -> return $ Just $ fmap S retString - _ -> fail "invalid type" - -pCall :: CharParser (Map String Val) ((String -> IO (FunPtr a)) -> IO (Maybe (String, Val))) -pCall = do - mbAssign <- optionMaybe $ try $ pIdent <* (spaces >> char '=' >> spaces) - mbRet <- pRet - space - sym <- pIdent - vals <- many (space >> pArg) - let call f retType = return $ \load -> load sym >>= \fp -> f <$> callFFI fp retType (map valToArg vals) - case (mbAssign, mbRet) of - (Just ident, Just retType) -> call (Just . (,) ident) retType - (Nothing , Just retType) -> call (Just . (,) "it" ) retType - (Nothing , Nothing ) -> call id (const Nothing <$> retVoid) - (Just ident, Nothing) -> fail "cannot assign void" - -repl env = do - putStr "> " - hFlush stdout - s <- getLine `catch` (\(e :: IOException) -> return ":q") - case s of - ":q" -> return () - ":l" -> do - forM_ (Map.toList env) $ \(ident, val) -> putStrLn $ ident ++ " = " ++ show val - repl env - _ -> do - case words s of - [ident] -> do - case Map.lookup ident env of - Nothing -> putStrLn ("No such identifier: " ++ show ident) - Just val -> print val - repl env - _ -> case runParser pCall env "repl" s of - Left err -> print err >> repl env - Right call -> do - mbAssign <- call (dlsym Default) - `catch` (\(e :: IOException) -> print e >> return Nothing) - repl $ maybe id (uncurry Map.insert) mbAssign env - -main = repl Map.empty diff --git a/examples/CTime.hsc b/examples/CTime.hsc deleted file mode 100644 --- a/examples/CTime.hsc +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module Main where - -#include - -import Foreign.C.Types -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal -import Foreign.LibFFI -import Foreign.LibFFI.Base -import Foreign.LibFFI.FFITypes -import System.Posix.DynamicLinker - -withDLCall :: String -> ((forall a. String -> RetType a -> [Arg] -> IO a) -> IO b) -> IO b -withDLCall lib f = do - withDL lib [RTLD_NOW] $ \dl -> - f $ \sym ret args -> do - p <- dlsym dl sym - callFFI p ret args - -main = do - withDLCall "" $ \call -> do - t <- call "time" retCTime [argPtr nullPtr] - - with t $ \t_p -> do - tm_p <- call "localtime" (retPtr retVoid) [argPtr t_p] - tm <- peek (castPtr tm_p :: Ptr TM) - t' <- call "mktime" retCTime [argPtr tm_p] - print t - print tm - print t' - - withDLCall "./mytime.so" $ \call -> do - t <- call "time" retCTime [argPtr nullPtr] - - -- struct tm actually has a few architecture dependent "hidden" fields... - (argTM, retTM, freeTMType) - <- newStorableStructArgRet $ replicate 9 ffi_type_sint ++ [ffi_type_slong, ffi_type_pointer] - :: IO (TM -> Arg, RetType TM, IO ()) - - tm <- call "mylocaltime" retTM [argCTime t] - t' <- call "mymktime" retCTime [argTM tm] - freeTMType - print t - print tm - print t' - -data TM = TM {sec, min, hour, mday, mon, year, wday, yday, isdst :: CInt} - deriving (Eq, Show) - -instance Storable TM where - alignment _ = #{size int} - sizeOf _ = #{size struct tm} - peek p = do - sec <- #{peek struct tm, tm_sec} p - min <- #{peek struct tm, tm_min} p - hour <- #{peek struct tm, tm_hour} p - mday <- #{peek struct tm, tm_mday} p - mon <- #{peek struct tm, tm_mon} p - year <- #{peek struct tm, tm_year} p - wday <- #{peek struct tm, tm_wday} p - yday <- #{peek struct tm, tm_yday} p - isdst <- #{peek struct tm, tm_isdst} p - return $ TM sec min hour mday mon year wday yday isdst - poke p (TM sec min hour mday mon year wday yday isdst) = do - #{poke struct tm, tm_sec} p sec - #{poke struct tm, tm_min} p min - #{poke struct tm, tm_hour} p hour - #{poke struct tm, tm_mday} p mday - #{poke struct tm, tm_mon} p mon - #{poke struct tm, tm_year} p year - #{poke struct tm, tm_wday} p wday - #{poke struct tm, tm_yday} p yday - #{poke struct tm, tm_isdst} p isdst diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -.PHONY: all clean - -all: MemSpeed CCall CTime mytime.so - -%.o: %.c - gcc $(CFLAGS) -fPIC -c $< - -%.so: %.o - gcc $(LDFLAGS) -nostartfiles -shared -Wl,-soname,$@ $< -o $@ - -mytime.so: mytime.o - -%.hs: %.hsc - hsc2hs -I/usr/lib/ghc-6.10.1/include $< - -%: %.hs - ghc --make $< - -CTime: CTime.hs - -clean: - rm -f MemSpeed CCall CTime CTime.hs *.o *.hi *.so core core.* diff --git a/examples/MemSpeed.hs b/examples/MemSpeed.hs deleted file mode 100644 --- a/examples/MemSpeed.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Main where - -import Control.Monad -import Foreign.C.Types -import Foreign.LibFFI -import System.Posix.DynamicLinker -import Numeric -import CPUTime -import Time -import Ratio -import System.Environment -import System.Exit - -main = withDL "" [RTLD_NOW] $ \dl -> do - args <- getArgs - sz <- case args of - [n] -> return $ (read n * 2^20) `quot` 2 - [] -> putStrLn "usage: MemSpeed megabytes-to-use" >> exitWith (ExitFailure 1) - - memset <- dlsym dl "memset" - memcpy <- dlsym dl "memcpy" - malloc <- dlsym dl "malloc" - free <- dlsym dl "free" - - s <- callFFI malloc (retPtr retVoid) [argCSize sz] - d <- callFFI malloc (retPtr retVoid) [argCSize sz] - check sz "memcpy 1" $ callFFI memcpy retVoid [argPtr d, argPtr s, argCSize sz] - check (10*sz) "memcpy 10" $ replicateM_ 10 $ callFFI memcpy retVoid [argPtr d, argPtr s, argCSize sz] - callFFI free retVoid [argPtr s] - callFFI free retVoid [argPtr d] - - p <- callFFI malloc (retPtr retVoid) [argCSize (2 * sz)] - check (2*sz) "memset 1" $ callFFI memset retVoid [argPtr p, argCInt 97, argCSize (2 * sz)] - check (20*sz) "memset 10" $ replicateM_ 10 $ callFFI memset retVoid [argPtr p, argCInt 97, argCSize (2 * sz)] - callFFI free retVoid [argPtr p] - -check sz s a = do - (r, cpu, clock) <- timeIt a - putStrLn $ s ++ ": " - ++ showf 2 ((fromIntegral sz / cpu) / (2 ^ 20)) ++ " mb/cpu sec " - ++ showf 2 ((fromIntegral sz / clock) / (2 ^ 20)) ++ " mb/clock sec " - return r - -type TimeIt = (Integer, ClockTime) - -timeItStart :: IO TimeIt -timeItStart = liftM2 (,) getCPUTime getClockTime - -timeItEnd :: TimeIt -> IO (Double, Double) -timeItEnd (startCPU, startClock) = do - stopCPU <- getCPUTime - stopClock <- getClockTime - let - cpuTime = (fromIntegral (stopCPU - startCPU) / 10^12) - clockTime = (timeDiffToSec $ diffClockTimes stopClock startClock) - return (cpuTime, clockTime) - where - timeDiffToSec td - = fromIntegral (tdSec td) + fromIntegral (tdPicosec td) / 10^12 - -{- | @timeIt action@ executes @action@, then returns - a tuple of its result, CPU- and wallclock-time elapsed. -} -timeIt :: IO a -> IO (a, Double, Double) -timeIt a = do - t <- timeItStart - r <- a - (cpuTime, clockTime) <- timeItEnd t - return (r, cpuTime, clockTime) - -showf :: RealFloat a => Int -> a -> String -showf n x - | x >= 0 = ' ':s - | otherwise = s - where - s = showFFloat (Just n) x "" diff --git a/examples/mytime.c b/examples/mytime.c deleted file mode 100644 --- a/examples/mytime.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -struct tm mylocaltime(const time_t); -time_t mymktime(struct tm); - -struct tm mylocaltime(const time_t t) -{ - return *localtime(&t); -} - -time_t mymktime(struct tm t) -{ - return mktime(&t); -} diff --git a/libffi.cabal b/libffi.cabal --- a/libffi.cabal +++ b/libffi.cabal @@ -1,23 +1,63 @@ Name: libffi -Version: 0.1 +cabal-version: >= 1.10 +Version: 0.2 Description: A binding to libffi, allowing C functions of types only known at runtime to be called from Haskell. License: BSD3 License-file: LICENSE Copyright: Remi Turk 2008-2009 Author: Remi Turk Maintainer: remi.turk@gmail.com +Homepage: http://haskell.org/haskellwiki/Library/libffi Stability: alpha Synopsis: A binding to libffi -Tested-With: GHC == 6.10.1 -Build-Depends: base, bytestring +Tested-With: GHC == 7.0.4 + , GHC == 7.2.2 + , GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.2 +extra-source-files: CHANGELOG.md, README.md Build-Type: Simple Category: Foreign -exposed-modules: Foreign.LibFFI, - Foreign.LibFFI.Base, - Foreign.LibFFI.Types, - Foreign.LibFFI.FFITypes, - Foreign.LibFFI.Internal -pkgconfig-depends: libffi -extra-libraries: ffi -includes: ffi.h ffitarget.h +flag ghc-bundled-libffi + description: When GHC is configured without @--with-system-libffi@, it + will bundle its own copies of @libffi@, one of them + statically linked and the other dynamically linked. This + flag will force linking against the static copy of @libffi@ + that GHC bundles. This avoids a GHC bug + (https://gitlab.haskell.org/ghc/ghc/-/issues/15397) that + can arise when the linker confuses the system's dynamic + @libffi@ with GHC's own dynamic @libffi@. + + Note that this flag only works when GHC is configured + without the @--with-system-libffi@ option. This is the case + for most GHC binary distributions, such as those provided + by @ghcup@. If you are using a GHC that was configured with + @--with-system-libffi@, however, you will need to disable + this option and link against the system's version of + @libffi@ instead. + default: True + +source-repository head + type: git + location: https://github.com/remiturk/libffi + +library + build-depends: base >= 3 && < 5, bytestring + exposed-modules: Foreign.LibFFI, + Foreign.LibFFI.Base, + Foreign.LibFFI.Types, + Foreign.LibFFI.FFITypes, + Foreign.LibFFI.Internal + if !flag(ghc-bundled-libffi) + pkgconfig-depends: libffi + default-language: Haskell2010