io-sim 1.3.0.0 → 1.3.1.0
raw patch · 5 files changed
+130/−202 lines, 5 filesdep ~basedep ~io-classesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, io-classes
API changes (from Hackage documentation)
Files
- CHANGELOG.md +7/−0
- io-sim.cabal +1/−1
- src/Control/Monad/IOSim/Internal.hs +70/−131
- src/Control/Monad/IOSim/Types.hs +14/−11
- src/Control/Monad/IOSimPOR/Internal.hs +38/−59
CHANGELOG.md view
@@ -6,6 +6,13 @@ ### Non-breaking changes +## 1.3.1.0++### Non-breaking changes++* Optimised `io-sim` performance (improved memory footprint).+* Fixed a bug in `io-sim-por`: `execAtomically'` should not commit tvars.+ ## 1.3.0.0 ### Breaking changes
io-sim.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: io-sim-version: 1.3.0.0+version: 1.3.1.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurency (base, async), stm,
src/Control/Monad/IOSim/Internal.hs view
@@ -105,7 +105,7 @@ _ -> False labelledTVarId :: TVar s a -> ST s (Labelled TVarId)-labelledTVarId TVar { tvarId, tvarLabel } = (Labelled tvarId) <$> readSTRef tvarLabel+labelledTVarId TVar { tvarId, tvarLabel } = Labelled tvarId <$> readSTRef tvarLabel labelledThreads :: Map IOSimThreadId (Thread s a) -> [Labelled IOSimThreadId] labelledThreads threadMap =@@ -210,8 +210,7 @@ invariant (Just thread) simstate $ case action of - Return x -> {-# SCC "schedule.Return" #-}- case ctl of+ Return x -> case ctl of MainFrame -> -- the main thread is done, so we're done -- even if other threads are still running@@ -267,8 +266,7 @@ timers' = PSQ.delete tmid timers schedule thread' simstate { timers = timers' } - Throw e -> {-# SCC "schedule.Throw" #-}- case unwindControlStack e thread timers of+ Throw e -> case unwindControlStack e thread timers of -- Found a CatchFrame (Right thread'@Thread { threadMasking = maskst' }, timers'') -> do -- We found a suitable exception handler, continue with that@@ -293,15 +291,13 @@ $ SimTrace time tid tlbl (EventDeschedule Terminated) $ trace - Catch action' handler k ->- {-# SCC "schedule.Catch" #-} do+ Catch action' handler k -> do -- push the failure and success continuations onto the control stack let thread' = thread { threadControl = ThreadControl action' (CatchFrame handler k ctl) } schedule thread' simstate - Evaluate expr k ->- {-# SCC "schedule.Evaulate" #-} do+ Evaluate expr k -> do mbWHNF <- unsafeIOToST $ try $ evaluate expr case mbWHNF of Left e -> do@@ -313,39 +309,33 @@ let thread' = thread { threadControl = ThreadControl (k whnf) ctl } schedule thread' simstate - Say msg k ->- {-# SCC "schedule.Say" #-} do+ Say msg k -> do let thread' = thread { threadControl = ThreadControl k ctl } trace <- schedule thread' simstate return (SimTrace time tid tlbl (EventSay msg) trace) - Output x k ->- {-# SCC "schedule.Output" #-} do+ Output x k -> do let thread' = thread { threadControl = ThreadControl k ctl } trace <- schedule thread' simstate return (SimTrace time tid tlbl (EventLog x) trace) - LiftST st k ->- {-# SCC "schedule.LiftST" #-} do+ LiftST st k -> do x <- strictToLazyST st let thread' = thread { threadControl = ThreadControl (k x) ctl } schedule thread' simstate - GetMonoTime k ->- {-# SCC "schedule.GetMonoTime" #-} do+ GetMonoTime k -> do let thread' = thread { threadControl = ThreadControl (k time) ctl } schedule thread' simstate - GetWallTime k ->- {-# SCC "schedule.GetWallTime" #-} do+ GetWallTime k -> do let !clockid = threadClockId thread !clockoff = clocks Map.! clockid !walltime = timeSinceEpoch time `addUTCTime` clockoff !thread' = thread { threadControl = ThreadControl (k walltime) ctl } schedule thread' simstate - SetWallTime walltime' k ->- {-# SCC "schedule.SetWallTime" #-} do+ SetWallTime walltime' k -> do let !clockid = threadClockId thread !clockoff = clocks Map.! clockid !walltime = timeSinceEpoch time `addUTCTime` clockoff@@ -354,8 +344,7 @@ !simstate' = simstate { clocks = Map.insert clockid clockoff' clocks } schedule thread' simstate' - UnshareClock k ->- {-# SCC "schedule.UnshareClock" #-} do+ UnshareClock k -> do let !clockid = threadClockId thread !clockoff = clocks Map.! clockid !clockid' = let ThreadId i = tid in ClockId i -- reuse the thread id@@ -368,9 +357,8 @@ StartTimeout d _ _ | d <= 0 -> error "schedule: StartTimeout: Impossible happened" - StartTimeout d action' k ->- {-# SCC "schedule.StartTimeout" #-} do- lock <- TMVar <$> execNewTVar nextVid (Just $ "lock-" ++ show nextTmid) Nothing+ StartTimeout d action' k -> do+ !lock <- TMVar <$> execNewTVar nextVid (Just $! "lock-" ++ show nextTmid) Nothing let !expiry = d `addTime` time !timers' = PSQ.insert nextTmid expiry (TimerTimeout tid nextTmid lock) timers !thread' = thread { threadControl =@@ -383,15 +371,13 @@ } return (SimTrace time tid tlbl (EventTimeoutCreated nextTmid tid expiry) trace) - UnregisterTimeout tmid k ->- {-# SCC "schedule.UnregisterTimeout" #-} do+ UnregisterTimeout tmid k -> do let thread' = thread { threadControl = ThreadControl k ctl } schedule thread' simstate { timers = PSQ.delete tmid timers } - RegisterDelay d k | d < 0 ->- {-# SCC "schedule.NewRegisterDelay.1" #-} do+ RegisterDelay d k | d < 0 -> do !tvar <- execNewTVar nextVid- (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>") True let !expiry = d `addTime` time !thread' = thread { threadControl = ThreadControl (k tvar) ctl }@@ -400,10 +386,9 @@ SimTrace time tid tlbl (EventRegisterDelayFired nextTmid) $ trace) - RegisterDelay d k ->- {-# SCC "schedule.NewRegisterDelay.2" #-} do+ RegisterDelay d k -> do !tvar <- execNewTVar nextVid- (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>") False let !expiry = d `addTime` time !timers' = PSQ.insert nextTmid expiry (TimerRegisterDelay tvar) timers@@ -414,8 +399,7 @@ return (SimTrace time tid tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) trace) - ThreadDelay d k | d < 0 ->- {-# SCC "schedule.NewThreadDelay" #-} do+ ThreadDelay d k | d < 0 -> do let !expiry = d `addTime` time !thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) } !simstate' = simstate { nextTmid = succ nextTmid }@@ -424,8 +408,7 @@ SimTrace time tid tlbl (EventThreadDelayFired nextTmid) $ trace) - ThreadDelay d k ->- {-# SCC "schedule.NewThreadDelay" #-} do+ ThreadDelay d k -> do let !expiry = d `addTime` time !timers' = PSQ.insert nextTmid expiry (TimerThreadDelay tid nextTmid) timers !thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }@@ -436,8 +419,7 @@ -- we treat negative timers as cancelled ones; for the record we put -- `EventTimerCreated` and `EventTimerCancelled` in the trace; This differs -- from `GHC.Event` behaviour.- NewTimeout d k | d < 0 ->- {-# SCC "schedule.NewTimeout.1" #-} do+ NewTimeout d k | d < 0 -> do let !t = NegativeTimeout nextTmid !expiry = d `addTime` time !thread' = thread { threadControl = ThreadControl (k t) ctl }@@ -446,10 +428,9 @@ SimTrace time tid tlbl (EventTimerCancelled nextTmid) $ trace) - NewTimeout d k ->- {-# SCC "schedule.NewTimeout.2" #-} do+ NewTimeout d k -> do !tvar <- execNewTVar nextVid- (Just $ "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")+ (Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>") TimeoutPending let !expiry = d `addTime` time !t = Timeout tvar nextTmid@@ -460,8 +441,7 @@ , nextTmid = succ nextTmid } return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) trace) - CancelTimeout (Timeout tvar tmid) k ->- {-# SCC "schedule.CancelTimeout" #-} do+ CancelTimeout (Timeout tvar tmid) k -> do let !timers' = PSQ.delete tmid timers !thread' = thread { threadControl = ThreadControl k ctl } !written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)@@ -482,14 +462,12 @@ $ trace -- cancelling a negative timer is a no-op- CancelTimeout (NegativeTimeout _tmid) k ->- {-# SCC "schedule.CancelTimeout" #-} do+ CancelTimeout (NegativeTimeout _tmid) k -> do -- negative timers are promptly removed from the state let thread' = thread { threadControl = ThreadControl k ctl } schedule thread' simstate - Fork a k ->- {-# SCC "schedule.Fork" #-} do+ Fork a k -> do let !nextId = threadNextTId thread !tid' = childThreadId tid nextId !thread' = thread { threadControl = ThreadControl (k tid') ctl@@ -510,7 +488,7 @@ return (SimTrace time tid tlbl (EventThreadForked tid') trace) Atomically a k ->- {-# SCC "schedule.Atomically" #-} execAtomically time tid tlbl nextVid (runSTM a) $ \res ->+ execAtomically time tid tlbl nextVid (runSTM a) $ \res -> case res of StmTxCommitted x written _read created tvarDynamicTraces tvarStringTraces nextVid' -> do@@ -560,30 +538,25 @@ $ SimTrace time tid tlbl (EventDeschedule (Blocked BlockedOnSTM)) $ trace - GetThreadId k ->- {-# SCC "schedule.GetThreadId" #-} do+ GetThreadId k -> do let thread' = thread { threadControl = ThreadControl (k tid) ctl } schedule thread' simstate - LabelThread tid' l k | tid' == tid ->- {-# SCC "schedule.LabelThread" #-} do+ LabelThread tid' l k | tid' == tid -> do let thread' = thread { threadControl = ThreadControl k ctl , threadLabel = Just l } schedule thread' simstate - LabelThread tid' l k ->- {-# SCC "schedule.LabelThread" #-} do+ LabelThread tid' l k -> do let thread' = thread { threadControl = ThreadControl k ctl } threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads schedule thread' simstate { threads = threads' } - GetMaskState k ->- {-# SCC "schedule.GetMaskState" #-} do+ GetMaskState k -> do let thread' = thread { threadControl = ThreadControl (k maskst) ctl } schedule thread' simstate - SetMaskState maskst' action' k ->- {-# SCC "schedule.SetMaskState" #-} do+ SetMaskState maskst' action' k -> do let thread' = thread { threadControl = ThreadControl (runIOSim action') (MaskFrame k maskst ctl)@@ -597,16 +570,14 @@ return $ SimTrace time tid tlbl (EventMask maskst') $ trace - ThrowTo e tid' _ | tid' == tid ->- {-# SCC "schedule.ThrowTo" #-} do+ ThrowTo e tid' _ | tid' == tid -> do -- Throw to ourself is equivalent to a synchronous throw, -- and works irrespective of masking state since it does not block. let thread' = thread { threadControl = ThreadControl (Throw e) ctl } trace <- schedule thread' simstate return (SimTrace time tid tlbl (EventThrowTo e tid) trace) - ThrowTo e tid' k ->- {-# SCC "schedule.ThrowTo" #-} do+ ThrowTo e tid' k -> do let thread' = thread { threadControl = ThreadControl k ctl } willBlock = case Map.lookup tid' threads of Just t -> not (threadInterruptible t)@@ -650,11 +621,9 @@ -- ExploreRaces is ignored by this simulator ExploreRaces k ->- {-# SCC "schedule.ExploreRaces" #-} schedule thread{ threadControl = ThreadControl k ctl } simstate - Fix f k ->- {-# SCC "schedule.Fix" #-} do+ Fix f k -> do r <- newSTRef (throw NonTermination) x <- unsafeInterleaveST $ readSTRef r let k' = unIOSim (f x) $ \x' ->@@ -683,7 +652,6 @@ -- algorithms are not sensitive to the exact policy, so long as it is a -- fair policy (all runnable threads eventually run). - {-# SCC "deschedule.Yield" #-} let runqueue' = Deque.snoc (threadId thread) runqueue threads' = Map.insert (threadId thread) thread threads in reschedule simstate { runqueue = runqueue', threads = threads' }@@ -700,7 +668,6 @@ -- We're unmasking, but there are pending blocked async exceptions. -- So immediately raise the exception and unblock the blocked thread -- if possible.- {-# SCC "deschedule.Interruptable.Unmasked" #-} let thread' = thread { threadControl = ThreadControl (Throw e) ctl , threadMasking = MaskedInterruptible , threadThrowTo = etids }@@ -717,7 +684,6 @@ deschedule Interruptable !thread !simstate = -- Either masked or unmasked but no pending async exceptions. -- Either way, just carry on.- {-# SCC "deschedule.Interruptable.Masked" #-} schedule thread simstate deschedule (Blocked _blockedReason) !thread@Thread { threadThrowTo = _ : _@@ -727,11 +693,9 @@ -- we have async exceptions masked, and there are pending blocked async -- exceptions. So immediately raise the exception and unblock the blocked -- thread if possible.- {-# SCC "deschedule.Interruptable.Blocked.1" #-} deschedule Interruptable thread { threadMasking = Unmasked } simstate deschedule (Blocked blockedReason) !thread !simstate@SimState{threads} =- {-# SCC "deschedule.Interruptable.Blocked.2" #-} let thread' = thread { threadStatus = ThreadBlocked blockedReason } threads' = Map.insert (threadId thread') thread' threads in reschedule simstate { threads = threads' }@@ -739,7 +703,6 @@ deschedule Terminated !thread !simstate@SimState{ curTime = time, threads } = -- This thread is done. If there are other threads blocked in a -- ThrowTo targeted at this thread then we can wake them up now.- {-# SCC "deschedule.Terminated" #-} let !wakeup = map (l_labelled . snd) (reverse (threadThrowTo thread)) (unblocked, !simstate') = unblockThreads False wakeup simstate@@ -759,7 +722,6 @@ reschedule :: SimState s a -> ST s (SimTrace a) reschedule !simstate@SimState{ runqueue, threads } | Just (!tid, runqueue') <- Deque.uncons runqueue =- {-# SCC "reschedule.Just" #-} let thread = threads Map.! tid in schedule thread simstate { runqueue = runqueue' , threads = Map.delete tid threads }@@ -767,7 +729,6 @@ -- But when there are no runnable threads, we advance the time to the next -- timer event, or stop. reschedule !simstate@SimState{ threads, timers, curTime = time } =- {-# SCC "reschedule.Nothing" #-} -- important to get all events that expire at this time case removeMinimums timers of@@ -1064,7 +1025,7 @@ -> StmA s a -> (StmTxResult s a -> ST s (SimTrace c)) -> ST s (SimTrace c)-execAtomically !time !tid !tlbl !nextVid0 action0 k0 =+execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 = go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0 where go :: forall b.@@ -1076,10 +1037,10 @@ -> TVarId -- var fresh name supply -> StmA s b -> ST s (SimTrace c)- go !ctl !read !written !writtenSeq !createdSeq !nextVid action = assert localInvariant $- case action of+ go !ctl !read !written !writtenSeq !createdSeq !nextVid !action =+ assert localInvariant $+ case action of ReturnStm x ->- {-# SCC "execAtomically.go.ReturnStm" #-} case ctl of AtomicallyFrame -> do -- Trace each created TVar@@ -1122,32 +1083,27 @@ -- Skip the right hand alternative and continue with the k continuation go ctl' read written' writtenSeq' createdSeq' nextVid (k x) - ThrowStm e ->- {-# SCC "execAtomically.go.ThrowStm" #-} do+ ThrowStm e -> do -- Rollback `TVar`s written since catch handler was installed !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written case ctl of AtomicallyFrame -> do k0 $ StmTxAborted (Map.elems read) (toException e) - BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do -- Execute the left side in a new frame with an empty written set. -- but preserve ones that were set prior to it, as specified in the -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package. let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' go ctl'' read Map.empty [] [] nextVid (h e) - BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) - BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) - CatchStm a h k ->- {-# SCC "execAtomically.go.ThrowStm" #-} do+ CatchStm a h k -> do -- Execute the catch handler with an empty written set. -- but preserve ones that were set prior to it, as specified in the -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.@@ -1155,8 +1111,7 @@ go ctl' read Map.empty [] [] nextVid a - Retry ->- {-# SCC "execAtomically.go.Retry" #-} do+ Retry -> do -- Always revert all the TVar writes for the retry !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written case ctl of@@ -1164,81 +1119,68 @@ -- Return vars read, so the thread can block on them k0 $! StmTxBlocked $! Map.elems read - BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do+ BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do -- Execute the orElse right hand with an empty written set let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' go ctl'' read Map.empty [] [] nextVid b - BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do -- Retry makes sense only within a OrElse context. If it is a branch other than -- OrElse left side, then bubble up the `retry` to the frame above. -- Skip the continuation and propagate the retry into the outer frame -- using the written set for the outer frame go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry - OrElse a b k ->- {-# SCC "execAtomically.go.OrElse" #-} do+ OrElse a b k -> do -- Execute the left side in a new frame with an empty written set let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl go ctl' read Map.empty [] [] nextVid a - NewTVar !mbLabel x k ->- {-# SCC "execAtomically.go.NewTVar" #-} do+ NewTVar !mbLabel x k -> do !v <- execNewTVar nextVid mbLabel x go ctl read written writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v) - LabelTVar !label tvar k ->- {-# SCC "execAtomically.go.LabelTVar" #-} do+ LabelTVar !label tvar k -> do !_ <- writeSTRef (tvarLabel tvar) $! (Just label) go ctl read written writtenSeq createdSeq nextVid k - TraceTVar tvar f k ->- {-# SCC "execAtomically.go.TraceTVar" #-} do+ TraceTVar tvar f k -> do !_ <- writeSTRef (tvarTrace tvar) (Just f) go ctl read written writtenSeq createdSeq nextVid k ReadTVar v k- | tvarId v `Map.member` read ->- {-# SCC "execAtomically.go.ReadTVar" #-} do+ | tvarId v `Map.member` read -> do x <- execReadTVar v go ctl read written writtenSeq createdSeq nextVid (k x) | otherwise ->- {-# SCC "execAtomically.go.ReadTVar" #-} do+ do x <- execReadTVar v let read' = Map.insert (tvarId v) (SomeTVar v) read go ctl read' written writtenSeq createdSeq nextVid (k x) WriteTVar v x k- | tvarId v `Map.member` written ->- {-# SCC "execAtomically.go.WriteTVar" #-} do+ | tvarId v `Map.member` written -> do !_ <- execWriteTVar v x go ctl read written writtenSeq createdSeq nextVid k- | otherwise ->- {-# SCC "execAtomically.go.WriteTVar" #-} do+ | otherwise -> do !_ <- saveTVar v !_ <- execWriteTVar v x let written' = Map.insert (tvarId v) (SomeTVar v) written go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k - SayStm msg k ->- {-# SCC "execAtomically.go.SayStm" #-} do+ SayStm msg k -> do trace <- go ctl read written writtenSeq createdSeq nextVid k return $ SimTrace time tid tlbl (EventSay msg) trace - OutputStm x k ->- {-# SCC "execAtomically.go.OutputStm" #-} do+ OutputStm x k -> do trace <- go ctl read written writtenSeq createdSeq nextVid k return $ SimTrace time tid tlbl (EventLog x) trace - LiftSTStm st k ->- {-# SCC "schedule.LiftSTStm" #-} do+ LiftSTStm st k -> do x <- strictToLazyST st go ctl read written writtenSeq createdSeq nextVid (k x) - FixStm f k ->- {-# SCC "execAtomically.go.FixStm" #-} do+ FixStm f k -> do r <- newSTRef (throw NonTermination) x <- unsafeInterleaveST $ readSTRef r let k' = unSTM (f x) $ \x' ->@@ -1308,26 +1250,23 @@ saveTVar :: TVar s a -> ST s () saveTVar TVar{tvarCurrent, tvarUndo} = do -- push the current value onto the undo stack- v <- readSTRef tvarCurrent- vs <- readSTRef tvarUndo- !_ <- writeSTRef tvarUndo (v:vs)- return ()+ v <- readSTRef tvarCurrent+ !vs <- readSTRef tvarUndo+ writeSTRef tvarUndo $! v:vs revertTVar :: TVar s a -> ST s () revertTVar TVar{tvarCurrent, tvarUndo} = do -- pop the undo stack, and revert the current value- vs <- readSTRef tvarUndo- !_ <- writeSTRef tvarCurrent (head vs)- !_ <- writeSTRef tvarUndo (tail vs)- return ()+ !vs <- readSTRef tvarUndo+ !_ <- writeSTRef tvarCurrent (head vs)+ writeSTRef tvarUndo $! tail vs {-# INLINE revertTVar #-} commitTVar :: TVar s a -> ST s () commitTVar TVar{tvarUndo} = do- vs <- readSTRef tvarUndo+ !vs <- readSTRef tvarUndo -- pop the undo stack, leaving the current value unchanged- !_ <- writeSTRef tvarUndo (tail vs)- return ()+ writeSTRef tvarUndo $! tail vs {-# INLINE commitTVar #-} readTVarUndos :: TVar s a -> ST s [a]@@ -1344,8 +1283,8 @@ Nothing -> return TraceValue { traceDynamic = (Nothing :: Maybe ()) , traceString = Nothing } Just f -> do- vs <- readSTRef tvarUndo- v <- readSTRef tvarCurrent+ !vs <- readSTRef tvarUndo+ v <- readSTRef tvarCurrent case (new, vs) of (True, _) -> f Nothing v (_, _:_) -> f (Just $ last vs) v
src/Control/Monad/IOSim/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}@@ -147,7 +148,7 @@ -- `selectTraceEventsDynamic'`. -- traceM :: Typeable a => a -> IOSim s ()-traceM x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ())+traceM !x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ()) -- | Trace a value, in the same was as `traceM` does, but from the `STM` monad. -- This is primarily useful for debugging.@@ -161,7 +162,7 @@ Return :: a -> SimA s a Say :: String -> SimA s b -> SimA s b- Output :: Dynamic -> SimA s b -> SimA s b+ Output :: !Dynamic -> SimA s b -> SimA s b LiftST :: StrictST.ST s a -> (a -> SimA s b) -> SimA s b @@ -458,6 +459,8 @@ forkIO task = IOSim $ oneShot $ \k -> Fork task k forkOn _ task = IOSim $ oneShot $ \k -> Fork task k forkIOWithUnmask f = forkIO (f unblock)+ forkFinally task k = mask $ \restore ->+ forkIO $ try (restore task) >>= k throwTo tid e = IOSim $ oneShot $ \k -> ThrowTo (toException e) tid (k ()) yield = IOSim $ oneShot $ \k -> YieldSim (k ()) @@ -472,7 +475,7 @@ labelTVar tvar label = STM $ \k -> LabelTVar label tvar (k ()) labelTVarIO tvar label = IOSim $ oneShot $ \k -> LiftST ( lazyToStrictST $- writeSTRef (tvarLabel tvar) $! (Just label)+ writeSTRef (tvarLabel tvar) $! Just label ) k labelTQueue = labelTQueueDefault labelTBQueue = labelTBQueueDefault@@ -1211,22 +1214,22 @@ -- -- It also includes the updated TVarId name supply. --- StmTxCommitted a [SomeTVar s] -- ^ written tvars- [SomeTVar s] -- ^ read tvars- [SomeTVar s] -- ^ created tvars- [Dynamic]- [String]- TVarId -- updated TVarId name supply+ StmTxCommitted a ![SomeTVar s] -- ^ written tvars+ ![SomeTVar s] -- ^ read tvars+ ![SomeTVar s] -- ^ created tvars+ ![Dynamic]+ ![String]+ !TVarId -- updated TVarId name supply -- | A blocked transaction reports the vars that were read so that the -- scheduler can block the thread on those vars. --- | StmTxBlocked [SomeTVar s]+ | StmTxBlocked ![SomeTVar s] -- | An aborted transaction reports the vars that were read so that the -- vector clock can be updated. --- | StmTxAborted [SomeTVar s] SomeException+ | StmTxAborted ![SomeTVar s] SomeException -- | A branch indicates that an alternative statement is available in the current
src/Control/Monad/IOSimPOR/Internal.hs view
@@ -482,7 +482,7 @@ error "schedule: StartTimeout: Impossible happened" StartTimeout d action' k -> do- lock <- TMVar <$> execNewTVar nextVid (Just $ "lock-" ++ show nextTmid) Nothing+ lock <- TMVar <$> execNewTVar nextVid (Just $! "lock-" ++ show nextTmid) Nothing let expiry = d `addTime` time timers' = PSQ.insert nextTmid expiry (TimerTimeout tid nextTmid lock) timers thread' = thread { threadControl =@@ -499,7 +499,7 @@ RegisterDelay d k | d < 0 -> do tvar <- execNewTVar nextVid- (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>") True modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock) let !expiry = d `addTime` time@@ -511,7 +511,7 @@ RegisterDelay d k -> do tvar <- execNewTVar nextVid- (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>") False modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock) let !expiry = d `addTime` time@@ -555,7 +555,7 @@ NewTimeout d k -> do tvar <- execNewTVar nextVid- (Just $ "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")+ (Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>") TimeoutPending modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock) let expiry = d `addTime` time@@ -1350,7 +1350,7 @@ -> StmA s a -> (StmTxResult s a -> ST s (SimTrace c)) -> ST s (SimTrace c)-execAtomically time tid tlbl nextVid0 action0 k0 =+execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 = go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0 where go :: forall b.@@ -1362,10 +1362,10 @@ -> TVarId -- var fresh name supply -> StmA s b -> ST s (SimTrace c)- go !ctl !read !written !writtenSeq !createdSeq !nextVid action = assert localInvariant $- case action of+ go !ctl !read !written !writtenSeq !createdSeq !nextVid !action =+ assert localInvariant $+ case action of ReturnStm x ->- {-# SCC "execAtomically.go.ReturnStm" #-} case ctl of AtomicallyFrame -> do -- Trace each created TVar@@ -1408,38 +1408,32 @@ -- Skip the orElse right hand and continue with the k continuation go ctl' read written' writtenSeq' createdSeq' nextVid (k x) - ThrowStm e ->- {-# SCC "execAtomically.go.ThrowStm" #-} do+ ThrowStm e -> do -- Revert all the TVar writes !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written case ctl of AtomicallyFrame -> do k0 $ StmTxAborted (Map.elems read) (toException e) - BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do -- Execute the left side in a new frame with an empty written set. -- but preserve ones that were set prior to it, as specified in the -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package. let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' go ctl'' read Map.empty [] [] nextVid (h e) - BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) - BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) - CatchStm a h k ->- {-# SCC "execAtomically.go.ThrowStm" #-} do+ CatchStm a h k -> do -- Execute the left side in a new frame with an empty written set let ctl' = BranchFrame (CatchStmA h) k written writtenSeq createdSeq ctl go ctl' read Map.empty [] [] nextVid a - Retry ->- {-# SCC "execAtomically.go.Retry" #-} do+ Retry -> do -- Always revert all the TVar writes for the retry !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written case ctl of@@ -1447,28 +1441,24 @@ -- Return vars read, so the thread can block on them k0 $! StmTxBlocked $! Map.elems read - BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do+ BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do -- Execute the orElse right hand with an empty written set let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' go ctl'' read Map.empty [] [] nextVid b - BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->- {-# SCC "execAtomically.go.BranchFrame" #-} do+ BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do -- Retry makes sense only within a OrElse context. If it is a branch other than -- OrElse left side, then bubble up the `retry` to the frame above. -- Skip the continuation and propagate the retry into the outer frame -- using the written set for the outer frame go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry - OrElse a b k ->- {-# SCC "execAtomically.go.OrElse" #-} do+ OrElse a b k -> do -- Execute the left side in a new frame with an empty written set let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl go ctl' read Map.empty [] [] nextVid a - NewTVar !mbLabel x k ->- {-# SCC "execAtomically.go.NewTVar" #-} do+ NewTVar !mbLabel x k -> do !v <- execNewTVar nextVid mbLabel x -- record a write to the TVar so we know to update its VClock let written' = Map.insert (tvarId v) (SomeTVar v) written@@ -1476,58 +1466,48 @@ !_ <- saveTVar v go ctl read written' writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v) - LabelTVar !label tvar k ->- {-# SCC "execAtomically.go.LabelTVar" #-} do+ LabelTVar !label tvar k -> do !_ <- writeSTRef (tvarLabel tvar) $! (Just label) go ctl read written writtenSeq createdSeq nextVid k - TraceTVar tvar f k ->- {-# SCC "execAtomically.go.TraceTVar" #-} do+ TraceTVar tvar f k -> do !_ <- writeSTRef (tvarTrace tvar) (Just f) go ctl read written writtenSeq createdSeq nextVid k ReadTVar v k- | tvarId v `Map.member` read ->- {-# SCC "execAtomically.go.ReadTVar" #-} do+ | tvarId v `Map.member` read -> do x <- execReadTVar v go ctl read written writtenSeq createdSeq nextVid (k x)- | otherwise ->- {-# SCC "execAtomically.go.ReadTVar" #-} do+ | otherwise -> do x <- execReadTVar v let read' = Map.insert (tvarId v) (SomeTVar v) read go ctl read' written writtenSeq createdSeq nextVid (k x) WriteTVar v x k- | tvarId v `Map.member` written ->- {-# SCC "execAtomically.go.WriteTVar" #-} do+ | tvarId v `Map.member` written -> do !_ <- execWriteTVar v x go ctl read written writtenSeq createdSeq nextVid k- | otherwise ->- {-# SCC "execAtomically.go.WriteTVar" #-} do+ | otherwise -> do !_ <- saveTVar v !_ <- execWriteTVar v x let written' = Map.insert (tvarId v) (SomeTVar v) written go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k - SayStm msg k ->- {-# SCC "execAtomically.go.SayStm" #-} do+ SayStm msg k -> do trace <- go ctl read written writtenSeq createdSeq nextVid k -- TODO: step return $ SimPORTrace time tid (-1) tlbl (EventSay msg) trace - OutputStm x k ->- {-# SCC "execAtomically.go.OutputStm" #-} do+ OutputStm x k -> do trace <- go ctl read written writtenSeq createdSeq nextVid k -- TODO: step return $ SimPORTrace time tid (-1) tlbl (EventLog x) trace - LiftSTStm st k ->- {-# SCC "schedule.LiftSTStm" #-} do+ LiftSTStm st k -> do x <- strictToLazyST st go ctl read written writtenSeq createdSeq nextVid (k x) - FixStm f k ->- {-# SCC "execAtomically.go.FixStm" #-} do+ FixStm f k -> do r <- newSTRef (throw NonTermination) x <- unsafeInterleaveST $ readSTRef r let k' = unSTM (f x) $ \x' ->@@ -1551,7 +1531,6 @@ -> ST s [SomeTVar s] go !written action = case action of ReturnStm () -> do- !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar) written return (Map.elems written) ReadTVar v k -> do x <- execReadTVar v@@ -1598,23 +1577,23 @@ saveTVar :: TVar s a -> ST s () saveTVar TVar{tvarCurrent, tvarUndo} = do -- push the current value onto the undo stack- v <- readSTRef tvarCurrent- vs <- readSTRef tvarUndo- writeSTRef tvarUndo (v:vs)+ v <- readSTRef tvarCurrent+ !vs <- readSTRef tvarUndo+ writeSTRef tvarUndo $! v:vs revertTVar :: TVar s a -> ST s () revertTVar TVar{tvarCurrent, tvarUndo} = do -- pop the undo stack, and revert the current value- vs <- readSTRef tvarUndo- writeSTRef tvarCurrent (head vs)- writeSTRef tvarUndo (tail vs)+ !vs <- readSTRef tvarUndo+ !_ <- writeSTRef tvarCurrent (head vs)+ writeSTRef tvarUndo $! tail vs {-# INLINE revertTVar #-} commitTVar :: TVar s a -> ST s () commitTVar TVar{tvarUndo} = do- vs <- readSTRef tvarUndo+ !vs <- readSTRef tvarUndo -- pop the undo stack, leaving the current value unchanged- writeSTRef tvarUndo (tail vs)+ writeSTRef tvarUndo $! tail vs {-# INLINE commitTVar #-} readTVarUndos :: TVar s a -> ST s [a]@@ -1630,8 +1609,8 @@ case mf of Nothing -> return TraceValue { traceDynamic = (Nothing :: Maybe ()), traceString = Nothing } Just f -> do- vs <- readSTRef tvarUndo- v <- readSTRef tvarCurrent+ !vs <- readSTRef tvarUndo+ v <- readSTRef tvarCurrent case (new, vs) of (True, _) -> f Nothing v (_, _:_) -> f (Just $ last vs) v