io-sim 1.9.1.0 → 1.10.0.0

raw patch · 9 files changed

+1902/−1599 lines, 9 filesdep ~io-classesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: io-classes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +25/−0
• io-sim.cabal +2/−2
• src/Control/Monad/IOSim.hs +1/−1
• src/Control/Monad/IOSim/Internal.hs +97/−35
• src/Control/Monad/IOSim/Types.hs +50/−12
• src/Control/Monad/IOSimPOR/Internal.hs +1559/−1494
• src/Data/List/Trace.hs +6/−1
• test/Test/Control/Monad/IOSim.hs +109/−51
• test/Test/Control/Monad/IOSimPOR.hs +53/−3

@@ -1,5 +1,30 @@ # Revision history of io-sim +## 1.10.0.0++### Breaking changes++* Added `EventEvaluationError`, `EventEvaluationSuccess`+* Added `EventSayEvaluationError`, `EventLogEvaluationError`+* Added `flushEventLog` to `MonadEventLog` instance.++### Non-breaking changes++* `ppSimEventType` (used by `Control.Monad.IOSim.ppTrace` and+  `Control.Monad.IOSim.ppTrace_`): does not fail if `EventThrow` or+  `EventThrowTo` contain a pure exception.  This supports laziness of `throwIO`+  and `throwTo`.+* `say`, `traceM` and `traceSTM` evaluate their arguments (first one to _NF_+  the other two to _WHNF_).  They throw an exception (within the simulator) if+  evaluation fails.  For `say` this makes it behave like `putStrLn` does.+  Previously all would throw a pure exception which would terminate the+  simulator prematurely.  If you want to verify that these calls do not fail,+  you can check for absence of `EventSayEvaluationError` or+  `EventLogEvaluationError`.+* Added `Data.List.Trace.last`+* Although `IOSim` and `IOSimPOR` are pure we use `evaluate` in a few places,+  non of them now catch asynchrounous exceptions.+ ## 1.9.1.0  ### Non-breaking changes

@@ -1,6 +1,6 @@ cabal-version:       3.4 name:                io-sim-version:             1.9.1.0+version:             1.10.0.0 synopsis:            A pure simulator for monadic concurrency with STM. description:   A pure simulator monad with support of concurrency (base & async style), stm,@@ -66,7 +66,7 @@     default-extensions: GADTs   build-depends:       base              >=4.16 && <4.22,                        io-classes:{io-classes,strict-stm,si-timers}-                                        ^>=1.9,+                                        ^>=1.9 || ^>=1.10,                        exceptions        >=0.10,                        containers,                        deepseq,

@@ -363,7 +363,7 @@   deriving Show  instance Exception Failure where-    displayException (FailureException err) = displayException  err+    displayException (FailureException err) = displayException err     displayException (FailureDeadlock threads) =       concat [ "<<io-sim deadlock: "              , intercalate ", " (show `map` threads)

@@ -56,7 +56,9 @@ import Data.Set qualified as Set import Data.Time (UTCTime (..), fromGregorian) -import Control.Exception (NonTermination (..), assert, throw)+import Control.DeepSeq (force)+import Control.Exception (NonTermination (..), SomeAsyncException, assert,+           throw) import Control.Monad (join, when) import Control.Monad.ST.Lazy import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)@@ -293,26 +295,55 @@       schedule thread' simstate      Evaluate expr k -> do-      mbWHNF <- unsafeIOToST $ try $ evaluate expr+      mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                          Nothing -> Just e+                                          Just {} -> Nothing)+                             $ evaluate expr       case mbWHNF of         Left e -> do           -- schedule this thread to immediately raise the exception           let thread' = thread { threadControl = ThreadControl (Throw e) ctl }-          schedule thread' simstate+          trace <- schedule thread' simstate+          return $ SimTrace time tid tlbl (EventEvaluationError e)+                 $ trace         Right whnf -> do           -- continue with the resulting WHNF           let thread' = thread { threadControl = ThreadControl (k whnf) ctl }-          schedule thread' simstate+          trace <- schedule thread' simstate+          return $ SimTrace time tid tlbl EventEvaluationSuccess+                 $ trace      Say msg k -> do-      let thread' = thread { threadControl = ThreadControl k ctl }-      trace <- schedule thread' simstate-      return (SimTrace time tid tlbl (EventSay msg) trace)+      mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                        Nothing -> Just e+                                        Just {} -> Nothing)+                           $ evaluate (force msg)+      case mbNF of+        Left e -> do+          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+          trace <- schedule thread' simstate+          return $ SimTrace time tid tlbl (EventSayEvaluationError e)+                 $ trace+        Right msg' -> do+          let thread' = thread { threadControl = ThreadControl k ctl }+          trace <- schedule thread' simstate+          return (SimTrace time tid tlbl (EventSay msg') trace) -    Output x k -> do-      let thread' = thread { threadControl = ThreadControl k ctl }-      trace <- schedule thread' simstate-      return (SimTrace time tid tlbl (EventLog x) trace)+    Output x@(Dynamic _ x') k -> do+      mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                          Nothing -> Just e+                                          Just {} -> Nothing)+                             $ evaluate x'+      case mbWHNF of+        Left e -> do+          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+          trace <- schedule thread' simstate+          return $ SimTrace time tid tlbl (EventLogEvaluationError e)+                 $ trace+        Right {} -> do+          let thread' = thread { threadControl = ThreadControl k ctl }+          trace <- schedule thread' simstate+          return (SimTrace time tid tlbl (EventLog x) trace)      LiftST st k -> do       x <- strictToLazyST st@@ -1094,25 +1125,8 @@           -- Skip the right hand alternative and continue with the k continuation           go ctl' read written' writtenSeq' createdSeq' nextVid (k x) -      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' -> 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' -> do-            go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)--          BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do-            go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)+      ThrowStm e ->+        throwStm ctl read written nextVid e        CatchStm a h k -> do         -- Execute the catch handler with an empty written set.@@ -1180,12 +1194,32 @@             go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k        SayStm msg k -> do-        trace <- go ctl read written writtenSeq createdSeq nextVid k-        return $ SimTrace time tid tlbl (EventSay msg) trace+        mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                          Nothing -> Just e+                                          Just {} -> Nothing)+                             $ evaluate (force msg)+        case mbNF of+          Left e -> do+            trace <- throwStm ctl read written nextVid e+            return $ SimTrace time tid tlbl (EventSayEvaluationError e)+                   $ trace+          Right msg' -> do+            trace <- go ctl read written writtenSeq createdSeq nextVid k+            return $ SimTrace time tid tlbl (EventSay msg') trace -      OutputStm x k -> do-        trace <- go ctl read written writtenSeq createdSeq nextVid k-        return $ SimTrace time tid tlbl (EventLog x) trace+      OutputStm x@(Dynamic _ x') k -> do+        mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                            Nothing -> Just e+                                            Just {} -> Nothing)+                               $ evaluate x'+        case mbWHNF of+          Left e -> do+            trace <- throwStm ctl read written nextVid e+            return $ SimTrace time tid tlbl (EventLogEvaluationError e)+                   $ trace+          Right {} -> do+            trace <- go ctl read written writtenSeq createdSeq nextVid k+            return $ SimTrace time tid tlbl (EventLog x) trace        LiftSTStm st k -> do         x <- strictToLazyST st@@ -1202,6 +1236,34 @@         localInvariant =             Map.keysSet written          == Set.fromList [ tvarId tvar | SomeTVar tvar <- writtenSeq ]++    -- throw an exception in an STM transaction+    throwStm :: forall b.+                StmStack s b a+             -> Map TVarId (SomeTVar s)+             -> Map TVarId (SomeTVar s)+             -> VarId+             -> SomeException+             -> ST s (SimTrace c)+    throwStm ctl read written nextVid 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' -> 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' -> do+          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)++        BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do+          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)   -- | Special case of 'execAtomically' supporting only var reads and writes

@@ -1,7 +1,8 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE DerivingVia     #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeFamilies    #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DerivingVia         #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}  -- Needed for `SimEvent` type. {-# OPTIONS_GHC -Wno-partial-fields    #-}@@ -65,7 +66,7 @@   ) where  import Control.Applicative-import Control.Exception (ErrorCall (..))+import Control.Exception (ErrorCall (..), SomeAsyncException) import Control.Exception qualified as IO import Control.Monad import Control.Monad.Fix (MonadFix (..))@@ -129,8 +130,9 @@ import Control.Monad.IOSimPOR.Types  +import Control.DeepSeq (force) import Data.List (intercalate)-import GHC.IO (mkUserError)+import GHC.IO (mkUserError, unsafePerformIO) import System.IO.Error qualified as IO.Error (userError)  {-# ANN module "HLint: ignore Use readTVarIO" #-}@@ -143,12 +145,18 @@ -- can then be recovered with `selectTraceEventsDynamic` or -- `selectTraceEventsDynamic'`. --+-- Note: `traceM` evaluates the `a` to `WHNF`, exceptions are thrown by the+-- current thread and the trace will include `EventLogEvaluationError`.+-- 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. --+-- Note: `traceSTM` evaluates the `a` to `WHNF`, if exception is thrown, the+-- trace will end with `TraceException`.+-- traceSTM :: Typeable a => a -> STMSim s () traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ()) @@ -331,6 +339,10 @@ instance MonadFix (STM s) where     mfix f = STM $ oneShot $ \k -> FixStm f k +-- | `IOSim s` instance is strict: the string will be evaluated to normal form,+-- if an exception is encountered it is thrown in the current thread, and the+-- log will contain `EventSayEvaluationError`.+-- instance MonadSay (IOSim s) where   say msg = IOSim $ oneShot $ \k -> Say msg (k ()) @@ -481,6 +493,10 @@ instance MonadTest (IOSim s) where   exploreRaces       = IOSim $ oneShot $ \k -> ExploreRaces (k ()) +-- | `STM (IOSim s)` instance is strict: the string will be evaluated to normal+-- form, if an exception is encountered the trace will finish with+-- `TraceException`.+-- instance MonadSay (STMSim s) where   say msg = STM $ oneShot $ \k -> SayStm msg (k ()) @@ -790,8 +806,9 @@ newtype EventlogMarker = EventlogMarker String  instance MonadEventlog (IOSim s) where-  traceEventIO = traceM . EventlogEvent+  traceEventIO  = traceM . EventlogEvent   traceMarkerIO = traceM . EventlogMarker+  flushEventLog = pure ()  -- | 'Trace' is a recursive data type, it is the trace of a 'IOSim' -- computation.  The trace will contain information about thread scheduling,@@ -1040,9 +1057,13 @@ -- data SimEventType   = EventSay  String-  -- ^ hold value of `say`+  -- ^ holds value of `say`+  | EventSayEvaluationError SomeException+  -- ^ holds error resulted from evaluation of the expression passed to `say` to NF.   | EventLog  Dynamic-  -- ^ hold a dynamic value of `Control.Monad.IOSim.traceM`+  -- ^ holds a dynamic value of `Control.Monad.IOSim.traceM`+  | EventLogEvaluationError SomeException+  -- ^ holds error resulted from evaluation of the expression passed to `traceM` to WHNF.   | EventMask MaskingState   -- ^ masking state changed @@ -1057,6 +1078,8 @@   | EventThrowToUnmasked (Labelled IOSimThreadId)   -- ^ a target thread of `throwTo` unmasked its exceptions, this is paired   -- with `EventThrowToWakeup` for threads which were blocked on `throwTo`+  | EventEvaluationError SomeException+  | EventEvaluationSuccess    | EventThreadForked    IOSimThreadId   -- ^ forked a thread@@ -1156,18 +1179,33 @@   -- a simulation.  Useful for debugging IOSimPOR.   deriving Show +unsafeEvaluateString :: String -> String -> String+unsafeEvaluateString name a = unsafePerformIO $+  catchJust+    (\e -> case fromException @SomeAsyncException e of+              Just{}  -> Nothing+              Nothing -> Just e+    )+    (evaluate (force a))+    (\(e :: SomeException) -> return ("- error evaluating " ++ name ++ ": " ++ show e))++ ppSimEventType :: SimEventType -> String ppSimEventType = \case   EventSay a -> "Say " ++ a+  EventSayEvaluationError err -> "SayEvaluationError " ++ show err   EventLog a -> "Dynamic " ++ show a+  EventLogEvaluationError err -> "DynamicEvaluationError " ++ show err   EventMask a -> "Mask " ++ show a-  EventThrow a -> "Throw " ++ show a+  EventThrow err -> "Throw " ++ unsafeEvaluateString "exception" (show err)   EventThrowTo err tid ->     concat [ "ThrowTo (",-              show err, ") ",+              unsafeEvaluateString "exception" (show err), ") ",               ppIOSimThreadId tid ]   EventThrowToBlocked -> "ThrowToBlocked"   EventThrowToWakeup -> "ThrowToWakeup"+  EventEvaluationError err -> "EvaluationError " ++ show err+  EventEvaluationSuccess -> "EvaluationSuccess"   EventThrowToUnmasked a ->     "ThrowToUnmasked " ++ ppLabelled ppIOSimThreadId a   EventThreadForked a ->

@@ -59,1500 +59,1565 @@ import Data.Set qualified as Set import Data.Time (UTCTime (..), fromGregorian) -import Control.Exception (NonTermination (..), assert, throw)-import Control.Monad (join, when)-import Control.Monad.ST.Lazy-import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)-import Data.STRef.Lazy--import Control.Concurrent.Class.MonadSTM.TMVar-import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)-import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)-import Control.Monad.Class.MonadSTM hiding (STM)-import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))-import Control.Monad.Class.MonadThrow as MonadThrow-import Control.Monad.Class.MonadTime (NominalDiffTime)-import Control.Monad.Class.MonadTime qualified as Time-import Control.Monad.Class.MonadTime.SI qualified as SI-import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))--import Control.Monad.IOSim.InternalTypes-import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Time (..),-           Trace (SimTrace))-import Control.Monad.IOSim.Types (SimEvent)-import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)-import Control.Monad.IOSimPOR.Types-import Data.Coerce (Coercible, coerce)-import Data.Hashable------- Simulation interpreter-----data Thread s a = Thread {-    threadId      :: !IOSimThreadId,-    threadControl :: !(ThreadControl s a),-    threadStatus  :: !ThreadStatus,-    threadMasking :: !MaskingState,-    -- other threads blocked in a ThrowTo to us because we are or were masked-    threadThrowTo :: ![(SomeException, Labelled IOSimThreadId, VectorClock)],-    threadClockId :: !ClockId,-    threadLabel   :: Maybe ThreadLabel,-    threadNextTId :: !Int,-    threadStep    :: !Int,-    threadVClock  :: VectorClock,-    threadEffect  :: Effect,  -- in the current step-    threadRacy    :: !Bool-  }-  deriving Show--isThreadBlocked :: Thread s a -> Bool-isThreadBlocked t = case threadStatus t of-    ThreadBlocked {} -> True-    _                -> False--isThreadDone :: Thread s a -> Bool-isThreadDone t = case threadStatus t of-    ThreadDone -> True-    _          -> False--threadStepId :: Thread s a -> (IOSimThreadId, Int)-threadStepId Thread{ threadId, threadStep } = (threadId, threadStep)--isRacyThreadId :: IOSimThreadId -> Bool-isRacyThreadId (RacyThreadId _) = True-isRacyThreadId _                = True--isNotRacyThreadId :: IOSimThreadId -> Bool-isNotRacyThreadId (ThreadId _) = True-isNotRacyThreadId _            = False--bottomVClock :: VectorClock-bottomVClock = VectorClock Map.empty--insertVClock :: IOSimThreadId -> Int -> VectorClock -> VectorClock-insertVClock tid !step (VectorClock m) = VectorClock (Map.insert tid step m)--leastUpperBoundVClock :: VectorClock -> VectorClock -> VectorClock-leastUpperBoundVClock (VectorClock m) (VectorClock m') =-    VectorClock (Map.unionWith max m m')---- hbfVClock :: VectorClock -> VectorClock -> Bool--- hbfVClock (VectorClock m) (VectorClock m') = Map.isSubmapOfBy (<=) m m'--happensBeforeStep :: Step -- ^ an earlier step-                  -> Step -- ^ a later step-                  -> Bool-happensBeforeStep step step' =-       Just (stepStep step)-    <= Map.lookup (stepThreadId step)-                  (getVectorClock $ stepVClock step')--labelledTVarId :: TVar s a -> ST s (Labelled TVarId)-labelledTVarId TVar { tvarId, tvarLabel } = Labelled tvarId <$> readSTRef tvarLabel--labelledThreads :: Map IOSimThreadId (Thread s a) -> [Labelled IOSimThreadId]-labelledThreads threadMap =-    -- @Map.foldr'@ (and alikes) are not strict enough, to not retain the-    -- original thread map we need to evaluate the spine of the list.-    -- TODO: https://github.com/haskell/containers/issues/749-    Map.foldr'-      (\Thread { threadId, threadLabel } !acc -> Labelled threadId threadLabel : acc)-      [] threadMap----- | Timers mutable variables.  First one supports 'newTimeout' api, the second--- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one--- 'Control.Monad.Class.MonadTimer.SI.threadDelay'.----data TimerCompletionInfo s =-       Timer !(TVar s TimeoutState)-     -- ^ `newTimeout` timer.-     | TimerRegisterDelay !(TVar s Bool)-     -- ^ `registerDelay` timer.-     | TimerThreadDelay !IOSimThreadId !TimeoutId-     -- ^ `threadDelay` timer run by `IOSimThreadId` which was assigned the given-     -- `TimeoutId` (only used to report in a trace).-     | TimerTimeout !IOSimThreadId !TimeoutId !(TMVar (IOSim s) IOSimThreadId)-     -- ^ `timeout` timer run by `IOSimThreadId` which was assigned the given-     -- `TimeoutId` (only used to report in a trace).--instance Hashable a => Hashable (Down a)--type RunQueue   = HashPSQ (Down IOSimThreadId) (Down IOSimThreadId) ()-type Timeouts s = IntPSQ SI.Time (TimerCompletionInfo s)---- | Internal state.----data SimState s a = SimState {-       runqueue         :: !RunQueue,-       -- | All threads other than the currently running thread: both running-       -- and blocked threads.-       threads          :: !(Map IOSimThreadId (Thread s a)),-       -- | current time-       curTime          :: !SI.Time,-       -- | ordered list of timers and timeouts-       timers           :: !(Timeouts s),-       -- | timeout locks in order to synchronize the timeout handler and the-       -- main thread-       clocks           :: !(Map ClockId UTCTime),-       nextVid          :: !VarId,     -- ^ next unused 'TVarId'-       nextTmid         :: !TimeoutId,  -- ^ next unused 'TimeoutId'-       nextUniq         :: !(Unique s), -- ^ next unused @'Unique' s@-       -- | previous steps (which we may race with).-       -- Note this is *lazy*, so that we don't compute races we will not reverse.-       races            :: Races,-       -- | control the schedule followed, and initial value-       control          :: !ScheduleControl,-       control0         :: !ScheduleControl,-       -- | limit on the computation time allowed per scheduling step, for-       -- catching infinite loops etc-       perStepTimeLimit :: Maybe Int--     }--initialState :: SimState s a-initialState =-    SimState {-      runqueue = PSQ.empty,-      threads  = Map.empty,-      curTime  = SI.Time 0,-      timers   = IPSQ.empty,-      clocks   = Map.singleton (ClockId []) epoch1970,-      nextVid  = 0,-      nextTmid = TimeoutId 0,-      nextUniq = MkUnique 0,-      races    = noRaces,-      control  = ControlDefault,-      control0 = ControlDefault,-      perStepTimeLimit = Nothing-    }-  where-    epoch1970 = UTCTime (fromGregorian 1970 1 1) 0--invariant :: Maybe (Thread s a) -> SimState s a -> x -> x--invariant (Just running) simstate@SimState{runqueue,threads,clocks} =-    assert (not (isThreadBlocked running))-  . assert (threadId running `Map.notMember` threads)-  . assert (not (Down (threadId running) `PSQ.member` runqueue))-  . assert (threadClockId running `Map.member` clocks)-  . invariant Nothing simstate--invariant Nothing SimState{runqueue,threads,clocks} =-    assert (PSQ.fold' (\(Down tid) _ _ a -> tid `Map.member` threads && a) True runqueue)-  . assert (and [ (isThreadBlocked t || isThreadDone t) == not (Down (threadId t) `PSQ.member` runqueue)-                | t <- Map.elems threads ])-  . assert (and [ threadClockId t `Map.member` clocks-                | t <- Map.elems threads ])---- | Interpret the simulation monotonic time as a 'NominalDiffTime' since--- the start.-timeSinceEpoch :: SI.Time -> NominalDiffTime-timeSinceEpoch (SI.Time t) = fromRational (toRational t)----- | Insert thread into `runqueue`.----insertThread :: Thread s a -> RunQueue -> RunQueue-insertThread Thread { threadId } = PSQ.insert (Down threadId) (Down threadId) ()----- | Schedule / run a thread.----schedule :: forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)-schedule thread@Thread{-           threadId      = tid,-           threadControl = ThreadControl action ctl,-           threadMasking = maskst,-           threadLabel   = tlbl,-           threadStep    = tstep,-           threadVClock  = vClock,-           threadEffect  = effect-         }-         simstate@SimState {-           runqueue,-           threads,-           timers,-           clocks,-           nextVid, nextTmid, nextUniq,-           curTime  = time,-           control,-           perStepTimeLimit-         }--  | controlTargets (tid,tstep) control =-      -- The next step is to be delayed according to the-      -- specified schedule. Switch to following the schedule.-      SimPORTrace time tid tstep tlbl (EventFollowControl control) <$>-      schedule thread simstate{ control = followControl control }--  | not $ controlFollows (tid,tstep) control =-      -- the control says this is not the next step to-      -- follow. We should be at the beginning of a step;-      -- we put the present thread to sleep and reschedule-      -- the correct thread.-      -- The assertion says that the only effect that may have-      -- happened in the start of a thread is us waking up.-      ( SimPORTrace time tid tstep tlbl (EventAwaitControl (tid,tstep) control)-      . SimPORTrace time tid tstep tlbl (EventDeschedule Sleep)-      ) <$> deschedule Sleep thread simstate--  | otherwise =-  invariant (Just thread) simstate $-  case control of-    ControlFollow (s:_) _-      -> fmap (SimPORTrace time tid tstep tlbl (EventPerformAction (tid,tstep)))-    _ -> id-  $-  -- The next line forces the evaluation of action, which should be unevaluated up to-  -- this point. This is where we actually *run* user code.-  case maybe Just unsafeTimeout perStepTimeLimit action of-   Nothing -> return TraceLoop-   Just _  -> case action of--    Return x -> case ctl of-      MainFrame ->-        -- the main thread is done, so we're done-        -- even if other threads are still running-        return $ SimPORTrace time tid tstep tlbl EventThreadFinished-               $ traceFinalRacesFound simstate-               $ TraceMainReturn time (Labelled tid tlbl) x-                                      ( labelledThreads-                                      . Map.filter (not . isThreadDone)-                                      $ threads-                                      )--      ForkFrame -> do-        -- this thread is done-        let thread' = thread-        !trace <- deschedule Terminated thread' simstate-        return $ SimPORTrace time tid tstep tlbl EventThreadFinished-               $ SimPORTrace time tid tstep tlbl (EventDeschedule Terminated)-               $ trace--      MaskFrame k maskst' ctl' -> do-        -- pop the control stack, restore thread-local state-        let thread' = thread { threadControl = ThreadControl (k x) ctl'-                             , threadMasking = maskst'-                             }-        -- but if we're now unmasked, check for any pending async exceptions-        !trace <- deschedule Interruptable thread' simstate-        return $ SimPORTrace time tid tstep tlbl (EventMask maskst')-               $ SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable)-               $ trace--      CatchFrame _handler k ctl' -> do-        -- pop the control stack and continue-        let thread' = thread { threadControl = ThreadControl (k x) ctl' }-        schedule thread' simstate--      TimeoutFrame tmid lock k ctl' -> do-        -- It could happen that the timeout action finished at the same time-        -- as the timeout expired, this will be a race condition. That's why-        -- we have the locks to solve this.--        -- We cannot do `tryPutMVar` in the `treadAction`, because we need to-        -- know if the `lock` is empty right now when we still have the frame.-        v <- execTryPutTMVar lock undefined-        let -- Kill the assassin throwing thread then unmask exceptions and-            -- carry on the continuation-            threadAction :: IOSim s ()-            threadAction =-              if v then unsafeUnregisterTimeout tmid-                   else atomically (takeTMVar lock) >>= killThread--            thread' =-              thread { threadControl =-                        ThreadControl (case threadAction of-                                        IOSim k' -> k' (\() -> k (Just x)))-                                      ctl'-                     }-        schedule thread' simstate--      DelayFrame tmid k ctl' -> do-        let thread' = thread { threadControl = ThreadControl k ctl' }-            timers' = IPSQ.delete (coerce tmid) timers-        schedule thread' simstate { timers = timers' }--    Throw e -> case unwindControlStack e thread timers of-      -- Found a CatchFrame-      (Right thread0@Thread { threadMasking = maskst' }, timers'') -> do-        -- We found a suitable exception handler, continue with that-        -- We record a step, in case there is no exception handler on replay.-        let (thread', eff)  = stepThread thread0-            control'        = advanceControl (threadStepId thread0) control-            races'          = updateRaces thread0 simstate-        trace <- schedule thread' simstate{ races = races',-                                            control = control',-                                            timers = timers'' }-        return (SimPORTrace time tid tstep tlbl (EventThrow e) $-                SimPORTrace time tid tstep tlbl (EventMask maskst') $-                SimPORTrace time tid tstep tlbl (EventEffect vClock eff) $-                SimPORTrace time tid tstep tlbl (EventRaces races')-                trace)--      (Left isMain, timers'')-        -- We unwound and did not find any suitable exception handler, so we-        -- have an unhandled exception at the top level of the thread.-        | isMain -> do-          let thread' = thread { threadStatus = ThreadDone }-          -- An unhandled exception in the main thread terminates the program-          return (SimPORTrace time tid tstep tlbl (EventThrow e) $-                  SimPORTrace time tid tstep tlbl (EventThreadUnhandled e) $-                  traceFinalRacesFound simstate { threads = Map.insert tid thread' threads } $-                  TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))--        | otherwise -> do-          -- An unhandled exception in any other thread terminates the thread-          let terminated = Terminated-          !trace <- deschedule terminated thread simstate { timers = timers'' }-          return $ SimPORTrace time tid tstep tlbl (EventThrow e)-                 $ SimPORTrace time tid tstep tlbl (EventThreadUnhandled e)-                 $ SimPORTrace time tid tstep tlbl (EventDeschedule terminated)-                 $ trace--    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 -> do-      mbWHNF <- unsafeIOToST $ try $ evaluate expr-      case mbWHNF of-        Left e -> do-          -- schedule this thread to immediately raise the exception-          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }-          schedule thread' simstate-        Right whnf -> do-          -- continue with the resulting WHNF-          let thread' = thread { threadControl = ThreadControl (k whnf) ctl }-          schedule thread' simstate--    Say msg k -> do-      let thread' = thread { threadControl = ThreadControl k ctl }-      trace <- schedule thread' simstate-      return (SimPORTrace time tid tstep tlbl (EventSay msg) trace)--    Output x k -> do-      let thread' = thread { threadControl = ThreadControl k ctl }-      trace <- schedule thread' simstate-      return (SimPORTrace time tid tstep tlbl (EventLog x) trace)--    LiftST st k -> do-      x <- strictToLazyST st-      let thread' = thread { threadControl = ThreadControl (k x) ctl }-      schedule thread' simstate--    GetMonoTime k -> do-      let thread' = thread { threadControl = ThreadControl (k time) ctl }-      schedule thread' simstate--    GetWallTime k -> do-      let clockid  = threadClockId thread-          clockoff = clocks Map.! clockid-          walltime = timeSinceEpoch time `Time.addUTCTime` clockoff-          thread'  = thread { threadControl = ThreadControl (k walltime) ctl }-      schedule thread' simstate--    SetWallTime walltime' k -> do-      let clockid   = threadClockId thread-          clockoff  = clocks Map.! clockid-          walltime  = timeSinceEpoch time `Time.addUTCTime` clockoff-          clockoff' = (walltime' `Time.diffUTCTime` walltime) `Time.addUTCTime` clockoff-          thread'   = thread { threadControl = ThreadControl k ctl }-          simstate' = simstate { clocks = Map.insert clockid clockoff' clocks }-      schedule thread' simstate'--    UnshareClock k -> do-      let clockid   = threadClockId thread-          clockoff  = clocks Map.! clockid-          clockid'  = let ThreadId i = tid in ClockId i -- reuse the thread id-          thread'   = thread { threadControl = ThreadControl k ctl-                             , threadClockId = clockid' }-          simstate' = simstate { clocks = Map.insert clockid' clockoff clocks }-      schedule thread' simstate'--    -- This case is guarded by checks in 'timeout' itself.-    StartTimeout d _ _ | d <= 0 ->-      error "schedule: StartTimeout: Impossible happened"--    StartTimeout d action' k -> do-      lock <- TMVar <$> execNewTVar (TMVarId nextVid) (Just $! "lock-" ++ show nextTmid) Nothing-      let expiry    = d `addTime` time-          timers'   = IPSQ.insert (coerce nextTmid) expiry (TimerTimeout tid nextTmid lock) timers-          thread'   = thread { threadControl =-                                 ThreadControl action'-                                               (TimeoutFrame nextTmid lock k ctl)-                              }-      trace <- deschedule Yield thread' simstate { timers   = timers'-                                                  , nextTmid = succ nextTmid }-      return (SimPORTrace time tid tstep tlbl (EventTimeoutCreated nextTmid tid expiry) trace)--    UnregisterTimeout tmid k -> do-      let thread' = thread { threadControl = ThreadControl k ctl }-      schedule thread' simstate { timers = IPSQ.delete (coerce tmid) timers }--    RegisterDelay d k | d < 0 -> do-      tvar <- execNewTVar (TVarId nextVid)-                          (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")-                          True-      modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)-      let !expiry  = d `addTime` time-          !thread' = thread { threadControl = ThreadControl (k tvar) ctl }-      trace <- schedule thread' simstate { nextVid = succ nextVid }-      return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) $-              SimPORTrace time tid tstep tlbl (EventRegisterDelayFired nextTmid) $-              trace)--    RegisterDelay d k -> do-      tvar <- execNewTVar (TVarId nextVid)-                          (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")-                          False-      modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)-      let !expiry  = d `addTime` time-          !timers' = IPSQ.insert (coerce nextTmid) expiry (TimerRegisterDelay tvar) timers-          !thread' = thread { threadControl = ThreadControl (k tvar) ctl }-      trace <- schedule thread' simstate { timers   = timers'-                                         , nextVid  = succ nextVid-                                         , nextTmid = succ nextTmid }-      return (SimPORTrace time tid tstep tlbl-                (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) trace)--    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 }-      trace <- schedule thread' simstate'-      return (SimPORTrace time tid tstep tlbl (EventThreadDelay nextTmid expiry) $-              SimPORTrace time tid tstep tlbl (EventThreadDelayFired nextTmid) $-              trace)--    ThreadDelay d k -> do-      let expiry  = d `addTime` time-          timers' = IPSQ.insert (coerce nextTmid) expiry (TimerThreadDelay tid nextTmid) timers-          thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }-      trace <- deschedule (Blocked BlockedOnDelay) thread'-                          simstate { timers   = timers',-                                     nextTmid = succ nextTmid }-      return (SimPORTrace time tid tstep tlbl (EventThreadDelay nextTmid expiry) trace)--    -- 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 -> do-      let t       = NegativeTimeout nextTmid-          expiry  = d `addTime` time-          thread' = thread { threadControl = ThreadControl (k t) ctl }-      trace <- schedule thread' simstate { nextTmid = succ nextTmid }-      return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) $-              SimPORTrace time tid tstep tlbl (EventTimerCancelled nextTmid) $-              trace)--    NewTimeout d k -> do-      tvar  <- execNewTVar (TVarId nextVid)-                           (Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")-                           TimeoutPending-      modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)-      let expiry  = d `addTime` time-          t       = Timeout tvar nextTmid-          timers' = IPSQ.insert (coerce nextTmid) expiry (Timer tvar) timers-          thread' = thread { threadControl = ThreadControl (k t) ctl }-      trace <- schedule thread' simstate { timers   = timers'-                                         , nextVid  = succ (succ nextVid)-                                         , nextTmid = succ nextTmid }-      return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) trace)--    CancelTimeout (Timeout tvar tmid) k -> do-      let timers' = IPSQ.delete (coerce tmid) timers-      written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)-      written' <- mapM someTVarToLabelled written-      (wakeup, wokeby) <- threadsUnblockedByWrites written-      mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written-      let effect' = effect-                 <> writeEffects written'-                 <> wakeupEffects wakeup-          thread' = thread { threadControl = ThreadControl k ctl-                           , threadEffect  = effect'-                           }-          (unblocked,-           simstate') = unblockThreads False vClock wakeup simstate-      modifySTRef (tvarVClock tvar)  (leastUpperBoundVClock vClock)-      !trace <- deschedule Yield thread' simstate' { timers = timers' }-      return $ SimPORTrace time tid tstep tlbl (EventTimerCancelled tmid)-             $ traceMany-                 -- TODO: step-                 [ (time, tid', (-1), tlbl', EventTxWakeup vids)-                 | tid' <- unblocked-                 , let tlbl' = lookupThreadLabel tid' threads-                 , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]-             $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)-             $ trace--    -- cancelling a negative timer is a no-op-    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 -> do-      let nextTId = threadNextTId thread-          tid' | threadRacy thread = setRacyThread $ childThreadId tid nextTId-               | otherwise         = childThreadId tid nextTId-          thread'  = thread { threadControl = ThreadControl (k tid') ctl,-                              threadNextTId = nextTId + 1,-                              threadEffect  = effect-                                           <> forkEffect tid'-                              }-          thread'' = Thread { threadId      = tid'-                            , threadControl = ThreadControl (runIOSim a)-                                                            ForkFrame-                            , threadStatus  = ThreadRunning-                            , threadMasking = threadMasking thread-                            , threadThrowTo = []-                            , threadClockId = threadClockId thread-                            , threadLabel   = Nothing-                            , threadNextTId = 1-                            , threadStep    = 0-                            , threadVClock  = insertVClock tid' 0-                                            $ vClock-                            , threadEffect  = mempty-                            , threadRacy    = threadRacy thread-                            }-          threads' = Map.insert tid' thread'' threads-      -- A newly forked thread may have a higher priority, so we deschedule this one.-      !trace <- deschedule Yield thread'-                  simstate { runqueue = insertThread thread'' runqueue-                           , threads  = threads' }-      return $ SimPORTrace time tid tstep tlbl (EventThreadForked tid')-             $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)-             $ trace--    Atomically a k -> execAtomically time tid tlbl nextVid (runSTM a) $ \res ->-      case res of-        StmTxCommitted x written read created-                         tvarDynamicTraces tvarStringTraces nextVid' -> do-          (wakeup, wokeby) <- threadsUnblockedByWrites written-          mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written-          vClockRead <- leastUpperBoundTVarVClocks read-          read' <- mapM someTVarToLabelled read-          written' <- mapM someTVarToLabelled written-          let vClock'     = vClock `leastUpperBoundVClock` vClockRead-              effect'     = effect-                         <> readEffects read'-                         <> writeEffects written'-                         <> wakeupEffects unblocked-              thread'     = thread { threadControl = ThreadControl (k x) ctl,-                                     threadVClock  = vClock',-                                     threadEffect  = effect' }-              (unblocked,-               simstate') = unblockThreads True vClock' wakeup simstate-          sequence_ [ modifySTRef (tvarVClock r) (leastUpperBoundVClock vClock')-                    | SomeTVar r <- created ++ written ]-          written'' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written-          created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created-          -- We deschedule a thread after a transaction... another may have woken up.-          !trace <- deschedule Yield thread' simstate' { nextVid  = nextVid' }-          return $-            SimPORTrace time tid tstep tlbl (EventTxCommitted written'' created' (Just effect')) $-            traceMany-              [ (time, tid', (-1), tlbl', EventTxWakeup vids')-              | tid' <- unblocked-              , let tlbl' = lookupThreadLabel tid' threads-              , let Just vids' = Set.toList <$> Map.lookup tid' wokeby ] $-            traceMany-              [ (time, tid, tstep, tlbl, EventLog tr)-              | tr <- tvarDynamicTraces-              ] $-            traceMany-              [ (time, tid, tstep, tlbl, EventSay str)-              | str <- tvarStringTraces-              ] $-            SimPORTrace time tid tstep tlbl (EventUnblocked unblocked) $-            SimPORTrace time tid tstep tlbl (EventDeschedule Yield) $-              trace--        StmTxAborted read e -> do-          -- schedule this thread to immediately raise the exception-          vClockRead <- leastUpperBoundTVarVClocks read-          read' <- mapM someTVarToLabelled read-          let effect' = effect <> readEffects read'-              thread' = thread { threadControl = ThreadControl (Throw e) ctl,-                                 threadVClock  = vClock `leastUpperBoundVClock` vClockRead,-                                 threadEffect  = effect' }-          trace <- schedule thread' simstate-          return $ SimPORTrace time tid tstep tlbl (EventTxAborted (Just effect'))-                 $ trace--        StmTxBlocked read -> do-          mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read-          vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read-          vClockRead <- leastUpperBoundTVarVClocks read-          read' <- mapM someTVarToLabelled read-          let effect' = effect <> readEffects read'-              thread' = thread { threadVClock  = vClock `leastUpperBoundVClock` vClockRead,-                                 threadEffect  = effect' }-          !trace <- deschedule (Blocked BlockedOnSTM) thread' simstate-          return $ SimPORTrace time tid tstep tlbl (EventTxBlocked vids (Just effect'))-                 $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnSTM))-                 $ trace--    GetThreadId k -> do-      let thread' = thread { threadControl = ThreadControl (k tid) ctl }-      schedule thread' simstate--    LabelThread tid' l k | tid' == tid -> do-      let thread' = thread { threadControl = ThreadControl k ctl-                           , threadLabel   = Just l }-      schedule thread' simstate--    GetThreadLabel tid' k -> do-      let tlbl' | tid' == tid = tlbl-                | otherwise   = tid' `Map.lookup` threads-                            >>= threadLabel-          thread' = thread { threadControl = ThreadControl (k tlbl') ctl }-      schedule thread' simstate--    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' }--    ExploreRaces k -> do-      let thread'  = thread { threadControl = ThreadControl k ctl-                            , threadRacy    = True }-      schedule thread' simstate--    Fix f k -> do-      r <- newSTRef (throw NonTermination)-      x <- unsafeInterleaveST $ readSTRef r-      let k' = unIOSim (f x) $ \x' ->-                  LiftST (lazyToStrictST (writeSTRef r x')) (\() -> k x')-          thread' = thread { threadControl = ThreadControl k' ctl }-      schedule thread' simstate--    GetMaskState k -> do-      let thread' = thread { threadControl = ThreadControl (k maskst) ctl }-      schedule thread' simstate--    SetMaskState maskst' action' k -> do-      let thread' = thread { threadControl = ThreadControl-                                               (runIOSim action')-                                               (MaskFrame k maskst ctl)-                           , threadMasking = maskst' }-      trace <--        case maskst' of-          -- If we're now unmasked then check for any pending async exceptions-          Unmasked -> SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable)-                  <$> deschedule Interruptable thread' simstate-          _        -> schedule                 thread' simstate-      return $ SimPORTrace time tid tstep tlbl (EventMask maskst')-             $ trace--    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-                           , threadEffect  = effect-                           }-      trace <- schedule thread' simstate-      return (SimPORTrace time tid tstep tlbl (EventThrowTo e tid) trace)--    ThrowTo e tid' k -> do-      let thread'    = thread { threadControl = ThreadControl k ctl,-                                threadEffect  = effect <> throwToEffect tid'-                                                       <> wakeUpEffect,-                                threadVClock  = vClock `leastUpperBoundVClock` vClockTgt-                              }-          (vClockTgt,-           wakeUpEffect,-           willBlock) = (threadVClock t,-                         if isThreadBlocked t then wakeupEffects [tid'] else mempty,-                         not (threadInterruptible t || isThreadDone t))-            where Just t = Map.lookup tid' threads--      if willBlock-        then do-          -- The target thread has async exceptions masked so we add the-          -- exception and the source thread id to the pending async exceptions.-          let adjustTarget t =-                t { threadThrowTo = (e, Labelled tid tlbl, vClock) : threadThrowTo t }-              threads'       = Map.adjust adjustTarget tid' threads-          trace <- deschedule (Blocked BlockedOnThrowTo) thread' simstate { threads = threads' }-          return $ SimPORTrace time tid tstep tlbl (EventThrowTo e tid')-                 $ SimPORTrace time tid tstep tlbl EventThrowToBlocked-                 $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnThrowTo))-                 $ trace-        else do-          -- The target thread has async exceptions unmasked, or is masked but-          -- is blocked (and all blocking operations are interruptible) then we-          -- raise the exception in that thread immediately. This will either-          -- cause it to terminate or enter an exception handler.-          -- In the meantime the thread masks new async exceptions. This will-          -- be resolved if the thread terminates or if it leaves the exception-          -- handler (when restoring the masking state would trigger the any-          -- new pending async exception).-          let adjustTarget t@Thread{ threadControl = ThreadControl _ ctl',-                                     threadVClock  = vClock' } =-                t { threadControl = ThreadControl (Throw e) ctl'-                  , threadStatus  = if isThreadDone t-                                    then threadStatus t-                                    else ThreadRunning-                  , threadVClock  = vClock' `leastUpperBoundVClock` vClock }-              (_unblocked, simstate'@SimState { threads = threads' }) = unblockThreads False vClock [tid'] simstate-              threads''  = Map.adjust adjustTarget tid' threads'-              simstate'' = simstate' { threads = threads'' }--          -- We yield at this point because the target thread may be higher-          -- priority, so this should be a step for race detection.-          trace <- deschedule Yield thread' simstate''-          return $ SimPORTrace time tid tstep tlbl (EventThrowTo e tid')-                 $ trace--    -- intentionally a no-op (at least for now)-    YieldSim k -> do-      let thread' = thread { threadControl = ThreadControl k ctl }-      schedule thread' simstate--    NewUnique k -> do-      let thread'   = thread{ threadControl = ThreadControl (k nextUniq) ctl }-          n         = unMkUnique nextUniq-          simstate' = simstate{ nextUniq = MkUnique (n + 1) }-      SimPORTrace time tid tstep tlbl (EventUniqueCreated n)-        <$> schedule thread' simstate'---threadInterruptible :: Thread s a -> Bool-threadInterruptible thread =-    case threadMasking thread of-      Unmasked                   -> True-      MaskedInterruptible-        | isThreadBlocked thread -> True  -- blocking operations are interruptible-        | otherwise              -> False-      MaskedUninterruptible      -> False----- | Deschedule a thread.------ A thread is descheduled, which marks a boundary of a `Step` when:------ * forking a new thread--- * thread termination--- * setting the masking state to interruptible--- * popping masking frame (which resets masking state)--- * starting or cancelling a timeout--- * thread delays--- * on committed or blocked, but not aborted STM transactions--- * on blocking or non-blocking `throwTo`--- * unhandled exception in a (non-main) thread----deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)--deschedule Yield thread@Thread { threadId     = tid,-                                 threadStep   = tstep,-                                 threadLabel  = tlbl,-                                 threadVClock = vClock }-                 simstate@SimState{runqueue,-                                   threads,-                                   curTime  = time,-                                   control } =--    -- We don't interrupt runnable threads anywhere else.-    -- We do it here by inserting the current thread into the runqueue in priority order.--    let (thread', eff) = stepThread thread-        runqueue'      = insertThread thread' runqueue-        threads'       = Map.insert tid thread' threads-        control'       = advanceControl (threadStepId thread) control-        races'         = updateRaces thread simstate in--    SimPORTrace time tid tstep tlbl (EventEffect vClock eff) .-    SimPORTrace time tid tstep tlbl (EventRaces races') <$>-    reschedule simstate { runqueue = runqueue',-                          threads  = threads',-                          races    = races',-                          control  = control' }--deschedule Interruptable thread@Thread {-                           threadId      = tid,-                           threadStep    = tstep,-                           threadControl = ThreadControl _ ctl,-                           threadMasking = Unmasked,-                           threadThrowTo = (e, tid', vClock') : etids,-                           threadLabel   = tlbl,-                           threadVClock  = vClock,-                           threadEffect  = effect-                         }-                        simstate@SimState{ curTime = time, threads } = do--    let effect' = effect <> wakeupEffects unblocked-        -- We're unmasking, but there are pending blocked async exceptions.-        -- So immediately raise the exception and unblock the blocked thread-        -- if possible.-        thread' = thread { threadControl = ThreadControl (Throw e) ctl-                         , threadMasking = MaskedInterruptible-                         , threadThrowTo = etids-                         , threadVClock  = vClock `leastUpperBoundVClock` vClock'-                         , threadEffect  = effect'-                         }-        (unblocked,-         simstate') = unblockThreads False vClock [l_labelled tid'] simstate-    -- the thread is stepped when we Yield-    !trace <- deschedule Yield thread' simstate'-    return $ SimPORTrace time tid tstep tlbl (EventThrowToUnmasked tid')-           $ SimPORTrace time tid tstep tlbl (EventEffect vClock effect')-           -- TODO: step-           $ traceMany [ (time, tid'', (-1), tlbl'', EventThrowToWakeup)-                       | tid'' <- unblocked-                       , let tlbl'' = lookupThreadLabel tid'' threads ]-           $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)-             trace--deschedule Interruptable thread@Thread{threadId     = tid,-                                       threadStep   = tstep,-                                       threadLabel  = tlbl,-                                       threadVClock = vClock}-                         simstate@SimState{ control,-                                            curTime = time } =-    -- Either masked or unmasked but no pending async exceptions.-    -- Either way, just carry on.-    -- Record a step, though, in case on replay there is an async exception.-    let (thread', eff) = stepThread thread-        races' = updateRaces thread simstate in--    SimPORTrace time tid tstep tlbl (EventEffect vClock eff) .-    SimPORTrace time tid tstep tlbl (EventRaces races') <$>-    schedule thread'-             simstate{ races   = races',-                       control = advanceControl (threadStepId thread) control }--deschedule (Blocked _blockedReason) thread@Thread { threadId      = tid-                                                  , threadStep    = tstep-                                                  , threadLabel   = tlbl-                                                  , threadThrowTo = _ : _-                                                  , threadMasking = maskst-                                                  , threadEffect  = effect }-                                    simstate@SimState{ curTime = time }-    | maskst /= MaskedUninterruptible =-    -- We're doing a blocking operation, which is an interrupt point even if-    -- we have async exceptions masked, and there are pending blocked async-    -- exceptions. So immediately raise the exception and unblock the blocked-    -- thread if possible.-    SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable) <$>-      deschedule Interruptable thread { threadMasking = Unmasked } simstate--deschedule (Blocked blockedReason) thread@Thread{ threadId     = tid,-                                                  threadStep   = tstep,-                                                  threadLabel  = tlbl,-                                                  threadVClock = vClock}-                                   simstate@SimState{ threads,-                                                      curTime = time,-                                                      control } =-    let thread1        = thread { threadStatus = ThreadBlocked blockedReason }-        (thread', eff) = stepThread thread1-        threads'       = Map.insert (threadId thread') thread' threads-        races'         = updateRaces thread1 simstate in--    SimPORTrace time tid tstep tlbl (EventEffect vClock eff) .-    SimPORTrace time tid tstep tlbl (EventRaces races') <$>-    reschedule simstate { threads = threads',-                          races   = races',-                          control = advanceControl (threadStepId thread1) control }--deschedule Terminated thread@Thread { threadId = tid, threadStep = tstep, threadLabel = tlbl,-                                      threadVClock = vClock, threadEffect = effect }-                               simstate@SimState{ curTime = time, control } = do-    -- This thread is done. If there are other threads blocked in a-    -- ThrowTo targeted at this thread then we can wake them up now.-    let wakeup         = map (\(_,tid',_) -> l_labelled tid') (reverse (threadThrowTo thread))-        (unblocked,-         simstate'@SimState{threads}) =-                      unblockThreads False vClock wakeup simstate-        effect'        = effect <> wakeupEffects unblocked-        (thread', eff) = stepThread $ thread { threadStatus = ThreadDone,-                                               threadEffect = effect' }-        threads'       = Map.insert tid thread' threads-        races'         = threadTerminatesRaces tid $ updateRaces thread { threadEffect = effect' } simstate-    -- We must keep terminated threads in the state to preserve their vector clocks,-    -- which matters when other threads throwTo them.-    !trace <- reschedule simstate' { races   = races',-                                     control = advanceControl (threadStepId thread) control,-                                     threads = threads' }-    return $ traceMany-               -- TODO: step-               [ (time, tid', (-1), tlbl', EventThrowToWakeup)-               | tid' <- unblocked-               , let tlbl' = lookupThreadLabel tid' threads ]-          $ SimPORTrace time tid tstep tlbl (EventEffect vClock eff)-          $ SimPORTrace time tid tstep tlbl (EventRaces races')-            trace--deschedule Sleep thread@Thread { threadId = tid , threadEffect = effect' }-                 simstate@SimState{runqueue, threads} =--    -- Schedule control says we should run a different thread. Put-    -- this one to sleep without recording a step.--    let runqueue' = insertThread thread runqueue-        threads'  = Map.insert tid thread threads in-    reschedule simstate { runqueue = runqueue', threads  = threads' }----- Choose the next thread to run.-reschedule :: SimState s a -> ST s (SimTrace a)---- If we are following a controlled schedule, just do that.-reschedule simstate@SimState { runqueue, control = control@(ControlFollow ((tid,_):_) _) }-                             | not (Down tid `PSQ.member` runqueue) =-    return (Trace.Nil (InternalError ("assertion failure: " ++ ppIOSimThreadId tid ++ " not runnable")))--reschedule simstate@SimState { threads, control = control@(ControlFollow ((tid,_):_) _) }-                             | not (tid `Map.member` threads) =-    return (Trace.Nil (InternalError ("assertion failure: " ++ ppIOSimThreadId tid ++ " not in threads")))--reschedule simstate@SimState { runqueue, threads,-                               control = control@(ControlFollow ((tid,tstep):_) _),-                               curTime = time } =-    fmap (SimPORTrace time tid tstep Nothing (EventReschedule control)) $-    invariant Nothing simstate $-    let thread = threads Map.! tid in-    assert (threadId thread == tid) $-    --assert (threadStep thread == tstep) $-    if threadStep thread /= tstep then-      error $ "Thread step out of sync\n"-           ++ "  runqueue:    "++show runqueue++"\n"-           ++ "  follows:     "++show tid++", step "++show tstep++"\n"-           ++ "  actual step: "++show (threadStep thread)++"\n"-           ++ "Thread:\n" ++ show thread ++ "\n"-    else-    schedule thread simstate { runqueue = PSQ.delete (Down tid) runqueue-                             , threads  = Map.delete tid threads }---- When there is no current running thread but the runqueue is non-empty then--- schedule the next one to run.-reschedule simstate@SimState{ runqueue, threads }-    | Just (Down !tid, _, _, runqueue') <- PSQ.minView runqueue =-    invariant Nothing simstate $--    let thread = threads Map.! tid in-    schedule thread simstate { runqueue = runqueue'-                             , threads  = Map.delete tid threads }---- 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, races } =-    invariant Nothing simstate $--    -- time is moving on-    --Debug.trace ("Rescheduling at "++show time++", "++-      --show (length (concatMap stepInfoRaces (activeRaces races++completeRaces races)))++" races") $--    -- important to get all events that expire at this time-    case removeMinimums timers of-      Nothing -> return (traceFinalRacesFound simstate $-                         TraceDeadlock time (labelledThreads threads))--      Just (tmids, time', fired, timers') -> assert (time' >= time) $ do--        -- Reuse the STM functionality here to write all the timer TVars.-        -- Simplify to a special case that only reads and writes TVars.-        written <- execAtomically' (runSTM $ mapM_ timeoutAction fired)-        !ds  <- traverse (\(SomeTVar tvar) -> do-                            tr <- traceTVarST tvar False-                            !_ <- commitTVar tvar-                            return tr) written-        (wakeupSTM, wokeby) <- threadsUnblockedByWrites written-        mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written--        let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ]-            -- TODO: the vector clock below cannot be right, can it?-            !simstate'        =-                snd . unblockThreads False bottomVClock (fst `fmap` wakeupThreadDelay)-              . snd . unblockThreads True  bottomVClock wakeupSTM-              $ simstate--            -- For each 'timeout' action where the timeout has fired, start a-            -- new thread to execute throwTo to interrupt the action.-            !timeoutExpired = [ (tid, tmid, lock)-                              | TimerTimeout tid tmid lock <- fired ]--        -- all open races will be completed and reported at this time-        !simstate'' <- forkTimeoutInterruptThreads timeoutExpired-                                                   simstate' { races = noRaces }-        !trace <- reschedule simstate'' { curTime = time'-                                        , timers  = timers' }-        let traceEntries =-                     [ ( time', ThreadId [-1], -1, Just "timer"-                       , EventTimerFired tmid)-                     | (tmid, Timer _) <- zip tmids fired ]-                  ++ [ ( time', ThreadId [-1], -1, Just "register delay timer"-                       , EventRegisterDelayFired tmid)-                     | (tmid, TimerRegisterDelay _) <- zip tmids fired ]-                  ++ [ (time', ThreadId [-1], -1, Just "register delay timer", EventLog (toDyn a))-                     | TraceValue { traceDynamic = Just a } <- ds ]-                  ++ [ (time', ThreadId [-1], -1, Just "register delay timer", EventSay a)-                     | TraceValue { traceString = Just a } <- ds ]-                  ++ [ (time', tid', -1, tlbl', EventTxWakeup vids)-                     | tid' <- wakeupSTM-                     , let tlbl' = lookupThreadLabel tid' threads-                     , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]-                  ++ [ ( time', tid, -1, Just "thread delay timer"-                       , EventThreadDelayFired tmid)-                     | (tid, tmid) <- wakeupThreadDelay ]-                  ++ [ ( time', tid, -1, Just "timeout timer"-                       , EventTimeoutFired tmid)-                     | (tid, tmid, _) <- timeoutExpired ]-                  ++ [ ( time', tid, -1, Just "forked thread"-                       , EventThreadForked tid)-                     | (tid, _, _) <- timeoutExpired ]--        return $-          traceFinalRacesFound simstate $-          traceMany traceEntries trace-  where-    timeoutAction (Timer var) = do-      x <- readTVar var-      case x of-        TimeoutPending   -> writeTVar var TimeoutFired-        TimeoutFired     -> error "MonadTimer(Sim): invariant violation"-        TimeoutCancelled -> return ()-    timeoutAction (TimerRegisterDelay var) = writeTVar var True-    timeoutAction (TimerThreadDelay _ _)   = return ()-    timeoutAction (TimerTimeout _ _ _)     = return ()--unblockThreads :: forall s a.-                  Bool -- ^ `True` if we are blocked on STM-               -> VectorClock-               -> [IOSimThreadId]-               -> SimState s a-               -> ([IOSimThreadId], SimState s a)-unblockThreads !onlySTM vClock wakeup simstate@SimState {runqueue, threads} =-    -- To preserve our invariants (that threadBlocked is correct)-    -- we update the runqueue and threads together here-    ( unblockedIds-    , simstate { runqueue = foldr insertThread runqueue unblocked,-                 threads  = threads'-               })-  where-    -- can only unblock if the thread exists and is blocked (not running)-    unblocked :: [Thread s a]-    !unblocked = [ thread-                 | tid <- wakeup-                 , thread <--                     case Map.lookup tid threads of-                       Just   Thread { threadStatus = ThreadRunning }-                         -> [ ]-                       Just t@Thread { threadStatus = ThreadBlocked BlockedOnSTM }-                         -> [t]-                       Just t@Thread { threadStatus = ThreadBlocked _ }-                         | onlySTM-                         -> [ ]-                         | otherwise-                         -> [t]-                       Just   Thread { threadStatus = ThreadDone } -> [ ]-                       Nothing -> [ ]-                 ]--    unblockedIds :: [IOSimThreadId]-    !unblockedIds = map threadId unblocked--    -- and in which case we mark them as now running-    !threads'  = List.foldl'-                   (flip (Map.adjust-                     (\t -> t { threadStatus = ThreadRunning,-                                threadVClock = vClock `leastUpperBoundVClock` threadVClock t })))-                   threads unblockedIds---- | This function receives a list of TimerTimeout values that represent threads--- for which the timeout expired and kills the running thread if needed.------ This function is responsible for the second part of the race condition issue--- and relates to the 'schedule's 'TimeoutFrame' locking explanation (here is--- where the assassin threads are launched. So, as explained previously, at this--- point in code, the timeout expired so we need to interrupt the running--- thread. If the running thread finished at the same time the timeout expired--- we have a race condition. To deal with this race condition what we do is--- look at the lock value. If it is 'Locked' this means that the running thread--- already finished (or won the race) so we can safely do nothing. Otherwise, if--- the lock value is 'NotLocked' we need to acquire the lock and launch an--- assassin thread that is going to interrupt the running one. Note that we--- should run this interrupting thread in an unmasked state since it might--- receive a 'ThreadKilled' exception.----forkTimeoutInterruptThreads :: forall s a.-                               [(IOSimThreadId, TimeoutId, TMVar (IOSim s) IOSimThreadId)]-                            -> SimState s a-                            -> ST s (SimState s a)-forkTimeoutInterruptThreads timeoutExpired simState =-  foldlM (\st@SimState{ runqueue, threads }-           (t, TMVar lock)-          -> do-            v <- execReadTVar lock-            return $ case v of-              Nothing -> st { runqueue = insertThread t runqueue,-                              threads  = Map.insert (threadId t) t threads-                            }-              Just _  -> st-          )-          simState'-          throwToThread--  where-    -- we launch a thread responsible for throwing an AsyncCancelled exception-    -- to the thread which timeout expired-    throwToThread :: [(Thread s a, TMVar (IOSim s) IOSimThreadId)]--    (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired-      where-        fn :: SimState s a-           -> (IOSimThreadId, TimeoutId, TMVar (IOSim s) IOSimThreadId)-           -> (SimState s a, (Thread s a, TMVar (IOSim s) IOSimThreadId))-        fn state@SimState { threads } (tid, tmid, lock) =-          let t = case tid `Map.lookup` threads of-                    Just t' -> t'-                    Nothing -> error ("IOSimPOR: internal error: unknown thread " ++ show tid)-              nextId   = threadNextTId t-              tid'     = childThreadId tid nextId-           in ( state { threads = Map.insert tid t { threadNextTId = succ nextId } threads }-              , ( Thread { threadId      = tid',-                           threadControl =-                            ThreadControl-                              (runIOSim $ do-                                 mtid <- myThreadId-                                 v2 <- atomically $ tryPutTMVar lock mtid-                                 when v2 $-                                   throwTo tid (toException (TimeoutException tmid)))-                              ForkFrame,-                           threadStatus  = ThreadRunning,-                           threadMasking = Unmasked,-                           threadThrowTo = [],-                           threadClockId = threadClockId t,-                           threadLabel   = Just "timeout-forked-thread",-                           threadNextTId = 1,-                           threadStep    = 0,-                           threadVClock  = insertVClock tid' 0-                                         $ threadVClock t,-                           threadEffect  = mempty,-                           threadRacy    = threadRacy t-                         }-                , lock-                )-              )----- | Iterate through the control stack to find an enclosing exception handler--- of the right type, or unwind all the way to the top level for the thread.------ Also return if it's the main thread or a forked thread since we handle the--- cases differently.----unwindControlStack :: forall s a.-                      SomeException-                   -> Thread s a-                   -> Timeouts s-                   -> ( Either Bool (Thread s a)-                      , Timeouts s-                      )-unwindControlStack e thread = \timeouts ->-    case threadControl thread of-      ThreadControl _ ctl -> unwind (threadMasking thread) ctl timeouts-  where-    unwind :: forall s' c. MaskingState-           -> ControlStack s' c a-           -> Timeouts s-           -> (Either Bool (Thread s' a), Timeouts s)-    unwind _  MainFrame                 timers = (Left True, timers)-    unwind _  ForkFrame                 timers = (Left False, timers)-    unwind _ (MaskFrame _k maskst' ctl) timers = unwind maskst' ctl timers--    unwind maskst (CatchFrame handler k ctl) timers =-      case fromException e of-        -- not the right type, unwind to the next containing handler-        Nothing -> unwind maskst ctl timers--        -- Ok! We will be able to continue the thread with the handler-        -- followed by the continuation after the catch-        Just e' -> ( Right thread {-                          -- As per async exception rules, the handler is run-                          -- masked-                         threadControl = ThreadControl (handler e')-                                                       (MaskFrame k maskst ctl),-                         threadMasking = atLeastInterruptibleMask maskst-                       }-                   , timers-                   )--    -- Either Timeout fired or the action threw an exception.-    -- - If Timeout fired, then it was possibly during this thread's execution-    --   so we need to run the continuation with a Nothing value.-    -- - If the timeout action threw an exception we need to keep unwinding the-    --   control stack looking for a handler to this exception.-    unwind maskst (TimeoutFrame tmid isLockedRef k ctl) timers =-        case fromException e of-          -- Exception came from timeout expiring-          Just (TimeoutException tmid')  | tmid == tmid' ->-            (Right thread { threadControl = ThreadControl (k Nothing) ctl }, timers')-            -- Exception came from a different exception-          _ -> unwind maskst ctl timers'-      where-        -- Remove the timeout associated with the 'TimeoutFrame'.-        timers' = IPSQ.delete (coerce tmid) timers--    unwind maskst (DelayFrame tmid _k ctl) timers =-        unwind maskst ctl timers'-      where-        -- Remove the timeout associated with the 'DelayFrame'.-        timers' = IPSQ.delete (coerce tmid) timers--    atLeastInterruptibleMask :: MaskingState -> MaskingState-    atLeastInterruptibleMask Unmasked = MaskedInterruptible-    atLeastInterruptibleMask ms       = ms---removeMinimums :: (Coercible Int k, Ord p)-               => IntPSQ p a-               -> Maybe ([k], p, [a], IntPSQ p a)-removeMinimums = \psq -> coerce $-    case IPSQ.minView psq of-      Nothing              -> Nothing-      Just (k, p, x, psq') -> Just (collectAll [k] p [x] psq')-  where-    collectAll ks p xs psq =-      case IPSQ.minView psq of-        Just (k, p', x, psq')-          | p == p' -> collectAll (k:ks) p (x:xs) psq'-        _           -> (reverse ks, p, reverse xs, psq)--traceMany :: [(SI.Time, IOSimThreadId, Int, Maybe ThreadLabel, SimEventType)]-          -> SimTrace a -> SimTrace a-traceMany []                                   trace = trace-traceMany ((time, tid, tstep, tlbl, event):ts) trace =-    SimPORTrace time tid tstep tlbl event (traceMany ts trace)--lookupThreadLabel :: IOSimThreadId -> Map IOSimThreadId (Thread s a) -> Maybe ThreadLabel-lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads)----- | The most general method of running 'IOSim' is in 'ST' monad.  One can--- recover failures or the result from 'SimTrace' with 'traceResult', or access--- 'TraceEvent's generated by the computation with 'traceEvents'.  A slightly--- more convenient way is exposed by 'runSimTrace'.----runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)-runSimTraceST mainAction = controlSimTraceST Nothing ControlDefault mainAction--controlSimTraceST :: Maybe Int -> ScheduleControl -> IOSim s a -> ST s (SimTrace a)-controlSimTraceST limit control mainAction =-  SimPORTrace (curTime initialState)-              (threadId mainThread)-              0-              (threadLabel mainThread)-              (EventSimStart control)-  <$> schedule mainThread initialState { control  = control,-                                         control0 = control,-                                         perStepTimeLimit = limit-                                       }-  where-    mainThread =-      Thread {-        threadId      = ThreadId [],-        threadControl = ThreadControl (runIOSim mainAction) MainFrame,-        threadStatus  = ThreadRunning,-        threadMasking = Unmasked,-        threadThrowTo = [],-        threadClockId = ClockId [],-        threadLabel   = Just "main",-        threadNextTId = 1,-        threadStep    = 0,-        threadVClock  = insertVClock (ThreadId []) 0 bottomVClock,-        threadEffect  = mempty,-        threadRacy    = False-      }-------- Executing STM Transactions-----execAtomically :: forall s a c.-                  SI.Time-               -> IOSimThreadId-               -> Maybe ThreadLabel-               -> VarId-               -> StmA s a-               -> (StmTxResult s a -> ST s (SimTrace c))-               -> ST s (SimTrace c)-execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =-    go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0-  where-    go :: forall b.-          StmStack s b a-       -> Map TVarId (SomeTVar s)  -- set of vars read-       -> Map TVarId (SomeTVar s)  -- set of vars written-       -> [SomeTVar s]             -- vars written in order (no dups)-       -> [SomeTVar s]             -- vars created in order-       -> VarId                   -- var fresh name supply-       -> StmA s b-       -> ST s (SimTrace c)-    go !ctl !read !written !writtenSeq !createdSeq !nextVid !action =-      assert localInvariant $-      case action of-      ReturnStm x ->-        case ctl of-        AtomicallyFrame -> do-          -- Trace each created TVar-          !ds  <- traverse (\(SomeTVar tvar) -> traceTVarST tvar True) createdSeq-          -- Trace & commit each TVar-          !ds' <- Map.elems <$> traverse-                    (\(SomeTVar tvar) -> do-                        tr <- traceTVarST tvar False-                        !_ <- commitTVar tvar-                        -- Also assert the data invariant that outside a tx-                        -- the undo stack is empty:-                        undos <- readTVarUndos tvar-                        assert (null undos) $ return tr-                    ) written--          -- Return the vars written, so readers can be unblocked-          k0 $ StmTxCommitted x (reverse writtenSeq)-                                (Map.elems read)-                                (reverse createdSeq)-                                (mapMaybe (\TraceValue { traceDynamic }-                                            -> toDyn <$> traceDynamic)-                                          $ ds ++ ds')-                                (mapMaybe traceString $ ds ++ ds')-                                nextVid--        BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do-          -- The branch has successfully completed the transaction. Hence,-          -- the alternative branch can be ignored.-          -- Commit the TVars written in this sub-transaction that are also-          -- in the written set of the outer transaction-          !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)-                          (Map.intersection written writtenOuter)-          -- Merge the written set of the inner with the outer-          let written'    = Map.union written writtenOuter-              writtenSeq' = filter (\(SomeTVar tvar) ->-                                      tvarId tvar `Map.notMember` writtenOuter)-                                    writtenSeq-                         ++ writtenOuterSeq-              createdSeq' = createdSeq ++ createdOuterSeq-          -- Skip the orElse right hand and continue with the k continuation-          go ctl' read written' writtenSeq' createdSeq' nextVid (k x)--      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' -> 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' -> do-            go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)--          BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do-            go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)--      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 -> do-        -- Always revert all the TVar writes for the retry-        !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written-        case ctl of-          AtomicallyFrame -> do-            -- Return vars read, so the thread can block on them-            k0 $! StmTxBlocked $! Map.elems read--          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' -> 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 -> 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 mkId !mbLabel x k -> do-        !v <- execNewTVar (mkId 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-        -- save the value: it will be committed or reverted-        !_ <- saveTVar v-        go ctl read written' writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v)--      LabelTVar !label tvar k -> do-        !_ <- writeSTRef (tvarLabel tvar) $! (Just label)-        go ctl read written writtenSeq createdSeq nextVid k--      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 -> do-            x <- execReadTVar v-            go ctl read written writtenSeq createdSeq nextVid (k x)-        | 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 -> do-            !_ <- execWriteTVar v x-            go ctl read written writtenSeq createdSeq nextVid k-        | 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 -> do-        trace <- go ctl read written writtenSeq createdSeq nextVid k-        -- TODO: step-        return $ SimPORTrace time tid (-1) tlbl (EventSay msg) trace--      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 -> do-        x <- strictToLazyST st-        go ctl read written writtenSeq createdSeq nextVid (k x)--      FixStm f k -> do-        r <- newSTRef (throw NonTermination)-        x <- unsafeInterleaveST $ readSTRef r-        let k' = unSTM (f x) $ \x' ->-                    LiftSTStm (lazyToStrictST (writeSTRef r x')) (\() -> k x')-        go ctl read written writtenSeq createdSeq nextVid k'--      where-        localInvariant =-            Map.keysSet written-         == Set.fromList ([ tvarId tvar | SomeTVar tvar <- writtenSeq ]-                       ++ [ tvarId tvar | SomeTVar tvar <- createdSeq ])+import Control.DeepSeq (force)+import Control.Exception (NonTermination (..), SomeAsyncException, assert,+           throw)+import Control.Monad (join, when)+import Control.Monad.ST.Lazy+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)+import Data.STRef.Lazy++import Control.Concurrent.Class.MonadSTM.TMVar+import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)+import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)+import Control.Monad.Class.MonadSTM hiding (STM)+import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))+import Control.Monad.Class.MonadThrow as MonadThrow+import Control.Monad.Class.MonadTime (NominalDiffTime)+import Control.Monad.Class.MonadTime qualified as Time+import Control.Monad.Class.MonadTime.SI qualified as SI+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))++import Control.Monad.IOSim.InternalTypes+import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Time (..),+           Trace (SimTrace))+import Control.Monad.IOSim.Types (SimEvent)+import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)+import Control.Monad.IOSimPOR.Types+import Data.Coerce (Coercible, coerce)+import Data.Hashable++--+-- Simulation interpreter+--++data Thread s a = Thread {+    threadId      :: !IOSimThreadId,+    threadControl :: !(ThreadControl s a),+    threadStatus  :: !ThreadStatus,+    threadMasking :: !MaskingState,+    -- other threads blocked in a ThrowTo to us because we are or were masked+    threadThrowTo :: ![(SomeException, Labelled IOSimThreadId, VectorClock)],+    threadClockId :: !ClockId,+    threadLabel   :: Maybe ThreadLabel,+    threadNextTId :: !Int,+    threadStep    :: !Int,+    threadVClock  :: VectorClock,+    threadEffect  :: Effect,  -- in the current step+    threadRacy    :: !Bool+  }+  deriving Show++isThreadBlocked :: Thread s a -> Bool+isThreadBlocked t = case threadStatus t of+    ThreadBlocked {} -> True+    _                -> False++isThreadDone :: Thread s a -> Bool+isThreadDone t = case threadStatus t of+    ThreadDone -> True+    _          -> False++threadStepId :: Thread s a -> (IOSimThreadId, Int)+threadStepId Thread{ threadId, threadStep } = (threadId, threadStep)++isRacyThreadId :: IOSimThreadId -> Bool+isRacyThreadId (RacyThreadId _) = True+isRacyThreadId _                = True++isNotRacyThreadId :: IOSimThreadId -> Bool+isNotRacyThreadId (ThreadId _) = True+isNotRacyThreadId _            = False++bottomVClock :: VectorClock+bottomVClock = VectorClock Map.empty++insertVClock :: IOSimThreadId -> Int -> VectorClock -> VectorClock+insertVClock tid !step (VectorClock m) = VectorClock (Map.insert tid step m)++leastUpperBoundVClock :: VectorClock -> VectorClock -> VectorClock+leastUpperBoundVClock (VectorClock m) (VectorClock m') =+    VectorClock (Map.unionWith max m m')++-- hbfVClock :: VectorClock -> VectorClock -> Bool+-- hbfVClock (VectorClock m) (VectorClock m') = Map.isSubmapOfBy (<=) m m'++happensBeforeStep :: Step -- ^ an earlier step+                  -> Step -- ^ a later step+                  -> Bool+happensBeforeStep step step' =+       Just (stepStep step)+    <= Map.lookup (stepThreadId step)+                  (getVectorClock $ stepVClock step')++labelledTVarId :: TVar s a -> ST s (Labelled TVarId)+labelledTVarId TVar { tvarId, tvarLabel } = Labelled tvarId <$> readSTRef tvarLabel++labelledThreads :: Map IOSimThreadId (Thread s a) -> [Labelled IOSimThreadId]+labelledThreads threadMap =+    -- @Map.foldr'@ (and alikes) are not strict enough, to not retain the+    -- original thread map we need to evaluate the spine of the list.+    -- TODO: https://github.com/haskell/containers/issues/749+    Map.foldr'+      (\Thread { threadId, threadLabel } !acc -> Labelled threadId threadLabel : acc)+      [] threadMap+++-- | Timers mutable variables.  First one supports 'newTimeout' api, the second+-- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one+-- 'Control.Monad.Class.MonadTimer.SI.threadDelay'.+--+data TimerCompletionInfo s =+       Timer !(TVar s TimeoutState)+     -- ^ `newTimeout` timer.+     | TimerRegisterDelay !(TVar s Bool)+     -- ^ `registerDelay` timer.+     | TimerThreadDelay !IOSimThreadId !TimeoutId+     -- ^ `threadDelay` timer run by `IOSimThreadId` which was assigned the given+     -- `TimeoutId` (only used to report in a trace).+     | TimerTimeout !IOSimThreadId !TimeoutId !(TMVar (IOSim s) IOSimThreadId)+     -- ^ `timeout` timer run by `IOSimThreadId` which was assigned the given+     -- `TimeoutId` (only used to report in a trace).++instance Hashable a => Hashable (Down a)++type RunQueue   = HashPSQ (Down IOSimThreadId) (Down IOSimThreadId) ()+type Timeouts s = IntPSQ SI.Time (TimerCompletionInfo s)++-- | Internal state.+--+data SimState s a = SimState {+       runqueue         :: !RunQueue,+       -- | All threads other than the currently running thread: both running+       -- and blocked threads.+       threads          :: !(Map IOSimThreadId (Thread s a)),+       -- | current time+       curTime          :: !SI.Time,+       -- | ordered list of timers and timeouts+       timers           :: !(Timeouts s),+       -- | timeout locks in order to synchronize the timeout handler and the+       -- main thread+       clocks           :: !(Map ClockId UTCTime),+       nextVid          :: !VarId,     -- ^ next unused 'TVarId'+       nextTmid         :: !TimeoutId,  -- ^ next unused 'TimeoutId'+       nextUniq         :: !(Unique s), -- ^ next unused @'Unique' s@+       -- | previous steps (which we may race with).+       -- Note this is *lazy*, so that we don't compute races we will not reverse.+       races            :: Races,+       -- | control the schedule followed, and initial value+       control          :: !ScheduleControl,+       control0         :: !ScheduleControl,+       -- | limit on the computation time allowed per scheduling step, for+       -- catching infinite loops etc+       perStepTimeLimit :: Maybe Int++     }++initialState :: SimState s a+initialState =+    SimState {+      runqueue = PSQ.empty,+      threads  = Map.empty,+      curTime  = SI.Time 0,+      timers   = IPSQ.empty,+      clocks   = Map.singleton (ClockId []) epoch1970,+      nextVid  = 0,+      nextTmid = TimeoutId 0,+      nextUniq = MkUnique 0,+      races    = noRaces,+      control  = ControlDefault,+      control0 = ControlDefault,+      perStepTimeLimit = Nothing+    }+  where+    epoch1970 = UTCTime (fromGregorian 1970 1 1) 0++invariant :: Maybe (Thread s a) -> SimState s a -> x -> x++invariant (Just running) simstate@SimState{runqueue,threads,clocks} =+    assert (not (isThreadBlocked running))+  . assert (threadId running `Map.notMember` threads)+  . assert (not (Down (threadId running) `PSQ.member` runqueue))+  . assert (threadClockId running `Map.member` clocks)+  . invariant Nothing simstate++invariant Nothing SimState{runqueue,threads,clocks} =+    assert (PSQ.fold' (\(Down tid) _ _ a -> tid `Map.member` threads && a) True runqueue)+  . assert (and [ (isThreadBlocked t || isThreadDone t) == not (Down (threadId t) `PSQ.member` runqueue)+                | t <- Map.elems threads ])+  . assert (and [ threadClockId t `Map.member` clocks+                | t <- Map.elems threads ])++-- | Interpret the simulation monotonic time as a 'NominalDiffTime' since+-- the start.+timeSinceEpoch :: SI.Time -> NominalDiffTime+timeSinceEpoch (SI.Time t) = fromRational (toRational t)+++-- | Insert thread into `runqueue`.+--+insertThread :: Thread s a -> RunQueue -> RunQueue+insertThread Thread { threadId } = PSQ.insert (Down threadId) (Down threadId) ()+++-- | Schedule / run a thread.+--+schedule :: forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)+schedule thread@Thread{+           threadId      = tid,+           threadControl = ThreadControl action ctl,+           threadMasking = maskst,+           threadLabel   = tlbl,+           threadStep    = tstep,+           threadVClock  = vClock,+           threadEffect  = effect+         }+         simstate@SimState {+           runqueue,+           threads,+           timers,+           clocks,+           nextVid, nextTmid, nextUniq,+           curTime  = time,+           control,+           perStepTimeLimit+         }++  | controlTargets (tid,tstep) control =+      -- The next step is to be delayed according to the+      -- specified schedule. Switch to following the schedule.+      SimPORTrace time tid tstep tlbl (EventFollowControl control) <$>+      schedule thread simstate{ control = followControl control }++  | not $ controlFollows (tid,tstep) control =+      -- the control says this is not the next step to+      -- follow. We should be at the beginning of a step;+      -- we put the present thread to sleep and reschedule+      -- the correct thread.+      -- The assertion says that the only effect that may have+      -- happened in the start of a thread is us waking up.+      ( SimPORTrace time tid tstep tlbl (EventAwaitControl (tid,tstep) control)+      . SimPORTrace time tid tstep tlbl (EventDeschedule Sleep)+      ) <$> deschedule Sleep thread simstate++  | otherwise =+  invariant (Just thread) simstate $+  case control of+    ControlFollow (s:_) _+      -> fmap (SimPORTrace time tid tstep tlbl (EventPerformAction (tid,tstep)))+    _ -> id+  $+  -- The next line forces the evaluation of action, which should be unevaluated up to+  -- this point. This is where we actually *run* user code.+  case maybe Just unsafeTimeout perStepTimeLimit action of+    Nothing -> return TraceLoop+    Just _  -> case action of++      Return x -> case ctl of+        MainFrame ->+          -- the main thread is done, so we're done+          -- even if other threads are still running+          return $ SimPORTrace time tid tstep tlbl EventThreadFinished+                 $ traceFinalRacesFound simstate+                 $ TraceMainReturn time (Labelled tid tlbl) x+                                        ( labelledThreads+                                        . Map.filter (not . isThreadDone)+                                        $ threads+                                        )++        ForkFrame -> do+          -- this thread is done+          let thread' = thread+          !trace <- deschedule Terminated thread' simstate+          return $ SimPORTrace time tid tstep tlbl EventThreadFinished+                 $ SimPORTrace time tid tstep tlbl (EventDeschedule Terminated)+                 $ trace++        MaskFrame k maskst' ctl' -> do+          -- pop the control stack, restore thread-local state+          let thread' = thread { threadControl = ThreadControl (k x) ctl'+                               , threadMasking = maskst'+                               }+          -- but if we're now unmasked, check for any pending async exceptions+          !trace <- deschedule Interruptable thread' simstate+          return $ SimPORTrace time tid tstep tlbl (EventMask maskst')+                 $ SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable)+                 $ trace++        CatchFrame _handler k ctl' -> do+          -- pop the control stack and continue+          let thread' = thread { threadControl = ThreadControl (k x) ctl' }+          schedule thread' simstate++        TimeoutFrame tmid lock k ctl' -> do+          -- It could happen that the timeout action finished at the same time+          -- as the timeout expired, this will be a race condition. That's why+          -- we have the locks to solve this.++          -- We cannot do `tryPutMVar` in the `treadAction`, because we need to+          -- know if the `lock` is empty right now when we still have the frame.+          v <- execTryPutTMVar lock undefined+          let -- Kill the assassin throwing thread then unmask exceptions and+              -- carry on the continuation+              threadAction :: IOSim s ()+              threadAction =+                if v then unsafeUnregisterTimeout tmid+                     else atomically (takeTMVar lock) >>= killThread++              thread' =+                thread { threadControl =+                          ThreadControl (case threadAction of+                                          IOSim k' -> k' (\() -> k (Just x)))+                                        ctl'+                       }+          schedule thread' simstate++        DelayFrame tmid k ctl' -> do+          let thread' = thread { threadControl = ThreadControl k ctl' }+              timers' = IPSQ.delete (coerce tmid) timers+          schedule thread' simstate { timers = timers' }++      Throw e -> case unwindControlStack e thread timers of+        -- Found a CatchFrame+        (Right thread0@Thread { threadMasking = maskst' }, timers'') -> do+          -- We found a suitable exception handler, continue with that+          -- We record a step, in case there is no exception handler on replay.+          let (thread', eff)  = stepThread thread0+              control'        = advanceControl (threadStepId thread0) control+              races'          = updateRaces thread0 simstate+          trace <- schedule thread' simstate{ races = races',+                                              control = control',+                                              timers = timers'' }+          return (SimPORTrace time tid tstep tlbl (EventThrow e) $+                  SimPORTrace time tid tstep tlbl (EventMask maskst') $+                  SimPORTrace time tid tstep tlbl (EventEffect vClock eff) $+                  SimPORTrace time tid tstep tlbl (EventRaces races')+                  trace)++        (Left isMain, timers'')+          -- We unwound and did not find any suitable exception handler, so we+          -- have an unhandled exception at the top level of the thread.+          | isMain -> do+            let thread' = thread { threadStatus = ThreadDone }+            -- An unhandled exception in the main thread terminates the program+            return (SimPORTrace time tid tstep tlbl (EventThrow e) $+                    SimPORTrace time tid tstep tlbl (EventThreadUnhandled e) $+                    traceFinalRacesFound simstate { threads = Map.insert tid thread' threads } $+                    TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))++          | otherwise -> do+            -- An unhandled exception in any other thread terminates the thread+            let terminated = Terminated+            !trace <- deschedule terminated thread simstate { timers = timers'' }+            return $ SimPORTrace time tid tstep tlbl (EventThrow e)+                   $ SimPORTrace time tid tstep tlbl (EventThreadUnhandled e)+                   $ SimPORTrace time tid tstep tlbl (EventDeschedule terminated)+                   $ trace++      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 -> do+        mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                            Nothing -> Just e+                                            Just {} -> Nothing)+                               $ evaluate expr+        case mbWHNF of+          Left e -> do+            -- schedule this thread to immediately raise the exception+            let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+            trace <- schedule thread' simstate+            return $ SimPORTrace time tid tstep tlbl (EventEvaluationError e)+                   $ trace+          Right whnf -> do+            -- continue with the resulting WHNF+            let thread' = thread { threadControl = ThreadControl (k whnf) ctl }+            trace <- schedule thread' simstate+            return $ SimPORTrace time tid tstep tlbl EventEvaluationSuccess+                   $ trace++      Say msg k -> do+        mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                          Nothing -> Just e+                                          Just {} -> Nothing)+                             $ evaluate (force msg)+        case mbNF of+          Left e  -> do+            let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+            trace <- schedule thread' simstate+            return $ SimPORTrace time tid tstep tlbl (EventSayEvaluationError e)+                   $ trace+          Right msg' -> do+            let thread' = thread { threadControl = ThreadControl k ctl }+            trace <- schedule thread' simstate+            return (SimPORTrace time tid tstep tlbl (EventSay msg') trace)++      Output x@(Dynamic _ x') k -> do+        mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                            Nothing -> Just e+                                            Just {} -> Nothing)+                               $ evaluate x'+        case mbWHNF of+          Left e  -> do+            let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+            trace <- schedule thread' simstate+            return $ SimPORTrace time tid tstep tlbl (EventLogEvaluationError e)+                   $ trace+          Right {} -> do+            let thread' = thread { threadControl = ThreadControl k ctl }+            trace <- schedule thread' simstate+            return (SimPORTrace time tid tstep tlbl (EventLog x) trace)++      LiftST st k -> do+        x <- strictToLazyST st+        let thread' = thread { threadControl = ThreadControl (k x) ctl }+        schedule thread' simstate++      GetMonoTime k -> do+        let thread' = thread { threadControl = ThreadControl (k time) ctl }+        schedule thread' simstate++      GetWallTime k -> do+        let clockid  = threadClockId thread+            clockoff = clocks Map.! clockid+            walltime = timeSinceEpoch time `Time.addUTCTime` clockoff+            thread'  = thread { threadControl = ThreadControl (k walltime) ctl }+        schedule thread' simstate++      SetWallTime walltime' k -> do+        let clockid   = threadClockId thread+            clockoff  = clocks Map.! clockid+            walltime  = timeSinceEpoch time `Time.addUTCTime` clockoff+            clockoff' = (walltime' `Time.diffUTCTime` walltime) `Time.addUTCTime` clockoff+            thread'   = thread { threadControl = ThreadControl k ctl }+            simstate' = simstate { clocks = Map.insert clockid clockoff' clocks }+        schedule thread' simstate'++      UnshareClock k -> do+        let clockid   = threadClockId thread+            clockoff  = clocks Map.! clockid+            clockid'  = let ThreadId i = tid in ClockId i -- reuse the thread id+            thread'   = thread { threadControl = ThreadControl k ctl+                               , threadClockId = clockid' }+            simstate' = simstate { clocks = Map.insert clockid' clockoff clocks }+        schedule thread' simstate'++      -- This case is guarded by checks in 'timeout' itself.+      StartTimeout d _ _ | d <= 0 ->+        error "schedule: StartTimeout: Impossible happened"++      StartTimeout d action' k -> do+        lock <- TMVar <$> execNewTVar (TMVarId nextVid) (Just $! "lock-" ++ show nextTmid) Nothing+        let expiry    = d `addTime` time+            timers'   = IPSQ.insert (coerce nextTmid) expiry (TimerTimeout tid nextTmid lock) timers+            thread'   = thread { threadControl =+                                   ThreadControl action'+                                                 (TimeoutFrame nextTmid lock k ctl)+                                }+        trace <- deschedule Yield thread' simstate { timers   = timers'+                                                    , nextTmid = succ nextTmid }+        return (SimPORTrace time tid tstep tlbl (EventTimeoutCreated nextTmid tid expiry) trace)++      UnregisterTimeout tmid k -> do+        let thread' = thread { threadControl = ThreadControl k ctl }+        schedule thread' simstate { timers = IPSQ.delete (coerce tmid) timers }++      RegisterDelay d k | d < 0 -> do+        tvar <- execNewTVar (TVarId nextVid)+                            (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+                            True+        modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+        let !expiry  = d `addTime` time+            !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+        trace <- schedule thread' simstate { nextVid = succ nextVid }+        return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) $+                SimPORTrace time tid tstep tlbl (EventRegisterDelayFired nextTmid) $+                trace)++      RegisterDelay d k -> do+        tvar <- execNewTVar (TVarId nextVid)+                            (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+                            False+        modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+        let !expiry  = d `addTime` time+            !timers' = IPSQ.insert (coerce nextTmid) expiry (TimerRegisterDelay tvar) timers+            !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+        trace <- schedule thread' simstate { timers   = timers'+                                           , nextVid  = succ nextVid+                                           , nextTmid = succ nextTmid }+        return (SimPORTrace time tid tstep tlbl+                  (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) trace)++      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 }+        trace <- schedule thread' simstate'+        return (SimPORTrace time tid tstep tlbl (EventThreadDelay nextTmid expiry) $+                SimPORTrace time tid tstep tlbl (EventThreadDelayFired nextTmid) $+                trace)++      ThreadDelay d k -> do+        let expiry  = d `addTime` time+            timers' = IPSQ.insert (coerce nextTmid) expiry (TimerThreadDelay tid nextTmid) timers+            thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }+        trace <- deschedule (Blocked BlockedOnDelay) thread'+                            simstate { timers   = timers',+                                       nextTmid = succ nextTmid }+        return (SimPORTrace time tid tstep tlbl (EventThreadDelay nextTmid expiry) trace)++      -- 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 -> do+        let t       = NegativeTimeout nextTmid+            expiry  = d `addTime` time+            thread' = thread { threadControl = ThreadControl (k t) ctl }+        trace <- schedule thread' simstate { nextTmid = succ nextTmid }+        return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) $+                SimPORTrace time tid tstep tlbl (EventTimerCancelled nextTmid) $+                trace)++      NewTimeout d k -> do+        tvar  <- execNewTVar (TVarId nextVid)+                             (Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")+                             TimeoutPending+        modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+        let expiry  = d `addTime` time+            t       = Timeout tvar nextTmid+            timers' = IPSQ.insert (coerce nextTmid) expiry (Timer tvar) timers+            thread' = thread { threadControl = ThreadControl (k t) ctl }+        trace <- schedule thread' simstate { timers   = timers'+                                           , nextVid  = succ (succ nextVid)+                                           , nextTmid = succ nextTmid }+        return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) trace)++      CancelTimeout (Timeout tvar tmid) k -> do+        let timers' = IPSQ.delete (coerce tmid) timers+        written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)+        written' <- mapM someTVarToLabelled written+        (wakeup, wokeby) <- threadsUnblockedByWrites written+        mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written+        let effect' = effect+                   <> writeEffects written'+                   <> wakeupEffects wakeup+            thread' = thread { threadControl = ThreadControl k ctl+                             , threadEffect  = effect'+                             }+            (unblocked,+             simstate') = unblockThreads False vClock wakeup simstate+        modifySTRef (tvarVClock tvar)  (leastUpperBoundVClock vClock)+        !trace <- deschedule Yield thread' simstate' { timers = timers' }+        return $ SimPORTrace time tid tstep tlbl (EventTimerCancelled tmid)+               $ traceMany+                   -- TODO: step+                   [ (time, tid', (-1), tlbl', EventTxWakeup vids)+                   | tid' <- unblocked+                   , let tlbl' = lookupThreadLabel tid' threads+                   , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]+               $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)+               $ trace++      -- cancelling a negative timer is a no-op+      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 -> do+        let nextTId = threadNextTId thread+            tid' | threadRacy thread = setRacyThread $ childThreadId tid nextTId+                 | otherwise         = childThreadId tid nextTId+            thread'  = thread { threadControl = ThreadControl (k tid') ctl,+                                threadNextTId = nextTId + 1,+                                threadEffect  = effect+                                             <> forkEffect tid'+                                }+            thread'' = Thread { threadId      = tid'+                              , threadControl = ThreadControl (runIOSim a)+                                                              ForkFrame+                              , threadStatus  = ThreadRunning+                              , threadMasking = threadMasking thread+                              , threadThrowTo = []+                              , threadClockId = threadClockId thread+                              , threadLabel   = Nothing+                              , threadNextTId = 1+                              , threadStep    = 0+                              , threadVClock  = insertVClock tid' 0+                                              $ vClock+                              , threadEffect  = mempty+                              , threadRacy    = threadRacy thread+                              }+            threads' = Map.insert tid' thread'' threads+        -- A newly forked thread may have a higher priority, so we deschedule this one.+        !trace <- deschedule Yield thread'+                    simstate { runqueue = insertThread thread'' runqueue+                             , threads  = threads' }+        return $ SimPORTrace time tid tstep tlbl (EventThreadForked tid')+               $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)+               $ trace++      Atomically a k -> execAtomically time tid (labelledThreads threads) tlbl nextVid (runSTM a) $ \res ->+        case res of+          StmTxCommitted x written read created+                           tvarDynamicTraces tvarStringTraces nextVid' -> do+            (wakeup, wokeby) <- threadsUnblockedByWrites written+            mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written+            vClockRead <- leastUpperBoundTVarVClocks read+            read' <- mapM someTVarToLabelled read+            written' <- mapM someTVarToLabelled written+            let vClock'     = vClock `leastUpperBoundVClock` vClockRead+                effect'     = effect+                           <> readEffects read'+                           <> writeEffects written'+                           <> wakeupEffects unblocked+                thread'     = thread { threadControl = ThreadControl (k x) ctl,+                                       threadVClock  = vClock',+                                       threadEffect  = effect' }+                (unblocked,+                 simstate') = unblockThreads True vClock' wakeup simstate+            sequence_ [ modifySTRef (tvarVClock r) (leastUpperBoundVClock vClock')+                      | SomeTVar r <- created ++ written ]+            written'' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written+            created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created+            -- We deschedule a thread after a transaction... another may have woken up.+            !trace <- deschedule Yield thread' simstate' { nextVid  = nextVid' }+            return $+              SimPORTrace time tid tstep tlbl (EventTxCommitted written'' created' (Just effect')) $+              traceMany+                [ (time, tid', (-1), tlbl', EventTxWakeup vids')+                | tid' <- unblocked+                , let tlbl' = lookupThreadLabel tid' threads+                , let Just vids' = Set.toList <$> Map.lookup tid' wokeby ] $+              traceMany+                [ (time, tid, tstep, tlbl, EventLog tr)+                | tr <- tvarDynamicTraces+                ] $+              traceMany+                [ (time, tid, tstep, tlbl, EventSay str)+                | str <- tvarStringTraces+                ] $+              SimPORTrace time tid tstep tlbl (EventUnblocked unblocked) $+              SimPORTrace time tid tstep tlbl (EventDeschedule Yield) $+                trace++          StmTxAborted read e -> do+            -- schedule this thread to immediately raise the exception+            vClockRead <- leastUpperBoundTVarVClocks read+            read' <- mapM someTVarToLabelled read+            let effect' = effect <> readEffects read'+                thread' = thread { threadControl = ThreadControl (Throw e) ctl,+                                   threadVClock  = vClock `leastUpperBoundVClock` vClockRead,+                                   threadEffect  = effect' }+            trace <- schedule thread' simstate+            return $ SimPORTrace time tid tstep tlbl (EventTxAborted (Just effect'))+                   $ trace++          StmTxBlocked read -> do+            mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read+            vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read+            vClockRead <- leastUpperBoundTVarVClocks read+            read' <- mapM someTVarToLabelled read+            let effect' = effect <> readEffects read'+                thread' = thread { threadVClock  = vClock `leastUpperBoundVClock` vClockRead,+                                   threadEffect  = effect' }+            !trace <- deschedule (Blocked BlockedOnSTM) thread' simstate+            return $ SimPORTrace time tid tstep tlbl (EventTxBlocked vids (Just effect'))+                   $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnSTM))+                   $ trace++      GetThreadId k -> do+        let thread' = thread { threadControl = ThreadControl (k tid) ctl }+        schedule thread' simstate++      LabelThread tid' l k | tid' == tid -> do+        let thread' = thread { threadControl = ThreadControl k ctl+                             , threadLabel   = Just l }+        schedule thread' simstate++      GetThreadLabel tid' k -> do+        let tlbl' | tid' == tid = tlbl+                  | otherwise   = tid' `Map.lookup` threads+                              >>= threadLabel+            thread' = thread { threadControl = ThreadControl (k tlbl') ctl }+        schedule thread' simstate++      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' }++      ExploreRaces k -> do+        let thread'  = thread { threadControl = ThreadControl k ctl+                              , threadRacy    = True }+        schedule thread' simstate++      Fix f k -> do+        r <- newSTRef (throw NonTermination)+        x <- unsafeInterleaveST $ readSTRef r+        let k' = unIOSim (f x) $ \x' ->+                    LiftST (lazyToStrictST (writeSTRef r x')) (\() -> k x')+            thread' = thread { threadControl = ThreadControl k' ctl }+        schedule thread' simstate++      GetMaskState k -> do+        let thread' = thread { threadControl = ThreadControl (k maskst) ctl }+        schedule thread' simstate++      SetMaskState maskst' action' k -> do+        let thread' = thread { threadControl = ThreadControl+                                                 (runIOSim action')+                                                 (MaskFrame k maskst ctl)+                             , threadMasking = maskst' }+        trace <-+          case maskst' of+            -- If we're now unmasked then check for any pending async exceptions+            Unmasked -> SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable)+                    <$> deschedule Interruptable thread' simstate+            _        -> schedule                 thread' simstate+        return $ SimPORTrace time tid tstep tlbl (EventMask maskst')+               $ trace++      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+                             , threadEffect  = effect+                             }+        trace <- schedule thread' simstate+        return (SimPORTrace time tid tstep tlbl (EventThrowTo e tid) trace)++      ThrowTo e tid' k -> do+        let thread'    = thread { threadControl = ThreadControl k ctl,+                                  threadEffect  = effect <> throwToEffect tid'+                                                         <> wakeUpEffect,+                                  threadVClock  = vClock `leastUpperBoundVClock` vClockTgt+                                }+            (vClockTgt,+             wakeUpEffect,+             willBlock) = (threadVClock t,+                           if isThreadBlocked t then wakeupEffects [tid'] else mempty,+                           not (threadInterruptible t || isThreadDone t))+              where Just t = Map.lookup tid' threads++        if willBlock+          then do+            -- The target thread has async exceptions masked so we add the+            -- exception and the source thread id to the pending async exceptions.+            let adjustTarget t =+                  t { threadThrowTo = (e, Labelled tid tlbl, vClock) : threadThrowTo t }+                threads'       = Map.adjust adjustTarget tid' threads+            trace <- deschedule (Blocked BlockedOnThrowTo) thread' simstate { threads = threads' }+            return $ SimPORTrace time tid tstep tlbl (EventThrowTo e tid')+                   $ SimPORTrace time tid tstep tlbl EventThrowToBlocked+                   $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnThrowTo))+                   $ trace+          else do+            -- The target thread has async exceptions unmasked, or is masked but+            -- is blocked (and all blocking operations are interruptible) then we+            -- raise the exception in that thread immediately. This will either+            -- cause it to terminate or enter an exception handler.+            -- In the meantime the thread masks new async exceptions. This will+            -- be resolved if the thread terminates or if it leaves the exception+            -- handler (when restoring the masking state would trigger the any+            -- new pending async exception).+            let adjustTarget t@Thread{ threadControl = ThreadControl _ ctl',+                                       threadVClock  = vClock' } =+                  t { threadControl = ThreadControl (Throw e) ctl'+                    , threadStatus  = if isThreadDone t+                                      then threadStatus t+                                      else ThreadRunning+                    , threadVClock  = vClock' `leastUpperBoundVClock` vClock }+                (_unblocked, simstate'@SimState { threads = threads' }) = unblockThreads False vClock [tid'] simstate+                threads''  = Map.adjust adjustTarget tid' threads'+                simstate'' = simstate' { threads = threads'' }++            -- We yield at this point because the target thread may be higher+            -- priority, so this should be a step for race detection.+            trace <- deschedule Yield thread' simstate''+            return $ SimPORTrace time tid tstep tlbl (EventThrowTo e tid')+                   $ trace++      -- intentionally a no-op (at least for now)+      YieldSim k -> do+        let thread' = thread { threadControl = ThreadControl k ctl }+        schedule thread' simstate++      NewUnique k -> do+        let thread'   = thread{ threadControl = ThreadControl (k nextUniq) ctl }+            n         = unMkUnique nextUniq+            simstate' = simstate{ nextUniq = MkUnique (n + 1) }+        SimPORTrace time tid tstep tlbl (EventUniqueCreated n)+          <$> schedule thread' simstate'+++threadInterruptible :: Thread s a -> Bool+threadInterruptible thread =+    case threadMasking thread of+      Unmasked                   -> True+      MaskedInterruptible+        | isThreadBlocked thread -> True  -- blocking operations are interruptible+        | otherwise              -> False+      MaskedUninterruptible      -> False+++-- | Deschedule a thread.+--+-- A thread is descheduled, which marks a boundary of a `Step` when:+--+-- * forking a new thread+-- * thread termination+-- * setting the masking state to interruptible+-- * popping masking frame (which resets masking state)+-- * starting or cancelling a timeout+-- * thread delays+-- * on committed or blocked, but not aborted STM transactions+-- * on blocking or non-blocking `throwTo`+-- * unhandled exception in a (non-main) thread+--+deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)++deschedule Yield thread@Thread { threadId     = tid,+                                 threadStep   = tstep,+                                 threadLabel  = tlbl,+                                 threadVClock = vClock }+                 simstate@SimState{runqueue,+                                   threads,+                                   curTime  = time,+                                   control } =++    -- We don't interrupt runnable threads anywhere else.+    -- We do it here by inserting the current thread into the runqueue in priority order.++    let (thread', eff) = stepThread thread+        runqueue'      = insertThread thread' runqueue+        threads'       = Map.insert tid thread' threads+        control'       = advanceControl (threadStepId thread) control+        races'         = updateRaces thread simstate in++    SimPORTrace time tid tstep tlbl (EventEffect vClock eff) .+    SimPORTrace time tid tstep tlbl (EventRaces races') <$>+    reschedule simstate { runqueue = runqueue',+                          threads  = threads',+                          races    = races',+                          control  = control' }++deschedule Interruptable thread@Thread {+                           threadId      = tid,+                           threadStep    = tstep,+                           threadControl = ThreadControl _ ctl,+                           threadMasking = Unmasked,+                           threadThrowTo = (e, tid', vClock') : etids,+                           threadLabel   = tlbl,+                           threadVClock  = vClock,+                           threadEffect  = effect+                         }+                        simstate@SimState{ curTime = time, threads } = do++    let effect' = effect <> wakeupEffects unblocked+        -- We're unmasking, but there are pending blocked async exceptions.+        -- So immediately raise the exception and unblock the blocked thread+        -- if possible.+        thread' = thread { threadControl = ThreadControl (Throw e) ctl+                         , threadMasking = MaskedInterruptible+                         , threadThrowTo = etids+                         , threadVClock  = vClock `leastUpperBoundVClock` vClock'+                         , threadEffect  = effect'+                         }+        (unblocked,+         simstate') = unblockThreads False vClock [l_labelled tid'] simstate+    -- the thread is stepped when we Yield+    !trace <- deschedule Yield thread' simstate'+    return $ SimPORTrace time tid tstep tlbl (EventThrowToUnmasked tid')+           $ SimPORTrace time tid tstep tlbl (EventEffect vClock effect')+           -- TODO: step+           $ traceMany [ (time, tid'', (-1), tlbl'', EventThrowToWakeup)+                       | tid'' <- unblocked+                       , let tlbl'' = lookupThreadLabel tid'' threads ]+           $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)+             trace++deschedule Interruptable thread@Thread{threadId     = tid,+                                       threadStep   = tstep,+                                       threadLabel  = tlbl,+                                       threadVClock = vClock}+                         simstate@SimState{ control,+                                            curTime = time } =+    -- Either masked or unmasked but no pending async exceptions.+    -- Either way, just carry on.+    -- Record a step, though, in case on replay there is an async exception.+    let (thread', eff) = stepThread thread+        races' = updateRaces thread simstate in++    SimPORTrace time tid tstep tlbl (EventEffect vClock eff) .+    SimPORTrace time tid tstep tlbl (EventRaces races') <$>+    schedule thread'+             simstate{ races   = races',+                       control = advanceControl (threadStepId thread) control }++deschedule (Blocked _blockedReason) thread@Thread { threadId      = tid+                                                  , threadStep    = tstep+                                                  , threadLabel   = tlbl+                                                  , threadThrowTo = _ : _+                                                  , threadMasking = maskst+                                                  , threadEffect  = effect }+                                    simstate@SimState{ curTime = time }+    | maskst /= MaskedUninterruptible =+    -- We're doing a blocking operation, which is an interrupt point even if+    -- we have async exceptions masked, and there are pending blocked async+    -- exceptions. So immediately raise the exception and unblock the blocked+    -- thread if possible.+    SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable) <$>+      deschedule Interruptable thread { threadMasking = Unmasked } simstate++deschedule (Blocked blockedReason) thread@Thread{ threadId     = tid,+                                                  threadStep   = tstep,+                                                  threadLabel  = tlbl,+                                                  threadVClock = vClock}+                                   simstate@SimState{ threads,+                                                      curTime = time,+                                                      control } =+    let thread1        = thread { threadStatus = ThreadBlocked blockedReason }+        (thread', eff) = stepThread thread1+        threads'       = Map.insert (threadId thread') thread' threads+        races'         = updateRaces thread1 simstate in++    SimPORTrace time tid tstep tlbl (EventEffect vClock eff) .+    SimPORTrace time tid tstep tlbl (EventRaces races') <$>+    reschedule simstate { threads = threads',+                          races   = races',+                          control = advanceControl (threadStepId thread1) control }++deschedule Terminated thread@Thread { threadId = tid, threadStep = tstep, threadLabel = tlbl,+                                      threadVClock = vClock, threadEffect = effect }+                               simstate@SimState{ curTime = time, control } = do+    -- This thread is done. If there are other threads blocked in a+    -- ThrowTo targeted at this thread then we can wake them up now.+    let wakeup         = map (\(_,tid',_) -> l_labelled tid') (reverse (threadThrowTo thread))+        (unblocked,+         simstate'@SimState{threads}) =+                      unblockThreads False vClock wakeup simstate+        effect'        = effect <> wakeupEffects unblocked+        (thread', eff) = stepThread $ thread { threadStatus = ThreadDone,+                                               threadEffect = effect' }+        threads'       = Map.insert tid thread' threads+        races'         = threadTerminatesRaces tid $ updateRaces thread { threadEffect = effect' } simstate+    -- We must keep terminated threads in the state to preserve their vector clocks,+    -- which matters when other threads throwTo them.+    !trace <- reschedule simstate' { races   = races',+                                     control = advanceControl (threadStepId thread) control,+                                     threads = threads' }+    return $ traceMany+               -- TODO: step+               [ (time, tid', (-1), tlbl', EventThrowToWakeup)+               | tid' <- unblocked+               , let tlbl' = lookupThreadLabel tid' threads ]+          $ SimPORTrace time tid tstep tlbl (EventEffect vClock eff)+          $ SimPORTrace time tid tstep tlbl (EventRaces races')+            trace++deschedule Sleep thread@Thread { threadId = tid , threadEffect = effect' }+                 simstate@SimState{runqueue, threads} =++    -- Schedule control says we should run a different thread. Put+    -- this one to sleep without recording a step.++    let runqueue' = insertThread thread runqueue+        threads'  = Map.insert tid thread threads in+    reschedule simstate { runqueue = runqueue', threads  = threads' }+++-- Choose the next thread to run.+reschedule :: SimState s a -> ST s (SimTrace a)++-- If we are following a controlled schedule, just do that.+reschedule simstate@SimState { runqueue, control = control@(ControlFollow ((tid,_):_) _) }+                             | not (Down tid `PSQ.member` runqueue) =+    return (Trace.Nil (InternalError ("assertion failure: " ++ ppIOSimThreadId tid ++ " not runnable")))++reschedule simstate@SimState { threads, control = control@(ControlFollow ((tid,_):_) _) }+                             | not (tid `Map.member` threads) =+    return (Trace.Nil (InternalError ("assertion failure: " ++ ppIOSimThreadId tid ++ " not in threads")))++reschedule simstate@SimState { runqueue, threads,+                               control = control@(ControlFollow ((tid,tstep):_) _),+                               curTime = time } =+    fmap (SimPORTrace time tid tstep Nothing (EventReschedule control)) $+    invariant Nothing simstate $+    let thread = threads Map.! tid in+    assert (threadId thread == tid) $+    --assert (threadStep thread == tstep) $+    if threadStep thread /= tstep then+      error $ "Thread step out of sync\n"+           ++ "  runqueue:    "++show runqueue++"\n"+           ++ "  follows:     "++show tid++", step "++show tstep++"\n"+           ++ "  actual step: "++show (threadStep thread)++"\n"+           ++ "Thread:\n" ++ show thread ++ "\n"+    else+    schedule thread simstate { runqueue = PSQ.delete (Down tid) runqueue+                             , threads  = Map.delete tid threads }++-- When there is no current running thread but the runqueue is non-empty then+-- schedule the next one to run.+reschedule simstate@SimState{ runqueue, threads }+    | Just (Down !tid, _, _, runqueue') <- PSQ.minView runqueue =+    invariant Nothing simstate $++    let thread = threads Map.! tid in+    schedule thread simstate { runqueue = runqueue'+                             , threads  = Map.delete tid threads }++-- 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, races } =+    invariant Nothing simstate $++    -- time is moving on+    --Debug.trace ("Rescheduling at "++show time++", "+++      --show (length (concatMap stepInfoRaces (activeRaces races++completeRaces races)))++" races") $++    -- important to get all events that expire at this time+    case removeMinimums timers of+      Nothing -> return (traceFinalRacesFound simstate $+                         TraceDeadlock time (labelledThreads threads))++      Just (tmids, time', fired, timers') -> assert (time' >= time) $ do++        -- Reuse the STM functionality here to write all the timer TVars.+        -- Simplify to a special case that only reads and writes TVars.+        written <- execAtomically' (runSTM $ mapM_ timeoutAction fired)+        !ds  <- traverse (\(SomeTVar tvar) -> do+                            tr <- traceTVarST tvar False+                            !_ <- commitTVar tvar+                            return tr) written+        (wakeupSTM, wokeby) <- threadsUnblockedByWrites written+        mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written++        let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ]+            -- TODO: the vector clock below cannot be right, can it?+            !simstate'        =+                snd . unblockThreads False bottomVClock (fst `fmap` wakeupThreadDelay)+              . snd . unblockThreads True  bottomVClock wakeupSTM+              $ simstate++            -- For each 'timeout' action where the timeout has fired, start a+            -- new thread to execute throwTo to interrupt the action.+            !timeoutExpired = [ (tid, tmid, lock)+                              | TimerTimeout tid tmid lock <- fired ]++        -- all open races will be completed and reported at this time+        !simstate'' <- forkTimeoutInterruptThreads timeoutExpired+                                                   simstate' { races = noRaces }+        !trace <- reschedule simstate'' { curTime = time'+                                        , timers  = timers' }+        let traceEntries =+                     [ ( time', ThreadId [-1], -1, Just "timer"+                       , EventTimerFired tmid)+                     | (tmid, Timer _) <- zip tmids fired ]+                  ++ [ ( time', ThreadId [-1], -1, Just "register delay timer"+                       , EventRegisterDelayFired tmid)+                     | (tmid, TimerRegisterDelay _) <- zip tmids fired ]+                  ++ [ (time', ThreadId [-1], -1, Just "register delay timer", EventLog (toDyn a))+                     | TraceValue { traceDynamic = Just a } <- ds ]+                  ++ [ (time', ThreadId [-1], -1, Just "register delay timer", EventSay a)+                     | TraceValue { traceString = Just a } <- ds ]+                  ++ [ (time', tid', -1, tlbl', EventTxWakeup vids)+                     | tid' <- wakeupSTM+                     , let tlbl' = lookupThreadLabel tid' threads+                     , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]+                  ++ [ ( time', tid, -1, Just "thread delay timer"+                       , EventThreadDelayFired tmid)+                     | (tid, tmid) <- wakeupThreadDelay ]+                  ++ [ ( time', tid, -1, Just "timeout timer"+                       , EventTimeoutFired tmid)+                     | (tid, tmid, _) <- timeoutExpired ]+                  ++ [ ( time', tid, -1, Just "forked thread"+                       , EventThreadForked tid)+                     | (tid, _, _) <- timeoutExpired ]++        return $+          traceFinalRacesFound simstate $+          traceMany traceEntries trace+  where+    timeoutAction (Timer var) = do+      x <- readTVar var+      case x of+        TimeoutPending   -> writeTVar var TimeoutFired+        TimeoutFired     -> error "MonadTimer(Sim): invariant violation"+        TimeoutCancelled -> return ()+    timeoutAction (TimerRegisterDelay var) = writeTVar var True+    timeoutAction (TimerThreadDelay _ _)   = return ()+    timeoutAction (TimerTimeout _ _ _)     = return ()++unblockThreads :: forall s a.+                  Bool -- ^ `True` if we are blocked on STM+               -> VectorClock+               -> [IOSimThreadId]+               -> SimState s a+               -> ([IOSimThreadId], SimState s a)+unblockThreads !onlySTM vClock wakeup simstate@SimState {runqueue, threads} =+    -- To preserve our invariants (that threadBlocked is correct)+    -- we update the runqueue and threads together here+    ( unblockedIds+    , simstate { runqueue = foldr insertThread runqueue unblocked,+                 threads  = threads'+               })+  where+    -- can only unblock if the thread exists and is blocked (not running)+    unblocked :: [Thread s a]+    !unblocked = [ thread+                 | tid <- wakeup+                 , thread <-+                     case Map.lookup tid threads of+                       Just   Thread { threadStatus = ThreadRunning }+                         -> [ ]+                       Just t@Thread { threadStatus = ThreadBlocked BlockedOnSTM }+                         -> [t]+                       Just t@Thread { threadStatus = ThreadBlocked _ }+                         | onlySTM+                         -> [ ]+                         | otherwise+                         -> [t]+                       Just   Thread { threadStatus = ThreadDone } -> [ ]+                       Nothing -> [ ]+                 ]++    unblockedIds :: [IOSimThreadId]+    !unblockedIds = map threadId unblocked++    -- and in which case we mark them as now running+    !threads'  = List.foldl'+                   (flip (Map.adjust+                     (\t -> t { threadStatus = ThreadRunning,+                                threadVClock = vClock `leastUpperBoundVClock` threadVClock t })))+                   threads unblockedIds++-- | This function receives a list of TimerTimeout values that represent threads+-- for which the timeout expired and kills the running thread if needed.+--+-- This function is responsible for the second part of the race condition issue+-- and relates to the 'schedule's 'TimeoutFrame' locking explanation (here is+-- where the assassin threads are launched. So, as explained previously, at this+-- point in code, the timeout expired so we need to interrupt the running+-- thread. If the running thread finished at the same time the timeout expired+-- we have a race condition. To deal with this race condition what we do is+-- look at the lock value. If it is 'Locked' this means that the running thread+-- already finished (or won the race) so we can safely do nothing. Otherwise, if+-- the lock value is 'NotLocked' we need to acquire the lock and launch an+-- assassin thread that is going to interrupt the running one. Note that we+-- should run this interrupting thread in an unmasked state since it might+-- receive a 'ThreadKilled' exception.+--+forkTimeoutInterruptThreads :: forall s a.+                               [(IOSimThreadId, TimeoutId, TMVar (IOSim s) IOSimThreadId)]+                            -> SimState s a+                            -> ST s (SimState s a)+forkTimeoutInterruptThreads timeoutExpired simState =+  foldlM (\st@SimState{ runqueue, threads }+           (t, TMVar lock)+          -> do+            v <- execReadTVar lock+            return $ case v of+              Nothing -> st { runqueue = insertThread t runqueue,+                              threads  = Map.insert (threadId t) t threads+                            }+              Just _  -> st+          )+          simState'+          throwToThread++  where+    -- we launch a thread responsible for throwing an AsyncCancelled exception+    -- to the thread which timeout expired+    throwToThread :: [(Thread s a, TMVar (IOSim s) IOSimThreadId)]++    (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired+      where+        fn :: SimState s a+           -> (IOSimThreadId, TimeoutId, TMVar (IOSim s) IOSimThreadId)+           -> (SimState s a, (Thread s a, TMVar (IOSim s) IOSimThreadId))+        fn state@SimState { threads } (tid, tmid, lock) =+          let t = case tid `Map.lookup` threads of+                    Just t' -> t'+                    Nothing -> error ("IOSimPOR: internal error: unknown thread " ++ show tid)+              nextId   = threadNextTId t+              tid'     = childThreadId tid nextId+           in ( state { threads = Map.insert tid t { threadNextTId = succ nextId } threads }+              , ( Thread { threadId      = tid',+                           threadControl =+                            ThreadControl+                              (runIOSim $ do+                                 mtid <- myThreadId+                                 v2 <- atomically $ tryPutTMVar lock mtid+                                 when v2 $+                                   throwTo tid (toException (TimeoutException tmid)))+                              ForkFrame,+                           threadStatus  = ThreadRunning,+                           threadMasking = Unmasked,+                           threadThrowTo = [],+                           threadClockId = threadClockId t,+                           threadLabel   = Just "timeout-forked-thread",+                           threadNextTId = 1,+                           threadStep    = 0,+                           threadVClock  = insertVClock tid' 0+                                         $ threadVClock t,+                           threadEffect  = mempty,+                           threadRacy    = threadRacy t+                         }+                , lock+                )+              )+++-- | Iterate through the control stack to find an enclosing exception handler+-- of the right type, or unwind all the way to the top level for the thread.+--+-- Also return if it's the main thread or a forked thread since we handle the+-- cases differently.+--+unwindControlStack :: forall s a.+                      SomeException+                   -> Thread s a+                   -> Timeouts s+                   -> ( Either Bool (Thread s a)+                      , Timeouts s+                      )+unwindControlStack e thread = \timeouts ->+    case threadControl thread of+      ThreadControl _ ctl -> unwind (threadMasking thread) ctl timeouts+  where+    unwind :: forall s' c. MaskingState+           -> ControlStack s' c a+           -> Timeouts s+           -> (Either Bool (Thread s' a), Timeouts s)+    unwind _  MainFrame                 timers = (Left True, timers)+    unwind _  ForkFrame                 timers = (Left False, timers)+    unwind _ (MaskFrame _k maskst' ctl) timers = unwind maskst' ctl timers++    unwind maskst (CatchFrame handler k ctl) timers =+      case fromException e of+        -- not the right type, unwind to the next containing handler+        Nothing -> unwind maskst ctl timers++        -- Ok! We will be able to continue the thread with the handler+        -- followed by the continuation after the catch+        Just e' -> ( Right thread {+                          -- As per async exception rules, the handler is run+                          -- masked+                         threadControl = ThreadControl (handler e')+                                                       (MaskFrame k maskst ctl),+                         threadMasking = atLeastInterruptibleMask maskst+                       }+                   , timers+                   )++    -- Either Timeout fired or the action threw an exception.+    -- - If Timeout fired, then it was possibly during this thread's execution+    --   so we need to run the continuation with a Nothing value.+    -- - If the timeout action threw an exception we need to keep unwinding the+    --   control stack looking for a handler to this exception.+    unwind maskst (TimeoutFrame tmid isLockedRef k ctl) timers =+        case fromException e of+          -- Exception came from timeout expiring+          Just (TimeoutException tmid')  | tmid == tmid' ->+            (Right thread { threadControl = ThreadControl (k Nothing) ctl }, timers')+            -- Exception came from a different exception+          _ -> unwind maskst ctl timers'+      where+        -- Remove the timeout associated with the 'TimeoutFrame'.+        timers' = IPSQ.delete (coerce tmid) timers++    unwind maskst (DelayFrame tmid _k ctl) timers =+        unwind maskst ctl timers'+      where+        -- Remove the timeout associated with the 'DelayFrame'.+        timers' = IPSQ.delete (coerce tmid) timers++    atLeastInterruptibleMask :: MaskingState -> MaskingState+    atLeastInterruptibleMask Unmasked = MaskedInterruptible+    atLeastInterruptibleMask ms       = ms+++removeMinimums :: (Coercible Int k, Ord p)+               => IntPSQ p a+               -> Maybe ([k], p, [a], IntPSQ p a)+removeMinimums = \psq -> coerce $+    case IPSQ.minView psq of+      Nothing              -> Nothing+      Just (k, p, x, psq') -> Just (collectAll [k] p [x] psq')+  where+    collectAll ks p xs psq =+      case IPSQ.minView psq of+        Just (k, p', x, psq')+          | p == p' -> collectAll (k:ks) p (x:xs) psq'+        _           -> (reverse ks, p, reverse xs, psq)++traceMany :: [(SI.Time, IOSimThreadId, Int, Maybe ThreadLabel, SimEventType)]+          -> SimTrace a -> SimTrace a+traceMany []                                   trace = trace+traceMany ((time, tid, tstep, tlbl, event):ts) trace =+    SimPORTrace time tid tstep tlbl event (traceMany ts trace)++lookupThreadLabel :: IOSimThreadId -> Map IOSimThreadId (Thread s a) -> Maybe ThreadLabel+lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads)+++-- | The most general method of running 'IOSim' is in 'ST' monad.  One can+-- recover failures or the result from 'SimTrace' with 'traceResult', or access+-- 'TraceEvent's generated by the computation with 'traceEvents'.  A slightly+-- more convenient way is exposed by 'runSimTrace'.+--+runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)+runSimTraceST mainAction = controlSimTraceST Nothing ControlDefault mainAction++controlSimTraceST :: Maybe Int -> ScheduleControl -> IOSim s a -> ST s (SimTrace a)+controlSimTraceST limit control mainAction =+  SimPORTrace (curTime initialState)+              (threadId mainThread)+              0+              (threadLabel mainThread)+              (EventSimStart control)+  <$> schedule mainThread initialState { control  = control,+                                         control0 = control,+                                         perStepTimeLimit = limit+                                       }+  where+    mainThread =+      Thread {+        threadId      = ThreadId [],+        threadControl = ThreadControl (runIOSim mainAction) MainFrame,+        threadStatus  = ThreadRunning,+        threadMasking = Unmasked,+        threadThrowTo = [],+        threadClockId = ClockId [],+        threadLabel   = Just "main",+        threadNextTId = 1,+        threadStep    = 0,+        threadVClock  = insertVClock (ThreadId []) 0 bottomVClock,+        threadEffect  = mempty,+        threadRacy    = False+      }+++--+-- Executing STM Transactions+--++execAtomically :: forall s a c.+                  SI.Time+               -> IOSimThreadId+               -> [Labelled IOSimThreadId]+               -> Maybe ThreadLabel+               -> VarId+               -> StmA s a+               -> (StmTxResult s a -> ST s (SimTrace c))+               -> ST s (SimTrace c)+execAtomically !time !tid threads !tlbl !nextVid0 !action0 !k0 =+    go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0+  where+    go :: forall b.+          StmStack s b a+       -> Map TVarId (SomeTVar s)  -- set of vars read+       -> Map TVarId (SomeTVar s)  -- set of vars written+       -> [SomeTVar s]             -- vars written in order (no dups)+       -> [SomeTVar s]             -- vars created in order+       -> VarId                   -- var fresh name supply+       -> StmA s b+       -> ST s (SimTrace c)+    go !ctl !read !written !writtenSeq !createdSeq !nextVid !action =+      assert localInvariant $+      case action of+      ReturnStm x ->+        case ctl of+        AtomicallyFrame -> do+          -- Trace each created TVar+          !ds  <- traverse (\(SomeTVar tvar) -> traceTVarST tvar True) createdSeq+          -- Trace & commit each TVar+          !ds' <- Map.elems <$> traverse+                    (\(SomeTVar tvar) -> do+                        tr <- traceTVarST tvar False+                        !_ <- commitTVar tvar+                        -- Also assert the data invariant that outside a tx+                        -- the undo stack is empty:+                        undos <- readTVarUndos tvar+                        assert (null undos) $ return tr+                    ) written++          -- Return the vars written, so readers can be unblocked+          k0 $ StmTxCommitted x (reverse writtenSeq)+                                (Map.elems read)+                                (reverse createdSeq)+                                (mapMaybe (\TraceValue { traceDynamic }+                                            -> toDyn <$> traceDynamic)+                                          $ ds ++ ds')+                                (mapMaybe traceString $ ds ++ ds')+                                nextVid++        BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do+          -- The branch has successfully completed the transaction. Hence,+          -- the alternative branch can be ignored.+          -- Commit the TVars written in this sub-transaction that are also+          -- in the written set of the outer transaction+          !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)+                          (Map.intersection written writtenOuter)+          -- Merge the written set of the inner with the outer+          let written'    = Map.union written writtenOuter+              writtenSeq' = filter (\(SomeTVar tvar) ->+                                      tvarId tvar `Map.notMember` writtenOuter)+                                    writtenSeq+                         ++ writtenOuterSeq+              createdSeq' = createdSeq ++ createdOuterSeq+          -- Skip the orElse right hand and continue with the k continuation+          go ctl' read written' writtenSeq' createdSeq' nextVid (k x)++      ThrowStm e ->+        throwStm ctl read written nextVid e++      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 -> do+        -- Always revert all the TVar writes for the retry+        !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written+        case ctl of+          AtomicallyFrame -> do+            -- Return vars read, so the thread can block on them+            k0 $! StmTxBlocked $! Map.elems read++          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' -> 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 -> 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 mkId !mbLabel x k -> do+        !v <- execNewTVar (mkId 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+        -- save the value: it will be committed or reverted+        !_ <- saveTVar v+        go ctl read written' writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v)++      LabelTVar !label tvar k -> do+        !_ <- writeSTRef (tvarLabel tvar) $! (Just label)+        go ctl read written writtenSeq createdSeq nextVid k++      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 -> do+            x <- execReadTVar v+            go ctl read written writtenSeq createdSeq nextVid (k x)+        | 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 -> do+            !_ <- execWriteTVar v x+            go ctl read written writtenSeq createdSeq nextVid k+        | 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 -> do+        mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                          Nothing -> Just e+                                          Just {} -> Nothing)+                             $ evaluate (force msg)+        case mbNF of+          Left e -> do+            trace <- throwStm ctl read written nextVid e+            -- TODO: step+            return $ SimPORTrace time tid (-1) tlbl (EventSayEvaluationError e)+                   $ trace+          Right msg' -> do+            trace <- go ctl read written writtenSeq createdSeq nextVid k+            -- TODO: step+            return $ SimPORTrace time tid (-1) tlbl (EventSay msg') trace++      OutputStm x@(Dynamic _ x') k -> do+        mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+                                            Nothing -> Just e+                                            Just {} -> Nothing)+                               $ evaluate x'+        case mbWHNF of+          Left e -> do+            trace <- throwStm ctl read written nextVid e+            -- TODO: step+            return $ SimPORTrace time tid (-1) tlbl (EventLogEvaluationError e)+                   $ trace+          Right {} -> do+            trace <- go ctl read written writtenSeq createdSeq nextVid k+            -- TODO: step+            return $ SimPORTrace time tid (-1) tlbl (EventLog x) trace++      LiftSTStm st k -> do+        x <- strictToLazyST st+        go ctl read written writtenSeq createdSeq nextVid (k x)++      FixStm f k -> do+        r <- newSTRef (throw NonTermination)+        x <- unsafeInterleaveST $ readSTRef r+        let k' = unSTM (f x) $ \x' ->+                    LiftSTStm (lazyToStrictST (writeSTRef r x')) (\() -> k x')+        go ctl read written writtenSeq createdSeq nextVid k'++      where+        localInvariant =+            Map.keysSet written+         == Set.fromList ([ tvarId tvar | SomeTVar tvar <- writtenSeq ]+                       ++ [ tvarId tvar | SomeTVar tvar <- createdSeq ])++    -- throw an exception in an STM transaction+    throwStm :: forall b.+                StmStack s b a+             -> Map TVarId (SomeTVar s)+             -> Map TVarId (SomeTVar s)+             -> VarId+             -> SomeException+             -> ST s (SimTrace c)+    throwStm ctl read written nextVid 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' -> 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' -> do+          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)++        BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do+          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)   -- | Special case of 'execAtomically' supporting only var reads and writes

@@ -7,6 +7,7 @@   , fromList   , head   , tail+  , last   , filter   , length   , take@@ -15,7 +16,7 @@   , dropWhile   ) where -import Prelude hiding (drop, dropWhile, filter, head, length, tail, take,+import Prelude hiding (drop, dropWhile, filter, head, last, length, tail, take,            takeWhile)  import Control.Applicative (Alternative (..))@@ -45,6 +46,10 @@ tail :: Trace a b -> Trace a b tail (Cons _ o) = o tail Nil {}     = error "Trace.tail: empty"++last :: Trace a b -> a+last (Cons _ k) = last k+last (Nil a)    = a  filter :: (b -> Bool) -> Trace a b -> Trace a b filter _fn o@Nil {}   = o

@@ -17,8 +17,10 @@   , TimeoutDuration   , ActionDuration   , singleTimeoutExperiment+  , TraceBottom (..)   ) where +import Data.Bifoldable (bifoldMap) import Data.Either (isLeft) import Data.Fixed (Micro) #if __GLASGOW_HASKELL__ < 910@@ -27,7 +29,7 @@ import Data.Functor (($>)) import Data.Time.Clock (picosecondsToDiffTime) -import Control.Exception (ArithException (..), AsyncException)+import Control.Exception (ArithException (..), AsyncException, ErrorCall (..)) import Control.Monad import Control.Monad.Fix import System.IO.Error (ioeGetErrorString, isUserError)@@ -70,6 +72,12 @@     , testProperty "threadDelay and STM"    unit_threadDelay_and_stm     , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay     , testProperty "throwTo and STM"        unit_throwTo_and_stm+    , testGroup "trace bottom"+      [ testProperty "say"                  unit_trace_bottom_say+      , testProperty "dynamic"              unit_trace_bottom_dynamic+      , testProperty "saySTM"               unit_trace_bottom_saySTM+      , testProperty "dynamicSTM"           unit_trace_bottom_dynamicSTM+      ]     ]   , testGroup "QuickCheck"     [ testProperty "timeout: discardAfter"  unit_discardAfter@@ -425,7 +433,7 @@   :: Property  -- unhandled top level exception-unit_catch_0 =+unit_catch_0 = once $       runSimTraceSay example === ["before"]  .&&. case traceResult True (runSimTrace example) of         Left (FailureException e) -> property (maybe False (==DivideByZero) $ fromException e)@@ -439,7 +447,7 @@     say "after"  -- normal execution of a catch frame-unit_catch_1 =+unit_catch_1 = once $     runSimTraceSay       (do catch (say "inner") (\(_e :: IOError) -> say "handler")           say "after"@@ -449,7 +457,7 @@   -- catching an exception thrown in a catch frame-unit_catch_2 =+unit_catch_2 = once $     runSimTraceSay       (do catch (do say "inner1"                     _ <- throwIO DivideByZero@@ -462,7 +470,7 @@   -- not catching an exception of the wrong type-unit_catch_3 =+unit_catch_3 = once $     runSimTraceSay       (do catch (do say "inner"                     throwIO DivideByZero)@@ -474,7 +482,7 @@   -- catching an exception in an outer handler-unit_catch_4 =+unit_catch_4 = once $     runSimTraceSay       (do catch (catch (do say "inner"                            throwIO DivideByZero)@@ -487,7 +495,7 @@   -- catching an exception in the inner handler-unit_catch_5 =+unit_catch_5 = once $     runSimTraceSay       (do catch (catch (do say "inner"                            throwIO DivideByZero)@@ -500,7 +508,7 @@   -- catching an exception in the inner handler, rethrowing and catching in outer-unit_catch_6 =+unit_catch_6 = once $     runSimTraceSay       (do catch (catch (do say "inner"                            throwIO DivideByZero)@@ -516,14 +524,14 @@  -- evaluate should catch pure errors unit_evaluate_0 :: Property-unit_evaluate_0 =+unit_evaluate_0 = once $     -- This property also fails if the @error@ is not caught by the sim monad     -- and instead reaches the QuickCheck driver.     property $ isLeft $ runSim $ evaluate (error "boom" :: ())   -- The sim terminates when the main thread terminates-unit_fork_1 =+unit_fork_1 = once $       runSimTraceSay example === ["parent"]  .&&. case traceResult True (runSimTrace example) of         Left FailureSloppyShutdown{} -> property True@@ -536,7 +544,7 @@  -- Try works and we can pass exceptions back from threads. -- And terminating with an exception is reported properly.-unit_fork_2 =+unit_fork_2 = once $       runSimTraceSay example === ["parent", "user error (oh noes!)"]  .&&. case traceResult True (runSimTrace example) of         Left (FailureException e)@@ -568,7 +576,7 @@   :: Property  -unit_async_1 =+unit_async_1 = once $     runSimTraceSay       (do mtid <- myThreadId           say ("main " ++ show mtid)@@ -581,7 +589,7 @@    ["main ThreadId []", "parent ThreadId [1]", "child ThreadId [1]"]  -unit_async_2 =+unit_async_2 = once $     runSimTraceSay       (do tid <- myThreadId           say "before"@@ -592,7 +600,7 @@    ["before"]  -unit_async_3 =+unit_async_3 = once $     runSimTraceSay       (do tid <- myThreadId           catch (do say "before"@@ -603,7 +611,7 @@    ["before", "handler"]  -unit_async_4 =+unit_async_4 = once $     runSimTraceSay       (do tid <- forkIO $ say "child"           threadDelay 1@@ -614,7 +622,7 @@    ["child", "parent done"]  -unit_async_5 =+unit_async_5 = once $     runSimTraceSay       (do tid <- forkIO $ do                    say "child"@@ -629,7 +637,7 @@    ["child", "handler", "child done", "parent done"]  -unit_async_6 =+unit_async_6 = once $     runSimTraceSay       (do tid <- forkIO $ mask_ $                    do@@ -649,7 +657,7 @@    ["child", "child masked", "handler", "child done", "parent done"]  -unit_async_7 =+unit_async_7 = once $     runSimTraceSay       (do tid <- forkIO $                    mask $ \restore -> do@@ -669,7 +677,7 @@    ["child", "child masked", "handler", "child done", "parent done"]  -unit_async_8 =+unit_async_8 = once $     runSimTraceSay       (do tid <- forkIO $ do                    catch (do mask_ $ do@@ -689,7 +697,7 @@    ["child", "child masked", "handler", "child done", "parent done"]  -unit_async_9 =+unit_async_9 = once $     runSimTraceSay       (do tid <- forkIO $                    mask_ $ do@@ -705,7 +713,7 @@    ["child", "parent done"]  -unit_async_10 =+unit_async_10 = once $     runSimTraceSay       (do tid1 <- forkIO $ do                     mask_ $ do@@ -733,7 +741,7 @@    ["child 1", "child 2", "child 1 running", "parent done"]  -unit_async_11 =+unit_async_11 = once $     runSimTraceSay       (do tid1 <- forkIO $ do                     mask_ $ do@@ -765,7 +773,7 @@    ["child 1", "child 2", "child 1 running", "parent done"]  -unit_async_12 =+unit_async_12 = once $     runSimTraceSay       (do tid <- forkIO $ do                    uninterruptibleMask_ $ do@@ -786,7 +794,7 @@    ["child", "child masked", "child done", "parent done"]  -unit_async_13 =+unit_async_13 = once $     case runSim            (uninterruptibleMask_ $ do               tid <- forkIO $ atomically retry@@ -795,7 +803,7 @@           _                       -> property False  -unit_async_14 =+unit_async_14 = once $     runSimTraceSay       (do tid <- forkIO $ do                    uninterruptibleMask_ $ do@@ -816,7 +824,7 @@    ["child", "child masked", "child done", "parent done"]  -unit_async_15 =+unit_async_15 = once $     runSimTraceSay       (do tid <- forkIO $                    uninterruptibleMask $ \restore -> do@@ -836,7 +844,7 @@    ["child", "child masked", "handler", "child done", "parent done"]  -unit_async_16 =+unit_async_16 = once $     runSimTraceSay       (do tid <- forkIO $ do                    catch (do uninterruptibleMask_ $ do@@ -1089,7 +1097,8 @@ -- moving the thunk outside of the lambda, and evaluating it just once. -- unit_discardAfter :: Property-unit_discardAfter = mapTotalResult f+unit_discardAfter = once+                  . mapTotalResult f                   . discardAfter 10                   $ \() -> runSimOrThrow $ True <$ (forever (threadDelay 10))   where@@ -1108,7 +1117,8 @@ -- | Check that `within` works as expected. -- unit_within :: Property-unit_within = mapTotalResult f+unit_within = once+            . mapTotalResult f             . within 10             $ runSimOrThrow $ True <$ (forever (threadDelay 10))   where@@ -1122,7 +1132,7 @@   unit_timeouts_and_async_exceptions_1 :: Property-unit_timeouts_and_async_exceptions_1 =+unit_timeouts_and_async_exceptions_1 = once $     let trace = runSimTrace experiment in         counterexample (ppTrace_ trace)       . either (\e -> counterexample (show e) False) id@@ -1143,7 +1153,7 @@   unit_timeouts_and_async_exceptions_2 :: Property-unit_timeouts_and_async_exceptions_2 =+unit_timeouts_and_async_exceptions_2 = once $     let trace = runSimTrace experiment in         counterexample (ppTrace_ trace)       . either (\e -> counterexample (show e) False) id@@ -1164,7 +1174,7 @@   unit_timeouts_and_async_exceptions_3 :: Property-unit_timeouts_and_async_exceptions_3 =+unit_timeouts_and_async_exceptions_3 = once $     let trace = runSimTrace experiment in         counterexample (ppTrace_ trace)       . either (\e -> counterexample (show e) False) id@@ -1188,7 +1198,7 @@ -- transaction. -- unit_threadDelay_and_stm :: Property-unit_threadDelay_and_stm =+unit_threadDelay_and_stm = once $     let trace = runSimTrace experiment in         counterexample (ppTrace_ trace)       . either (\e -> counterexample (show e) False) id@@ -1216,7 +1226,7 @@       return (t1 `diffTime` t0 === delay)  unit_registerDelay_threadDelay :: Property-unit_registerDelay_threadDelay =+unit_registerDelay_threadDelay = once $     let trace = runSimTrace experiment in         counterexample (ppTrace_ trace)       . either (\e -> counterexample (show e) False) id@@ -1248,7 +1258,7 @@ -- transaction. -- unit_throwTo_and_stm :: Property-unit_throwTo_and_stm =+unit_throwTo_and_stm = once $     let trace = runSimTrace experiment in         counterexample (ppTrace_ trace)       . either (\e -> counterexample (show e) False) id@@ -1277,68 +1287,116 @@        return (t1 `diffTime` t0 === delay) ++data TraceBottom = TraceBottomSay+                 | TraceBottomDynamic+                 | TraceBottomSaySTM+                 | TraceBottomDynamicSTM++prop_trace_bottom :: TraceBottom -> Property+prop_trace_bottom tb =+    let trace = runSimTrace sim in+    property $+    bifoldMap+      (\_ -> Some False)+      (\ev ->+        case seType ev of+          EventSayEvaluationError e+            | Just ErrorCall{} <- fromException e+            -> Some True+          EventLogEvaluationError e+            | Just ErrorCall{} <- fromException e+            -> Some True+          _ -> Some False+      )+      trace+  where+    sim :: IOSim s ()+    sim = case tb of+      TraceBottomSay ->+        say (error "bottom")+      TraceBottomDynamic ->+        traceM (error "bottom" :: String)+      TraceBottomSaySTM ->+        atomically $ say (error "bottom")+      TraceBottomDynamicSTM ->+        atomically $ traceSTM (error "bottom" :: String)++unit_trace_bottom_say :: Property+unit_trace_bottom_say = once (prop_trace_bottom TraceBottomSay)++unit_trace_bottom_dynamic :: Property+unit_trace_bottom_dynamic = once (prop_trace_bottom TraceBottomDynamic)++unit_trace_bottom_saySTM :: Property+unit_trace_bottom_saySTM = once (prop_trace_bottom TraceBottomSaySTM)++unit_trace_bottom_dynamicSTM :: Property+unit_trace_bottom_dynamicSTM = once (prop_trace_bottom TraceBottomDynamicSTM)++ -- -- MonadMask properties --  unit_set_masking_state_IO :: MaskingState -> Property-unit_set_masking_state_IO =+unit_set_masking_state_IO = once .     ioProperty . prop_set_masking_state  unit_set_masking_state_ST :: MaskingState -> Property-unit_set_masking_state_ST ms =+unit_set_masking_state_ST ms = once $     runSimOrThrow (prop_set_masking_state ms)  unit_unmask_IO :: MaskingState -> MaskingState -> Property-unit_unmask_IO ms ms' = ioProperty $ prop_unmask ms ms'+unit_unmask_IO ms ms' = once $ ioProperty $ prop_unmask ms ms'  unit_unmask_ST :: MaskingState -> MaskingState -> Property-unit_unmask_ST ms ms' = runSimOrThrow $ prop_unmask ms ms'+unit_unmask_ST ms ms' = once $ runSimOrThrow $ prop_unmask ms ms'  unit_fork_masking_state_IO :: MaskingState -> Property-unit_fork_masking_state_IO =+unit_fork_masking_state_IO = once .     ioProperty . prop_fork_masking_state  unit_fork_masking_state_ST :: MaskingState -> Property-unit_fork_masking_state_ST ms =+unit_fork_masking_state_ST ms = once $     runSimOrThrow (prop_fork_masking_state ms)  unit_fork_unmask_IO :: MaskingState -> MaskingState -> Property-unit_fork_unmask_IO ms ms' = ioProperty $ prop_fork_unmask ms ms'+unit_fork_unmask_IO ms ms' = once $ ioProperty $ prop_fork_unmask ms ms'  unit_fork_unmask_ST :: MaskingState -> MaskingState -> Property-unit_fork_unmask_ST ms ms' = runSimOrThrow $ prop_fork_unmask ms ms'+unit_fork_unmask_ST ms ms' = once $ runSimOrThrow $ prop_fork_unmask ms ms'  unit_catch_throwIO_masking_state_IO :: MaskingState -> Property-unit_catch_throwIO_masking_state_IO ms =+unit_catch_throwIO_masking_state_IO ms = once $     ioProperty $ prop_catch_throwIO_masking_state ms  unit_catch_throwIO_masking_state_ST :: MaskingState -> Property-unit_catch_throwIO_masking_state_ST ms =+unit_catch_throwIO_masking_state_ST ms = once $     runSimOrThrow (prop_catch_throwIO_masking_state ms)  unit_catch_throwTo_masking_state_IO :: MaskingState -> Property-unit_catch_throwTo_masking_state_IO =+unit_catch_throwTo_masking_state_IO = once .     ioProperty . prop_catch_throwTo_masking_state  unit_catch_throwTo_masking_state_ST :: MaskingState -> Property-unit_catch_throwTo_masking_state_ST ms =+unit_catch_throwTo_masking_state_ST ms = once $     runSimOrThrow $ prop_catch_throwTo_masking_state ms  unit_catch_throwTo_masking_state_async_IO :: MaskingState -> Property-unit_catch_throwTo_masking_state_async_IO =+unit_catch_throwTo_masking_state_async_IO = once .     ioProperty . prop_catch_throwTo_masking_state_async  unit_catch_throwTo_masking_state_async_ST :: MaskingState -> Property-unit_catch_throwTo_masking_state_async_ST ms =+unit_catch_throwTo_masking_state_async_ST ms = once $     runSimOrThrow (prop_catch_throwTo_masking_state_async ms)  unit_catch_throwTo_masking_state_async_mayblock_IO :: MaskingState -> Property-unit_catch_throwTo_masking_state_async_mayblock_IO =+unit_catch_throwTo_masking_state_async_mayblock_IO = once .     ioProperty . prop_catch_throwTo_masking_state_async_mayblock  unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property-unit_catch_throwTo_masking_state_async_mayblock_ST ms =+unit_catch_throwTo_masking_state_async_mayblock_ST ms = once $     runSimOrThrow (prop_catch_throwTo_masking_state_async_mayblock ms)  --

@@ -6,6 +6,7 @@  module Test.Control.Monad.IOSimPOR (tests) where +import Data.Bifoldable (bifoldMap) import Data.Fixed (Micro) #if __GLASGOW_HASKELL__ >= 910 import Data.Foldable (traverse_)@@ -20,7 +21,7 @@ import System.Exit import System.IO.Error (ioeGetErrorString, isUserError) -import Control.Exception (ArithException (..), AsyncException)+import Control.Exception (ArithException (..), AsyncException, ErrorCall (..)) import Control.Monad import Control.Monad.Fix @@ -37,8 +38,8 @@ import GHC.Generics  import Test.Control.Monad.IOSim (ActionDuration, TimeoutDuration,-           WithSanityCheck (..), ignoreSanityCheck, isSanityCheckIgnored,-           singleTimeoutExperiment, withSanityCheck)+           TraceBottom (..), WithSanityCheck (..), ignoreSanityCheck,+           isSanityCheckIgnored, singleTimeoutExperiment, withSanityCheck) import Test.Control.Monad.STM import Test.Control.Monad.Utils @@ -76,6 +77,12 @@       , testProperty "timeouts"               prop_timeouts       , testProperty "stacked timeouts"       prop_stacked_timeouts       , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay+      , testGroup "trace bottom"+        [ testProperty "say"                  unit_trace_bottom_say+        , testProperty "dynamic"              unit_trace_bottom_dynamic+        , testProperty "saySTM"               unit_trace_bottom_saySTM+        , testProperty "dynamicSTM"           unit_trace_bottom_dynamicSTM+        ]       ]     , testProperty "infinite simulation"      prop_explore_endless_simulation     , testProperty "threadId order (IOSim)"   (withMaxSuccess 1000 prop_threadId_order_order_Sim)@@ -1053,6 +1060,49 @@       t1 <- getMonotonicTime        return (t1 `diffTime` t0 === delay)+++prop_trace_bottom :: TraceBottom -> Property+prop_trace_bottom tb =+    exploreSimTrace id sim $ \_ trace ->+      property $+      bifoldMap+        (\_ -> Some False)+        (\ev ->+          case seType ev of+            EventSayEvaluationError e+              | Just ErrorCall{} <- fromException e+              -> Some True+            EventLogEvaluationError e+              | Just ErrorCall{} <- fromException e+              -> Some True+            _ -> Some False+        )+        trace+  where+    sim :: IOSim s ()+    sim = case tb of+      TraceBottomSay ->+        say (error "bottom")+      TraceBottomDynamic ->+        traceM (error "bottom" :: String)+      TraceBottomSaySTM ->+        atomically $ say (error "bottom")+      TraceBottomDynamicSTM ->+        atomically $ traceSTM (error "bottom" :: String)++unit_trace_bottom_say :: Property+unit_trace_bottom_say = once (prop_trace_bottom TraceBottomSay)++unit_trace_bottom_dynamic :: Property+unit_trace_bottom_dynamic = once (prop_trace_bottom TraceBottomDynamic)++unit_trace_bottom_saySTM :: Property+unit_trace_bottom_saySTM = once (prop_trace_bottom TraceBottomSaySTM)++unit_trace_bottom_dynamicSTM :: Property+unit_trace_bottom_dynamicSTM = once (prop_trace_bottom TraceBottomDynamicSTM)+  unit_timeouts_and_async_exceptions_1 :: Property unit_timeouts_and_async_exceptions_1 =