packages feed

libffi 0.1 → 0.2.1

raw patch · 16 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,28 @@+## 0.2.1 [2022.09.24]
+* Add `sizeAndAlignmentOfCType` to `Foreign.LibFFI.Base`, which can be used to
+  retrieve the size and alignment of a `CType`.
+
+## 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.
Foreign/LibFFI.hs view
@@ -1,28 +1,28 @@-{- |-This is the only module that normal users should need to import.--As an example, allocate 1GB of memory, zero it, and crash:--@-import System.Posix.DynamicLinker-import Foreign.Ptr-import Foreign.LibFFI--main = do-    malloc <- dlsym Default \"malloc\"-    memset <- dlsym Default \"memset\"-    p <- callFFI malloc (retPtr retVoid) [argCSize (2^30)]-    callFFI memset (retPtr retVoid) [argPtr p, argCInt 0, argCSize (2^30)]-    callFFI memset (retPtr retVoid) [argPtr nullPtr, argCInt 0, argCSize 1]-@--}-module Foreign.LibFFI-    (Arg-    ,RetType-    ,callFFI-    ,withRetType-    ,module Foreign.LibFFI.Types-    ) where--import Foreign.LibFFI.Base-import Foreign.LibFFI.Types+{- |
+This is the only module that normal users should need to import.
+
+As an example, allocate 1GB of memory, zero it, and crash:
+
+@
+import System.Posix.DynamicLinker
+import Foreign.Ptr
+import Foreign.LibFFI
+
+main = do
+    malloc <- dlsym Default \"malloc\"
+    memset <- dlsym Default \"memset\"
+    p <- callFFI malloc (retPtr retVoid) [argCSize (2^30)]
+    callFFI memset (retPtr retVoid) [argPtr p, argCInt 0, argCSize (2^30)]
+    callFFI memset (retPtr retVoid) [argPtr nullPtr, argCInt 0, argCSize 1]
+@
+-}
+module Foreign.LibFFI
+    (Arg
+    ,RetType
+    ,callFFI
+    ,withRetType
+    ,module Foreign.LibFFI.Types
+    ) where
+
+import Foreign.LibFFI.Base
+import Foreign.LibFFI.Types
Foreign/LibFFI/Base.hs view
@@ -1,72 +1,86 @@-{- | 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 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 ()) }--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)--mkStorableArg :: Storable a => Ptr CType -> a -> Arg-mkStorableArg cType a = Arg $ do-    p <- malloc-    poke p a-    return (cType, castPtr p, free p)--data RetType a = RetType (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)--mkStorableRetType :: Storable a => Ptr CType -> RetType a-mkStorableRetType cType-            = RetType cType-                (\write -> alloca $ \ptr -> write (castPtr ptr) >> peek ptr)--newStorableStructArgRet :: Storable a => [Ptr CType] -> IO (a -> Arg, RetType a, IO ())-newStorableStructArgRet cTypes = do-    (cType, freeit) <- newStructCType cTypes-    return (mkStorableArg cType, mkStorableRetType cType, freeit)--newStructCType  :: [Ptr CType] -> IO (Ptr CType, IO ())-newStructCType cTypes = do-    ffi_type <- mallocBytes sizeOf_ffi_type-    elements <- newArray0 nullPtr cTypes-    init_ffi_type ffi_type elements-    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+{-# 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 Control.Exception
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal
+
+import Foreign.LibFFI.Internal
+import Foreign.LibFFI.FFITypes
+
+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 $ \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 $ \withArg ->
+    with a $ \p ->
+        withArg cType (castPtr p)
+
+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 withPoke) = RetType $ withPoke >=> f
+
+mkStorableRetType :: Storable a => Ptr CType -> RetType a
+mkStorableRetType cType
+    = RetType $ \write -> alloca $ \cValue -> write cType (castPtr cValue) >> peek cValue
+
+newStorableStructArgRet :: Storable a => [Ptr CType] -> IO (a -> Arg, RetType a, IO ())
+newStorableStructArgRet cTypes = do
+    (cType, freeit) <- newStructCType cTypes
+    return (mkStorableArg cType, mkStorableRetType cType, freeit)
+
+newStructCType  :: [Ptr CType] -> IO (Ptr CType, IO ())
+newStructCType cTypes = do
+    ffi_type <- mallocBytes sizeOf_ffi_type
+    elements <- newArray0 nullPtr cTypes
+    init_ffi_type ffi_type elements
+    return (ffi_type, free ffi_type >> free elements)
+
+sizeAndAlignmentOfCType :: Ptr CType -> IO (Int, Int)
+sizeAndAlignmentOfCType cType = do
+  (size, alignment) <- ffi_type_size_and_alignment cType
+  if size /= 0 && alignment /= 0
+  then return (fromIntegral size, fromIntegral alignment)
+  else do
+    -- The type's size and alignment haven't been initialized
+    -- so we force it with a call to `ffi_prep_cif`.
+    status <- allocaBytes sizeOf_cif $ \cif ->
+                ffi_prep_cif cif ffi_default_abi 0 cType nullPtr
+    unless (status == ffi_ok) $
+      error "sizeAndAlignmentOfCType: ffi_prep_cif failed"
+    (size, alignment) <- ffi_type_size_and_alignment cType
+    return (fromIntegral size, fromIntegral alignment)
+
+callFFI :: FunPtr a -> RetType b -> [Arg] -> IO b
+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
Foreign/LibFFI/FFITypes.hs view
@@ -1,85 +1,85 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{- | The pointers exported and used by the C libffi describing basic ffi types. -}-module Foreign.LibFFI.FFITypes where--import Data.Int-import Data.Word-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable--import Foreign.LibFFI.Internal--foreign import ccall unsafe "&" ffi_type_void :: Ptr CType-foreign import ccall unsafe "&" ffi_type_sint8 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_uint8 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_uint16 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_sint16 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_uint32 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_sint32 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_uint64 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_sint64 :: Ptr CType-foreign import ccall unsafe "&" ffi_type_float  :: Ptr CType-foreign import ccall unsafe "&" ffi_type_double :: Ptr CType-foreign import ccall unsafe "&" ffi_type_pointer :: Ptr CType--ffi_type_uchar  :: Ptr CType-ffi_type_uchar  = ffi_type_uint8--ffi_type_schar  :: Ptr CType-ffi_type_schar  = ffi_type_sint8--ffi_type_wchar  :: Ptr CType-ffi_type_wchar  = case sizeOf (undefined :: CWchar) of-                    2   -> ffi_type_sint16-                    4   -> ffi_type_sint32-                    8   -> ffi_type_sint64-                    _   -> error "ffi_type_wchar of unsupported size"--ffi_type_size   :: Ptr CType-ffi_type_size   = case sizeOf (undefined :: CSize) of-                    4   -> ffi_type_uint32-                    8   -> ffi_type_uint64-                    _   -> error "ffi_type_size of unsupported size"--ffi_type_time   :: Ptr CType-ffi_type_time   = case sizeOf (undefined :: CTime) of-                    4   -> ffi_type_sint32-                    8   -> ffi_type_sint64-                    _   -> error "ffi_type_time of unsupported size"--ffi_type_uint   :: Ptr CType-ffi_type_uint   = case sizeOf (undefined :: CUInt) of-                    4   -> ffi_type_uint32-                    8   -> ffi_type_uint64-                    _   -> error "ffi_type_uint of unsupported size"--ffi_type_sint   :: Ptr CType-ffi_type_sint   = case sizeOf (undefined :: CInt) of-                    4   -> ffi_type_sint32-                    8   -> ffi_type_sint64-                    _   -> error "ffi_type_sint of unsupported size"--ffi_type_ulong  :: Ptr CType-ffi_type_ulong  = case sizeOf (undefined :: CULong) of-                    4   -> ffi_type_uint32-                    8   -> ffi_type_uint64-                    _   -> error "ffi_type_ulong of unsupported size"--ffi_type_slong  :: Ptr CType-ffi_type_slong  = case sizeOf (undefined :: CLong) of-                    4   -> ffi_type_sint32-                    8   -> ffi_type_sint64-                    _   -> error "ffi_type_slong of unsupported size"--ffi_type_hs_int :: Ptr CType-ffi_type_hs_int = case sizeOf (undefined :: Int) of-                    4   -> ffi_type_sint32-                    8   -> ffi_type_sint64-                    _   -> error "ffi_type_hs_int: unsupported sizeOf (_ :: Int)"--ffi_type_hs_word :: Ptr CType-ffi_type_hs_word = case sizeOf (undefined :: Word) of-                    4   -> ffi_type_uint32-                    8   -> ffi_type_uint64-                    _   -> error "ffi_type_hs_word: unsupported sizeOf (_ :: Word)"+{-# LANGUAGE ForeignFunctionInterface #-}
+{- | The pointers exported and used by the C libffi describing basic ffi types. -}
+module Foreign.LibFFI.FFITypes where
+
+import Data.Int
+import Data.Word
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Storable
+
+import Foreign.LibFFI.Internal
+
+foreign import ccall unsafe "&" ffi_type_void :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_sint8 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_uint8 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_uint16 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_sint16 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_uint32 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_sint32 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_uint64 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_sint64 :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_float  :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_double :: Ptr CType
+foreign import ccall unsafe "&" ffi_type_pointer :: Ptr CType
+
+ffi_type_uchar  :: Ptr CType
+ffi_type_uchar  = ffi_type_uint8
+
+ffi_type_schar  :: Ptr CType
+ffi_type_schar  = ffi_type_sint8
+
+ffi_type_wchar  :: Ptr CType
+ffi_type_wchar  = case sizeOf (undefined :: CWchar) of
+                    2   -> ffi_type_sint16
+                    4   -> ffi_type_sint32
+                    8   -> ffi_type_sint64
+                    _   -> error "ffi_type_wchar of unsupported size"
+
+ffi_type_size   :: Ptr CType
+ffi_type_size   = case sizeOf (undefined :: CSize) of
+                    4   -> ffi_type_uint32
+                    8   -> ffi_type_uint64
+                    _   -> error "ffi_type_size of unsupported size"
+
+ffi_type_time   :: Ptr CType
+ffi_type_time   = case sizeOf (undefined :: CTime) of
+                    4   -> ffi_type_sint32
+                    8   -> ffi_type_sint64
+                    _   -> error "ffi_type_time of unsupported size"
+
+ffi_type_uint   :: Ptr CType
+ffi_type_uint   = case sizeOf (undefined :: CUInt) of
+                    4   -> ffi_type_uint32
+                    8   -> ffi_type_uint64
+                    _   -> error "ffi_type_uint of unsupported size"
+
+ffi_type_sint   :: Ptr CType
+ffi_type_sint   = case sizeOf (undefined :: CInt) of
+                    4   -> ffi_type_sint32
+                    8   -> ffi_type_sint64
+                    _   -> error "ffi_type_sint of unsupported size"
+
+ffi_type_ulong  :: Ptr CType
+ffi_type_ulong  = case sizeOf (undefined :: CULong) of
+                    4   -> ffi_type_uint32
+                    8   -> ffi_type_uint64
+                    _   -> error "ffi_type_ulong of unsupported size"
+
+ffi_type_slong  :: Ptr CType
+ffi_type_slong  = case sizeOf (undefined :: CLong) of
+                    4   -> ffi_type_sint32
+                    8   -> ffi_type_sint64
+                    _   -> error "ffi_type_slong of unsupported size"
+
+ffi_type_hs_int :: Ptr CType
+ffi_type_hs_int = case sizeOf (undefined :: Int) of
+                    4   -> ffi_type_sint32
+                    8   -> ffi_type_sint64
+                    _   -> error "ffi_type_hs_int: unsupported sizeOf (_ :: Int)"
+
+ffi_type_hs_word :: Ptr CType
+ffi_type_hs_word = case sizeOf (undefined :: Word) of
+                    4   -> ffi_type_uint32
+                    8   -> ffi_type_uint64
+                    _   -> error "ffi_type_hs_word: unsupported sizeOf (_ :: Word)"
Foreign/LibFFI/Internal.hsc view
@@ -1,43 +1,49 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}-{- | The internals of the C library libffi -}-module Foreign.LibFFI.Internal where--#include <ffi.h>--import Data.Int-import Data.Word-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable--data CValue-data CType-data CIF--type C_ffi_status   = (#type ffi_status)-type C_ffi_abi      = (#type ffi_abi)--ffi_default_abi :: C_ffi_abi-ffi_default_abi = #const FFI_DEFAULT_ABI--ffi_ok          :: C_ffi_status-ffi_ok          = #const FFI_OK--sizeOf_cif :: Int-sizeOf_cif = #size ffi_cif--sizeOf_ffi_type :: Int-sizeOf_ffi_type = #size ffi_type--init_ffi_type   :: Ptr CType -> Ptr (Ptr CType) -> IO ()-init_ffi_type cType cTypes = do-    (#poke ffi_type, size) cType (0 :: CSize)-    (#poke ffi_type, alignment) cType (0 :: CUShort)-    (#poke ffi_type, type) cType ((#const FFI_TYPE_STRUCT) :: CUShort)-    (#poke ffi_type, elements) cType cTypes--foreign import ccall safe ffi_prep_cif-    :: Ptr CIF -> C_ffi_abi -> CUInt -> Ptr CType -> Ptr (Ptr CType) -> IO C_ffi_status--foreign import ccall safe ffi_call-    :: Ptr CIF -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO ()+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
+{- | The internals of the C library libffi -}
+module Foreign.LibFFI.Internal where
+
+#include <ffi.h>
+
+import Data.Int
+import Data.Word
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Storable
+
+data CValue
+data CType
+data CIF
+
+type C_ffi_status   = (#type ffi_status)
+type C_ffi_abi      = (#type ffi_abi)
+
+ffi_default_abi :: C_ffi_abi
+ffi_default_abi = #const FFI_DEFAULT_ABI
+
+ffi_ok          :: C_ffi_status
+ffi_ok          = #const FFI_OK
+
+sizeOf_cif :: Int
+sizeOf_cif = #size ffi_cif
+
+sizeOf_ffi_type :: Int
+sizeOf_ffi_type = #size ffi_type
+
+init_ffi_type   :: Ptr CType -> Ptr (Ptr CType) -> IO ()
+init_ffi_type cType cTypes = do
+    (#poke ffi_type, size) cType (0 :: CSize)
+    (#poke ffi_type, alignment) cType (0 :: CUShort)
+    (#poke ffi_type, type) cType ((#const FFI_TYPE_STRUCT) :: CUShort)
+    (#poke ffi_type, elements) cType cTypes
+
+ffi_type_size_and_alignment :: Ptr CType -> IO (CSize, CUShort)
+ffi_type_size_and_alignment cType = do
+  size <- (#peek ffi_type, size) cType
+  alignment <- (#peek ffi_type, alignment) cType
+  return (size, alignment)
+
+foreign import ccall safe ffi_prep_cif
+    :: Ptr CIF -> C_ffi_abi -> CUInt -> Ptr CType -> Ptr (Ptr CType) -> IO C_ffi_status
+
+foreign import ccall safe ffi_call
+    :: Ptr CIF -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO ()
Foreign/LibFFI/Types.hs view
@@ -1,227 +1,215 @@--- | Arguments and return types-module Foreign.LibFFI.Types (-    -- * Arguments-    -- ** Integral types-    argCInt,-    argCUInt,-    argCLong,-    argCULong,-    argInt,-    argInt8,-    argInt16,-    argInt32,-    argInt64,-    argWord,-    argWord8,-    argWord16,-    argWord32,-    argWord64,-    -- ** Floating point types-    argCFloat,-    argCDouble,-    -- ** Various other C types-    argCSize,-    argCTime,-    argCChar,-    argCUChar,-    argCWchar,-    argPtr,-    argFunPtr,-    -- ** Strings-    argString,-    argByteString,-    argConstByteString,-    -- * Return types-    -- ** Integral types-    retVoid,-    retCInt,-    retCUInt,-    retCLong,-    retCULong,-    retInt,-    retInt8,-    retInt16,-    retInt32,-    retInt64,-    retWord,-    retWord8,-    retWord16,-    retWord32,-    retWord64,-    -- ** Floating point types-    retCFloat,-    retCDouble,-    -- ** Various other C types-    retCSize,-    retCTime,-    retCChar,-    retCUChar,-    retCWchar,-    retPtr,-    retFunPtr,-    -- ** Strings-    retCString,-    retString,-    retByteString,-    retMallocByteString-    ) where--import Control.Monad-import Data.List-import Data.Char-import Data.Int-import Data.Word--import Foreign.C.Types-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.Base-import Foreign.LibFFI.FFITypes--argCInt     :: CInt -> Arg-argCInt     = mkStorableArg ffi_type_sint-argCUInt    :: CUInt -> Arg-argCUInt    = mkStorableArg ffi_type_uint-argCLong    :: CLong -> Arg-argCLong    = mkStorableArg ffi_type_slong-argCULong   :: CULong -> Arg-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-argInt16    = mkStorableArg ffi_type_sint16-argInt32    :: Int32 -> Arg-argInt32    = mkStorableArg ffi_type_sint32-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-argWord16   = mkStorableArg ffi_type_uint16-argWord32   :: Word32 -> Arg-argWord32   = mkStorableArg ffi_type_uint32-argWord64   :: Word64 -> Arg-argWord64   = mkStorableArg ffi_type_uint64--argCFloat   :: CFloat -> Arg-argCFloat   = mkStorableArg ffi_type_float-argCDouble  :: CDouble -> Arg-argCDouble  = mkStorableArg ffi_type_double--argCSize    :: CSize -> Arg-argCSize    = mkStorableArg ffi_type_size-argCTime    :: CTime -> Arg-argCTime    = mkStorableArg ffi_type_size--argCChar    :: CChar -> Arg-argCChar    = mkStorableArg ffi_type_schar-argCUChar   :: CUChar -> Arg-argCUChar   = mkStorableArg ffi_type_uchar--argCWchar   :: CWchar -> Arg-argCWchar   = mkStorableArg ffi_type_schar--argPtr      :: Ptr a -> Arg-argPtr      = mkStorableArg ffi_type_pointer--argFunPtr   :: FunPtr a -> Arg-argFunPtr   = mkStorableArg ffi_type_pointer--{- | The string argument is passed to C as a char * pointer, which is freed afterwards.-     The argument should not contain zero-bytes. -}-argString   :: String -> Arg-argString   = customPointerArg newCString free---- | Like argString, but for ByteString's.-argByteString  :: BS.ByteString -> Arg-argByteString  = customPointerArg (flip BS.useAsCString return) (const $ return ())---- | Like argByteString, but changing the string from C breaks referential transparency.-argConstByteString  :: BS.ByteString -> Arg-argConstByteString  = customPointerArg (flip BSU.unsafeUseAsCString return) (const $ return ())--retVoid     :: RetType ()-retVoid     = RetType ffi_type_void (\write -> write nullPtr >> return ())--retCInt     :: RetType CInt-retCInt     = mkStorableRetType ffi_type_sint-retCUInt    :: RetType CUInt-retCUInt    = mkStorableRetType ffi_type_uint-retCLong    :: RetType CLong-retCLong    = mkStorableRetType ffi_type_slong-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-retInt16    = mkStorableRetType ffi_type_sint16-retInt32    :: RetType Int32-retInt32    = mkStorableRetType ffi_type_sint32-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-retWord16   = mkStorableRetType ffi_type_uint16-retWord32   :: RetType Word32-retWord32   = mkStorableRetType ffi_type_uint32-retWord64   :: RetType Word64-retWord64   = mkStorableRetType ffi_type_uint64--retCFloat   :: RetType CFloat-retCFloat   = mkStorableRetType ffi_type_float-retCDouble  :: RetType CDouble-retCDouble  = mkStorableRetType ffi_type_double--retCSize    :: RetType CSize-retCSize    = mkStorableRetType ffi_type_size-retCTime    :: RetType CTime-retCTime    = mkStorableRetType ffi_type_time--retCChar    :: RetType CChar-retCChar    = mkStorableRetType ffi_type_schar-retCUChar   :: RetType CUChar-retCUChar   = mkStorableRetType ffi_type_uchar--retCWchar   :: RetType CWchar-retCWchar   = mkStorableRetType ffi_type_schar--retFunPtr   :: RetType a -> RetType (FunPtr a)-retFunPtr _ = mkStorableRetType ffi_type_pointer--retPtr      :: RetType a -> RetType (Ptr a)-retPtr _    = mkStorableRetType ffi_type_pointer--retCString          :: RetType CString-retCString          = retPtr retCChar--{- | Peek a String out of the returned char *. The char * is not freed. -}-retString           :: RetType String-retString           = withRetType peekCString (retPtr retCChar)--{- | Like retString, but for ByteString's -}-retByteString       :: RetType BS.ByteString-retByteString       = withRetType BS.packCString (retPtr retCChar)--{- | Make a ByteString out of the returned char *.-     The char * will be free(3)ed when the ByteString is garbage collected. -}-retMallocByteString :: RetType BS.ByteString-retMallocByteString = withRetType BSU.unsafePackMallocCString (retPtr retCChar)+-- | Arguments and return types
+module Foreign.LibFFI.Types (
+    -- * Arguments
+    -- ** Integral types
+    argCInt,
+    argCUInt,
+    argCLong,
+    argCULong,
+    argInt8,
+    argInt16,
+    argInt32,
+    argInt64,
+    argWord8,
+    argWord16,
+    argWord32,
+    argWord64,
+    -- ** Floating point types
+    argCFloat,
+    argCDouble,
+    -- ** Various other C types
+    argCSize,
+    argCTime,
+    argCChar,
+    argCUChar,
+    argCWchar,
+    argPtr,
+    argFunPtr,
+    -- ** Strings
+    argString,
+    argByteString,
+    argConstByteString,
+    -- * Return types
+    -- ** Integral types
+    retVoid,
+    retCInt,
+    retCUInt,
+    retCLong,
+    retCULong,
+    retInt8,
+    retInt16,
+    retInt32,
+    retInt64,
+    retWord8,
+    retWord16,
+    retWord32,
+    retWord64,
+    -- ** Floating point types
+    retCFloat,
+    retCDouble,
+    -- ** Various other C types
+    retCSize,
+    retCTime,
+    retCChar,
+    retCUChar,
+    retCWchar,
+    retPtr,
+    retFunPtr,
+    -- ** Strings
+    retCString,
+    retString,
+    retByteString,
+    retMallocByteString
+    ) where
+
+import Control.Monad
+import Data.List
+import Data.Char
+import Data.Int
+import Data.Word
+
+import Foreign.C.Types
+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.Base
+import Foreign.LibFFI.FFITypes
+
+argCInt     :: CInt -> Arg
+argCInt     = mkStorableArg ffi_type_sint
+argCUInt    :: CUInt -> Arg
+argCUInt    = mkStorableArg ffi_type_uint
+argCLong    :: CLong -> Arg
+argCLong    = mkStorableArg ffi_type_slong
+argCULong   :: CULong -> Arg
+argCULong   = mkStorableArg ffi_type_ulong
+
+-- | Note that on e.g. x86_64, Int \/= CInt
+argInt8     :: Int8 -> Arg
+argInt8     = mkStorableArg ffi_type_sint8
+argInt16    :: Int16 -> Arg
+argInt16    = mkStorableArg ffi_type_sint16
+argInt32    :: Int32 -> Arg
+argInt32    = mkStorableArg ffi_type_sint32
+argInt64    :: Int64 -> Arg
+argInt64    = mkStorableArg ffi_type_sint64
+
+argWord8    :: Word8 -> Arg
+argWord8    = mkStorableArg ffi_type_uint8
+argWord16   :: Word16 -> Arg
+argWord16   = mkStorableArg ffi_type_uint16
+argWord32   :: Word32 -> Arg
+argWord32   = mkStorableArg ffi_type_uint32
+argWord64   :: Word64 -> Arg
+argWord64   = mkStorableArg ffi_type_uint64
+
+argCFloat   :: CFloat -> Arg
+argCFloat   = mkStorableArg ffi_type_float
+argCDouble  :: CDouble -> Arg
+argCDouble  = mkStorableArg ffi_type_double
+
+argCSize    :: CSize -> Arg
+argCSize    = mkStorableArg ffi_type_size
+argCTime    :: CTime -> Arg
+argCTime    = mkStorableArg ffi_type_size
+
+argCChar    :: CChar -> Arg
+argCChar    = mkStorableArg ffi_type_schar
+argCUChar   :: CUChar -> Arg
+argCUChar   = mkStorableArg ffi_type_uchar
+
+argCWchar   :: CWchar -> Arg
+argCWchar   = mkStorableArg ffi_type_wchar
+
+argPtr      :: Ptr a -> Arg
+argPtr      = mkStorableArg ffi_type_pointer
+
+argFunPtr   :: FunPtr a -> Arg
+argFunPtr   = mkStorableArg ffi_type_pointer
+
+{- | The string argument is passed to C as a char * pointer, which is freed afterwards.
+     The argument should not contain zero-bytes. -}
+argString   :: String -> Arg
+argString   = customPointerArg newCString free
+
+-- | Like argString, but for ByteString's.
+argByteString  :: BS.ByteString -> Arg
+argByteString  = customPointerArg (flip BS.useAsCString return) (const $ return ())
+
+-- | Like argByteString, but changing the string from C breaks referential transparency.
+argConstByteString  :: BS.ByteString -> Arg
+argConstByteString  = customPointerArg (flip BSU.unsafeUseAsCString return) (const $ return ())
+
+retVoid     :: RetType ()
+retVoid     = RetType (\write -> write ffi_type_void nullPtr >> return ())
+
+retCInt     :: RetType CInt
+retCInt     = mkStorableRetType ffi_type_sint
+retCUInt    :: RetType CUInt
+retCUInt    = mkStorableRetType ffi_type_uint
+retCLong    :: RetType CLong
+retCLong    = mkStorableRetType ffi_type_slong
+retCULong   :: RetType CULong
+retCULong   = mkStorableRetType ffi_type_ulong
+
+retInt8     :: RetType Int8
+retInt8     = mkStorableRetType ffi_type_sint8
+retInt16    :: RetType Int16
+retInt16    = mkStorableRetType ffi_type_sint16
+retInt32    :: RetType Int32
+retInt32    = mkStorableRetType ffi_type_sint32
+retInt64    :: RetType Int64
+retInt64    = mkStorableRetType ffi_type_sint64
+
+retWord8    :: RetType Word8
+retWord8    = mkStorableRetType ffi_type_uint8
+retWord16   :: RetType Word16
+retWord16   = mkStorableRetType ffi_type_uint16
+retWord32   :: RetType Word32
+retWord32   = mkStorableRetType ffi_type_uint32
+retWord64   :: RetType Word64
+retWord64   = mkStorableRetType ffi_type_uint64
+
+retCFloat   :: RetType CFloat
+retCFloat   = mkStorableRetType ffi_type_float
+retCDouble  :: RetType CDouble
+retCDouble  = mkStorableRetType ffi_type_double
+
+retCSize    :: RetType CSize
+retCSize    = mkStorableRetType ffi_type_size
+retCTime    :: RetType CTime
+retCTime    = mkStorableRetType ffi_type_time
+
+retCChar    :: RetType CChar
+retCChar    = mkStorableRetType ffi_type_schar
+retCUChar   :: RetType CUChar
+retCUChar   = mkStorableRetType ffi_type_uchar
+
+retCWchar   :: RetType CWchar
+retCWchar   = mkStorableRetType ffi_type_wchar
+
+retFunPtr   :: RetType a -> RetType (FunPtr a)
+retFunPtr _ = mkStorableRetType ffi_type_pointer
+
+retPtr      :: RetType a -> RetType (Ptr a)
+retPtr _    = mkStorableRetType ffi_type_pointer
+
+retCString          :: RetType CString
+retCString          = retPtr retCChar
+
+{- | Peek a String out of the returned char *. The char * is not freed. -}
+retString           :: RetType String
+retString           = withRetType peekCString (retPtr retCChar)
+
+{- | Like retString, but for ByteString's -}
+retByteString       :: RetType BS.ByteString
+retByteString       = withRetType BS.packCString (retPtr retCChar)
+
+{- | Make a ByteString out of the returned char *.
+     The char * will be free(3)ed when the ByteString is garbage collected. -}
+retMallocByteString :: RetType BS.ByteString
+retMallocByteString = withRetType BSU.unsafePackMallocCString (retPtr retCChar)
LICENSE view
@@ -1,23 +1,23 @@-Copyright (c) 2008, Remi Turk-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice,-   this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2008, Remi Turk
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+   this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -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 dynamically 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.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain
− TODO 
@@ -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.
− examples/CCall.hs 
@@ -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
− examples/CTime.hsc 
@@ -1,75 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Main where--#include <time.h>--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
− examples/Makefile 
@@ -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.*
− examples/MemSpeed.hs 
@@ -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 ""
− examples/mytime.c 
@@ -1,14 +0,0 @@-#include <time.h>--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);-}
libffi.cabal view
@@ -1,23 +1,63 @@-Name:               libffi-Version:            0.1-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-Stability:          alpha-Synopsis:           A binding to libffi-Tested-With:        GHC == 6.10.1-Build-Depends:      base, bytestring-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+Name:               libffi
+cabal-version:      >= 1.10
+Version:            0.2.1
+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 == 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
+
+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