module HsForeign.AsyncFFI
  ( withAsyncFFI
  , withAsyncFFI'
  , withPrimAsyncFFI
  ) where

import           Control.Concurrent.MVar (newEmptyMVar, takeMVar)
import           Control.Exception       (mask_, onException)
import           Control.Monad           (void)
import           Foreign.ForeignPtr
import           Foreign.StablePtr
import           GHC.Conc

import           HsForeign.Primitive

withAsyncFFI
  :: Int
  -- ^ Size of callback data
  -> (Ptr a -> IO a)
  -- ^ Peek callback data
  -> (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
  -- ^ Normal async foreign function: sp -> cap -> ptr -> ()
  -> IO a
withAsyncFFI :: Int
-> (Ptr a -> IO a)
-> (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
-> IO a
withAsyncFFI = [MutableByteArray RealWorld]
-> Int
-> (Ptr a -> IO a)
-> (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
-> IO a
forall a b.
[MutableByteArray RealWorld]
-> Int
-> (Ptr a -> IO a)
-> (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
-> IO a
withAsyncFFI' []

withPrimAsyncFFI
  :: Prim a
  => (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
  -> IO a
withPrimAsyncFFI :: (StablePtr PrimMVar -> Int -> Ptr a -> IO b) -> IO a
withPrimAsyncFFI StablePtr PrimMVar -> Int -> Ptr a -> IO b
f = IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  (a
ret, ()
_) <- (Ptr a -> IO ()) -> IO (a, ())
forall a b. Prim a => (Ptr a -> IO b) -> IO (a, b)
allocPrim ((Ptr a -> IO ()) -> IO (a, ())) -> (Ptr a -> IO ()) -> IO (a, ())
forall a b. (a -> b) -> a -> b
$ \Ptr a
ret' -> do
    MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    StablePtr PrimMVar
sp <- MVar () -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar MVar ()
mvar
    (Int
cap, Bool
_) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
    IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ StablePtr PrimMVar -> Int -> Ptr a -> IO b
f StablePtr PrimMVar
sp Int
cap Ptr a
ret'
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar IO () -> IO ThreadId -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` IO () -> IO ThreadId
forkIO (do MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar;)
  a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
{-# INLINABLE withPrimAsyncFFI #-}

-- NOTE: memory allocated by haskell and pass to async cpp function must be
-- pinned.
withAsyncFFI'
  :: [MutableByteArray RealWorld]
  -- ^ A list of extra Bytes we will touch, usually it's empty
  -> Int
  -- ^ Size of callback data
  -> (Ptr a -> IO a)
  -- ^ Peek callback data
  -> (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
  -- ^ Normal async foreign function: sp -> cap -> ptr -> ()
  -> IO a
withAsyncFFI' :: [MutableByteArray RealWorld]
-> Int
-> (Ptr a -> IO a)
-> (StablePtr PrimMVar -> Int -> Ptr a -> IO b)
-> IO a
withAsyncFFI' [MutableByteArray RealWorld]
bas Int
size Ptr a -> IO a
peek_fun StablePtr PrimMVar -> Int -> Ptr a -> IO b
f = IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  StablePtr PrimMVar
sp <- MVar () -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar MVar ()
mvar
  ForeignPtr a
fp <- Int -> IO (ForeignPtr a)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
size
  ForeignPtr a -> (Ptr a -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fp ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
data' -> do
    (Int
cap, Bool
_) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
    IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ StablePtr PrimMVar -> Int -> Ptr a -> IO b
f StablePtr PrimMVar
sp Int
cap Ptr a
data'
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar IO () -> IO ThreadId -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` IO () -> IO ThreadId
forkIO (do MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar; ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr a
fp; [MutableByteArray RealWorld] -> IO ()
forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch [MutableByteArray RealWorld]
bas)
    Ptr a -> IO a
peek_fun Ptr a
data'
{-# INLINABLE withAsyncFFI' #-}