-- | Defines a type similar to C++ futures,
-- that can be passed to C and used
-- to interrupt asynchronous calls
-- or to get their results.
--
-- From within Haskell, you can use
-- 'forkFuture' to start a calculation,
-- 'get' to wait on it
-- and 'abort' to abort it.
--
-- From C, interruption happens
-- via calling a C-native FFI function,
-- without the cost of a full FFI call.
-- See the C source for more information.
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Concurrent.CFuture
  (Future, CFuturePtr,
   forkFuture, writeFutureC, forkFutureC,
   get, getC, waitC, abort)
  where

import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable
import Control.Concurrent
import BasePrelude (PrimMVar, newStablePtrPrimMVar,
                    Int8, Int16, Int32, Int64,
                    Word8, Word16, Word32, Word64)

                    -- | A C pointer to a C array of two 'StablePtr's.
                    -- freeing the pointers is possible
                    -- via hs_free_stable_ptr

-- | Gets translated to HsStablePtr* (i.e. void**) in C.
type CFuturePtr = Ptr (StablePtr PrimMVar)

-- | An object representing an asynchronous calculation.
-- Filling the first MVar activates a thread that aborts the calculation
-- and writes Nothing to the other MVar
-- (which would otherwise contain the result).
-- It is recommended not to manipulate the MVars directly,
-- but to use the functions in the library instead.
data Future a = MkFuture
  (MVar ())           -- ^ For interruption: fill it to interrupt the calculation.
  (MVar (Maybe a))    -- ^ For the result: Nothing if it has been aborted, Just otherwise.

-- | Starts an asynchronous calculation
-- and returns a 'Future' to it.
forkFuture :: IO a -> IO (Future a)
forkFuture :: forall a. IO a -> IO (Future a)
forkFuture IO a
action = do
  MVar ()
intMVar <- (IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar ()))
  MVar (Maybe a)
resMVar <- (IO (MVar (Maybe a))
forall a. IO (MVar a)
forall {a}. IO (MVar (Maybe a))
newEmptyMVar :: IO (MVar (Maybe a)))

  -- The thread doing the actual calculation.
  -- It also wakes up the watcher thread.
  ThreadId
calculationThreadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
resMVar (Maybe a -> IO ()) -> (a -> Maybe a) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
action) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
intMVar ()

  -- The "watcher thread", killing the calculation thread if woken up.
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    -- this is activated if intMVar gets filled
    MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
intMVar
    ThreadId -> IO ()
killThread ThreadId
calculationThreadId
    MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
resMVar Maybe a
forall a. Maybe a
Nothing

  Future a -> IO (Future a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Future a -> IO (Future a)) -> Future a -> IO (Future a)
forall a b. (a -> b) -> a -> b
$ MVar () -> MVar (Maybe a) -> Future a
forall a. MVar () -> MVar (Maybe a) -> Future a
MkFuture MVar ()
intMVar MVar (Maybe a)
resMVar

-- | Interrupts the calculation behind the 'Future'.
-- Do not call this from C;
-- use hs_try_putmvar instead
-- (that frees the first 'MVar', too).
-- Returns 'False' if it has already been interrupted
-- and 'True' otherwise.
abort :: Future a -> IO Bool
abort :: forall a. Future a -> IO Bool
abort (MkFuture MVar ()
intMVar MVar (Maybe a)
_) = MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
intMVar ()

-- | Creates 'StablePtr's
-- and writes them to a memory area
-- provided by a C caller.
-- Use this in functions where the C frontend provides
-- a 'CFuturePtr' to write the future to.
--
-- Note: it is the responsibility of the C side
-- to free the 'StablePtr's.
writeFutureC :: CFuturePtr -> Future a -> IO ()
writeFutureC :: forall a. CFuturePtr -> Future a -> IO ()
writeFutureC CFuturePtr
ptr (MkFuture MVar ()
intMVar MVar (Maybe a)
resMVar) = do
  StablePtr PrimMVar
intMVarSPtr <- MVar () -> IO (StablePtr PrimMVar)
forall a. MVar a -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar MVar ()
intMVar
  StablePtr (MVar (Maybe a))
resMVarSPtr <- MVar (Maybe a) -> IO (StablePtr (MVar (Maybe a)))
forall a. a -> IO (StablePtr a)
newStablePtr MVar (Maybe a)
resMVar
  let convPtr :: CFuturePtr
convPtr = (CFuturePtr -> CFuturePtr
forall a b. Ptr a -> Ptr b
castPtr CFuturePtr
ptr :: CFuturePtr)
  CFuturePtr -> StablePtr PrimMVar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke CFuturePtr
convPtr StablePtr PrimMVar
intMVarSPtr
  Ptr (StablePtr (MVar (Maybe a)))
-> Int -> StablePtr (MVar (Maybe a)) -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff (CFuturePtr -> Ptr (StablePtr (MVar (Maybe a)))
forall a b. Ptr a -> Ptr b
castPtr CFuturePtr
convPtr) Int
1 StablePtr (MVar (Maybe a))
resMVarSPtr

-- | Similar to 'forkFuture', but
-- we write the 'Future' into a location
-- given by the caller.
-- This makes it easier to create C exports
-- for actions.
--
-- Use this in functions where the C frontend provides
-- a 'CFuturePtr' to write the future to.
--
-- Note: it is the responsibility of the C side
-- to free the 'StablePtr's.
forkFutureC :: CFuturePtr -> IO a -> IO ()
forkFutureC :: forall a. CFuturePtr -> IO a -> IO ()
forkFutureC CFuturePtr
ptr IO a
action = CFuturePtr -> Future a -> IO ()
forall a. CFuturePtr -> Future a -> IO ()
writeFutureC CFuturePtr
ptr (Future a -> IO ()) -> IO (Future a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> IO (Future a)
forall a. IO a -> IO (Future a)
forkFuture IO a
action

-- | Reads the result from the 'Future'.
-- This is a blocking call,
-- waiting for the result (or the 'Nothing' signalling interruption)
-- until it is ready.
get :: Future a -> IO (Maybe a)
get :: forall a. Future a -> IO (Maybe a)
get (MkFuture MVar ()
_ MVar (Maybe a)
resMVar) = MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
resMVar

-- | A helper function to 'getC' and 'waitC',
-- expecting a function which we are going to do with the result.
-- Not meant to be used directly.
getCHelper :: CFuturePtr -> (a -> IO ()) -> IO Bool
getCHelper :: forall a. CFuturePtr -> (a -> IO ()) -> IO Bool
getCHelper CFuturePtr
futurePtr a -> IO ()
doOnCompletion = do
  -- we assume both StablePtrs are of the same size,
  -- which should be in a sane world
  StablePtr (MVar (Maybe a))
resMVarSPtr <- Ptr (StablePtr (MVar (Maybe a)))
-> Int -> IO (StablePtr (MVar (Maybe a)))
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (CFuturePtr -> Ptr (StablePtr (MVar (Maybe a)))
forall a b. Ptr a -> Ptr b
castPtr CFuturePtr
futurePtr :: Ptr (StablePtr (MVar (Maybe a)))) Int
1
  Maybe a
result <- MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar (MVar (Maybe a) -> IO (Maybe a))
-> IO (MVar (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StablePtr (MVar (Maybe a)) -> IO (MVar (Maybe a))
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr (MVar (Maybe a))
resMVarSPtr
  case Maybe a
result of
        Just a
a  -> a -> IO ()
doOnCompletion a
a IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe a
_       -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False  -- we don't run 'doOnCompletion' in this case


-- | A variant of 'get' to call from C
-- which writes the result to the memory location
-- defined by the pointer.
-- If there is 'Nothing' instead of a result,
-- it writes nothing to the pointer
-- and returns 'False';
-- on success, it returns 'True'.
--
-- Note: do _not_ call this on a freed 'Future'
-- (the abortC function of the C side frees it).
getC :: Storable a => CFuturePtr -> Ptr a -> IO Bool
getC :: forall a. Storable a => CFuturePtr -> Ptr a -> IO Bool
getC CFuturePtr
futurePtr Ptr a
destPtr = CFuturePtr -> (a -> IO ()) -> IO Bool
forall a. CFuturePtr -> (a -> IO ()) -> IO Bool
getCHelper CFuturePtr
futurePtr (Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
destPtr)

-- | Only waits until the calculation gets finished;
-- then returns 'True' if it was successful and 'False' otherwise.
-- To be called from C.
-- Differs from 'getC' in that it ignores the result.
--
-- Note: do _not_ call this on a freed 'Future'
-- (the abortC function of the C side frees it).
waitC :: CFuturePtr -> IO Bool
waitC :: CFuturePtr -> IO Bool
waitC CFuturePtr
futurePtr = CFuturePtr -> (Any -> IO ()) -> IO Bool
forall a. CFuturePtr -> (a -> IO ()) -> IO Bool
getCHelper CFuturePtr
futurePtr ((Any -> IO ()) -> IO Bool) -> (Any -> IO ()) -> IO Bool
forall a b. (a -> b) -> a -> b
$ IO () -> Any -> IO ()
forall a b. a -> b -> a
const (IO () -> Any -> IO ()) -> IO () -> Any -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Finally, the foreign export declarations:
-- this is quite ugly, but c'est la vie.
-- It does not work with a void pointer
-- because then, the Haskell side does not get to know the type
-- and tries to poke a ().
foreign export ccall "getC_Char" getC :: CFuturePtr -> Ptr Char -> IO Bool
foreign export ccall "getC_Int" getC :: CFuturePtr -> Ptr Int -> IO Bool
foreign export ccall "getC_Int8" getC :: CFuturePtr -> Ptr Int8 -> IO Bool
foreign export ccall "getC_Int16" getC :: CFuturePtr -> Ptr Int16 -> IO Bool
foreign export ccall "getC_Int32" getC :: CFuturePtr -> Ptr Int32 -> IO Bool
foreign export ccall "getC_Int64" getC :: CFuturePtr -> Ptr Int64 -> IO Bool
foreign export ccall "getC_Word" getC :: CFuturePtr -> Ptr Word -> IO Bool
foreign export ccall "getC_Word8" getC :: CFuturePtr -> Ptr Word8 -> IO Bool
foreign export ccall "getC_Word16" getC :: CFuturePtr -> Ptr Word16 -> IO Bool
foreign export ccall "getC_Word32" getC :: CFuturePtr -> Ptr Word32 -> IO Bool
foreign export ccall "getC_Word64" getC :: CFuturePtr -> Ptr Word64 -> IO Bool
foreign export ccall "getC_Float" getC :: CFuturePtr -> Ptr Float -> IO Bool
foreign export ccall "getC_Double" getC :: CFuturePtr -> Ptr Double -> IO Bool
foreign export ccall "getC_Bool" getC :: CFuturePtr -> Ptr Bool -> IO Bool
foreign export ccall "getC_Ptr" getC :: CFuturePtr -> Ptr (Ptr a) -> IO Bool
foreign export ccall "getC_FunPtr" getC :: CFuturePtr -> Ptr (FunPtr a) -> IO Bool
foreign export ccall "getC_StablePtr" getC :: CFuturePtr -> Ptr (StablePtr a) -> IO Bool
foreign export ccall waitC :: CFuturePtr -> IO Bool