diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/io-sim.cabal b/io-sim.cabal --- a/io-sim.cabal +++ b/io-sim.cabal @@ -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, diff --git a/src/Control/Monad/IOSim.hs b/src/Control/Monad/IOSim.hs --- a/src/Control/Monad/IOSim.hs +++ b/src/Control/Monad/IOSim.hs @@ -363,7 +363,7 @@ deriving Show instance Exception Failure where - displayException (FailureException err) = displayException err + displayException (FailureException err) = displayException err displayException (FailureDeadlock threads) = concat [ "< 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 diff --git a/src/Control/Monad/IOSim/Types.hs b/src/Control/Monad/IOSim/Types.hs --- a/src/Control/Monad/IOSim/Types.hs +++ b/src/Control/Monad/IOSim/Types.hs @@ -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 -> diff --git a/src/Control/Monad/IOSimPOR/Internal.hs b/src/Control/Monad/IOSimPOR/Internal.hs --- a/src/Control/Monad/IOSimPOR/Internal.hs +++ b/src/Control/Monad/IOSimPOR/Internal.hs @@ -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 $! "<>") - 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 $! "<>") - 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 $! "<>") - 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 $! "<>") + 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 $! "<>") + 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 $! "<>") + 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 diff --git a/src/Data/List/Trace.hs b/src/Data/List/Trace.hs --- a/src/Data/List/Trace.hs +++ b/src/Data/List/Trace.hs @@ -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 diff --git a/test/Test/Control/Monad/IOSim.hs b/test/Test/Control/Monad/IOSim.hs --- a/test/Test/Control/Monad/IOSim.hs +++ b/test/Test/Control/Monad/IOSim.hs @@ -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) -- diff --git a/test/Test/Control/Monad/IOSimPOR.hs b/test/Test/Control/Monad/IOSimPOR.hs --- a/test/Test/Control/Monad/IOSimPOR.hs +++ b/test/Test/Control/Monad/IOSimPOR.hs @@ -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 =