diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/Foreign/LibFFI.hs b/Foreign/LibFFI.hs --- a/Foreign/LibFFI.hs +++ b/Foreign/LibFFI.hs @@ -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 diff --git a/Foreign/LibFFI/Base.hs b/Foreign/LibFFI/Base.hs --- a/Foreign/LibFFI/Base.hs +++ b/Foreign/LibFFI/Base.hs @@ -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 diff --git a/Foreign/LibFFI/FFITypes.hs b/Foreign/LibFFI/FFITypes.hs --- a/Foreign/LibFFI/FFITypes.hs +++ b/Foreign/LibFFI/FFITypes.hs @@ -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)" diff --git a/Foreign/LibFFI/Internal.hsc b/Foreign/LibFFI/Internal.hsc --- a/Foreign/LibFFI/Internal.hsc +++ b/Foreign/LibFFI/Internal.hsc @@ -1,43 +1,49 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} -{- | The internals of the C library libffi -} -module Foreign.LibFFI.Internal where - -#include - -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 + +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 () diff --git a/Foreign/LibFFI/Types.hs b/Foreign/LibFFI/Types.hs --- a/Foreign/LibFFI/Types.hs +++ b/Foreign/LibFFI/Types.hs @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. 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 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain 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 -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