From 5114fd37a1bfdd5fb96ea7e84da74119a74ea8f1 Mon Sep 17 00:00:00 2001 From: Michael Walker Date: Thu, 2 Feb 2017 14:45:24 +0000 Subject: [PATCH] Make things monomorphic over the STM type. Only `STMLike n r` is used, so passing around the type variable and STM runner is just noise. --- dejafu/Test/DejaFu/Conc.hs | 8 +- dejafu/Test/DejaFu/Conc/Internal.hs | 50 ++++++------- dejafu/Test/DejaFu/Conc/Internal/Common.hs | 73 ++++++++++--------- dejafu/Test/DejaFu/Conc/Internal/Memory.hs | 32 ++++---- dejafu/Test/DejaFu/Conc/Internal/Threading.hs | 38 +++++----- 5 files changed, 99 insertions(+), 102 deletions(-) diff --git a/dejafu/Test/DejaFu/Conc.hs b/dejafu/Test/DejaFu/Conc.hs index 90b50a8..e93e974 100755 --- a/dejafu/Test/DejaFu/Conc.hs +++ b/dejafu/Test/DejaFu/Conc.hs @@ -66,7 +66,7 @@ import Test.DejaFu.STM {-# ANN module ("HLint: ignore Avoid lambda" :: String) #-} {-# ANN module ("HLint: ignore Use const" :: String) #-} -newtype Conc n r a = C { unC :: M n r (STMLike n r) a } deriving (Functor, Applicative, Monad) +newtype Conc n r a = C { unC :: M n r a } deriving (Functor, Applicative, Monad) -- | A 'MonadConc' implementation using @ST@, this should be preferred -- if you do not need 'liftIO'. @@ -75,10 +75,10 @@ type ConcST t = Conc (ST t) (STRef t) -- | A 'MonadConc' implementation using @IO@. type ConcIO = Conc IO IORef -toConc :: ((a -> Action n r (STMLike n r)) -> Action n r (STMLike n r)) -> Conc n r a +toConc :: ((a -> Action n r) -> Action n r) -> Conc n r a toConc = C . cont -wrap :: (M n r (STMLike n r) a -> M n r (STMLike n r) a) -> Conc n r a -> Conc n r a +wrap :: (M n r a -> M n r a) -> Conc n r a -> Conc n r a wrap f = C . f . unC instance IO.MonadIO ConcIO where @@ -180,7 +180,7 @@ runConcurrent :: MonadRef r n -> Conc n r a -> n (Either Failure a, s, Trace) runConcurrent sched memtype s ma = do - (res, s', trace) <- runConcurrency runTransaction sched memtype s (unC ma) + (res, s', trace) <- runConcurrency sched memtype s (unC ma) pure (res, s', reverse trace) -- | Run a concurrent computation and return its result. diff --git a/dejafu/Test/DejaFu/Conc/Internal.hs b/dejafu/Test/DejaFu/Conc/Internal.hs index 7f1eb07..a9357b7 100755 --- a/dejafu/Test/DejaFu/Conc/Internal.hs +++ b/dejafu/Test/DejaFu/Conc/Internal.hs @@ -28,7 +28,7 @@ import Test.DejaFu.Conc.Internal.Common import Test.DejaFu.Conc.Internal.Memory import Test.DejaFu.Conc.Internal.Threading import Test.DejaFu.Schedule -import Test.DejaFu.STM (Result(..)) +import Test.DejaFu.STM (Result(..), runTransaction) {-# ANN module ("HLint: ignore Use record patterns" :: String) #-} {-# ANN module ("HLint: ignore Use const" :: String) #-} @@ -41,20 +41,18 @@ import Test.DejaFu.STM (Result(..)) -- final state of the scheduler, and an execution trace (in reverse -- order). runConcurrency :: MonadRef r n - => (forall x. s x -> IdSource -> n (Result x, IdSource, TTrace)) - -> Scheduler g + => Scheduler g -> MemType -> g - -> M n r s a + -> M n r a -> n (Either Failure a, g, Trace) -runConcurrency runstm sched memtype g ma = do +runConcurrency sched memtype g ma = do ref <- newRef Nothing let c = runCont ma (AStop . writeRef ref . Just . Right) let threads = launch' Unmasked initialThread (const c) M.empty - (g', trace) <- runThreads runstm - sched + (g', trace) <- runThreads sched memtype g threads @@ -71,9 +69,9 @@ runConcurrency runstm sched memtype g ma = do -- efficient to prepend to a list than append. As this function isn't -- exposed to users of the library, this is just an internal gotcha to -- watch out for. -runThreads :: MonadRef r n => (forall x. s x -> IdSource -> n (Result x, IdSource, TTrace)) - -> Scheduler g -> MemType -> g -> Threads n r s -> IdSource -> r (Maybe (Either Failure a)) -> n (g, Trace) -runThreads runstm sched memtype origg origthreads idsrc ref = go idsrc [] Nothing origg origthreads emptyBuffer 2 where +runThreads :: MonadRef r n + => Scheduler g -> MemType -> g -> Threads n r -> IdSource -> r (Maybe (Either Failure a)) -> n (g, Trace) +runThreads sched memtype origg origthreads idsrc ref = go idsrc [] Nothing origg origthreads emptyBuffer 2 where go idSource sofar prior g threads wb caps | isTerminated = stop g | isDeadlocked = die g Deadlock @@ -82,7 +80,7 @@ runThreads runstm sched memtype origg origthreads idsrc ref = go idsrc [] Nothin | isNonexistant = die g' InternalError | isBlocked = die g' InternalError | otherwise = do - stepped <- stepThread runstm sched memtype g (_continuation $ fromJust thread) idSource chosen threads wb caps + stepped <- stepThread sched memtype g (_continuation $ fromJust thread) idSource chosen threads wb caps case stepped of Right (threads', idSource', act, wb', caps', mg') -> loop threads' idSource' act (fromMaybe g' mg') wb' caps' @@ -138,29 +136,27 @@ runThreads runstm sched memtype origg origthreads idsrc ref = go idsrc [] Nothin -- | Run a single thread one step, by dispatching on the type of -- 'Action'. -stepThread :: forall n r s g. MonadRef r n - => (forall x. s x -> IdSource -> n (Result x, IdSource, TTrace)) - -- ^ Run a 'MonadSTM' transaction atomically. - -> Scheduler g +stepThread :: forall n r g. MonadRef r n + => Scheduler g -- ^ The scheduler. -> MemType -- ^ The memory model -> g -- ^ The scheduler state. - -> Action n r s + -> Action n r -- ^ Action to step -> IdSource -- ^ Source of fresh IDs -> ThreadId -- ^ ID of the current thread - -> Threads n r s + -> Threads n r -- ^ Current state of threads -> WriteBuffer r -- ^ @CRef@ write buffer -> Int -- ^ The number of capabilities - -> n (Either Failure (Threads n r s, IdSource, Either (ThreadAction, Trace) ThreadAction, WriteBuffer r, Int, Maybe g)) -stepThread runstm sched memtype g action idSource tid threads wb caps = case action of + -> n (Either Failure (Threads n r, IdSource, Either (ThreadAction, Trace) ThreadAction, WriteBuffer r, Int, Maybe g)) +stepThread sched memtype g action idSource tid threads wb caps = case action of AFork n a b -> stepFork n a b AMyTId c -> stepMyTId c AGetNumCapabilities c -> stepGetNumCapabilities c @@ -199,9 +195,9 @@ stepThread runstm sched memtype g action idSource tid threads wb caps = case act -- Explicit type signature needed for GHC 8. Looks like the -- impredicative polymorphism checks got stronger. stepFork :: String - -> ((forall b. M n r s b -> M n r s b) -> Action n r s) - -> (ThreadId -> Action n r s) - -> n (Either Failure (Threads n r s, IdSource, Either z ThreadAction, WriteBuffer r, Int, Maybe g)) + -> ((forall b. M n r b -> M n r b) -> Action n r) + -> (ThreadId -> Action n r) + -> n (Either Failure (Threads n r, IdSource, Either z ThreadAction, WriteBuffer r, Int, Maybe g)) stepFork n a b = return $ Right (goto (b newtid) tid threads', idSource', Right (Fork newtid), wb, caps, Nothing) where threads' = launch tid newtid a threads (idSource', newtid) = nextTId n idSource @@ -308,7 +304,7 @@ stepThread runstm sched memtype g action idSource tid threads wb caps = case act -- | Run a STM transaction atomically. stepAtom stm c = synchronised $ do - (res, idSource', trace) <- runstm stm idSource + (res, idSource', trace) <- runTransaction stm idSource case res of Success _ written val -> let (threads', woken) = wake (OnTVar written) threads @@ -362,9 +358,9 @@ stepThread runstm sched memtype g action idSource tid threads wb caps = case act -- Explicit type sig necessary for checking in the prescence of -- 'umask', sadly. stepMasking :: MaskingState - -> ((forall b. M n r s b -> M n r s b) -> M n r s a) - -> (a -> Action n r s) - -> n (Either Failure (Threads n r s, IdSource, Either z ThreadAction, WriteBuffer r, Int, Maybe g)) + -> ((forall b. M n r b -> M n r b) -> M n r a) + -> (a -> Action n r) + -> n (Either Failure (Threads n r, IdSource, Either z ThreadAction, WriteBuffer r, Int, Maybe g)) stepMasking m ma c = simple threads' $ SetMasking False m where a = runCont (ma umask) (AResetMask False False m' . c) @@ -412,7 +408,7 @@ stepThread runstm sched memtype g action idSource tid threads wb caps = case act stepSubconcurrency ma c | M.size threads > 1 = return (Left IllegalSubconcurrency) | otherwise = do - (res, g', trace) <- runConcurrency runstm sched memtype g ma + (res, g', trace) <- runConcurrency sched memtype g ma return $ Right (goto (c res) tid threads, idSource, Left (Subconcurrency, trace), wb, caps, Just g') -- | Helper for actions which don't touch the 'IdSource' or diff --git a/dejafu/Test/DejaFu/Conc/Internal/Common.hs b/dejafu/Test/DejaFu/Conc/Internal/Common.hs index 03e6aaf..aab7eae 100755 --- a/dejafu/Test/DejaFu/Conc/Internal/Common.hs +++ b/dejafu/Test/DejaFu/Conc/Internal/Common.hs @@ -18,6 +18,7 @@ import Data.Dynamic (Dynamic) import Data.Map.Strict (Map) import Data.List.NonEmpty (NonEmpty, fromList) import Test.DejaFu.Common +import Test.DejaFu.STM (STMLike) {-# ANN module ("HLint: ignore Use record patterns" :: String) #-} @@ -32,16 +33,16 @@ import Test.DejaFu.Common -- current expression of threads and exception handlers very difficult -- (perhaps even not possible without significant reworking), so I -- abandoned the attempt. -newtype M n r s a = M { runM :: (a -> Action n r s) -> Action n r s } +newtype M n r a = M { runM :: (a -> Action n r) -> Action n r } -instance Functor (M n r s) where +instance Functor (M n r) where fmap f m = M $ \ c -> runM m (c . f) -instance Applicative (M n r s) where +instance Applicative (M n r) where pure x = M $ \c -> AReturn $ c x f <*> v = M $ \c -> runM f (\g -> runM v (c . g)) -instance Monad (M n r s) where +instance Monad (M n r) where return = pure m >>= k = M $ \c -> runM m (\x -> runM (k x) c) @@ -82,11 +83,11 @@ data Ticket a = Ticket } -- | Construct a continuation-passing operation from a function. -cont :: ((a -> Action n r s) -> Action n r s) -> M n r s a +cont :: ((a -> Action n r) -> Action n r) -> M n r a cont = M -- | Run a CPS computation with the given final computation. -runCont :: M n r s a -> (a -> Action n r s) -> Action n r s +runCont :: M n r a -> (a -> Action n r) -> Action n r runCont = runM -------------------------------------------------------------------------------- @@ -96,51 +97,51 @@ runCont = runM -- only occur as a result of an action, and they cover (most of) the -- primitives of the concurrency. 'spawn' is absent as it is -- implemented in terms of 'newEmptyMVar', 'fork', and 'putMVar'. -data Action n r s = - AFork String ((forall b. M n r s b -> M n r s b) -> Action n r s) (ThreadId -> Action n r s) - | AMyTId (ThreadId -> Action n r s) +data Action n r = + AFork String ((forall b. M n r b -> M n r b) -> Action n r) (ThreadId -> Action n r) + | AMyTId (ThreadId -> Action n r) - | AGetNumCapabilities (Int -> Action n r s) - | ASetNumCapabilities Int (Action n r s) + | AGetNumCapabilities (Int -> Action n r) + | ASetNumCapabilities Int (Action n r) - | forall a. ANewVar String (MVar r a -> Action n r s) - | forall a. APutVar (MVar r a) a (Action n r s) - | forall a. ATryPutVar (MVar r a) a (Bool -> Action n r s) - | forall a. AReadVar (MVar r a) (a -> Action n r s) - | forall a. ATakeVar (MVar r a) (a -> Action n r s) - | forall a. ATryTakeVar (MVar r a) (Maybe a -> Action n r s) + | forall a. ANewVar String (MVar r a -> Action n r) + | forall a. APutVar (MVar r a) a (Action n r) + | forall a. ATryPutVar (MVar r a) a (Bool -> Action n r) + | forall a. AReadVar (MVar r a) (a -> Action n r) + | forall a. ATakeVar (MVar r a) (a -> Action n r) + | forall a. ATryTakeVar (MVar r a) (Maybe a -> Action n r) - | forall a. ANewRef String a (CRef r a -> Action n r s) - | forall a. AReadRef (CRef r a) (a -> Action n r s) - | forall a. AReadRefCas (CRef r a) (Ticket a -> Action n r s) - | forall a b. AModRef (CRef r a) (a -> (a, b)) (b -> Action n r s) - | forall a b. AModRefCas (CRef r a) (a -> (a, b)) (b -> Action n r s) - | forall a. AWriteRef (CRef r a) a (Action n r s) - | forall a. ACasRef (CRef r a) (Ticket a) a ((Bool, Ticket a) -> Action n r s) + | forall a. ANewRef String a (CRef r a -> Action n r) + | forall a. AReadRef (CRef r a) (a -> Action n r) + | forall a. AReadRefCas (CRef r a) (Ticket a -> Action n r) + | forall a b. AModRef (CRef r a) (a -> (a, b)) (b -> Action n r) + | forall a b. AModRefCas (CRef r a) (a -> (a, b)) (b -> Action n r) + | forall a. AWriteRef (CRef r a) a (Action n r) + | forall a. ACasRef (CRef r a) (Ticket a) a ((Bool, Ticket a) -> Action n r) | forall e. Exception e => AThrow e - | forall e. Exception e => AThrowTo ThreadId e (Action n r s) - | forall a e. Exception e => ACatching (e -> M n r s a) (M n r s a) (a -> Action n r s) - | APopCatching (Action n r s) - | forall a. AMasking MaskingState ((forall b. M n r s b -> M n r s b) -> M n r s a) (a -> Action n r s) - | AResetMask Bool Bool MaskingState (Action n r s) + | forall e. Exception e => AThrowTo ThreadId e (Action n r) + | forall a e. Exception e => ACatching (e -> M n r a) (M n r a) (a -> Action n r) + | APopCatching (Action n r) + | forall a. AMasking MaskingState ((forall b. M n r b -> M n r b) -> M n r a) (a -> Action n r) + | AResetMask Bool Bool MaskingState (Action n r) - | AMessage Dynamic (Action n r s) + | AMessage Dynamic (Action n r) - | forall a. AAtom (s a) (a -> Action n r s) - | ALift (n (Action n r s)) - | AYield (Action n r s) - | AReturn (Action n r s) + | forall a. AAtom (STMLike n r a) (a -> Action n r) + | ALift (n (Action n r)) + | AYield (Action n r) + | AReturn (Action n r) | ACommit ThreadId CRefId | AStop (n ()) - | forall a. ASub (M n r s a) (Either Failure a -> Action n r s) + | forall a. ASub (M n r a) (Either Failure a -> Action n r) -------------------------------------------------------------------------------- -- * Scheduling & Traces -- | Look as far ahead in the given continuation as possible. -lookahead :: Action n r s -> NonEmpty Lookahead +lookahead :: Action n r -> NonEmpty Lookahead lookahead = fromList . lookahead' where lookahead' (AFork _ _ _) = [WillFork] lookahead' (AMyTId _) = [WillMyThreadId] diff --git a/dejafu/Test/DejaFu/Conc/Internal/Memory.hs b/dejafu/Test/DejaFu/Conc/Internal/Memory.hs index 2165cad..a63a763 100755 --- a/dejafu/Test/DejaFu/Conc/Internal/Memory.hs +++ b/dejafu/Test/DejaFu/Conc/Internal/Memory.hs @@ -126,7 +126,7 @@ writeBarrier (WriteBuffer wb) = mapM_ flush $ M.elems wb where flush = mapM_ $ \(BufferedWrite _ cref a) -> writeImmediate cref a -- | Add phantom threads to the thread list to commit pending writes. -addCommitThreads :: WriteBuffer r -> Threads n r s -> Threads n r s +addCommitThreads :: WriteBuffer r -> Threads n r -> Threads n r addCommitThreads (WriteBuffer wb) ts = ts <> M.fromList phantoms where phantoms = [ (ThreadId Nothing $ negate tid, mkthread $ fromJust c) | ((k, b), tid) <- zip (M.toList wb) [1..] @@ -136,41 +136,41 @@ addCommitThreads (WriteBuffer wb) ts = ts <> M.fromList phantoms where go EmptyL = Nothing -- | Remove phantom threads. -delCommitThreads :: Threads n r s -> Threads n r s +delCommitThreads :: Threads n r -> Threads n r delCommitThreads = M.filterWithKey $ \k _ -> k >= initialThread -------------------------------------------------------------------------------- -- * Manipulating @MVar@s -- | Put into a @MVar@, blocking if full. -putIntoMVar :: MonadRef r n => MVar r a -> a -> Action n r s - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) +putIntoMVar :: MonadRef r n => MVar r a -> a -> Action n r + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) putIntoMVar cvar a c = mutMVar True cvar a (const c) -- | Try to put into a @MVar@, not blocking if full. -tryPutIntoMVar :: MonadRef r n => MVar r a -> a -> (Bool -> Action n r s) - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) +tryPutIntoMVar :: MonadRef r n => MVar r a -> a -> (Bool -> Action n r) + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) tryPutIntoMVar = mutMVar False -- | Read from a @MVar@, blocking if empty. -readFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r s) - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) +readFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r) + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) readFromMVar cvar c = seeMVar False True cvar (c . fromJust) -- | Take from a @MVar@, blocking if empty. -takeFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r s) - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) +takeFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r) + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) takeFromMVar cvar c = seeMVar True True cvar (c . fromJust) -- | Try to take from a @MVar@, not blocking if empty. -tryTakeFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r s) - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) +tryTakeFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r) + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) tryTakeFromMVar = seeMVar True False -- | Mutate a @MVar@, in either a blocking or nonblocking way. mutMVar :: MonadRef r n - => Bool -> MVar r a -> a -> (Bool -> Action n r s) - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) + => Bool -> MVar r a -> a -> (Bool -> Action n r) + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) mutMVar blocking (MVar cvid ref) a c threadid threads = do val <- readRef ref @@ -191,8 +191,8 @@ mutMVar blocking (MVar cvid ref) a c threadid threads = do -- | Read a @MVar@, in either a blocking or nonblocking -- way. seeMVar :: MonadRef r n - => Bool -> Bool -> MVar r a -> (Maybe a -> Action n r s) - -> ThreadId -> Threads n r s -> n (Bool, Threads n r s, [ThreadId]) + => Bool -> Bool -> MVar r a -> (Maybe a -> Action n r) + -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) seeMVar emptying blocking (MVar cvid ref) c threadid threads = do val <- readRef ref diff --git a/dejafu/Test/DejaFu/Conc/Internal/Threading.hs b/dejafu/Test/DejaFu/Conc/Internal/Threading.hs index 63925d6..2302a67 100644 --- a/dejafu/Test/DejaFu/Conc/Internal/Threading.hs +++ b/dejafu/Test/DejaFu/Conc/Internal/Threading.hs @@ -27,22 +27,22 @@ import qualified Data.Map.Strict as M -- * Threads -- | Threads are stored in a map index by 'ThreadId'. -type Threads n r s = Map ThreadId (Thread n r s) +type Threads n r = Map ThreadId (Thread n r) -- | All the state of a thread. -data Thread n r s = Thread - { _continuation :: Action n r s +data Thread n r = Thread + { _continuation :: Action n r -- ^ The next action to execute. , _blocking :: Maybe BlockedOn -- ^ The state of any blocks. - , _handlers :: [Handler n r s] + , _handlers :: [Handler n r] -- ^ Stack of exception handlers , _masking :: MaskingState -- ^ The exception masking state. } -- | Construct a thread with just one action -mkthread :: Action n r s -> Thread n r s +mkthread :: Action n r -> Thread n r mkthread c = Thread c Nothing [] Unmasked -------------------------------------------------------------------------------- @@ -53,7 +53,7 @@ mkthread c = Thread c Nothing [] Unmasked data BlockedOn = OnMVarFull MVarId | OnMVarEmpty MVarId | OnTVar [TVarId] | OnMask ThreadId deriving Eq -- | Determine if a thread is blocked in a certain way. -(~=) :: Thread n r s -> BlockedOn -> Bool +(~=) :: Thread n r -> BlockedOn -> Bool thread ~= theblock = case (_blocking thread, theblock) of (Just (OnMVarFull _), OnMVarFull _) -> True (Just (OnMVarEmpty _), OnMVarEmpty _) -> True @@ -65,11 +65,11 @@ thread ~= theblock = case (_blocking thread, theblock) of -- * Exceptions -- | An exception handler. -data Handler n r s = forall e. Exception e => Handler (e -> Action n r s) +data Handler n r = forall e. Exception e => Handler (e -> Action n r) -- | Propagate an exception upwards, finding the closest handler -- which can deal with it. -propagate :: SomeException -> ThreadId -> Threads n r s -> Maybe (Threads n r s) +propagate :: SomeException -> ThreadId -> Threads n r -> Maybe (Threads n r) propagate e tid threads = case M.lookup tid threads >>= go . _handlers of Just (act, hs) -> Just $ except act hs tid threads Nothing -> Nothing @@ -79,40 +79,40 @@ propagate e tid threads = case M.lookup tid threads >>= go . _handlers of go (Handler h:hs) = maybe (go hs) (\act -> Just (act, hs)) $ h <$> fromException e -- | Check if a thread can be interrupted by an exception. -interruptible :: Thread n r s -> Bool +interruptible :: Thread n r -> Bool interruptible thread = _masking thread == Unmasked || (_masking thread == MaskedInterruptible && isJust (_blocking thread)) -- | Register a new exception handler. -catching :: Exception e => (e -> Action n r s) -> ThreadId -> Threads n r s -> Threads n r s +catching :: Exception e => (e -> Action n r) -> ThreadId -> Threads n r -> Threads n r catching h = M.alter $ \(Just thread) -> Just $ thread { _handlers = Handler h : _handlers thread } -- | Remove the most recent exception handler. -uncatching :: ThreadId -> Threads n r s -> Threads n r s +uncatching :: ThreadId -> Threads n r -> Threads n r uncatching = M.alter $ \(Just thread) -> Just $ thread { _handlers = tail $ _handlers thread } -- | Raise an exception in a thread. -except :: Action n r s -> [Handler n r s] -> ThreadId -> Threads n r s -> Threads n r s +except :: Action n r -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r except act hs = M.alter $ \(Just thread) -> Just $ thread { _continuation = act, _handlers = hs, _blocking = Nothing } -- | Set the masking state of a thread. -mask :: MaskingState -> ThreadId -> Threads n r s -> Threads n r s +mask :: MaskingState -> ThreadId -> Threads n r -> Threads n r mask ms = M.alter $ \(Just thread) -> Just $ thread { _masking = ms } -------------------------------------------------------------------------------- -- * Manipulating threads -- | Replace the @Action@ of a thread. -goto :: Action n r s -> ThreadId -> Threads n r s -> Threads n r s +goto :: Action n r -> ThreadId -> Threads n r -> Threads n r goto a = M.alter $ \(Just thread) -> Just (thread { _continuation = a }) -- | Start a thread with the given ID, inheriting the masking state -- from the parent thread. This ID must not already be in use! -launch :: ThreadId -> ThreadId -> ((forall b. M n r s b -> M n r s b) -> Action n r s) -> Threads n r s -> Threads n r s +launch :: ThreadId -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action n r) -> Threads n r -> Threads n r launch parent tid a threads = launch' ms tid a threads where ms = fromMaybe Unmasked $ _masking <$> M.lookup parent threads -- | Start a thread with the given ID and masking state. This must not already be in use! -launch' :: MaskingState -> ThreadId -> ((forall b. M n r s b -> M n r s b) -> Action n r s) -> Threads n r s -> Threads n r s +launch' :: MaskingState -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action n r) -> Threads n r -> Threads n r launch' ms tid a = M.insert tid thread where thread = Thread { _continuation = a umask, _blocking = Nothing, _handlers = [], _masking = ms } @@ -120,11 +120,11 @@ launch' ms tid a = M.insert tid thread where resetMask typ m = cont $ \k -> AResetMask typ True m $ k () -- | Kill a thread. -kill :: ThreadId -> Threads n r s -> Threads n r s +kill :: ThreadId -> Threads n r -> Threads n r kill = M.delete -- | Block a thread. -block :: BlockedOn -> ThreadId -> Threads n r s -> Threads n r s +block :: BlockedOn -> ThreadId -> Threads n r -> Threads n r block blockedOn = M.alter doBlock where doBlock (Just thread) = Just $ thread { _blocking = Just blockedOn } doBlock _ = error "Invariant failure in 'block': thread does NOT exist!" @@ -132,7 +132,7 @@ block blockedOn = M.alter doBlock where -- | Unblock all threads waiting on the appropriate block. For 'TVar' -- blocks, this will wake all threads waiting on at least one of the -- given 'TVar's. -wake :: BlockedOn -> Threads n r s -> (Threads n r s, [ThreadId]) +wake :: BlockedOn -> Threads n r -> (Threads n r, [ThreadId]) wake blockedOn threads = (unblock <$> threads, M.keys $ M.filter isBlocked threads) where unblock thread | isBlocked thread = thread { _blocking = Nothing }