never executed always true always false
1 -----------------------------------------------------------------------------
2 --
3 -- libffi bindings
4 --
5 -- (c) The University of Glasgow 2008
6 --
7 -----------------------------------------------------------------------------
8
9 #include <ffi.h>
10
11 {-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}
12 module GHCi.FFI
13 ( FFIType(..)
14 , FFIConv(..)
15 , C_ffi_cif
16 , prepForeignCall
17 , freeForeignCallInfo
18 ) where
19
20 import Prelude -- See note [Why do we import Prelude here?]
21 import Control.Exception
22 import Data.Binary
23 import GHC.Generics
24 import Foreign
25 import Foreign.C
26
27 data FFIType
28 = FFIVoid
29 | FFIPointer
30 | FFIFloat
31 | FFIDouble
32 | FFISInt8
33 | FFISInt16
34 | FFISInt32
35 | FFISInt64
36 | FFIUInt8
37 | FFIUInt16
38 | FFIUInt32
39 | FFIUInt64
40 deriving (Show, Generic, Binary)
41
42 data FFIConv
43 = FFICCall
44 | FFIStdCall
45 deriving (Show, Generic, Binary)
46
47
48 prepForeignCall
49 :: FFIConv
50 -> [FFIType] -- arg types
51 -> FFIType -- result type
52 -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller)
53
54 prepForeignCall cconv arg_types result_type = do
55 let n_args = length arg_types
56 arg_arr <- mallocArray n_args
57 pokeArray arg_arr (map ffiType arg_types)
58 cif <- mallocBytes (#const sizeof(ffi_cif))
59 let abi = convToABI cconv
60 r <- ffi_prep_cif cif abi (fromIntegral n_args) (ffiType result_type) arg_arr
61 if r /= fFI_OK then
62 throwIO $ ErrorCall $ concat
63 [ "prepForeignCallFailed: ", strError r,
64 "(cconv: ", show cconv,
65 " arg tys: ", show arg_types,
66 " res ty: ", show result_type, ")" ]
67 else
68 return (castPtr cif)
69
70 freeForeignCallInfo :: Ptr C_ffi_cif -> IO ()
71 freeForeignCallInfo p = do
72 free ((#ptr ffi_cif, arg_types) p)
73 free p
74
75 strError :: C_ffi_status -> String
76 strError r
77 | r == fFI_BAD_ABI
78 = "invalid ABI (FFI_BAD_ABI)"
79 | r == fFI_BAD_TYPEDEF
80 = "invalid type description (FFI_BAD_TYPEDEF)"
81 | otherwise
82 = "unknown error: " ++ show r
83
84 convToABI :: FFIConv -> C_ffi_abi
85 convToABI FFICCall = fFI_DEFAULT_ABI
86 #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
87 convToABI FFIStdCall = fFI_STDCALL
88 #endif
89 -- unknown conventions are mapped to the default, (#3336)
90 convToABI _ = fFI_DEFAULT_ABI
91
92 ffiType :: FFIType -> Ptr C_ffi_type
93 ffiType FFIVoid = ffi_type_void
94 ffiType FFIPointer = ffi_type_pointer
95 ffiType FFIFloat = ffi_type_float
96 ffiType FFIDouble = ffi_type_double
97 ffiType FFISInt8 = ffi_type_sint8
98 ffiType FFISInt16 = ffi_type_sint16
99 ffiType FFISInt32 = ffi_type_sint32
100 ffiType FFISInt64 = ffi_type_sint64
101 ffiType FFIUInt8 = ffi_type_uint8
102 ffiType FFIUInt16 = ffi_type_uint16
103 ffiType FFIUInt32 = ffi_type_uint32
104 ffiType FFIUInt64 = ffi_type_uint64
105
106 data C_ffi_type
107 data C_ffi_cif
108
109 type C_ffi_status = (#type ffi_status)
110 type C_ffi_abi = (#type ffi_abi)
111
112 foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type
113 foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type
114 foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type
115 foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type
116 foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type
117 foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type
118 foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type
119 foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type
120 foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type
121 foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type
122 foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type
123 foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type
124
125 fFI_OK, fFI_BAD_ABI, fFI_BAD_TYPEDEF :: C_ffi_status
126 fFI_OK = (#const FFI_OK)
127 fFI_BAD_ABI = (#const FFI_BAD_ABI)
128 fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)
129
130 fFI_DEFAULT_ABI :: C_ffi_abi
131 fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
132 #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
133 fFI_STDCALL :: C_ffi_abi
134 fFI_STDCALL = (#const FFI_STDCALL)
135 #endif
136
137 -- ffi_status ffi_prep_cif(ffi_cif *cif,
138 -- ffi_abi abi,
139 -- unsigned int nargs,
140 -- ffi_type *rtype,
141 -- ffi_type **atypes);
142
143 foreign import ccall "ffi_prep_cif"
144 ffi_prep_cif :: Ptr C_ffi_cif -- cif
145 -> C_ffi_abi -- abi
146 -> CUInt -- nargs
147 -> Ptr C_ffi_type -- result type
148 -> Ptr (Ptr C_ffi_type) -- arg types
149 -> IO C_ffi_status
150
151 -- Currently unused:
152
153 -- void ffi_call(ffi_cif *cif,
154 -- void (*fn)(),
155 -- void *rvalue,
156 -- void **avalue);
157
158 -- foreign import ccall "ffi_call"
159 -- ffi_call :: Ptr C_ffi_cif -- cif
160 -- -> FunPtr (IO ()) -- function to call
161 -- -> Ptr () -- put result here
162 -- -> Ptr (Ptr ()) -- arg values
163 -- -> IO ()