1 -----------------------------------------------------------------------------
5 -- (c) The University of Glasgow 2008
7 -----------------------------------------------------------------------------
11 module LibFFI () where
31 import Control.Exception
33 ----------------------------------------------------------------------------
35 type ForeignCallToken = C_ffi_cif
39 -> [PrimRep] -- arg types
40 -> PrimRep -- result type
41 -> IO (Ptr ForeignCallToken) -- token for making calls
42 -- (must be freed by caller)
43 prepForeignCall cconv arg_types result_type
45 let n_args = length arg_types
46 arg_arr <- mallocArray n_args
47 let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType ty)
48 mapM_ init_arg (zip arg_types [0..])
49 cif <- mallocBytes (#const sizeof(ffi_cif))
50 let abi = convToABI cconv
51 let res_ty = primRepToFFIType result_type
52 r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
54 then throwDyn (InstallationError
55 (printf "prepForeignCallFailed: %d" (show r)))
58 convToABI :: CCallConv -> C_ffi_abi
59 convToABI CCallConv = fFI_DEFAULT_ABI
60 #ifdef mingw32_HOST_OS
61 convToABI StdCallConv = fFI_STDCALL
63 convToABI _ = panic "convToABI: convention not supported"
65 -- c.f. DsForeign.primTyDescChar
66 primRepToFFIType :: PrimRep -> Ptr C_ffi_type
69 VoidRep -> ffi_type_void
71 WordRep -> unsigned_word
72 Int64Rep -> ffi_type_sint64
73 Word64Rep -> ffi_type_uint64
74 AddrRep -> ffi_type_pointer
75 FloatRep -> ffi_type_float
76 DoubleRep -> ffi_type_double
77 _ -> panic "primRepToFFIType"
79 (signed_word, unsigned_word)
80 | wORD_SIZE == 4 = (ffi_type_sint32, ffi_type_uint32)
81 | wORD_SIZE == 8 = (ffi_type_sint64, ffi_type_uint64)
82 | otherwise = panic "primTyDescChar"
88 type C_ffi_status = (#type ffi_status)
89 type C_ffi_abi = (#type ffi_abi)
91 foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type
92 --foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type
93 --foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type
94 --foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type
95 --foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type
96 foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type
97 foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type
98 foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type
99 foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type
100 foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type
101 foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type
102 foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type
104 fFI_OK :: C_ffi_status
105 fFI_OK = (#const FFI_OK)
106 --fFI_BAD_ABI :: C_ffi_status
107 --fFI_BAD_ABI = (#const FFI_BAD_ABI)
108 --fFI_BAD_TYPEDEF :: C_ffi_status
109 --fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)
111 fFI_DEFAULT_ABI :: C_ffi_abi
112 fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
113 #ifdef mingw32_HOST_OS
114 fFI_STDCALL :: C_ffi_abi
115 fFI_STDCALL = (#const FFI_STDCALL)
118 -- ffi_status ffi_prep_cif(ffi_cif *cif,
120 -- unsigned int nargs,
122 -- ffi_type **atypes);
124 foreign import ccall "ffi_prep_cif"
125 ffi_prep_cif :: Ptr C_ffi_cif -- cif
128 -> Ptr C_ffi_type -- result type
129 -> Ptr (Ptr C_ffi_type) -- arg types
134 -- void ffi_call(ffi_cif *cif,
139 -- foreign import ccall "ffi_call"
140 -- ffi_call :: Ptr C_ffi_cif -- cif
141 -- -> FunPtr (IO ()) -- function to call
142 -- -> Ptr () -- put result here
143 -- -> Ptr (Ptr ()) -- arg values