{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Turning a Unison function into a C-callable function pointer, so that C
-- code can call back into Unison. This is the mirror image of the dynamic
-- call in "Unison.Runtime.Machine": there, Unison stack values are marshalled
-- into a libffi argument buffer and a C function is called; here a C caller
-- fills an argument buffer, a libffi /closure/ invokes a single generic
-- Haskell entry point, we decode the arguments directly onto a Unison stack,
-- run the Unison function, and marshal its result (left on the stack) back
-- into the C return slot.
--
-- The Haskell @libffi@ package does not expose the closure API, so the three
-- @ffi_closure_*@ entry points are imported directly (they are linked via
-- that package already), as is done for @ffi_prep_cif_var@ in
-- "Unison.Runtime.Foreign.Dynamic".
--
-- Running the Unison function is supplied by the caller (a @Stack -> (Stack ->
-- IO ()) -> IO ()@ action, in practice a partially-applied evaluator entry) so
-- that this module does not depend on the evaluator. Arguments are written
-- straight to the stack rather than through an intermediate @[Val]@, so the
-- marshalling allocates nothing beyond the stack itself.
module Unison.Runtime.Foreign.Callback
  ( RunCallback,
    mkCallback,
    freeCallback,
    CallbackException (..),
  )
where

import Control.Exception (Exception, finally, throwIO)
import Control.Monad (unless, when)
import Data.IORef
import Data.Int
import Data.Word
import Foreign.C.Types (CSize (..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.LibFFI.Internal (CIF, CValue, C_ffi_status, ffi_ok)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable (peek, peekElemOff, poke)
import GHC.Float (double2Float, float2Double)
import System.IO.Unsafe (unsafePerformIO)
import Unison.Runtime.Foreign.Dynamic
import Unison.Runtime.Stack
  ( Stack,
    alloc,
    bump,
    defaultStackSlots,
    peekOffBi,
    peekOffD,
    peekOffI,
    peekOffN,
    pokeBi,
    pokeD,
    pokeI,
    pokeN,
  )

-- | Runs the Unison function from a callback: the given stack already holds the
-- decoded C arguments (pushed in parameter order); apply the function to them
-- and hand the result stack to the continuation (the result on top). Supplied
-- by the evaluator so this module stays off it. Expected to be synchronous.
type RunCallback = Stack -> (Stack -> IO ()) -> IO ()

-- | What a prepared closure needs at call time: the signature (for
-- marshalling), the action that runs the Unison function, and a reusable stack
-- guarded by an in-use flag (see 'callbackEntry').
data CallbackCtx = CallbackCtx !FFSpec !RunCallback !(IORef Bool) !Stack

data CallbackException
  = -- | A callback argument/result type that is not supported.
    UnsupportedCallbackType FFType
  | -- | @ffi_prep_closure_loc@ failed.
    BadClosureInit
  deriving (CallbackException -> CallbackException -> Bool
(CallbackException -> CallbackException -> Bool)
-> (CallbackException -> CallbackException -> Bool)
-> Eq CallbackException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallbackException -> CallbackException -> Bool
== :: CallbackException -> CallbackException -> Bool
$c/= :: CallbackException -> CallbackException -> Bool
/= :: CallbackException -> CallbackException -> Bool
Eq, Int -> CallbackException -> ShowS
[CallbackException] -> ShowS
CallbackException -> String
(Int -> CallbackException -> ShowS)
-> (CallbackException -> String)
-> ([CallbackException] -> ShowS)
-> Show CallbackException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallbackException -> ShowS
showsPrec :: Int -> CallbackException -> ShowS
$cshow :: CallbackException -> String
show :: CallbackException -> String
$cshowList :: [CallbackException] -> ShowS
showList :: [CallbackException] -> ShowS
Show)

instance Exception CallbackException

-- The entry function has a fixed C signature regardless of the callback's
-- actual type, so it can be wrapped once and shared by every closure.
type CallbackEntry =
  Ptr CIF -> Ptr CValue -> Ptr (Ptr CValue) -> Ptr () -> IO ()

foreign import ccall "wrapper"
  wrapCallbackEntry :: CallbackEntry -> IO (FunPtr CallbackEntry)

foreign import ccall unsafe "ffi_closure_alloc"
  ffi_closure_alloc :: CSize -> Ptr (Ptr ()) -> IO (Ptr ())

foreign import ccall unsafe "ffi_closure_free"
  ffi_closure_free :: Ptr () -> IO ()

foreign import ccall unsafe "ffi_prep_closure_loc"
  ffi_prep_closure_loc ::
    Ptr () -> Ptr CIF -> FunPtr CallbackEntry -> Ptr () -> Ptr () -> IO C_ffi_status

-- @sizeof(ffi_closure)@ is tens of bytes on every supported platform;
-- @ffi_closure_alloc@ accepts any size at least that large, so we over-
-- allocate a generous fixed amount rather than pull in @ffi.h@ for the exact
-- size (its path is not portable). The extra bytes are unused.
closureSize :: CSize
closureSize :: CSize
closureSize = CSize
1024

-- The single, shared entry point. It recovers the per-closure context from the
-- user-data pointer, obtains a Unison stack, decodes the C arguments onto it,
-- runs the function, and writes the result (left on the stack) back.
--
-- Copy-on-concurrent-write: the callback keeps one reusable stack behind an
-- atomic in-use flag. A caller claims it with a test-and-set; whoever wins
-- reuses it (and allocates nothing), and anyone who finds it already in use —
-- a concurrent call on another thread, or a reentrant call on this one (e.g.
-- the Unison function calls back out to C which invokes this callback again) —
-- falls back to a fresh stack, so two live calls never share one. The flag is
-- released in a @finally@ so an exception can't leave it stuck.
callbackEntry :: CallbackEntry
callbackEntry :: CallbackEntry
callbackEntry Ptr CIF
_cif Ptr CValue
ret Ptr (Ptr CValue)
argv Ptr ()
userData = do
  CallbackCtx FFSpec
spec RunCallback
run IORef Bool
inUse Stack
reusable <- StablePtr CallbackCtx -> IO CallbackCtx
forall a. StablePtr a -> IO a
deRefStablePtr (Ptr () -> StablePtr CallbackCtx
forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
userData)
  Bool
won <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
inUse (\Bool
used -> (Bool
True, Bool
used))
  Stack
stk <- if Bool
won then Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
reusable else Int -> IO Stack
alloc Int
defaultStackSlots
  let invoke :: IO ()
invoke = do
        Stack
stk <- [FFType] -> Ptr (Ptr CValue) -> Stack -> IO Stack
pushArgs (FFSpec -> [FFType]
ffArgs FFSpec
spec) Ptr (Ptr CValue)
argv Stack
stk
        RunCallback
run Stack
stk \Stack
result -> FFType -> Ptr CValue -> Stack -> IO ()
writeResult (FFSpec -> FFType
ffResult FFSpec
spec) Ptr CValue
ret Stack
result
  IO ()
invoke IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
won (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
inUse Bool
False)

sharedEntry :: FunPtr CallbackEntry
sharedEntry :: FunPtr CallbackEntry
sharedEntry = IO (FunPtr CallbackEntry) -> FunPtr CallbackEntry
forall a. IO a -> a
unsafePerformIO (CallbackEntry -> IO (FunPtr CallbackEntry)
wrapCallbackEntry CallbackEntry
callbackEntry)
{-# NOINLINE sharedEntry #-}

-- | Build a C-callable function pointer from a Unison function. The 'FFSpec'
-- describes the C signature; @run@ applies the Unison function to the arguments
-- the callback decodes onto the stack. The result is a 'CDynFunc' (so it flows
-- through the same paths as a symbol loaded from a DLL) whose underlying
-- pointer calls back into Unison.
--
-- The returned callback holds the Unison function (and anything it closes
-- over) alive until 'freeCallback' is called; using the pointer afterwards is
-- a use-after-free, exactly as with a freed 'Unison.Runtime.Foreign.Dynamic'
-- pointer.
mkCallback :: FFSpec -> RunCallback -> IO CDynFunc
mkCallback :: FFSpec -> RunCallback -> IO CDynFunc
mkCallback FFSpec
spec0 RunCallback
run = do
  CSpec
cspec <- FFSpec -> IO CSpec
prepareSpec FFSpec
spec0
  let spec :: FFSpec
spec = CSpec -> FFSpec
ffSpec CSpec
cspec
  (FFType -> IO ()) -> [FFType] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FFType -> IO ()
checkArgType (FFSpec -> [FFType]
ffArgs FFSpec
spec)
  FFType -> IO ()
checkResultType (FFSpec -> FFType
ffResult FFSpec
spec)
  IORef Bool
inUse <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  -- The stack takes its size here since this module is off the evaluator,
  -- which is where the JIT's settings live; the `ustack` stress mode's tiny
  -- stack doesn't apply to callbacks, so growth is exercised on the main
  -- stacks only.
  Stack
reusable <- Int -> IO Stack
alloc Int
defaultStackSlots
  (Ptr (Ptr ()) -> IO CDynFunc) -> IO CDynFunc
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr ())
codeRef -> do
    Ptr ()
writable <- CSize -> Ptr (Ptr ()) -> IO (Ptr ())
ffi_closure_alloc CSize
closureSize Ptr (Ptr ())
codeRef
    Ptr ()
code <- Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ())
codeRef
    StablePtr CallbackCtx
sp <- CallbackCtx -> IO (StablePtr CallbackCtx)
forall a. a -> IO (StablePtr a)
newStablePtr (FFSpec -> RunCallback -> IORef Bool -> Stack -> CallbackCtx
CallbackCtx FFSpec
spec RunCallback
run IORef Bool
inUse Stack
reusable)
    Word32
status <-
      ForeignPtr CIF -> (Ptr CIF -> IO Word32) -> IO Word32
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (CSpec -> ForeignPtr CIF
cInterface CSpec
cspec) \Ptr CIF
cif ->
        Ptr ()
-> Ptr CIF -> FunPtr CallbackEntry -> Ptr () -> Ptr () -> IO Word32
ffi_prep_closure_loc Ptr ()
writable Ptr CIF
cif FunPtr CallbackEntry
sharedEntry (StablePtr CallbackCtx -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr CallbackCtx
sp) Ptr ()
code
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
status Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
ffi_ok) do
      Ptr () -> IO ()
ffi_closure_free Ptr ()
writable
      StablePtr CallbackCtx -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr CallbackCtx
sp
      CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO CallbackException
BadClosureInit
    -- The teardown is carried on the function value itself (see
    -- 'Unison.Runtime.Foreign.Dynamic.cFinalize'), so 'freeCallback' needs no
    -- global or runtime-threaded registry. The flag makes a double free safe.
    IORef Bool
freedRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    let finalize :: IO ()
finalize = do
          Bool
firstTime <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
freedRef \Bool
freed -> (Bool
True, Bool -> Bool
not Bool
freed)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
firstTime do
            Ptr () -> IO ()
ffi_closure_free Ptr ()
writable
            StablePtr CallbackCtx -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr CallbackCtx
sp
    pure $ String -> CSpec -> FunPtr (ZonkAny 0) -> IO () -> CDynFunc
forall a. String -> CSpec -> FunPtr a -> IO () -> CDynFunc
CDynFunc String
"<callback>" CSpec
cspec (Ptr () -> FunPtr (ZonkAny 0)
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr Ptr ()
code) IO ()
finalize

-- | Release a callback created by 'mkCallback': frees the libffi closure and
-- drops the reference keeping the Unison function alive. Safe to call more
-- than once, and a no-op on a 'CDynFunc' that is not a callback (e.g. a DLL
-- symbol, whose finalizer is @pure ()@).
freeCallback :: CDynFunc -> IO ()
freeCallback :: CDynFunc -> IO ()
freeCallback = CDynFunc -> IO ()
cFinalize

checkArgType :: FFType -> IO ()
checkArgType :: FFType -> IO ()
checkArgType FFType
t
  | FFType
t FFType -> [FFType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FFType
MBArr, FFType
Fun, FFType
Void] = CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
t)
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

checkResultType :: FFType -> IO ()
checkResultType :: FFType -> IO ()
checkResultType FFType
t
  | FFType
t FFType -> [FFType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FFType
MBArr, FFType
Fun] = CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
t)
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- Decode the C argument buffer directly onto the stack, pushing one value per
-- argument in parameter order (so the first argument ends up deepest).
pushArgs :: [FFType] -> Ptr (Ptr CValue) -> Stack -> IO Stack
pushArgs :: [FFType] -> Ptr (Ptr CValue) -> Stack -> IO Stack
pushArgs [FFType]
tys Ptr (Ptr CValue)
argv = Int -> [FFType] -> Stack -> IO Stack
go Int
0 [FFType]
tys
  where
    go :: Int -> [FFType] -> Stack -> IO Stack
go Int
_ [] Stack
stk = Stack -> IO Stack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stack
stk
    go Int
i (FFType
ty : [FFType]
rest) Stack
stk = do
      Ptr ()
p <- Ptr CValue -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr (Ptr CValue -> Ptr ()) -> IO (Ptr CValue) -> IO (Ptr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (Ptr CValue) -> Int -> IO (Ptr CValue)
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr (Ptr CValue)
argv Int
i
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      FFType -> Ptr () -> Stack -> IO ()
pushArg FFType
ty Ptr ()
p Stack
stk
      Int -> [FFType] -> Stack -> IO Stack
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [FFType]
rest Stack
stk

pushArg :: FFType -> Ptr () -> Stack -> IO ()
pushArg :: FFType -> Ptr () -> Stack -> IO ()
pushArg FFType
ty Ptr ()
p Stack
stk = case FFType
ty of
  FFType
I8 -> (Ptr Int8 -> IO Int8
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Int8
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Int8) IO Int8 -> (Int8 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int8 -> Int) -> Int8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
I16 -> (Ptr Int16 -> IO Int16
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Int16
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Int16) IO Int16 -> (Int16 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int16 -> Int) -> Int16 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
I32 -> (Ptr Int32 -> IO Int32
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Int32
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Int32) IO Int32 -> (Int32 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int32 -> Int) -> Int32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
I64 -> (Ptr Int64 -> IO Int64
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Int64
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Int64) IO Int64 -> (Int64 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Int -> IO ()
pokeI Stack
stk (Int -> IO ()) -> (Int64 -> Int) -> Int64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
U8 -> (Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Word8) IO Word8 -> (Word8 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> IO ()) -> (Word8 -> Word64) -> Word8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
U16 -> (Ptr Word16 -> IO Word16
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Word16) IO Word16 -> (Word16 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> IO ()) -> (Word16 -> Word64) -> Word16 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
U32 -> (Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Word32) IO Word32 -> (Word32 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Word64 -> IO ()
pokeN Stack
stk (Word64 -> IO ()) -> (Word32 -> Word64) -> Word32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  FFType
U64 -> (Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Word64) IO Word64 -> (Word64 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Word64 -> IO ()
pokeN Stack
stk
  FFType
F32 -> (Ptr Float -> IO Float
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Float) IO Float -> (Float -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Double -> IO ()
pokeD Stack
stk (Double -> IO ()) -> (Float -> Double) -> Float -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
float2Double
  FFType
D64 -> (Ptr Double -> IO Double
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO Double) IO Double -> (Double -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Double -> IO ()
pokeD Stack
stk
  FFType
Ptr -> (Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr (Ptr ())
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
p) :: IO (Ptr ())) IO (Ptr ()) -> (Ptr () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stack -> Ptr () -> IO ()
forall b. BuiltinForeign b => Stack -> b -> IO ()
pokeBi Stack
stk
  FFType
MBArr -> CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
ty)
  FFType
Fun -> CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
ty)
  FFType
Void -> CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
ty)

-- Write the result, left on top of the stack, into the C return slot. Integer
-- results are written at @ffi_arg@ width (8 bytes), as libffi requires for
-- integral returns narrower than a register; floating-point and pointer results
-- are written at their natural width.
writeResult :: FFType -> Ptr CValue -> Stack -> IO ()
writeResult :: FFType -> Ptr CValue -> Stack -> IO ()
writeResult FFType
ty Ptr CValue
ret Stack
stk = case FFType
ty of
  FFType
Void -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  FFType
I8 -> IO ()
writeInt
  FFType
I16 -> IO ()
writeInt
  FFType
I32 -> IO ()
writeInt
  FFType
I64 -> IO ()
writeInt
  FFType
U8 -> IO ()
writeNat
  FFType
U16 -> IO ()
writeNat
  FFType
U32 -> IO ()
writeNat
  FFType
U64 -> IO ()
writeNat
  FFType
F32 -> Stack -> Int -> IO Double
peekOffD Stack
stk Int
0 IO Double -> (Double -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Float -> Float -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr CValue -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr CValue
ret) (Float -> IO ()) -> (Double -> Float) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Float
double2Float
  FFType
D64 -> Stack -> Int -> IO Double
peekOffD Stack
stk Int
0 IO Double -> (Double -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Double -> Double -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr CValue -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr CValue
ret)
  FFType
Ptr -> (Stack -> Int -> IO (Ptr ())
forall b. BuiltinForeign b => Stack -> Int -> IO b
peekOffBi Stack
stk Int
0 :: IO (Ptr ())) IO (Ptr ()) -> (Ptr () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr (Ptr ()) -> Ptr () -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr CValue -> Ptr (Ptr ())
forall a b. Ptr a -> Ptr b
castPtr Ptr CValue
ret)
  FFType
MBArr -> CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
ty)
  FFType
Fun -> CallbackException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (FFType -> CallbackException
UnsupportedCallbackType FFType
ty)
  where
    writeInt :: IO ()
writeInt = DebugCallStack => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
0 IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Int64 -> Int64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr CValue -> Ptr Int64
forall a b. Ptr a -> Ptr b
castPtr Ptr CValue
ret) (Int64 -> IO ()) -> (Int -> Int64) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Int64)
    writeNat :: IO ()
writeNat = (Stack -> Int -> IO Word64
peekOffN Stack
stk Int
0 :: IO Word64) IO Word64 -> (Word64 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Word64 -> Word64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr CValue -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr CValue
ret)