compiler/ghci/LibFFI.hsc

   1 -----------------------------------------------------------------------------
   2 --
   3 -- libffi bindings
   4 --
   5 -- (c) The University of Glasgow 2008
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 #ifndef USE_LIBFFI
  10
  11 module LibFFI () where
  12
  13 #else
  14
  15 #include <ffi.h>
  16
  17 module LibFFI (
  18   ForeignCallToken,
  19   prepForeignCall
  20  ) where
  21
  22 import TyCon
  23 import ForeignCall
  24 import Panic
  25 import Outputable
  26 import Constants
  27
  28 import Foreign
  29 import Foreign.C
  30 import Text.Printf
  31 import Control.Exception
  32
  33 ----------------------------------------------------------------------------
  34
  35 type ForeignCallToken = C_ffi_cif
  36
  37 prepForeignCall
  38     :: CCallConv
  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
  44   = do
  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
  53     if (r /= fFI_OK)
  54        then throwDyn (InstallationError
  55                         (printf "prepForeignCallFailed: %d" (show r)))
  56        else return cif
  57
  58 convToABI :: CCallConv -> C_ffi_abi
  59 convToABI CCallConv   = fFI_DEFAULT_ABI
  60 #ifdef mingw32_HOST_OS
  61 convToABI StdCallConv = fFI_STDCALL
  62 #endif
  63 convToABI _ = panic "convToABI: convention not supported"
  64
  65 -- c.f. DsForeign.primTyDescChar
  66 primRepToFFIType :: PrimRep -> Ptr C_ffi_type
  67 primRepToFFIType r
  68   = case r of
  69      VoidRep     -> ffi_type_void
  70      IntRep      -> signed_word
  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"
  78   where
  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"
  83
  84
  85 data C_ffi_type
  86 data C_ffi_cif
  87
  88 type C_ffi_status = (#type ffi_status)
  89 type C_ffi_abi    = (#type ffi_abi)
  90
  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
 103
 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)
 110
 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)
 116 #endif
 117
 118 -- ffi_status ffi_prep_cif(ffi_cif *cif,
 119 --                      ffi_abi abi,
 120 --                      unsigned int nargs,
 121 --                      ffi_type *rtype,
 122 --                      ffi_type **atypes);
 123
 124 foreign import ccall "ffi_prep_cif"
 125   ffi_prep_cif :: Ptr C_ffi_cif         -- cif
 126                -> C_ffi_abi             -- abi
 127                -> CUInt                 -- nargs
 128                -> Ptr C_ffi_type        -- result type
 129                -> Ptr (Ptr C_ffi_type)  -- arg types
 130                -> IO C_ffi_status
 131
 132 -- Currently unused:
 133
 134 -- void ffi_call(ffi_cif *cif,
 135 --            void (*fn)(),
 136 --            void *rvalue,
 137 --            void **avalue);
 138
 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
 144 --            -> IO ()
 145
 146 #endif