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
|
-----------------------------------------------------------------------------
--
-- libffi bindings
--
-- (c) The University of Glasgow 2008
--
-----------------------------------------------------------------------------
#include <ffi.h>
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp
-- for details
module LibFFI (
ForeignCallToken,
prepForeignCall
) where
import TyCon
import ForeignCall
import Panic
-- import Outputable
import Constants
import Foreign
import Foreign.C
import Text.Printf
----------------------------------------------------------------------------
type ForeignCallToken = C_ffi_cif
prepForeignCall
:: CCallConv
-> [PrimRep] -- arg types
-> PrimRep -- result type
-> IO (Ptr ForeignCallToken) -- 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
let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType ty)
mapM_ init_arg (zip arg_types [0..])
cif <- mallocBytes (#const sizeof(ffi_cif))
let abi = convToABI cconv
let res_ty = primRepToFFIType result_type
r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
if (r /= fFI_OK)
then ghcError (InstallationError
(printf "prepForeignCallFailed: %d" (show r)))
else return cif
convToABI :: CCallConv -> C_ffi_abi
convToABI CCallConv = fFI_DEFAULT_ABI
#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
convToABI StdCallConv = fFI_STDCALL
#endif
-- unknown conventions are mapped to the default, (#3336)
convToABI _ = fFI_DEFAULT_ABI
-- c.f. DsForeign.primTyDescChar
primRepToFFIType :: PrimRep -> Ptr C_ffi_type
primRepToFFIType r
= case r of
VoidRep -> ffi_type_void
IntRep -> signed_word
WordRep -> unsigned_word
Int64Rep -> ffi_type_sint64
Word64Rep -> ffi_type_uint64
AddrRep -> ffi_type_pointer
FloatRep -> ffi_type_float
DoubleRep -> ffi_type_double
_ -> panic "primRepToFFIType"
where
(signed_word, unsigned_word)
| wORD_SIZE == 4 = (ffi_type_sint32, ffi_type_uint32)
| wORD_SIZE == 8 = (ffi_type_sint64, ffi_type_uint64)
| otherwise = panic "primTyDescChar"
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 ()
|
