cinvoke (empty) → 0.1
raw patch · 12 files changed
+1075/−0 lines, 12 filesdep +basedep +bytestringsetup-changed
Dependencies added: base, bytestring
Files
- Data/RefCount.hs +23/−0
- Foreign/CInvoke.hs +72/−0
- Foreign/CInvoke/Base.hs +311/−0
- Foreign/CInvoke/Internal.hsc +43/−0
- Foreign/CInvoke/Types.hs +201/−0
- Foreign/TreePtr.hs +47/−0
- LICENSE +23/−0
- Setup.hs +2/−0
- cinvoke.cabal +28/−0
- examples/CCall.hs +232/−0
- examples/Makefile +9/−0
- examples/MemSpeed.hs +84/−0
+ Data/RefCount.hs view
@@ -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
+ Foreign/CInvoke.hs view
@@ -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
+ Foreign/CInvoke/Base.hs view
@@ -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
+ Foreign/CInvoke/Internal.hsc view
@@ -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 <cinvoke.h>+#include <cinvoke-arch.h>++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
+ Foreign/CInvoke/Types.hs view
@@ -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)
+ Foreign/TreePtr.hs view
@@ -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
+ 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
+ cinvoke.cabal view
@@ -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 <http://www.nongnu.org/cinvoke/>+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
+ examples/CCall.hs view
@@ -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
+ examples/Makefile view
@@ -0,0 +1,9 @@+.PHONY: all clean++all: MemSpeed CCall++%: %.hs+ ghc --make $<++clean:+ rm -f MemSpeed CCall *.o *.hi core core.*
+ examples/MemSpeed.hs view
@@ -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 ""