Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[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 {-# OPTIONS -fno-warn-tabs #-}
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and
14 -- detab the module (please do the detabbing in a separate patch). See
15 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp
16 -- for details
17
18 module LibFFI (
19   ForeignCallToken,
20   prepForeignCall
21  ) where
22
23 import TyCon
24 import ForeignCall
25 import Panic
26 -- import Outputable
27 import DynFlags
28
29 import Foreign
30 import Foreign.C
31 import Text.Printf
32
33 ----------------------------------------------------------------------------
34
35 type ForeignCallToken = C_ffi_cif
36
37 prepForeignCall
38     :: DynFlags
39     -> CCallConv
40     -> [PrimRep]                        -- arg types
41     -> PrimRep                          -- result type
42     -> IO (Ptr ForeignCallToken)        -- token for making calls
43                                         -- (must be freed by caller)
44 prepForeignCall dflags cconv arg_types result_type
45   = do
46     let n_args = length arg_types
47     arg_arr <- mallocArray n_args
48     let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType dflags ty)
49     mapM_ init_arg (zip arg_types [0..])
50     cif <- mallocBytes (#const sizeof(ffi_cif))
51     let abi = convToABI cconv
52     let res_ty = primRepToFFIType dflags result_type
53     r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
54     if (r /= fFI_OK)
55        then ghcError (InstallationError 
56                         (printf "prepForeignCallFailed: %d" (show r)))
57        else return cif
58     
59 convToABI :: CCallConv -> C_ffi_abi
60 convToABI CCallConv   = fFI_DEFAULT_ABI
61 #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
62 convToABI StdCallConv = fFI_STDCALL
63 #endif
64 -- unknown conventions are mapped to the default, (#3336)
65 convToABI _           = fFI_DEFAULT_ABI
66
67 -- c.f. DsForeign.primTyDescChar
68 primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type
69 primRepToFFIType dflags r
70   = case r of
71      VoidRep     -> ffi_type_void
72      IntRep      -> signed_word
73      WordRep     -> unsigned_word
74      Int64Rep    -> ffi_type_sint64
75      Word64Rep   -> ffi_type_uint64
76      AddrRep     -> ffi_type_pointer
77      FloatRep    -> ffi_type_float
78      DoubleRep   -> ffi_type_double
79      _           -> panic "primRepToFFIType"
80   where
81     (signed_word, unsigned_word)
82        | wORD_SIZE dflags == 4  = (ffi_type_sint32, ffi_type_uint32)
83        | wORD_SIZE dflags == 8  = (ffi_type_sint64, ffi_type_uint64)
84        | otherwise              = panic "primTyDescChar"
85
86
87 data C_ffi_type
88 data C_ffi_cif
89
90 type C_ffi_status = (#type ffi_status)
91 type C_ffi_abi    = (#type ffi_abi)
92
93 foreign import ccall "&ffi_type_void"   ffi_type_void    :: Ptr C_ffi_type
94 --foreign import ccall "&ffi_type_uint8"  ffi_type_uint8   :: Ptr C_ffi_type
95 --foreign import ccall "&ffi_type_sint8"  ffi_type_sint8   :: Ptr C_ffi_type
96 --foreign import ccall "&ffi_type_uint16" ffi_type_uint16  :: Ptr C_ffi_type
97 --foreign import ccall "&ffi_type_sint16" ffi_type_sint16  :: Ptr C_ffi_type
98 foreign import ccall "&ffi_type_uint32" ffi_type_uint32  :: Ptr C_ffi_type
99 foreign import ccall "&ffi_type_sint32" ffi_type_sint32  :: Ptr C_ffi_type
100 foreign import ccall "&ffi_type_uint64" ffi_type_uint64  :: Ptr C_ffi_type
101 foreign import ccall "&ffi_type_sint64" ffi_type_sint64  :: Ptr C_ffi_type
102 foreign import ccall "&ffi_type_float"  ffi_type_float   :: Ptr C_ffi_type
103 foreign import ccall "&ffi_type_double" ffi_type_double  :: Ptr C_ffi_type
104 foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type
105
106 fFI_OK            :: C_ffi_status
107 fFI_OK            = (#const FFI_OK)
108 --fFI_BAD_ABI     :: C_ffi_status
109 --fFI_BAD_ABI     = (#const FFI_BAD_ABI)
110 --fFI_BAD_TYPEDEF :: C_ffi_status
111 --fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)
112
113 fFI_DEFAULT_ABI :: C_ffi_abi
114 fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
115 #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
116 fFI_STDCALL     :: C_ffi_abi
117 fFI_STDCALL     = (#const FFI_STDCALL)
118 #endif
119
120 -- ffi_status ffi_prep_cif(ffi_cif *cif,
121 --                      ffi_abi abi,
122 --                      unsigned int nargs,
123 --                      ffi_type *rtype,
124 --                      ffi_type **atypes);
125
126 foreign import ccall "ffi_prep_cif"
127   ffi_prep_cif :: Ptr C_ffi_cif         -- cif
128                -> C_ffi_abi             -- abi
129                -> CUInt                 -- nargs
130                -> Ptr C_ffi_type        -- result type
131                -> Ptr (Ptr C_ffi_type)  -- arg types
132                -> IO C_ffi_status
133
134 -- Currently unused:
135
136 -- void ffi_call(ffi_cif *cif,
137 --            void (*fn)(),
138 --            void *rvalue,
139 --            void **avalue);
140
141 -- foreign import ccall "ffi_call"
142 --   ffi_call :: Ptr C_ffi_cif             -- cif
143 --            -> FunPtr (IO ())            -- function to call
144 --            -> Ptr ()                    -- put result here
145 --            -> Ptr (Ptr ())              -- arg values
146 --            -> IO ()