CFuture.hs

-- | 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 action = do
  intMVar <- (newEmptyMVar :: IO (MVar ()))
  resMVar <- (newEmptyMVar :: IO (MVar (Maybe a)))

  -- The thread doing the actual calculation.
  -- It also wakes up the watcher thread.
  calculationThreadId <- forkIO $ (putMVar resMVar . Just =<< action) >> putMVar intMVar ()

  -- The "watcher thread", killing the calculation thread if woken up.
  _ <- forkIO $ do
    -- this is activated if intMVar gets filled
    readMVar intMVar
    killThread calculationThreadId
    putMVar resMVar Nothing

  return $ MkFuture intMVar 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 (MkFuture intMVar _) = tryPutMVar 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 ptr (MkFuture intMVar resMVar) = do
  intMVarSPtr <- newStablePtrPrimMVar intMVar
  resMVarSPtr <- newStablePtr resMVar
  let convPtr = (castPtr ptr :: CFuturePtr)
  poke convPtr intMVarSPtr
  pokeElemOff (castPtr convPtr) 1 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 ptr action = writeFutureC ptr =<< forkFuture 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 (MkFuture _ resMVar) = readMVar 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 futurePtr doOnCompletion = do
  -- we assume both StablePtrs are of the same size,
  -- which should be in a sane world
  resMVarSPtr <- peekElemOff (castPtr futurePtr :: Ptr (StablePtr (MVar (Maybe a)))) 1
  result <- readMVar =<< deRefStablePtr resMVarSPtr
  case result of
        Just a  -> doOnCompletion a >> return True
        _       -> return 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 futurePtr destPtr = getCHelper futurePtr (poke 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 futurePtr = getCHelper futurePtr $ const $ 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