{-# LINE 1 "compiler/ghci/LibFFI.hsc" #-}
-----------------------------------------------------------------------------
{-# LINE 2 "compiler/ghci/LibFFI.hsc" #-}
--
-- libffi bindings
--
-- (c) The University of Glasgow 2008
--
-----------------------------------------------------------------------------


{-# LINE 10 "compiler/ghci/LibFFI.hsc" #-}

module LibFFI (
  ForeignCallToken,
  prepForeignCall
 ) where

import TyCon
import ForeignCall
import Panic
import DynFlags

import Control.Monad
import Foreign
import Foreign.C

----------------------------------------------------------------------------

type ForeignCallToken = C_ffi_cif

prepForeignCall
    :: DynFlags
    -> CCallConv
    -> [PrimRep]                        -- arg types
    -> PrimRep                          -- result type
    -> IO (Ptr ForeignCallToken)        -- token for making calls
                                        -- (must be freed by caller)
prepForeignCall dflags cconv arg_types result_type
  = do
    let n_args = length arg_types
    arg_arr <- mallocArray n_args
    let init_arg ty n = pokeElemOff arg_arr n (primRepToFFIType dflags ty)
    zipWithM_ init_arg arg_types [0..]
    cif <- mallocBytes (32)
{-# LINE 43 "compiler/ghci/LibFFI.hsc" #-}
    let abi = convToABI cconv
    let res_ty = primRepToFFIType dflags result_type
    r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
    if (r /= fFI_OK)
       then throwGhcExceptionIO (InstallationError
                                     ("prepForeignCallFailed: " ++ show r))
       else return cif

convToABI :: CCallConv -> C_ffi_abi
convToABI CCallConv   = fFI_DEFAULT_ABI

{-# LINE 56 "compiler/ghci/LibFFI.hsc" #-}
-- unknown conventions are mapped to the default, (#3336)
convToABI _           = fFI_DEFAULT_ABI

-- c.f. DsForeign.primTyDescChar
primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type
primRepToFFIType dflags r
  = case r of
     VoidRep     -> ffi_type_void
     IntRep      -> signed_word
     WordRep     -> unsigned_word
     Int64Rep    -> ffi_type_sint64
     Word64Rep   -> ffi_type_uint64
     AddrRep     -> ffi_type_pointer
     FloatRep    -> ffi_type_float
     DoubleRep   -> ffi_type_double
     _           -> panic "primRepToFFIType"
  where
    (signed_word, unsigned_word)
       | wORD_SIZE dflags == 4  = (ffi_type_sint32, ffi_type_uint32)
       | wORD_SIZE dflags == 8  = (ffi_type_sint64, ffi_type_uint64)
       | otherwise              = panic "primTyDescChar"


data C_ffi_type
data C_ffi_cif

type C_ffi_status = (Word32)
{-# LINE 83 "compiler/ghci/LibFFI.hsc" #-}
type C_ffi_abi    = (Word32)
{-# LINE 84 "compiler/ghci/LibFFI.hsc" #-}

foreign import ccall "&ffi_type_void"   ffi_type_void    :: Ptr C_ffi_type
--foreign import ccall "&ffi_type_uint8"  ffi_type_uint8   :: Ptr C_ffi_type
--foreign import ccall "&ffi_type_sint8"  ffi_type_sint8   :: Ptr C_ffi_type
--foreign import ccall "&ffi_type_uint16" ffi_type_uint16  :: Ptr C_ffi_type
--foreign import ccall "&ffi_type_sint16" ffi_type_sint16  :: Ptr C_ffi_type
foreign import ccall "&ffi_type_uint32" ffi_type_uint32  :: Ptr C_ffi_type
foreign import ccall "&ffi_type_sint32" ffi_type_sint32  :: Ptr C_ffi_type
foreign import ccall "&ffi_type_uint64" ffi_type_uint64  :: Ptr C_ffi_type
foreign import ccall "&ffi_type_sint64" ffi_type_sint64  :: Ptr C_ffi_type
foreign import ccall "&ffi_type_float"  ffi_type_float   :: Ptr C_ffi_type
foreign import ccall "&ffi_type_double" ffi_type_double  :: Ptr C_ffi_type
foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type

fFI_OK            :: C_ffi_status
fFI_OK            = (0)
{-# LINE 100 "compiler/ghci/LibFFI.hsc" #-}
--fFI_BAD_ABI     :: C_ffi_status
--fFI_BAD_ABI     = (#const FFI_BAD_ABI)
--fFI_BAD_TYPEDEF :: C_ffi_status
--fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)

fFI_DEFAULT_ABI :: C_ffi_abi
fFI_DEFAULT_ABI = (2)
{-# LINE 107 "compiler/ghci/LibFFI.hsc" #-}

{-# LINE 111 "compiler/ghci/LibFFI.hsc" #-}

-- ffi_status ffi_prep_cif(ffi_cif *cif,
--                         ffi_abi abi,
--                         unsigned int nargs,
--                         ffi_type *rtype,
--                         ffi_type **atypes);

foreign import ccall "ffi_prep_cif"
  ffi_prep_cif :: Ptr C_ffi_cif         -- cif
               -> C_ffi_abi             -- abi
               -> CUInt                 -- nargs
               -> Ptr C_ffi_type        -- result type
               -> Ptr (Ptr C_ffi_type)  -- arg types
               -> IO C_ffi_status

-- Currently unused:

-- void ffi_call(ffi_cif *cif,
--               void (*fn)(),
--               void *rvalue,
--               void **avalue);

-- foreign import ccall "ffi_call"
--   ffi_call :: Ptr C_ffi_cif             -- cif
--            -> FunPtr (IO ())            -- function to call
--            -> Ptr ()                    -- put result here
--            -> Ptr (Ptr ())              -- arg values
--            -> IO ()