diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/NOTICE b/NOTICE --- a/NOTICE +++ b/NOTICE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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 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 @@ -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 - -- . + -- . | 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 , +-- 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 , +-- 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 diff --git a/src/Control/Monad/IOSim/Internal.hs b/src/Control/Monad/IOSim/Internal.hs --- a/src/Control/Monad/IOSim/Internal.hs +++ b/src/Control/Monad/IOSim/Internal.hs @@ -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 } 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" #-} @@ -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 + -- ^ An `IOSim` bug, please report to 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 -> 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,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 $! "<>") - 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 $! "<>") - 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 $! "<>") + 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 $! "<>") + 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 $! "<>") - 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 $! "<>") + 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 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 @@ -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) -- 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 @@ -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 diff --git a/test/Test/Control/Monad/Utils.hs b/test/Test/Control/Monad/Utils.hs --- a/test/Test/Control/Monad/Utils.hs +++ b/test/Test/Control/Monad/Utils.hs @@ -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]