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 import Control.Exception
  26
  27 ----------------------------------------------------------------------------
  28
  29 type ForeignCallToken = C_ffi_cif
  30
  31 prepForeignCall
  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 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 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 result_type
  46     r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
  47     if (r /= fFI_OK)
  48        then throwDyn (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 #ifdef mingw32_HOST_OS
  55 convToABI StdCallConv = fFI_STDCALL
  56 #endif
  57 convToABI _ = panic "convToABI: convention not supported"
  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 ()