packages feed

libffi (empty) → 0.1

raw patch · 14 files changed

+882/−0 lines, 14 filesdep +basedep +bytestringsetup-changed

Dependencies added: base, bytestring

Files

+ Foreign/LibFFI.hs view
@@ -0,0 +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
+ Foreign/LibFFI/Base.hs view
@@ -0,0 +1,72 @@+{- | 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 view
@@ -0,0 +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)"
+ Foreign/LibFFI/Internal.hsc view
@@ -0,0 +1,43 @@+{-# 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 view
@@ -0,0 +1,227 @@+-- | 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)
+ LICENSE view
@@ -0,0 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TODO view
@@ -0,0 +1,17 @@+- 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 view
@@ -0,0 +1,176 @@+{-# 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 view
@@ -0,0 +1,75 @@+{-# 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 view
@@ -0,0 +1,22 @@+.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 view
@@ -0,0 +1,75 @@+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 view
@@ -0,0 +1,14 @@+#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
@@ -0,0 +1,23 @@+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