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