Commits

Carter Schonwald committed 2e7becf

first commit into new repo

Comments (0)

Files changed (14)

Foreign/LibFFI.hs

+{- |
+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

+{- | 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

Foreign/LibFFI/FFITypes.hs

+{-# 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

+{-# 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 ()

Foreign/LibFFI/Types.hs

+-- | 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)
+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.
+import Distribution.Simple
+main = defaultMain
+- 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

+{-# 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

+{-# 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

+.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

+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

+#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);
+}
+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