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