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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
-----------------------------------------------------------------------------
--
-- libffi bindings
--
-- (c) The University of Glasgow 2008
--
-----------------------------------------------------------------------------
{- Note [FFI for the JS-Backend]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The JS-backend does not use GHC's native rts, as such you might think that it
doesn't require ghci. However, that is not true, because we need ghci in
order to interoperate with iserv even if we do not use any of the FFI stuff
in this file. So obviously we do not require libffi, but we still need to be
able to build ghci in order for the JS-Backend to supply its own iserv
interop solution. Thus we bite the bullet and wrap all the unneeded bits in a
CPP conditional compilation blocks that detect the JS-backend. A necessary
evil to be sure; notice that the only symbols remaining the JS_HOST_ARCH case
are those that are explicitly exported by this module and set to error if
they are every used.
-}
#if !defined(js_HOST_ARCH)
#include <ffi.h>
#endif
{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}
module GHCi.FFI
( FFIType(..)
, FFIConv(..)
, C_ffi_cif
, prepForeignCall
, freeForeignCallInfo
) where
import Prelude -- See note [Why do we import Prelude here?]
#if !defined(js_HOST_ARCH)
import Control.Exception
import Foreign.C
#endif
import Data.Binary
import GHC.Generics
import Foreign
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)
#if !defined(js_HOST_ARCH)
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 $ concat
[ "prepForeignCallFailed: ", strError r,
"(cconv: ", show cconv,
" arg tys: ", show arg_types,
" res ty: ", show result_type, ")" ]
else
return (castPtr cif)
#else
prepForeignCall _ _ _ =
error "GHCi.FFI.prepForeignCall: Called with JS_HOST_ARCH! Perhaps you need to run configure?"
#endif
freeForeignCallInfo :: Ptr C_ffi_cif -> IO ()
#if !defined(js_HOST_ARCH)
freeForeignCallInfo p = do
free ((#ptr ffi_cif, arg_types) p)
free p
#else
freeForeignCallInfo _ =
error "GHCi.FFI.freeForeignCallInfo: Called with JS_HOST_ARCH! Perhaps you need to run configure?"
#endif
data C_ffi_cif
#if !defined(js_HOST_ARCH)
data C_ffi_type
strError :: C_ffi_status -> String
strError r
| r == fFI_BAD_ABI
= "invalid ABI (FFI_BAD_ABI)"
| r == fFI_BAD_TYPEDEF
= "invalid type description (FFI_BAD_TYPEDEF)"
| otherwise
= "unknown error: " ++ show r
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
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, fFI_BAD_ABI, fFI_BAD_TYPEDEF :: C_ffi_status
fFI_OK = (#const FFI_OK)
fFI_BAD_ABI = (#const FFI_BAD_ABI)
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 ()
#endif
|
