{-# LINE 1 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Foreign.LibFFI.Dynamic.CIF
( ABI(..)
, defaultABI
, SomeCIF(..)
, getCIF
, CIF(..)
, toSomeCIF
, cif
, cifWithABI
, abi
, retType
, argTypes, nArgs
, cifFlags
, SigType, SigReturn
, retTypeOf, argTypesOf
, call, callWithABI, callWithCIF
) where
import Control.Applicative
import Data.Hashable
import Data.Interned
import Data.List
import Foreign.LibFFI.Dynamic.Base
import Foreign.LibFFI.Dynamic.FFIType
import Foreign.LibFFI.Dynamic.Type
import Foreign.C.Types
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe
newtype ABI = ABI CInt
deriving (Eq, Ord, Show, Storable)
instance Hashable ABI where
hashWithSalt salt (ABI x) =
hashWithSalt salt (fromIntegral x :: Int)
defaultABI = ABI (2)
{-# LINE 50 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
newtype SomeCIF = SomeCIF (Ptr SomeCIF)
deriving (Eq, Ord, Show)
instance Interned SomeCIF where
data Description SomeCIF = Sig ABI SomeType [SomeType]
deriving (Eq, Show)
type Uninterned SomeCIF = Description SomeCIF
describe = id
identify _ (Sig abi ret args) = unsafePerformIO $ do
cif <- SomeCIF <$> mallocBytes ((32))
{-# LINE 63 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
let nArgs = fromIntegral (length args)
argTypes <- newArray args
ffi_prep_cif cif abi nArgs ret argTypes
return cif
cache = cifCache
{-# NOINLINE cifCache #-}
cifCache :: Cache SomeCIF
cifCache = mkCache
instance Hashable (Description SomeCIF) where
hashWithSalt salt (Sig abi ret args) =
foldl' hashWithSalt (hashWithSalt salt abi) (ret : args)
foreign import ccall ffi_prep_cif :: SomeCIF -> ABI -> CInt -> SomeType -> Ptr SomeType -> IO FFI_Status
getCIF :: ABI -> SomeType -> [SomeType] -> SomeCIF
getCIF abi retType argTypes = intern (Sig abi retType argTypes)
class SigType t where
type SigReturn t
retTypeOf' :: p t -> SomeType
argTypesOf' :: p t -> [SomeType]
retTypeOf :: SigType t => p t -> SomeType
retTypeOf = retTypeOf'
argTypesOf :: SigType t => p t -> [SomeType]
argTypesOf = argTypesOf'
instance FFIType t => SigType (IO t) where
type SigReturn (IO t) = t
retTypeOf' = ffiTypeOf_ . (const Nothing :: p (IO b) -> Maybe b)
argTypesOf' _ = []
instance (FFIType a, SigType b) => SigType (a -> b) where
type SigReturn (a -> b) = SigReturn b
retTypeOf' = retTypeOf . (const Nothing :: p (a -> b) -> Maybe b)
argTypesOf' p
= ffiTypeOf_ ((const Nothing :: p (a -> b) -> Maybe a) p)
: argTypesOf ((const Nothing :: p (a -> b) -> Maybe b) p)
newtype CIF a = CIF SomeCIF
deriving (Eq, Ord, Show)
toSomeCIF :: CIF a -> SomeCIF
toSomeCIF (CIF c) = c
cif :: SigType t => CIF t
cif = cifWithABI defaultABI
cifWithABI :: SigType t => ABI -> CIF t
cifWithABI abi = theCIF
where
theCIF = CIF (getCIF abi (retTypeOf theCIF) (argTypesOf theCIF))
call :: SigType t => FunPtr t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO ()
call = callWithCIF theCIF
where
{-# NOINLINE theCIF #-}
theCIF = cif
callWithABI :: SigType t => ABI -> FunPtr t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO ()
callWithABI abi = callWithCIF theCIF
where
{-# NOINLINE theCIF #-}
theCIF = cifWithABI abi
foreign import ccall "ffi_call"
callWithCIF :: CIF a -> FunPtr a -> Ptr (SigReturn a) -> Ptr (Ptr ()) -> IO ()
abi :: SomeCIF -> ABI
abi (SomeCIF p) = unsafePerformIO $ do
((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 145 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
retType :: SomeCIF -> SomeType
retType (SomeCIF p) = unsafePerformIO $ do
((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 149 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
argTypes :: SomeCIF -> [SomeType]
argTypes cif@(SomeCIF p) = unsafePerformIO $ do
ts <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p :: IO (Ptr SomeType)
{-# LINE 153 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
peekArray (nArgs cif) ts
nArgs :: SomeCIF -> Int
nArgs (SomeCIF p) = unsafePerformIO $ do
n <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p :: IO CUInt
{-# LINE 158 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
return $! fromIntegral n
cifFlags :: SomeCIF -> CUInt
cifFlags (SomeCIF p) = unsafePerformIO $ do
((\hsc_ptr -> peekByteOff hsc_ptr 28)) p