io-sim 1.9.1.0 → 1.11.0.0
raw patch · 12 files changed
Files
- CHANGELOG.md +54/−0
- NOTICE +1/−1
- README.md +3/−3
- io-sim.cabal +10/−8
- src/Control/Monad/IOSim.hs +91/−3
- src/Control/Monad/IOSim/Internal.hs +12/−4
- src/Control/Monad/IOSim/Types.hs +29/−12
- src/Control/Monad/IOSimPOR/Internal.hs +473/−465
- src/Data/List/Trace.hs +6/−1
- test/Test/Control/Monad/IOSim.hs +56/−54
- test/Test/Control/Monad/IOSimPOR.hs +34/−4
- test/Test/Control/Monad/Utils.hs +7/−1
CHANGELOG.md view
@@ -1,5 +1,59 @@ # Revision history of io-sim +## 1.11.0.0++### Breaking changes++* Removed `EventSayEvaluationError` and `EventLogEvaluationError`.++### Non-breaking changes++* Added `ppSayTrace` which pritty prints `EventSay` which are coming from `say` usage.+* Repository moved to https://github.com/IntersectMBO/io-sim+* Exported `traceMarker`, `traceEvent` from `Control.Monad.Class.MonadEventlog`.+* `say`, `traceM` and `traceSTM` no longer evaluate their arguments to _NF_ or+ _WHNF_. This is dropped since it introduced a performance regression in+ `io-sim-1.10` on large tests which include `say` used just for debugging+ purposes.++## 1.10.1.0++### Non-breaking changes++* Added `IOSimPOR` `QuickCheck` combinators:+ * `monadicIOSimPOR_`+ * `monadicIOSimPOR`+ * `runIOSimPORGen`+* Support ghc-9.14+* Support QuickCheck-2.18.0.0++## 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,+ none of them now catch asynchronous exceptions.+* Added `IOSimPOR` QuickCheck monadic combinators:+ `monadicIOSimPOR`, `monadicIOSimPOR_` and `runIOSimPORGen`.+ ## 1.9.1.0 ### Non-breaking changes
NOTICE view
@@ -1,4 +1,4 @@-Copyright 2019-2024 Input Output Global Inc (IOG)+Copyright 2019-2026 Input Output Global Inc (IOG), 2026 Intersect Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
README.md view
@@ -47,9 +47,9 @@ * [Marcin Szamotulski (@coot) IOSim and Partial Order Reduction][io-sim-por-presentation] [`io-sim`]: https://hackage.haskell.org/package/io-sim-[`io-classes`]: https://input-output-hk.github.io/io-sim/io-classes/index.html-[`si-timers`]: https://input-output-hk.github.io/io-sim/io-classes/si-timers/index.html-[`IOSimPOR`]: https://github.com/input-output-hk/io-sim/tree/main/io-sim/how-to-use-IOSimPOR.md+[`io-classes`]: https://intersectmbo/io-sim/io-classes/index.html+[`si-timers`]: https://intersectmbo/io-sim/io-classes/si-timers/index.html+[`IOSimPOR`]: https://github.com/intersectmbo/io-sim/tree/main/io-sim/how-to-use-IOSimPOR.md [`IOSim`]: https://hackage.haskell.org/package/io-sim/docs/Control-Monad-IOSim.html#t:IOSim [bob-conf]: https://youtu.be/uedUGeWN4ZM
io-sim.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: io-sim-version: 1.9.1.0+version: 1.11.0.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurrency (base & async style), stm,@@ -9,17 +9,17 @@ = Documentation Documentation is published- [here](https://input-output-hk.github.io/io-sim/io-sim).+ [here](https://intersectmbo.github.io/io-sim/io-sim). license: Apache-2.0 license-files: LICENSE NOTICE-copyright: 2022-2025 Input Output Global Inc (IOG)+copyright: 2022-2026 Input Output Global Inc (IOG) 2026 Intersect author: Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Testing build-type: Simple extra-doc-files: CHANGELOG.md README.md-bug-reports: https://github.com/input-output-hk/io-sim/issues-tested-with: GHC == { 9.6, 9.8, 9.10, 9.12 }+bug-reports: https://github.com/intersectmbo/io-sim/issues+tested-with: GHC == { 9.6, 9.8, 9.10, 9.12, 9.14 } flag asserts description: Enable assertions@@ -28,7 +28,7 @@ source-repository head type: git- location: https://github.com/input-output-hk/io-sim+ location: https://github.com/intersectmbo/io-sim subdir: io-sim common test-warnings@@ -64,9 +64,9 @@ default-extensions: LambdaCase if impl(ghc < 9.4) default-extensions: GADTs- build-depends: base >=4.16 && <4.22,+ build-depends: base >=4.16 && <4.23, io-classes:{io-classes,strict-stm,si-timers}- ^>=1.9,+ ^>=1.11, exceptions >=0.10, containers, deepseq,@@ -112,6 +112,8 @@ -rtsopts if impl(ghc >= 9.8) ghc-options: -Wno-x-partial+ if impl(ghc >= 9.14)+ ghc-options: -Wno-incomplete-record-selectors benchmark bench import: warnings
src/Control/Monad/IOSim.hs view
@@ -18,6 +18,9 @@ , monadicIOSim , runIOSimGen -- ** Explore races using /IOSimPOR/+ , monadicIOSimPOR_+ , monadicIOSimPOR+ , runIOSimPORGen -- $iosimpor , exploreSimTrace , controlSimTrace@@ -55,6 +58,7 @@ -- ** Pretty printers , ppTrace , ppTrace_+ , ppSayTrace , ppEvents , ppSimEvent , ppDebug@@ -358,7 +362,7 @@ -- | An internal failure of the simulator. -- -- Please open an issue at- -- <https://github.com/input-output-hk/io-sim/issues>.+ -- <https://github.com/intersectmbo/io-sim/issues>. | FailureInternal String deriving Show @@ -384,7 +388,7 @@ , msg , ">>\n" , "please report the issue at\n"- , "https://github.com/input-output-hk/io-sim/issues"+ , "https://github.com/intersectmbo/io-sim/issues" ] @@ -483,6 +487,16 @@ ] +-- | Filter `EventSay` and pretty print them.+--+ppSayTrace :: SimTrace a -> String+ppSayTrace tr = ppEvents+ [ a+ | a@(_, _, _, EventSay {})+ <- traceEvents tr+ ]++ -- | See 'runSimTraceST' below. -- runSimTrace :: forall a. (forall s. IOSim s a) -> SimTrace a@@ -497,7 +511,7 @@ -- /IOSimPOR/ is a different interpreter of 'IOSim' which has the ability to -- discover race conditions and replay the simulation using a schedule which -- reverts them. For extended documentation how to use it see--- [here](https://github.com/input-output-hk/io-sim/blob/main/io-sim/how-to-use-IOSimPOR.md).+-- [here](https://github.com/intersectmbo/io-sim/blob/main/io-sim/how-to-use-IOSimPOR.md). -- -- /IOSimPOR/ only discovers races between events which happen in the same time -- slot. In /IOSim/ and /IOSimPOR/ time only moves explicitly through timer@@ -801,3 +815,77 @@ Capture eval <- capture let trace = runSimTrace (eval sim) return (f trace)++-- | Like <runSTGen+-- https://hackage.haskell.org/package/QuickCheck-2.14.3/docs/Test-QuickCheck-Monadic.html#v:runSTGen>,+-- but evaluates generated simulations using 'exploreSimTrace'.+--+-- The callback receives the previously passing trace (if any) and the current+-- trace being checked.+--+-- @since 1.10.0.0+--+runIOSimPORGen :: Testable test+ => (ExplorationOptions -> ExplorationOptions)+ -> (Maybe (SimTrace a) -> SimTrace a -> test)+ -> (forall s. Gen (IOSim s a))+ -> Gen Property+runIOSimPORGen optsf k sim = do+ Capture eval <- capture+ pure $ exploreSimTrace optsf (eval sim) k++-- | A /IOSimPOR/ variant of 'monadicIOSim_', which:+--+-- * explores alternative schedules using 'exploreSimTrace';+-- * allows to run in monad stacks build on top of `IOSim`;+-- * gives more control how to attach debugging information to failed+-- tests.+--+-- Note, to use this combinator your monad needs to be defined as:+--+-- > newtype M s a = M { runM :: ReaderT State (IOSim s) a }+--+-- It's important that `M s` is a monad. For such a monad you'll need to+-- provide a natural transformation:+-- @+-- -- the state could also be created as an `IOSim` computation.+-- nat :: forall s a. State -> M s a -> 'IOSim' s a+-- nat state m = runStateT (runM m) state+-- @+--+-- @since 1.10.0.0+--+monadicIOSimPOR :: (Testable a, forall s. Monad (m s))+ => (ExplorationOptions -> ExplorationOptions)+ -> (Maybe (SimTrace Property) -> SimTrace Property -> Property)+ -> (forall s a. m s a -> IOSim s a)+ -> (forall s. PropertyM (m s) a)+ -> Property+monadicIOSimPOR optsf f tr sim =+ property (runIOSimPORGen optsf f (tr <$> monadic' sim))++-- | Like <monadicST+-- https://hackage.haskell.org/package/QuickCheck-2.14.3/docs/Test-QuickCheck-Monadic.html#v:monadicST>,+-- but using /IOSimPOR/ schedule exploration.+--+-- Note: it calls `traceResult` in non-strict mode, e.g. leaked threads do not+-- cause failures.+--+-- > testProperty "example" $+-- > monadicIOSimPOR_ $ do+-- > x <- run (pure (1 :: Int))+-- > assert (x == 1)+--+-- @since 1.10.0.0+--+monadicIOSimPOR_ :: Testable a+ => (forall s. PropertyM (IOSim s) a)+ -> Property+monadicIOSimPOR_ sim =+ monadicIOSimPOR+ id+ (\_ tr -> case traceResult False tr of+ Left e -> counterexample (show e) False+ Right p -> p)+ id+ sim
src/Control/Monad/IOSim/Internal.hs view
@@ -56,7 +56,8 @@ import Data.Set qualified as Set import Data.Time (UTCTime (..), fromGregorian) -import Control.Exception (NonTermination (..), assert, throw)+import Control.Exception (NonTermination (..), SomeAsyncException, assert,+ throw) import Control.Monad (join, when) import Control.Monad.ST.Lazy import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)@@ -293,16 +294,23 @@ schedule thread' simstate Evaluate expr k -> do- mbWHNF <- unsafeIOToST $ try $ evaluate expr+ mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of+ Nothing -> Just e+ Just {} -> Nothing)+ $ evaluate expr case mbWHNF of Left e -> do -- schedule this thread to immediately raise the exception let thread' = thread { threadControl = ThreadControl (Throw e) ctl }- schedule thread' simstate+ trace <- schedule thread' simstate+ return $ SimTrace time tid tlbl (EventEvaluationError e)+ $ trace Right whnf -> do -- continue with the resulting WHNF let thread' = thread { threadControl = ThreadControl (k whnf) ctl }- schedule thread' simstate+ trace <- schedule thread' simstate+ return $ SimTrace time tid tlbl EventEvaluationSuccess+ $ trace Say msg k -> do let thread' = thread { threadControl = ThreadControl k ctl }
src/Control/Monad/IOSim/Types.hs view
@@ -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" #-}@@ -150,7 +152,7 @@ -- This is primarily useful for debugging. -- traceSTM :: Typeable a => a -> STMSim s ()-traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ())+traceSTM !x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ()) data Thrower = ThrowSelf | ThrowOther deriving (Ord, Eq, Show) @@ -790,8 +792,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,@@ -829,7 +832,6 @@ deriving Generic deriving Show via Quiet SimEvent - -- | Pretty print a 'SimEvent'. -- ppSimEvent :: Int -- ^ width of the time@@ -876,7 +878,7 @@ -- ^ Only returned by /IOSimPOR/ when a step execution took longer than -- 'explorationStepTimelimit` was exceeded. | InternalError String- -- ^ An `IOSim` bug, please report to <https://github.com/input-output-hk/io-sim>+ -- ^ An `IOSim` bug, please report to <https://github.com/intersectmbo/io-sim> deriving (Show, Functor) ppSimResult :: Show a@@ -1057,6 +1059,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 +1160,31 @@ -- 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 EventLog a -> "Dynamic " ++ show a 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 ->
src/Control/Monad/IOSimPOR/Internal.hs view
@@ -59,7 +59,8 @@ import Data.Set qualified as Set import Data.Time (UTCTime (..), fromGregorian) -import Control.Exception (NonTermination (..), assert, throw)+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)@@ -308,520 +309,527 @@ -- 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- )+ Nothing -> return TraceLoop+ Just _ -> case action of - 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+ 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+ ) - 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+ 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 - CatchFrame _handler k ctl' -> do- -- pop the control stack and continue- let thread' = thread { threadControl = ThreadControl (k x) ctl' }- schedule thread' simstate+ 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 - 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.+ CatchFrame _handler k ctl' -> do+ -- pop the control stack and continue+ let thread' = thread { threadControl = ThreadControl (k x) ctl' }+ schedule thread' simstate - -- 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+ 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. - thread' =- thread { threadControl =- ThreadControl (case threadAction of- IOSim k' -> k' (\() -> k (Just x)))- ctl'- }- schedule thread' simstate+ -- 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 - DelayFrame tmid k ctl' -> do- let thread' = thread { threadControl = ThreadControl k ctl' }- timers' = IPSQ.delete (coerce tmid) timers- schedule thread' simstate { timers = timers' }+ thread' =+ thread { threadControl =+ ThreadControl (case threadAction of+ IOSim k' -> k' (\() -> k (Just x)))+ ctl'+ }+ schedule thread' simstate - 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)+ DelayFrame tmid k ctl' -> do+ let thread' = thread { threadControl = ThreadControl k ctl' }+ timers' = IPSQ.delete (coerce tmid) timers+ schedule thread' simstate { timers = timers' } - (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+ 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 (EventThreadUnhandled e) $- traceFinalRacesFound simstate { threads = Map.insert tid thread' threads } $- TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))+ SimPORTrace time tid tstep tlbl (EventMask maskst') $+ SimPORTrace time tid tstep tlbl (EventEffect vClock eff) $+ SimPORTrace time tid tstep tlbl (EventRaces races')+ trace) - | 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+ (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)) - 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+ | 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 - 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+ 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 - Say msg k -> do- let thread' = thread { threadControl = ThreadControl k ctl }- trace <- schedule thread' simstate- return (SimPORTrace time tid tstep tlbl (EventSay msg) trace)+ 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 - Output x k -> do- let thread' = thread { threadControl = ThreadControl k ctl }- trace <- schedule thread' simstate- return (SimPORTrace time tid tstep tlbl (EventLog x) trace)+ Say msg k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ trace <- schedule thread' simstate+ return (SimPORTrace time tid tstep tlbl (EventSay msg) trace) - LiftST st k -> do- x <- strictToLazyST st- let thread' = thread { threadControl = ThreadControl (k x) ctl }- schedule thread' simstate+ Output x k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ trace <- schedule thread' simstate+ return (SimPORTrace time tid tstep tlbl (EventLog x) trace) - GetMonoTime k -> do- let thread' = thread { threadControl = ThreadControl (k time) ctl }- schedule thread' simstate+ LiftST st k -> do+ x <- strictToLazyST st+ let thread' = thread { threadControl = ThreadControl (k x) 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+ GetMonoTime k -> do+ let thread' = thread { threadControl = ThreadControl (k time) 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'+ 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 - 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'+ 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' - -- This case is guarded by checks in 'timeout' itself.- StartTimeout d _ _ | d <= 0 ->- error "schedule: StartTimeout: Impossible happened"+ 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' - 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)+ -- This case is guarded by checks in 'timeout' itself.+ StartTimeout d _ _ | d <= 0 ->+ error "schedule: StartTimeout: Impossible happened" - UnregisterTimeout tmid k -> do- let thread' = thread { threadControl = ThreadControl k ctl }- schedule thread' simstate { timers = IPSQ.delete (coerce tmid) timers }+ 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) - RegisterDelay d k | d < 0 -> do- tvar <- execNewTVar (TVarId nextVid)- (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")- True- modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)- let !expiry = d `addTime` time- !thread' = thread { threadControl = ThreadControl (k tvar) ctl }- trace <- schedule thread' simstate { nextVid = succ nextVid }- return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) $- SimPORTrace time tid tstep tlbl (EventRegisterDelayFired nextTmid) $- trace)+ UnregisterTimeout tmid k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ schedule thread' simstate { timers = IPSQ.delete (coerce tmid) timers } - RegisterDelay d k -> do- tvar <- execNewTVar (TVarId nextVid)- (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")- False- modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)- let !expiry = d `addTime` time- !timers' = IPSQ.insert (coerce nextTmid) expiry (TimerRegisterDelay tvar) timers- !thread' = thread { threadControl = ThreadControl (k tvar) ctl }- trace <- schedule thread' simstate { timers = timers'- , nextVid = succ nextVid- , nextTmid = succ nextTmid }- return (SimPORTrace time tid tstep tlbl- (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) trace)+ RegisterDelay d k | d < 0 -> do+ tvar <- execNewTVar (TVarId nextVid)+ (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ True+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ let !expiry = d `addTime` time+ !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+ trace <- schedule thread' simstate { nextVid = succ nextVid }+ return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) $+ SimPORTrace time tid tstep tlbl (EventRegisterDelayFired nextTmid) $+ trace) - 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)+ RegisterDelay d k -> do+ tvar <- execNewTVar (TVarId nextVid)+ (Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ False+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ let !expiry = d `addTime` time+ !timers' = IPSQ.insert (coerce nextTmid) expiry (TimerRegisterDelay tvar) timers+ !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+ trace <- schedule thread' simstate { timers = timers'+ , nextVid = succ nextVid+ , nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl+ (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) trace) - ThreadDelay d k -> 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)+ 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) - -- 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)+ 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) - NewTimeout d k -> do- tvar <- execNewTVar (TVarId nextVid)- (Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")- TimeoutPending- modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)- let expiry = d `addTime` time- t = Timeout tvar nextTmid- timers' = IPSQ.insert (coerce nextTmid) expiry (Timer tvar) timers- thread' = thread { threadControl = ThreadControl (k t) ctl }- trace <- schedule thread' simstate { timers = timers'- , nextVid = succ (succ nextVid)- , nextTmid = succ nextTmid }- return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) trace)+ -- 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) - 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+ NewTimeout d k -> do+ tvar <- execNewTVar (TVarId nextVid)+ (Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")+ TimeoutPending+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ let expiry = d `addTime` time+ t = Timeout tvar nextTmid+ timers' = IPSQ.insert (coerce nextTmid) expiry (Timer tvar) timers+ thread' = thread { threadControl = ThreadControl (k t) ctl }+ trace <- schedule thread' simstate { timers = timers'+ , nextVid = succ (succ nextVid)+ , nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) trace) - -- 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+ 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 - 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'+ -- 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 }- 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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' }+ 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+ 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+ 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+ 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+ 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' _ | 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+ 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'' }+ 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+ -- 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+ -- 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'+ 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
src/Data/List/Trace.hs view
@@ -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
test/Test/Control/Monad/IOSim.hs view
@@ -54,9 +54,9 @@ tests = testGroup "IOSim" [ testProperty "read/write graph (IO)" prop_stm_graph_io- , testProperty "read/write graph (IOSim)" (withMaxSuccess 1000 prop_stm_graph_sim)+ , testProperty "read/write graph (IOSim)" (withNumTests 1000 prop_stm_graph_sim) , testGroup "timeouts"- [ testProperty "IOSim" (withMaxSuccess 1000 prop_timers_ST)+ [ testProperty "IOSim" (withNumTests 1000 prop_timers_ST) -- fails since we just use `threadDelay` to schedule timers in `IO`. , testProperty "IO" (expectFailure prop_timers_IO) , testProperty "IOSim: no deadlock" prop_timeout_no_deadlock_Sim@@ -75,8 +75,8 @@ [ testProperty "timeout: discardAfter" unit_discardAfter , testProperty "timeout: within" unit_within ]- , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim)- , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST)+ , testProperty "threadId order (IOSim)" (withNumTests 1000 prop_threadId_order_order_Sim)+ , testProperty "forkIO order (IOSim)" (withNumTests 1000 prop_fork_order_ST) , testProperty "order (IO)" (expectFailure prop_fork_order_IO) , testProperty "STM wakeup order" prop_wakeup_order_ST , testGroup "throw/catch unit tests"@@ -425,7 +425,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 +439,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 +449,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 +462,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 +474,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 +487,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 +500,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 +516,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 +536,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 +568,7 @@ :: Property -unit_async_1 =+unit_async_1 = once $ runSimTraceSay (do mtid <- myThreadId say ("main " ++ show mtid)@@ -581,7 +581,7 @@ ["main ThreadId []", "parent ThreadId [1]", "child ThreadId [1]"] -unit_async_2 =+unit_async_2 = once $ runSimTraceSay (do tid <- myThreadId say "before"@@ -592,7 +592,7 @@ ["before"] -unit_async_3 =+unit_async_3 = once $ runSimTraceSay (do tid <- myThreadId catch (do say "before"@@ -603,7 +603,7 @@ ["before", "handler"] -unit_async_4 =+unit_async_4 = once $ runSimTraceSay (do tid <- forkIO $ say "child" threadDelay 1@@ -614,7 +614,7 @@ ["child", "parent done"] -unit_async_5 =+unit_async_5 = once $ runSimTraceSay (do tid <- forkIO $ do say "child"@@ -629,7 +629,7 @@ ["child", "handler", "child done", "parent done"] -unit_async_6 =+unit_async_6 = once $ runSimTraceSay (do tid <- forkIO $ mask_ $ do@@ -649,7 +649,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 +669,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 +689,7 @@ ["child", "child masked", "handler", "child done", "parent done"] -unit_async_9 =+unit_async_9 = once $ runSimTraceSay (do tid <- forkIO $ mask_ $ do@@ -705,7 +705,7 @@ ["child", "parent done"] -unit_async_10 =+unit_async_10 = once $ runSimTraceSay (do tid1 <- forkIO $ do mask_ $ do@@ -733,7 +733,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 +765,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 +786,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 +795,7 @@ _ -> property False -unit_async_14 =+unit_async_14 = once $ runSimTraceSay (do tid <- forkIO $ do uninterruptibleMask_ $ do@@ -816,7 +816,7 @@ ["child", "child masked", "child done", "parent done"] -unit_async_15 =+unit_async_15 = once $ runSimTraceSay (do tid <- forkIO $ uninterruptibleMask $ \restore -> do@@ -836,7 +836,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 +1089,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 +1109,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 +1124,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 +1145,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 +1166,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 +1190,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 +1218,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 +1250,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@@ -1282,63 +1284,63 @@ -- 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) --
test/Test/Control/Monad/IOSimPOR.hs view
@@ -44,6 +44,7 @@ import Data.List.Trace qualified as Trace import Test.QuickCheck+import Test.QuickCheck.Monadic (assert, run) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck @@ -68,9 +69,9 @@ -- , testProperty "propPermutations" propPermutations ] , testGroup "IO simulator properties"- [ testProperty "read/write graph (IOSim)" (withMaxSuccess 1000 prop_stm_graph_sim)+ [ testProperty "read/write graph (IOSim)" (withNumTests 1000 prop_stm_graph_sim) , testGroup "timeouts"- [ testProperty "IOSim" (withMaxSuccess 1000 prop_timers_ST)+ [ testProperty "IOSim" (withNumTests 1000 prop_timers_ST) , testProperty "IOSim: no deadlock" prop_timeout_no_deadlock_Sim , testProperty "timeout" prop_timeout , testProperty "timeouts" prop_timeouts@@ -78,8 +79,8 @@ , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay ] , testProperty "infinite simulation" prop_explore_endless_simulation- , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim)- , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST)+ , testProperty "threadId order (IOSim)" (withNumTests 1000 prop_threadId_order_order_Sim)+ , testProperty "forkIO order (IOSim)" (withNumTests 1000 prop_fork_order_ST) , testGroup "throw/catch unit tests" [ testProperty "0" unit_catch_0 , testProperty "1" unit_catch_1@@ -116,6 +117,11 @@ , testProperty "catch: throwTo async blocking (IOSim)" $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_ST ]+ , testGroup "PropertyM callbacks"+ [ testProperty "happy path" unit_monadicIOSimPOR_0+ , testProperty "failing assert" unit_monadicIOSimPOR_1+ , testProperty "exception" unit_monadicIOSimPOR_2+ ] , testProperty "evaluate unit test" unit_evaluate_0 , testGroup "forkIO unit tests" [ testProperty "1" unit_fork_1@@ -749,6 +755,30 @@ say "after" ) $ \_ trace -> selectTraceSay trace === ["inner", "handler1", "handler2", "after"]++unit_monadicIOSimPOR_0, unit_monadicIOSimPOR_1, unit_monadicIOSimPOR_2+ :: Property++-- | Basic success case: a PropertyM test can be executed through IOSimPOR.+unit_monadicIOSimPOR_0 =+ monadicIOSimPOR_ $ do+ x <- run (pure (1 :: Int))+ assert (x == 1)++-- | Failing assertions inside PropertyM are reported as property failures.+unit_monadicIOSimPOR_1 =+ expectFailure $+ monadicIOSimPOR_ $ do+ x <- run (pure (1 :: Int))+ assert (x == 2)++-- | Exceptions thrown by the simulation are turned into failing properties via+-- `traceResult False`, matching the manual workaround from issue #229.+unit_monadicIOSimPOR_2 =+ expectFailure $+ monadicIOSimPOR_ $ do+ _ <- run $ evaluate (error "boom" :: ())+ assert True -- evaluate should catch pure errors unit_evaluate_0 :: Property
test/Test/Control/Monad/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Test.Control.Monad.Utils where import Data.Array@@ -18,6 +19,11 @@ import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,18,0)+withNumTests :: Testable prop => Int -> prop -> Property+withNumTests = withMaxSuccess+#endif+ -- -- Read/Write graph --@@ -489,7 +495,7 @@ -> Property forall_masking_states prop = -- make sure that the property is executed once!- withMaxSuccess 1 $+ withNumTests 1 $ foldr (\ms p -> counterexample (show ms) (prop ms) .&&. p) (property True) [Unmasked, MaskedInterruptible, MaskedUninterruptible]