73b80952afd3143e1c64a60806c621d105931a52
[ghc.git] / compiler / ghci / LibFFI.hsc
1 -----------------------------------------------------------------------------
2 --
3 -- libffi bindings
4 --
5 -- (c) The University of Glasgow 2008
6 --
7 -----------------------------------------------------------------------------
8
9 #include <ffi.h>
10
11 module LibFFI (
12   ForeignCallToken,
13   prepForeignCall
14  ) where
15
16 import TyCon
17 import ForeignCall
18 import Panic
19 -- import Outputable
20 import DynFlags
21
22 import Foreign
23 import Foreign.C
24 import Text.Printf
25
26 ----------------------------------------------------------------------------
27
28 type ForeignCallToken = C_ffi_cif
29
30 prepForeignCall
31     :: DynFlags
32     -> CCallConv
33     -> [PrimRep]                        -- arg types
34     -> PrimRep                          -- result type
35     -> IO (Ptr ForeignCallToken)        -- token for making calls
36                                         -- (must be freed by caller)
37 prepForeignCall dflags cconv arg_types result_type
38   = do
39     let n_args = length arg_types
40     arg_arr <- mallocArray n_args
41     let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType dflags ty)
42     mapM_ init_arg (zip arg_types [0..])
43     cif <- mallocBytes (#const sizeof(ffi_cif))
44     let abi = convToABI cconv
45     let res_ty = primRepToFFIType dflags result_type
46     r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
47     if (r /= fFI_OK)
48        then throwGhcException (InstallationError
49                         (printf "prepForeignCallFailed: %d" (show r)))
50        else return cif
51
52 convToABI :: CCallConv -> C_ffi_abi
53 convToABI CCallConv   = fFI_DEFAULT_ABI
54 #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
55 convToABI StdCallConv = fFI_STDCALL
56 #endif
57 -- unknown conventions are mapped to the default, (#3336)
58 convToABI _           = fFI_DEFAULT_ABI
59
60 -- c.f. DsForeign.primTyDescChar
61 primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type
62 primRepToFFIType dflags r
63   = case r of
64      VoidRep     -> ffi_type_void
65      IntRep      -> signed_word
66      WordRep     -> unsigned_word
67      Int64Rep    -> ffi_type_sint64
68      Word64Rep   -> ffi_type_uint64
69      AddrRep     -> ffi_type_pointer
70      FloatRep    -> ffi_type_float
71      DoubleRep   -> ffi_type_double
72      _           -> panic "primRepToFFIType"
73   where
74     (signed_word, unsigned_word)
75        | wORD_SIZE dflags == 4  = (ffi_type_sint32, ffi_type_uint32)
76        | wORD_SIZE dflags == 8  = (ffi_type_sint64, ffi_type_uint64)
77        | otherwise              = panic "primTyDescChar"
78
79
80 data C_ffi_type
81 data C_ffi_cif
82
83 type C_ffi_status = (#type ffi_status)
84 type C_ffi_abi    = (#type ffi_abi)
85
86 foreign import ccall "&ffi_type_void"   ffi_type_void    :: Ptr C_ffi_type
87 --foreign import ccall "&ffi_type_uint8"  ffi_type_uint8   :: Ptr C_ffi_type
88 --foreign import ccall "&ffi_type_sint8"  ffi_type_sint8   :: Ptr C_ffi_type
89 --foreign import ccall "&ffi_type_uint16" ffi_type_uint16  :: Ptr C_ffi_type
90 --foreign import ccall "&ffi_type_sint16" ffi_type_sint16  :: Ptr C_ffi_type
91 foreign import ccall "&ffi_type_uint32" ffi_type_uint32  :: Ptr C_ffi_type
92 foreign import ccall "&ffi_type_sint32" ffi_type_sint32  :: Ptr C_ffi_type
93 foreign import ccall "&ffi_type_uint64" ffi_type_uint64  :: Ptr C_ffi_type
94 foreign import ccall "&ffi_type_sint64" ffi_type_sint64  :: Ptr C_ffi_type
95 foreign import ccall "&ffi_type_float"  ffi_type_float   :: Ptr C_ffi_type
96 foreign import ccall "&ffi_type_double" ffi_type_double  :: Ptr C_ffi_type
97 foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type
98
99 fFI_OK            :: C_ffi_status
100 fFI_OK            = (#const FFI_OK)
101 --fFI_BAD_ABI     :: C_ffi_status
102 --fFI_BAD_ABI     = (#const FFI_BAD_ABI)
103 --fFI_BAD_TYPEDEF :: C_ffi_status
104 --fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)
105
106 fFI_DEFAULT_ABI :: C_ffi_abi
107 fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
108 #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
109 fFI_STDCALL     :: C_ffi_abi
110 fFI_STDCALL     = (#const FFI_STDCALL)
111 #endif
112
113 -- ffi_status ffi_prep_cif(ffi_cif *cif,
114 --                         ffi_abi abi,
115 --                         unsigned int nargs,
116 --                         ffi_type *rtype,
117 --                         ffi_type **atypes);
118
119 foreign import ccall "ffi_prep_cif"
120   ffi_prep_cif :: Ptr C_ffi_cif         -- cif
121                -> C_ffi_abi             -- abi
122                -> CUInt                 -- nargs
123                -> Ptr C_ffi_type        -- result type
124                -> Ptr (Ptr C_ffi_type)  -- arg types
125                -> IO C_ffi_status
126
127 -- Currently unused:
128
129 -- void ffi_call(ffi_cif *cif,
130 --               void (*fn)(),
131 --               void *rvalue,
132 --               void **avalue);
133
134 -- foreign import ccall "ffi_call"
135 --   ffi_call :: Ptr C_ffi_cif             -- cif
136 --            -> FunPtr (IO ())            -- function to call
137 --            -> Ptr ()                    -- put result here
138 --            -> Ptr (Ptr ())              -- arg values
139 --            -> IO ()