dejafu/Test/DejaFu/Deterministic/IO.hs

245 lines
8.7 KiB
Haskell
Raw Normal View History

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImpredicativeTypes #-}
2015-02-16 06:16:55 +03:00
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
-- | Deterministic traced execution of concurrent computations which
-- may do @IO@.
--
-- __Caution!__ Blocking on the action of another thread in 'liftIO'
-- cannot be detected! So if you perform some potentially blocking
-- action in a 'liftIO' the entire collection of threads may deadlock!
-- You should therefore keep @IO@ blocks small, and only perform
-- blocking operations with the supplied primitives, insofar as
-- possible.
2015-01-31 18:50:54 +03:00
module Test.DejaFu.Deterministic.IO
( -- * The @ConcIO@ Monad
ConcIO
, Failure(..)
, runConcIO
, liftIO
, fork
, forkFinally
, forkWithUnmask
2015-02-13 03:39:27 +03:00
, myThreadId
, spawn
, atomically
2015-02-12 16:42:32 +03:00
, throw
2015-02-13 20:13:00 +03:00
, throwTo
, killThread
, Test.DejaFu.Deterministic.IO.catch
, mask
, uninterruptibleMask
-- * Communication: CVars
, CVar
, newEmptyCVar
, putCVar
, tryPutCVar
, readCVar
, takeCVar
, tryTakeCVar
2015-01-25 19:15:23 +03:00
-- * Testing
, _concNoTest
-- * Execution traces
, Trace
, Decision(..)
, ThreadAction(..)
2015-02-03 17:14:36 +03:00
, CVarId
, MaskingState(..)
, showTrace
-- * Scheduling
, module Test.DejaFu.Deterministic.Schedule
) where
import Control.Applicative (Applicative(..), (<$>))
2015-02-13 21:30:21 +03:00
import Control.Exception (Exception, MaskingState(..), SomeException(..))
import Control.Monad.Cont (cont, runCont)
2015-02-10 01:04:28 +03:00
import Control.State (Wrapper(..), refIO)
import Data.IORef (IORef, newIORef)
2015-01-31 18:50:54 +03:00
import Test.DejaFu.Deterministic.Internal
import Test.DejaFu.Deterministic.Schedule
import Test.DejaFu.STM (STMLike, runTransactionIO)
2015-02-12 22:15:07 +03:00
import qualified Control.Monad.Catch as Ca
import qualified Control.Monad.Conc.Class as C
import qualified Control.Monad.IO.Class as IO
-- | The 'IO' variant of Test.DejaFu.Deterministic's @Conc@ monad.
newtype ConcIO t a = C { unC :: M IO IORef (STMLike t) a } deriving (Functor, Applicative, Monad)
2015-02-15 00:16:44 +03:00
wrap :: (M IO IORef (STMLike t) a -> M IO IORef (STMLike t) a) -> (ConcIO t a -> ConcIO t a)
wrap f = C . f . unC
2015-02-12 22:15:07 +03:00
instance Ca.MonadCatch (ConcIO t) where
catch = Test.DejaFu.Deterministic.IO.catch
2015-02-12 22:15:07 +03:00
instance Ca.MonadThrow (ConcIO t) where
2015-02-12 16:42:32 +03:00
throwM = throw
instance Ca.MonadMask (ConcIO t) where
mask = mask
uninterruptibleMask = uninterruptibleMask
instance IO.MonadIO (ConcIO t) where
liftIO = liftIO
instance C.MonadConc (ConcIO t) where
2015-02-13 03:39:27 +03:00
type CVar (ConcIO t) = CVar t
type STMLike (ConcIO t) = STMLike t IO IORef
type ThreadId (ConcIO t) = Int
fork = fork
forkWithUnmask = forkWithUnmask
myThreadId = myThreadId
throwTo = throwTo
newEmptyCVar = newEmptyCVar
putCVar = putCVar
tryPutCVar = tryPutCVar
readCVar = readCVar
takeCVar = takeCVar
tryTakeCVar = tryTakeCVar
atomically = atomically
_concNoTest = _concNoTest
fixed :: Fixed IO IORef (STMLike t)
2015-02-10 01:04:28 +03:00
fixed = Wrapper refIO $ unC . liftIO
-- | The concurrent variable type used with the 'ConcIO' monad. These
-- behave the same as @Conc@'s @CVar@s
2014-12-28 01:03:37 +03:00
newtype CVar t a = V { unV :: R IORef a } deriving Eq
-- | Lift an 'IO' action into the 'ConcIO' monad.
liftIO :: IO a -> ConcIO t a
liftIO ma = C $ cont lifted where
lifted c = ALift $ c <$> ma
-- | Run the provided computation concurrently, returning the result.
spawn :: ConcIO t a -> ConcIO t (CVar t a)
spawn = C.spawn
-- | Block on a 'CVar' until it is full, then read from it (without
-- emptying).
readCVar :: CVar t a -> ConcIO t a
2014-12-28 01:03:37 +03:00
readCVar cvar = C $ cont $ AGet $ unV cvar
-- | Run the provided computation concurrently.
2015-02-13 03:39:27 +03:00
fork :: ConcIO t () -> ConcIO t ThreadId
2015-02-15 00:16:44 +03:00
fork (C ma) = C $ cont $ AFork (const $ runCont ma $ const AStop)
2015-02-13 03:39:27 +03:00
-- | Get the 'ThreadId' of the current thread.
myThreadId :: ConcIO t ThreadId
myThreadId = C $ cont AMyTId
-- | Run the provided 'MonadSTM' transaction atomically. If 'retry' is
-- called, it will be blocked until any of the touched 'CTVar's have
-- been written to.
atomically :: STMLike t IO IORef a -> ConcIO t a
atomically stm = C $ cont $ AAtom stm
-- | Create a new empty 'CVar'.
newEmptyCVar :: ConcIO t (CVar t a)
newEmptyCVar = C $ cont lifted where
2015-02-03 17:14:36 +03:00
lifted c = ANew $ \cvid -> c <$> newEmptyCVar' cvid
newEmptyCVar' cvid = (\ref -> V (cvid, ref)) <$> newIORef Nothing
-- | Block on a 'CVar' until it is empty, then write to it.
putCVar :: CVar t a -> a -> ConcIO t ()
2014-12-28 01:03:37 +03:00
putCVar cvar a = C $ cont $ \c -> APut (unV cvar) a $ c ()
-- | Put a value into a 'CVar' if there isn't one, without blocking.
tryPutCVar :: CVar t a -> a -> ConcIO t Bool
2014-12-28 01:03:37 +03:00
tryPutCVar cvar a = C $ cont $ ATryPut (unV cvar) a
-- | Block on a 'CVar' until it is full, then read from it (with
-- emptying).
takeCVar :: CVar t a -> ConcIO t a
2014-12-28 01:03:37 +03:00
takeCVar cvar = C $ cont $ ATake $ unV cvar
-- | Read a value from a 'CVar' if there is one, without blocking.
tryTakeCVar :: CVar t a -> ConcIO t (Maybe a)
2014-12-28 01:03:37 +03:00
tryTakeCVar cvar = C $ cont $ ATryTake $ unV cvar
2015-02-12 16:42:32 +03:00
-- | Raise an exception in the 'ConcIO' monad. The exception is raised
-- when the action is run, not when it is applied. It short-citcuits
-- the rest of the computation:
--
-- > throw e >> x == throw e
throw :: Exception e => e -> ConcIO t a
throw e = C $ cont $ \_ -> AThrow (SomeException e)
2015-02-13 20:13:00 +03:00
-- | Throw an exception to the target thread. This blocks until the
-- exception is delivered, and it is just as if the target thread had
-- raised it with 'throw'. This can interrupt a blocked action.
throwTo :: Exception e => ThreadId -> e -> ConcIO t ()
throwTo tid e = C $ cont $ \c -> AThrowTo tid (SomeException e) $ c ()
-- | Raise the 'ThreadKilled' exception in the target thread. Note
-- that if the thread is prepared to catch this exception, it won't
-- actually kill it.
killThread :: ThreadId -> ConcIO t ()
2015-02-13 20:13:00 +03:00
killThread = C.killThread
2015-02-12 22:15:07 +03:00
-- | Catch an exception raised by 'throw'. This __cannot__ catch
-- errors, such as evaluating 'undefined', or division by zero. If you
-- need that, use Control.Exception.catch and 'liftIO'.
catch :: Exception e => ConcIO t a -> (e -> ConcIO t a) -> ConcIO t a
2015-02-13 03:56:45 +03:00
catch ma h = C $ cont $ ACatching (unC . h) (unC ma)
2015-02-12 22:15:07 +03:00
-- | Fork a thread and call the supplied function when the thread is
-- about to terminate, with an exception or a returned value. The
-- function is called with asynchronous exceptions masked.
--
-- This function is useful for informing the parent when a child
-- terminates, for example.
forkFinally :: ConcIO t a -> (Either SomeException a -> ConcIO t ()) -> ConcIO t ThreadId
forkFinally action and_then =
mask $ \restore ->
fork $ Ca.try (restore action) >>= and_then
-- | Like 'fork', but the child thread is passed a function that can
2015-02-15 00:16:44 +03:00
-- be used to unmask asynchronous exceptions. This function should not
-- be used within a 'mask' or 'uninterruptibleMask'.
forkWithUnmask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t ()) -> ConcIO t ThreadId
2015-02-15 00:16:44 +03:00
forkWithUnmask ma = C $ cont $ AFork (\umask -> runCont (unC $ ma $ wrap umask) $ const AStop)
-- | Executes a computation with asynchronous exceptions
-- /masked/. That is, any thread which attempts to raise an exception
-- in the current thread with 'throwTo' will be blocked until
-- asynchronous exceptions are unmasked again.
--
-- The argument passed to mask is a function that takes as its
-- argument another function, which can be used to restore the
-- prevailing masking state within the context of the masked
2015-02-15 00:16:44 +03:00
-- computation. This function should not be used within an
-- 'uninterruptibleMask'.
mask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b
2015-02-15 00:16:44 +03:00
mask mb = C $ cont $ AMasking MaskedInterruptible (\f -> unC $ mb $ wrap f)
-- | Like 'mask', but the masked computation is not
-- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a
-- thread executing in 'uninterruptibleMask' blocks for any reason,
-- then the thread (and possibly the program, if this is the main
-- thread) will be unresponsive and unkillable. This function should
-- only be necessary if you need to mask exceptions around an
-- interruptible operation, and you can guarantee that the
2015-02-15 00:16:44 +03:00
-- interruptible operation will only block for a short period of
-- time. The supplied unmasking function should not be used within a
-- 'mask'.
uninterruptibleMask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b
2015-02-15 00:16:44 +03:00
uninterruptibleMask mb = C $ cont $ AMasking MaskedUninterruptible (\f -> unC $ mb $ wrap f)
-- | Run the argument in one step. If the argument fails, the whole
-- computation will fail.
_concNoTest :: ConcIO t a -> ConcIO t a
_concNoTest ma = C $ cont $ \c -> ANoTest (unC ma) c
-- | Run a concurrent computation with a given 'Scheduler' and initial
-- state, returning an failure reason on error. Also returned is the
-- final state of the scheduler, and an execution trace.
runConcIO :: Scheduler s -> s -> (forall t. ConcIO t a) -> IO (Either Failure a, s, Trace)
runConcIO sched s ma = runFixed fixed runTransactionIO sched s $ unC ma