diff --git a/Data/RefCount.hs b/Data/RefCount.hs new file mode 100644 --- /dev/null +++ b/Data/RefCount.hs @@ -0,0 +1,23 @@ +{- | Reference counting + Data with a finalizer that will be called when the counter reached zero. + Thread-safe. -} +module Data.RefCount ( + RefCount, + newRefCount, + incRefCount, + decRefCount, +) where + +import Control.Monad +import Data.IORef + +data RefCount = RefCount !(IO ()) !(IORef Int) + +newRefCount cleanup = RefCount cleanup `liftM` newIORef 1 + +incRefCount (RefCount _ ref) = atomicModifyIORef ref $ \x -> (succ x, ()) + +decRefCount (RefCount cleanup ref) = do + refCnt <- atomicModifyIORef ref $ \x -> let x' = pred x in (x', x') + when (refCnt == 0) + cleanup diff --git a/Foreign/CInvoke.hs b/Foreign/CInvoke.hs new file mode 100644 --- /dev/null +++ b/Foreign/CInvoke.hs @@ -0,0 +1,72 @@ +{- | +This is the only module that normal users should need to import. + +As an example, allocate 1GB of memory, zero it and free it again: + +> module Main where +> +> import Foreign.Ptr +> import Foreign.CInvoke +> +> main = do +> cxt <- newContext +> libc <- loadLibrary cxt "libc.so.6" +> malloc <- loadSymbol libc "malloc" +> memset <- loadSymbol libc "memset" +> free <- loadSymbol libc "free" +> let sz = 2^30 +> p <- cinvoke malloc (retPtr retVoid) [argCSize sz] +> cinvoke memset (retPtr retVoid) [argPtr p, argCInt 0, argCSize sz] +> cinvoke free (retPtr retVoid) [argPtr p] + +Another example shows how to ask the X Window System for the resolution of the first screen. + +> module Main where +> +> import Foreign.CInvoke +> +> main = do +> cxt <- newContext +> libx <- loadLibrary cxt "libX11.so" +> xOpenDisplay <- loadSymbol libx "XOpenDisplay" +> xCloseDisplay <- loadSymbol libx "XCloseDisplay" +> xDisplayWidth <- loadSymbol libx "XDisplayWidth" +> xDisplayHeight <- loadSymbol libx "XDisplayHeight" +> +> display <- cinvoke xOpenDisplay (retPtr retVoid) [argString ":0"] +> width <- cinvoke xDisplayWidth retCInt [argPtr display, argCInt 0] +> height <- cinvoke xDisplayHeight retCInt [argPtr display, argCInt 0] +> cinvoke xCloseDisplay retCInt [argPtr display] +> putStrLn $ show width ++ "x" ++ show height + +Contexts, libraries and symbols are all freed by the garbage collector when necessary. + +The source distribution examples/ directory contains more complicated examples. + +-} +module Foreign.CInvoke + (FFIException(..) + + -- * Contexts + ,Context + ,newContext + + -- * Libraries + ,Library + ,loadLibrary + + -- * Symbols + ,Symbol + ,loadSymbol + ,cinvoke + ,withSymbol + + -- * Function arguments and return types + ,Arg + ,RetType + ,withRetType + ,module Foreign.CInvoke.Types + ) where + +import Foreign.CInvoke.Base +import Foreign.CInvoke.Types diff --git a/Foreign/CInvoke/Base.hs b/Foreign/CInvoke/Base.hs new file mode 100644 --- /dev/null +++ b/Foreign/CInvoke/Base.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE Rank2Types, DeriveDataTypeable, ScopedTypeVariables #-} +{- | This module defines the basic CInvoke machinery. + You will need this to create support for new FFI types, or when the + standard garbage collection behaviour doesn't suffice. -} +module Foreign.CInvoke.Base ( + FFIException(..), + + -- * High level interface + -- | In the high level interface, everything is under control of the garbage collector. + + -- ** Contexts + Context, + newContext, + + -- ** Libraries + Library, + loadLibrary, + + -- ** Symbols + Symbol, + loadSymbol, + cinvoke, + withSymbol, + + -- ** Function arguments + Arg(..), + mkStorableArg, + mkPointerArg, + + -- ** Function return types + RetType(..), + mkStorableRetType, + withRetType, + + -- * Low level interface + -- | In the low level interface, memory has to be managed manually. + + -- ** Contexts + CContext, + newContextPtr, + freeContextPtr, + + -- ** Libraries + CLibrary, + loadLibraryPtr, + freeLibraryPtr, + + -- ** Symbols + CSymbol, + loadSymbolPtr, + cinvokePtr, + +) where + +import Control.Monad +import Control.Exception +import Data.Typeable +import Data.IORef +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Storable +import Foreign.Marshal + +import Foreign.CInvoke.Internal +import Foreign.TreePtr + +import System.Mem + +-- | Things you can pass as arguments to foreign functions called with 'cinvoke'. +newtype Arg + {- | The higher order function inside an 'Arg' must call its argument function with two parameters: + A 'CChar' representing the type of the argument in C (see the cinvoke docs) and a pointer to the C value. + This function will then take the marshalled argument and pass it to the C function. + -} + = Arg { unArg :: forall a. (CChar -> Ptr CValue -> IO a) -> IO a } + +storableToCChar :: Storable a => a -> Char +storableToCChar a = case sizeOf a of + 1 -> '1' + 2 -> '2' + 4 -> '4' + 8 -> '8' + i -> error $ "cinvoke: storableToCChar: unsupported size: " ++ show i + +{- | @mkStorableArg@ can be used to automatically define 'Arg' constructor functions for 'Storable' types. + For example, + + > import System.Posix + > + > argCOff = mkStorableArg :: COff -> Arg + + N.B. This only works for types @a@ where @sizeOf (undefined :: a) \`elem\` [1, 2, 4, 8]@, and yields a run-time error otherwise. +-} +mkStorableArg :: forall a. Storable a => a -> Arg +mkStorableArg = mkStorableArg' (storableToCChar (undefined :: a)) + where + mkStorableArg' cType a = Arg $ \withArg -> + with a $ \p -> + withArg (castCharToCChar cType) (castPtr p) + +{- | @mkPointerArg@ can be used to build 'Arg' constructor functions types that are represented by pointers in C. + For example, 'argString' has been defined as follows: + + > import Foreign.C.String + > import Foreign.Marshal.Alloc + > + > argString :: String -> Arg + > argString = mkPointerArg newCString free +-} +mkPointerArg :: (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg +mkPointerArg newA freeA a = Arg $ \withArg -> + bracket (newA a) freeA $ \p -> + with p $ \pp -> + withArg (castCharToCChar 'p') (castPtr pp) + +-- | Types you can return from 'cinvoke'. +newtype RetType a + {- | The higher order function inside an 'RetType' must call its argument function with two parameters: + A 'CChar' representing the return type in C (see the cinvoke docs) and a pointer where the C result may be stored. + The argument function will then perform the actual FFI call, after which the higher order function is expected to take the + stored value back into Haskell country. + -} + = RetType { unRetType :: (CChar -> Ptr CValue -> IO ()) -> IO a } + +instance Functor RetType where + fmap f = withRetType (return . f) + +{- | Apply an IO performing function to a 'RetType'. + For example, 'retString' has been defined as follows: + + > import Foreign.C.String + > + > retString :: RetType String + > retString = withRetType peekCString (retPtr retCChar) +-} +withRetType :: (a -> IO b) -> RetType a -> RetType b +withRetType f (RetType withPoke) = RetType $ withPoke >=> f + +{- | @mkStorableRetType@ can be used to automatically define 'RetType' values for 'Storable' types. + For example, + + > import System.Posix + > + > retCOff = mkStorableRetType :: RetType COff + + N.B. This only works for types @a@ where @sizeOf (undefined :: a) \`elem\` [1, 2, 4, 8]@, and yields a run-time error otherwise. +-} +mkStorableRetType :: forall a. Storable a => RetType a +mkStorableRetType = mkStorableRetType' (storableToCChar (undefined :: a)) + where + mkStorableRetType' cType + = RetType $ \write -> alloca $ \cValue -> write (castCharToCChar cType) (castPtr cValue) >> peek cValue + +-- | The type used for CInvoke errors. +data FFIException + = FFIException String + deriving (Show, Typeable) + +instance Exception FFIException + +ffiError cContext + = cinv_context_geterrormsg cContext >>= peekCString + >>= throwIO . FFIException + +{- | 'cinvokePtr' is passed a cinvoke context, a pointer to a dynamically loaded function, + a 'RetType' representing the return type of the function, and a list of 'Arg' values + representing the values to pass to the foreign function. + In case of error, an 'FFIException' will be thrown. + Consider using 'cinvoke' instead. -} +cinvokePtr :: Ptr CContext -> Ptr () -> RetType b -> [Arg] -> IO b +cinvokePtr cContext ptr (RetType actRet) args + = allocaArray0 1 $ \cRetTypePtr -> + allocaArray0 n $ \cTypesPtr -> + allocaArray n $ \cValuesPtr -> + let + createFunction + = onNull (ffiError cContext) + $ cinv_function_create cContext default_callconv cRetTypePtr cTypesPtr + + deleteFunction cFunction = do + status <- cinv_function_delete cContext cFunction + when (status /= success_status) $ ffiError cContext + + doCall = actRet $ \cType cValue -> do + pokeElemOff cRetTypePtr 0 cType + pokeElemOff cRetTypePtr 1 0 + pokeElemOff cTypesPtr n 0 + bracket createFunction deleteFunction $ \cFunction -> do + status <- cinv_function_invoke cContext cFunction (castPtrToFunPtr ptr) cValue cValuesPtr + when (status /= success_status) $ ffiError cContext + + 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 + +{- | 'cinvoke' is passed a 'Symbol' pointing to a dynamically loaded function, + a 'RetType' representing the return type of the function, and a list of 'Arg' values + representing the values to pass to the foreign function. + In case of error, an 'FFIException' will be thrown. + 'cinvokePtr' can be used instead by people who like mucking around with pointers. -} +cinvoke :: Symbol -> RetType b -> [Arg] -> IO b +cinvoke (Symbol ctp fp) retType args + = withTreePtr ctp $ \cContext -> + withForeignPtr fp $ \ptr -> + cinvokePtr cContext ptr retType args + +onNull e a = do + ptr <- a + when (ptr == nullPtr) e + return ptr + +-- | Most CInvoke calls take a 'Context' as a parameter. In multi-threaded programs, it is safe to use one 'Context' per thread. +newtype Context = Context (TreePtr CContext) + deriving Show + +{- | Returns a pointer to a newly created CInvoke context. This context can be freed again with 'freeContextPtr'. + Consider using 'newContext' instead. -} +newContextPtr :: IO (Ptr CContext) +newContextPtr = onNull (throwIO $ FFIException "newContextPtr failed") + cinv_context_create + +-- | Free a CInvoke context that has been created with 'newContextPtr'. +freeContextPtr :: Ptr CContext -> IO () +freeContextPtr cContext = cinv_context_delete cContext >> return () + +{- | Create a new 'Context', that will be garbage collected when necessary. + + 'newContextPtr' and 'freeContextPtr' can be used in cases where manual memory management is preferred. -} +newContext :: IO Context +newContext = do + cContext <- newContextPtr + Context `liftM` newTreePtr cContext (freeContextPtr cContext) + +-- | Represents a loaded shared object (DLL). +data Library = Library (TreePtr CContext) (TreePtr CLibrary) + deriving Show + +{- | @loadLibraryPtr cxt lib@ uses the context pointer @cxt@ to load the library named @lib@. + If @lib@ is not a full path, the library-path will be used to try to locate the named shared library. + When the library cannot be loaded, an 'FFIException' will be thrown. + The resulting library must be closed again with 'freeLibraryPtr'. + + 'loadLibraryPtr' is primarily useful when 'loadLibrary' does not provide enough control about when the loaded + library is freed again. As each opened library usually implies an open + file, one might worry about limits on the maximum number of simultaneously open files. -} +loadLibraryPtr :: Ptr CContext -> String -> IO (Ptr CLibrary) +loadLibraryPtr cContext path + = withCString path $ \cPath -> do + onNull (ffiError cContext) + $ cinv_library_create cContext cPath + +-- | Free a library opened by 'loadLibraryPtr'. +freeLibraryPtr :: Ptr CContext -> Ptr CLibrary -> IO () +freeLibraryPtr cContext cLibrary = cinv_library_delete cContext cLibrary >> return () + +{- | @loadLibrary cxt lib@ uses the 'Context' @cxt@ to load the library named @lib@. + If @lib@ is not a full path, the library-path will be used to try to locate the named shared library. + When the library cannot be loaded, an 'FFIException' will be thrown. + The resulting library will be closed by the garbage collector. + + 'loadLibraryPtr' and 'freeLibraryPtr' can be used in cases where manual memory management is preferred. + -} +loadLibrary :: Context -> String -> IO Library +loadLibrary (Context tp) path + = withTreePtr tp $ \cContext -> do + cLibrary <- loadLibraryPtr cContext path + Library tp `liftM` addNode cLibrary (freeLibraryPtr cContext cLibrary) tp + +{- | A 'Symbol' represents a symbol in a shared library. + It can be used either by passing it to 'cinvoke' or 'cinvokePtr', + or by calling 'withSymbol' on it. -} +data Symbol = Symbol (TreePtr CContext) (ForeignPtr ()) + deriving Show + +{- | Internally, a 'Symbol' is just a pointer into a loaded shared library. + 'withSymbol' allows for direct access to this pointer. + This pointer must not be used after 'withSymbol' has returned. -} +withSymbol :: Symbol -> (Ptr a -> IO b) -> IO b +withSymbol (Symbol _ fp) f = withForeignPtr fp $ f . castPtr + +{- | @loadSymbolPtr cxt lib name@ tries to lookup the symbol @name@ from the opened library @lib@, + using the cinvoke context @cxt@. + An 'FFIException' is thrown on failure. Care must be taken not to free either the context or the library + as long as the returned symbol may still be used. + + Consider using 'loadSymbol' instead. -} +loadSymbolPtr :: Ptr CContext -> Ptr CLibrary -> String -> IO (Ptr ()) +loadSymbolPtr cContext cLibrary sym + = withCString sym $ \cSym -> do + onNull (ffiError cContext) + $ cinv_library_load_entrypoint cContext cLibrary cSym + +{- | @loadSymbol lib name@ tries to lookup the symbol @name@ from the opened library @lib@. + An 'FFIException' is thrown on failure. The loaded symbol will keep its library alive for the garbage collector. + When manual memory management is preferred, one may choose to use 'loadSymbolPtr' instead. -} +loadSymbol :: Library -> String -> IO Symbol +loadSymbol (Library ctp ltp) sym + = withTreePtr ctp $ \cContext -> + withTreePtr ltp $ \cLibrary -> do + ptr <- loadSymbolPtr cContext cLibrary sym + let final = return () + Symbol ctp `liftM` addLeaf ptr final ltp diff --git a/Foreign/CInvoke/Internal.hsc b/Foreign/CInvoke/Internal.hsc new file mode 100644 --- /dev/null +++ b/Foreign/CInvoke/Internal.hsc @@ -0,0 +1,43 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{- | The internals of the C library cinvoke. + Mail the maintainer if you think you need this module. -} +module Foreign.CInvoke.Internal where + +#include +#include + +import Data.Int +import Data.Word +import Foreign.C.Types +import Foreign.C.String +import Foreign.Ptr +import Foreign.Storable + +data CValue +data CContext +data CLibrary +data CSymbol + +type C_int32 = (#type cinv_int32_t) +type C_status = (#type cinv_status_t) +type C_callconv = (#type cinv_callconv_t) + +default_callconv :: C_callconv +default_callconv = #const CINV_CC_DEFAULT + +success_status :: C_status +success_status = #const CINV_SUCCESS + +error_status :: C_status +error_status = #const CINV_ERROR + +foreign import ccall safe cinv_context_create :: IO (Ptr CContext) +foreign import ccall safe cinv_context_geterrormsg :: Ptr CContext -> IO CString +foreign import ccall safe cinv_context_geterrorcode :: Ptr CContext -> IO C_int32 +foreign import ccall safe cinv_context_delete :: Ptr CContext -> IO C_status +foreign import ccall safe cinv_library_create :: Ptr CContext -> CString -> IO (Ptr CLibrary) +foreign import ccall safe cinv_library_load_entrypoint :: Ptr CContext -> Ptr CLibrary -> CString -> IO (Ptr ()) +foreign import ccall safe cinv_library_delete :: Ptr CContext -> Ptr CLibrary -> IO C_status +foreign import ccall safe cinv_function_create :: Ptr CContext -> C_callconv -> CString -> CString -> IO (Ptr CSymbol) +foreign import ccall safe cinv_function_invoke :: Ptr CContext -> Ptr CSymbol -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO C_status +foreign import ccall safe cinv_function_delete :: Ptr CContext -> Ptr CSymbol -> IO C_status diff --git a/Foreign/CInvoke/Types.hs b/Foreign/CInvoke/Types.hs new file mode 100644 --- /dev/null +++ b/Foreign/CInvoke/Types.hs @@ -0,0 +1,201 @@ +{- | Arguments and return types. + + Note that functions for 'Int' and 'Word' are not provided here, as Haskell merely defines that + 'Int' is a \"fixed-precision integer type with at least the range [-2^29 .. 2^29-1]\", + and 'Word' is an \"unsigned integral type, with the same size as 'Int'\". + (As both types are instances of 'Storable', the user may easily define them himself when determined useful.) + + Note also that on e.g. Linux x86_64, 'Int' \/= 'CInt'. + -} +module Foreign.CInvoke.Types ( + -- * Arguments + -- ** Integral types + argCShort, + argCUShort, + argCInt, + argCUInt, + argCLong, + argCULong, + argCLLong, + argCULLong, + argInt8, + argInt16, + argInt32, + argInt64, + argWord8, + argWord16, + argWord32, + argWord64, + -- ** Floating point types + argCFloat, + argCDouble, + -- ** Various other C types + argCSize, + argCTime, + argCChar, + argCSChar, + argCUChar, + argCWchar, + argPtr, + argFunPtr, + -- ** Strings + argString, + argByteString, + argConstByteString, + -- * Return types + -- ** Integral types + retVoid, + retCShort, + retCUShort, + retCInt, + retCUInt, + retCLong, + retCULong, + retCLLong, + retCULLong, + retInt8, + retInt16, + retInt32, + retInt64, + retWord8, + retWord16, + retWord32, + retWord64, + -- ** Floating point types + retCFloat, + retCDouble, + -- ** Various other C types + retCSize, + retCTime, + retCChar, + retCSChar, + 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.CInvoke.Base + +argCShort = mkStorableArg :: CShort -> Arg +argCUShort = mkStorableArg :: CUShort -> Arg +argCInt = mkStorableArg :: CInt -> Arg +argCUInt = mkStorableArg :: CUInt -> Arg +argCLong = mkStorableArg :: CLong -> Arg +argCULong = mkStorableArg :: CULong -> Arg +argCLLong = mkStorableArg :: CLLong -> Arg +argCULLong = mkStorableArg :: CULLong -> Arg + +argInt8 = mkStorableArg :: Int8 -> Arg +argInt16 = mkStorableArg :: Int16 -> Arg +argInt32 = mkStorableArg :: Int32 -> Arg +argInt64 = mkStorableArg :: Int64 -> Arg + +argWord8 = mkStorableArg :: Word8 -> Arg +argWord16 = mkStorableArg :: Word16 -> Arg +argWord32 = mkStorableArg :: Word32 -> Arg +argWord64 = mkStorableArg :: Word64 -> Arg + +argCFloat = mkStorableArg :: CFloat -> Arg +argCDouble = mkStorableArg :: CDouble -> Arg + +argCSize = mkStorableArg :: CSize -> Arg +argCTime = mkStorableArg :: CTime -> Arg + +argCChar = mkStorableArg :: CChar -> Arg +argCSChar = mkStorableArg :: CSChar -> Arg +argCUChar = mkStorableArg :: CUChar -> Arg + +argCWchar = mkStorableArg :: CWchar -> Arg + +argPtr = mkStorableArg :: Ptr a -> Arg + +argFunPtr = mkStorableArg :: FunPtr a -> Arg + +{- | 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 = mkPointerArg newCString free + +-- | Like 'argString', but for 'ByteString''s. +argByteString :: BS.ByteString -> Arg +argByteString = mkPointerArg (flip BS.useAsCString return) (const $ return ()) + +-- | Like 'argByteString', but changing the string from C breaks referential transparency. +argConstByteString :: BS.ByteString -> Arg +argConstByteString = mkPointerArg (flip BSU.unsafeUseAsCString return) (const $ return ()) + +retVoid :: RetType () +retVoid = RetType (\write -> write 0 nullPtr >> return ()) + +retCShort = mkStorableRetType :: RetType CShort +retCUShort = mkStorableRetType :: RetType CUShort +retCInt = mkStorableRetType :: RetType CInt +retCUInt = mkStorableRetType :: RetType CUInt +retCLong = mkStorableRetType :: RetType CLong +retCULong = mkStorableRetType :: RetType CULong +retCLLong = mkStorableRetType :: RetType CLLong +retCULLong = mkStorableRetType :: RetType CULLong + +retInt8 = mkStorableRetType :: RetType Int8 +retInt16 = mkStorableRetType :: RetType Int16 +retInt32 = mkStorableRetType :: RetType Int32 +retInt64 = mkStorableRetType :: RetType Int64 + +retWord8 = mkStorableRetType :: RetType Word8 +retWord16 = mkStorableRetType :: RetType Word16 +retWord32 = mkStorableRetType :: RetType Word32 +retWord64 = mkStorableRetType :: RetType Word64 + +retCFloat = mkStorableRetType :: RetType CFloat +retCDouble = mkStorableRetType :: RetType CDouble + +retCSize = mkStorableRetType :: RetType CSize +retCTime = mkStorableRetType :: RetType CTime + +retCChar = mkStorableRetType :: RetType CChar +retCSChar = mkStorableRetType :: RetType CSChar +retCUChar = mkStorableRetType :: RetType CUChar + +retCWchar = mkStorableRetType :: RetType CWchar + +retFunPtr :: RetType a -> RetType (FunPtr a) +retFunPtr _ = mkStorableRetType + +retPtr :: RetType a -> RetType (Ptr a) +retPtr _ = mkStorableRetType + +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/Foreign/TreePtr.hs b/Foreign/TreePtr.hs new file mode 100644 --- /dev/null +++ b/Foreign/TreePtr.hs @@ -0,0 +1,47 @@ +{- | No Child Left Behind - + Pointers that won't be freed until all its children have been freed -} +module Foreign.TreePtr ( + TreePtr, + newTreePtr, + addNode, + addLeaf, + nodePtr, + withTreePtr, +) where + +import Control.Monad +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr, addForeignPtrFinalizer) +import Foreign.Concurrent + +import Data.RefCount + +data TreePtr a = TreePtr !RefCount !(ForeignPtr a) + +instance Show (TreePtr a) where + showsPrec p (TreePtr _ fp) = showsPrec p fp + +newTreePtr :: Ptr a -> IO () -> IO (TreePtr a) +newTreePtr ptr free = do + refCnt <- newRefCount free + liftM (TreePtr refCnt) + $ newForeignPtr ptr + $ decRefCount refCnt + +addWith f ptr free (TreePtr refCnt _) = do + incRefCount refCnt + f ptr $ do + free + decRefCount refCnt + +addNode :: Ptr a -> IO () -> TreePtr b -> IO (TreePtr a) +addNode = addWith newTreePtr + +addLeaf :: Ptr a -> IO () -> TreePtr b -> IO (ForeignPtr a) +addLeaf = addWith newForeignPtr + +nodePtr :: TreePtr a -> ForeignPtr a +nodePtr (TreePtr _ fp) = fp + +withTreePtr :: TreePtr a -> (Ptr a -> IO b) -> IO b +withTreePtr = withForeignPtr . nodePtr diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cinvoke.cabal b/cinvoke.cabal new file mode 100644 --- /dev/null +++ b/cinvoke.cabal @@ -0,0 +1,28 @@ +Name: cinvoke +Version: 0.1 +Description: A binding to cinvoke, allowing C functions of types only known at runtime to be called from Haskell. + See "Foreign.CInvoke" to get started. + The C library used can be found at +License: BSD3 +License-file: LICENSE +Copyright: Copyright (c) Remi Turk 2009-2011 +Author: Remi Turk +Maintainer: remi.turk@gmail.com +Homepage: http://haskell.org/haskellwiki/Library/cinvoke +Stability: alpha +Synopsis: A binding to cinvoke. +Tested-With: GHC == 6.12.3, GHC == 7.0.1, GHC == 7.0.2 +Build-Type: Simple +cabal-version: >= 1.6 +extra-source-files: examples/Makefile examples/*.hs +Category: Foreign +Library + Build-Depends: base >= 4 && < 5, bytestring + exposed-modules: Foreign.CInvoke, + Foreign.CInvoke.Base, + Foreign.CInvoke.Types, + Foreign.CInvoke.Internal + other-modules: Foreign.TreePtr + Data.RefCount + extra-libraries: cinvoke + includes: cinvoke.h cinvoke-arch.h diff --git a/examples/CCall.hs b/examples/CCall.hs new file mode 100644 --- /dev/null +++ b/examples/CCall.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{- +:a libx /usr/lib/libX11.so +display = i libx:XOpenDisplay ":0" +i libx:XDisplayWidth display 0 +i libx:XDisplayHeight display 0 +i libx:XCloseDisplay display +-} +module Main where + +import Control.Arrow +import Control.Applicative hiding (Alternative(..), many) +import Control.Monad.State.Strict +import Control.Exception hiding (try) +import qualified Control.Exception as Exc +import Control.Concurrent (threadDelay) +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.Console.Haskeline +import System.Directory +import System.IO +import System.Mem (performGC) +import Foreign.C.Types +import Foreign.Ptr +import Foreign.CInvoke +import Prelude hiding (catch) + +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" + +strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +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 Env 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 + "f" -> 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" + +type EnvVal = Map String Val +type EnvLib = Map String (FilePath, Library) +type Env = (EnvVal, EnvLib) + +pFun = do + libName <- pIdent + char ':' + sym <- pIdent + return (libName, sym) + +pCall :: CharParser Env ((String, String), RetType (Maybe (Bool, String, Val)), [Val]) +pCall = do + mbAssign <- optionMaybe $ try $ pIdent <* (spaces >> char '=' >> spaces) + mbRet <- pRet + space + fun <- pFun + vals <- many (space >> pArg) + case (mbAssign, mbRet) of + (Just ident, Just retType) -> return (fun, Just . (,,) False ident <$> retType, vals) + (Nothing , Just retType) -> return (fun, Just . (,,) True "it" <$> retType, vals) + (Nothing , Nothing ) -> return (fun, const Nothing <$> retVoid, vals) + (Just ident, Nothing) -> fail "cannot assign void" + +repl env libs context = do + s <- fromMaybe ":q" <$> getInputLine "> " + case s of + _ | all isSpace s -> repl env libs context + ":c" -> outputStrLn (show context) >> repl env libs context + ':':'f':' ':s -> case runParser (spaces >> pFun) (env, libs) "repl" s of + Left err -> outputStrLn (show err) >> repl env libs context + Right (libName, sym) -> do + lib <- case Map.lookup libName libs of + Nothing -> outputStrLn "No such library" + Just (_, lib) -> do + liftIO $ (loadSymbol lib sym >>= print) + `Exc.catch` (\(e :: FFIException) -> print e) + repl env libs context + ":q" -> liftIO (performGC >> threadDelay (10^5)) >> return () + ":p" -> do + forM_ (Map.toList env) $ \(ident, val) -> outputStrLn $ ident ++ " = " ++ show val + repl env libs context + ":l" -> do + forM_ (Map.toList libs) $ \(name, (path,lib)) -> do + outputStrLn $ name ++ ": " ++ path ++ " (" ++ show lib ++ ")" + repl env libs context + ':':'a':' ':s -> do + let (name, path) = second (drop 1) $ break isSpace $ strip s + eiLib <- liftIO (Exc.try $ loadLibrary context path :: IO (Either FFIException Library)) + case eiLib of + Left e -> outputStrLn (show e) >> repl env libs context + Right lib -> repl env (Map.insert name (path, lib) libs) context + ':':'u':' ':s -> do + repl env (Map.delete (strip s) libs) context + ":gc" -> liftIO performGC >> repl env libs context + _ -> do + case words s of + [ident] -> do + case Map.lookup ident env of + Nothing -> outputStrLn $ "No such identifier: " ++ show ident + Just val -> outputStrLn $ show val + repl env libs context + _ -> case runParser pCall (env, libs) "repl" s of + Left err-> outputStrLn (show err) >> repl env libs context + Right ((libName, sym), retType, vals) + -> case Map.lookup libName libs of + Nothing -> outputStrLn "no such library" >> repl env libs context + Just (_, lib) -> do + eiFun <- liftIO (Exc.try $ loadSymbol lib sym :: IO (Either FFIException Symbol)) + case eiFun of + Left e -> outputStrLn (show e) >> repl env libs context + Right fun -> do + mbVal <- liftIO $ cinvoke fun retType $ map valToArg vals + case mbVal of + Nothing -> repl env libs context + Just (wantShow, ident, val) -> do + when wantShow + $ outputStrLn $ show val + repl (Map.insert ident val env) libs context + +main = do + cxt <- newContext + appDir <- getAppUserDataDirectory "CCall" + let settings = defaultSettings{historyFile = Just $ appDir ++ "_history"} + runInputT settings $ repl Map.empty Map.empty cxt diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,9 @@ +.PHONY: all clean + +all: MemSpeed CCall + +%: %.hs + ghc --make $< + +clean: + rm -f MemSpeed CCall *.o *.hi core core.* diff --git a/examples/MemSpeed.hs b/examples/MemSpeed.hs new file mode 100644 --- /dev/null +++ b/examples/MemSpeed.hs @@ -0,0 +1,84 @@ +module Main where + +import Control.Monad +import Control.Concurrent +import Foreign.C.Types +import Foreign.CInvoke +import Numeric +import CPUTime +import Time +import Ratio +import System.Environment +import System.Exit +import System.Mem + +readMiB s = ceiling $ (read s * 2^20) / 2 + +main = do + args <- getArgs + (sz, cnt) <- case args of + [n] -> return (readMiB n, 10) + [n,c] -> return (readMiB n, read c) + [] -> putStrLn "usage: MemSpeed megabytes-to-use [count]" >> exitWith (ExitFailure 1) + + context <- newContext + libc <- loadLibrary context "libc.so.6" + memset <- loadSymbol libc "memset" + memcpy <- loadSymbol libc "memcpy" + malloc <- loadSymbol libc "malloc" + free <- loadSymbol libc "free" + + s <- cinvoke malloc (retPtr retVoid) [argCSize sz] + d <- cinvoke malloc (retPtr retVoid) [argCSize sz] + cinvoke memcpy retVoid [argPtr d, argPtr s, argCSize sz] + check (cnt*sz) "memcpy" $ replicateM_ (fromIntegral cnt) $ cinvoke memcpy retVoid [argPtr d, argPtr s, argCSize sz] + cinvoke free retVoid [argPtr s] + cinvoke free retVoid [argPtr d] + + p <- cinvoke malloc (retPtr retVoid) [argCSize (2 * sz)] + cinvoke memset retVoid [argPtr p, argCInt 97, argCSize (2 * sz)] + check (2*cnt*sz) "memset" $ replicateM_ (fromIntegral cnt) $ cinvoke memset retVoid [argPtr p, argCInt 97, argCSize (2 * sz)] + cinvoke free retVoid [argPtr p] + + performGC + threadDelay (10^5) + +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 ""