{-# LINE 1 "libraries/ghci/GHCi/FFI.hsc" #-}
-----------------------------------------------------------------------------
--
-- libffi bindings
--
-- (c) The University of Glasgow 2008
--
-----------------------------------------------------------------------------



{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}
module GHCi.FFI
  ( FFIType(..)
  , FFIConv(..)
  , C_ffi_cif
  , prepForeignCall
  , freeForeignCallInfo
  ) where

import Prelude -- See note [Why do we import Prelude here?]
import Control.Exception
import Data.Binary
import GHC.Generics
import Foreign
import Foreign.C

data FFIType
  = FFIVoid
  | FFIPointer
  | FFIFloat
  | FFIDouble
  | FFISInt8
  | FFISInt16
  | FFISInt32
  | FFISInt64
  | FFIUInt8
  | FFIUInt16
  | FFIUInt32
  | FFIUInt64
  deriving (Int -> FFIType -> ShowS
[FFIType] -> ShowS
FFIType -> String
(Int -> FFIType -> ShowS)
-> (FFIType -> String) -> ([FFIType] -> ShowS) -> Show FFIType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FFIType -> ShowS
showsPrec :: Int -> FFIType -> ShowS
$cshow :: FFIType -> String
show :: FFIType -> String
$cshowList :: [FFIType] -> ShowS
showList :: [FFIType] -> ShowS
Show, (forall x. FFIType -> Rep FFIType x)
-> (forall x. Rep FFIType x -> FFIType) -> Generic FFIType
forall x. Rep FFIType x -> FFIType
forall x. FFIType -> Rep FFIType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FFIType -> Rep FFIType x
from :: forall x. FFIType -> Rep FFIType x
$cto :: forall x. Rep FFIType x -> FFIType
to :: forall x. Rep FFIType x -> FFIType
Generic, Get FFIType
[FFIType] -> Put
FFIType -> Put
(FFIType -> Put)
-> Get FFIType -> ([FFIType] -> Put) -> Binary FFIType
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: FFIType -> Put
put :: FFIType -> Put
$cget :: Get FFIType
get :: Get FFIType
$cputList :: [FFIType] -> Put
putList :: [FFIType] -> Put
Binary)

data FFIConv
  = FFICCall
  | FFIStdCall
  deriving (Int -> FFIConv -> ShowS
[FFIConv] -> ShowS
FFIConv -> String
(Int -> FFIConv -> ShowS)
-> (FFIConv -> String) -> ([FFIConv] -> ShowS) -> Show FFIConv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FFIConv -> ShowS
showsPrec :: Int -> FFIConv -> ShowS
$cshow :: FFIConv -> String
show :: FFIConv -> String
$cshowList :: [FFIConv] -> ShowS
showList :: [FFIConv] -> ShowS
Show, (forall x. FFIConv -> Rep FFIConv x)
-> (forall x. Rep FFIConv x -> FFIConv) -> Generic FFIConv
forall x. Rep FFIConv x -> FFIConv
forall x. FFIConv -> Rep FFIConv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FFIConv -> Rep FFIConv x
from :: forall x. FFIConv -> Rep FFIConv x
$cto :: forall x. Rep FFIConv x -> FFIConv
to :: forall x. Rep FFIConv x -> FFIConv
Generic, Get FFIConv
[FFIConv] -> Put
FFIConv -> Put
(FFIConv -> Put)
-> Get FFIConv -> ([FFIConv] -> Put) -> Binary FFIConv
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: FFIConv -> Put
put :: FFIConv -> Put
$cget :: Get FFIConv
get :: Get FFIConv
$cputList :: [FFIConv] -> Put
putList :: [FFIConv] -> Put
Binary)


prepForeignCall
    :: FFIConv
    -> [FFIType]          -- arg types
    -> FFIType            -- result type
    -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller)

prepForeignCall :: FFIConv -> [FFIType] -> FFIType -> IO (Ptr C_ffi_cif)
prepForeignCall FFIConv
cconv [FFIType]
arg_types FFIType
result_type = do
  let n_args :: Int
n_args = [FFIType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FFIType]
arg_types
  Ptr (Ptr C_ffi_type)
arg_arr <- Int -> IO (Ptr (Ptr C_ffi_type))
forall a. Storable a => Int -> IO (Ptr a)
mallocArray Int
n_args
  Ptr (Ptr C_ffi_type) -> [Ptr C_ffi_type] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr (Ptr C_ffi_type)
arg_arr ((FFIType -> Ptr C_ffi_type) -> [FFIType] -> [Ptr C_ffi_type]
forall a b. (a -> b) -> [a] -> [b]
map FFIType -> Ptr C_ffi_type
ffiType [FFIType]
arg_types)
  Ptr C_ffi_cif
cif <- Int -> IO (Ptr C_ffi_cif)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
32)
{-# LINE 59 "libraries/ghci/GHCi/FFI.hsc" #-}
  let abi = convToABI cconv
  C_ffi_abi
r <- Ptr C_ffi_cif
-> C_ffi_abi
-> CUInt
-> Ptr C_ffi_type
-> Ptr (Ptr C_ffi_type)
-> IO C_ffi_abi
ffi_prep_cif Ptr C_ffi_cif
cif C_ffi_abi
abi (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n_args) (FFIType -> Ptr C_ffi_type
ffiType FFIType
result_type) Ptr (Ptr C_ffi_type)
arg_arr
  if C_ffi_abi
r C_ffi_abi -> C_ffi_abi -> Bool
forall a. Eq a => a -> a -> Bool
/= C_ffi_abi
fFI_OK then
    ErrorCall -> IO (Ptr C_ffi_cif)
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO (Ptr C_ffi_cif))
-> ErrorCall -> IO (Ptr C_ffi_cif)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"prepForeignCallFailed: ", C_ffi_abi -> String
strError C_ffi_abi
r,
        String
"(cconv: ", FFIConv -> String
forall a. Show a => a -> String
show FFIConv
cconv,
        String
" arg tys: ", [FFIType] -> String
forall a. Show a => a -> String
show [FFIType]
arg_types,
        String
" res ty: ", FFIType -> String
forall a. Show a => a -> String
show FFIType
result_type, String
")" ]
  else
    Ptr C_ffi_cif -> IO (Ptr C_ffi_cif)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C_ffi_cif -> Ptr C_ffi_cif
forall a b. Ptr a -> Ptr b
castPtr Ptr C_ffi_cif
cif)

freeForeignCallInfo :: Ptr C_ffi_cif -> IO ()
freeForeignCallInfo :: Ptr C_ffi_cif -> IO ()
freeForeignCallInfo Ptr C_ffi_cif
p = do
  Ptr Any -> IO ()
forall a. Ptr a -> IO ()
free (((\Ptr C_ffi_cif
hsc_ptr -> Ptr C_ffi_cif
hsc_ptr Ptr C_ffi_cif -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8)) Ptr C_ffi_cif
p)
{-# LINE 73 "libraries/ghci/GHCi/FFI.hsc" #-}
  free p

strError :: C_ffi_status -> String
strError :: C_ffi_abi -> String
strError C_ffi_abi
r
  | C_ffi_abi
r C_ffi_abi -> C_ffi_abi -> Bool
forall a. Eq a => a -> a -> Bool
== C_ffi_abi
fFI_BAD_ABI
  = String
"invalid ABI (FFI_BAD_ABI)"
  | C_ffi_abi
r C_ffi_abi -> C_ffi_abi -> Bool
forall a. Eq a => a -> a -> Bool
== C_ffi_abi
fFI_BAD_TYPEDEF
  = String
"invalid type description (FFI_BAD_TYPEDEF)"
  | Bool
otherwise
  = String
"unknown error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ C_ffi_abi -> String
forall a. Show a => a -> String
show C_ffi_abi
r

convToABI :: FFIConv -> C_ffi_abi
convToABI :: FFIConv -> C_ffi_abi
convToABI FFIConv
FFICCall  = C_ffi_abi
fFI_DEFAULT_ABI

{-# LINE 89 "libraries/ghci/GHCi/FFI.hsc" #-}
-- unknown conventions are mapped to the default, (#3336)
convToABI FFIConv
_           = C_ffi_abi
fFI_DEFAULT_ABI

ffiType :: FFIType -> Ptr C_ffi_type
ffiType :: FFIType -> Ptr C_ffi_type
ffiType FFIType
FFIVoid     = Ptr C_ffi_type
ffi_type_void
ffiType FFIType
FFIPointer  = Ptr C_ffi_type
ffi_type_pointer
ffiType FFIType
FFIFloat    = Ptr C_ffi_type
ffi_type_float
ffiType FFIType
FFIDouble   = Ptr C_ffi_type
ffi_type_double
ffiType FFIType
FFISInt8    = Ptr C_ffi_type
ffi_type_sint8
ffiType FFIType
FFISInt16   = Ptr C_ffi_type
ffi_type_sint16
ffiType FFIType
FFISInt32   = Ptr C_ffi_type
ffi_type_sint32
ffiType FFIType
FFISInt64   = Ptr C_ffi_type
ffi_type_sint64
ffiType FFIType
FFIUInt8    = Ptr C_ffi_type
ffi_type_uint8
ffiType FFIType
FFIUInt16   = Ptr C_ffi_type
ffi_type_uint16
ffiType FFIType
FFIUInt32   = Ptr C_ffi_type
ffi_type_uint32
ffiType FFIType
FFIUInt64   = Ptr C_ffi_type
ffi_type_uint64

data C_ffi_type
data C_ffi_cif

type C_ffi_status = (Word32)
{-# LINE 110 "libraries/ghci/GHCi/FFI.hsc" #-}
type C_ffi_abi    = (Word32)
{-# LINE 111 "libraries/ghci/GHCi/FFI.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, fFI_BAD_ABI, fFI_BAD_TYPEDEF :: C_ffi_status
fFI_OK :: C_ffi_abi
fFI_OK = (C_ffi_abi
0)
{-# LINE 127 "libraries/ghci/GHCi/FFI.hsc" #-}
fFI_BAD_ABI = (2)
{-# LINE 128 "libraries/ghci/GHCi/FFI.hsc" #-}
fFI_BAD_TYPEDEF = (1)
{-# LINE 129 "libraries/ghci/GHCi/FFI.hsc" #-}

fFI_DEFAULT_ABI :: C_ffi_abi
fFI_DEFAULT_ABI :: C_ffi_abi
fFI_DEFAULT_ABI = (C_ffi_abi
2)
{-# LINE 132 "libraries/ghci/GHCi/FFI.hsc" #-}

{-# LINE 136 "libraries/ghci/GHCi/FFI.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 ()