From 5a006fbe09d62fe77dc251f745f335ef70523f6c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 14 Nov 2026 09:57:09 +0100 Subject: [PATCH 1/3] MonadAsync: fixed default implementation for withAsyncWithUnmask The default implementation of `withAsyncWithUnmask` (used by IOSim, but not IO), didn't restore masking state the same way `async` and `base` packages do. This only matters if the `withAsyncWithUnmask` is called when exception are `Unmasked`. The correct implementation (below) uses `restore` in ```hs withAsyncWithUnmask action inner = mask $ \restore -> do a <- asyncWithUnmask (\unmask -> restore (action unmask)) restore (inner a) `finally` uninterruptibleCancel a ``` to restores the original `Unmasked` state. The buggy implementation: ```hs withAsyncWithUnmask action inner = mask $ \restore -> do a <- asyncWithUnmask action restore (inner a) `finally` uninterruptibleCancel a ``` when called with exceptions `Unmasked`, will run `action` in `InterruptibleMasked` state instead. There's not difference between the two implementations when the function is called when exceptions are masked or uninterruptibly masked. The commit includes tests for `IO` and `IOSim` instances. --- .../Control/Monad/Class/MonadAsync.hs | 6 +++-- io-sim/test/Test/Control/Monad/IOSim.hs | 13 +++++++++ io-sim/test/Test/Control/Monad/Utils.hs | 27 +++++++++++++++++++ 3 files changed, 44 insertions(+), 2 deletions(-) diff --git a/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs b/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs index c809c8ae..617b5c97 100644 --- a/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs +++ b/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs @@ -240,13 +240,15 @@ class ( MonadSTM m `finally` uninterruptibleCancel a + -- the child runs in the masking state of the parent, as in the `async` + -- package; `asyncWithUnmask` forks it masked, since we are inside `mask`. withAsyncWithUnmask action inner = mask $ \restore -> do - a <- asyncWithUnmask action + a <- asyncWithUnmask (\unmask -> restore (action unmask)) restore (inner a) `finally` uninterruptibleCancel a withAsyncOnWithUnmask n action inner = mask $ \restore -> do - a <- asyncOnWithUnmask n action + a <- asyncOnWithUnmask n (\unmask -> restore (action unmask)) restore (inner a) `finally` uninterruptibleCancel a diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index 03b1dbac..b1c65a0b 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -113,6 +113,11 @@ tests = $ forall_masking_states $ \ms -> forall_masking_states $ \ms' -> unit_fork_unmask_ST ms ms' + , testProperty "withAsyncWithUnmask (IO)" + $ forall_masking_states unit_withAsyncWithUnmask_masking_state_IO + , testProperty "withAsyncWithUnmask (IOSim)" + $ forall_masking_states unit_withAsyncWithUnmask_masking_state_ST + , testProperty "catch (IO)" $ forall_masking_states unit_catch_throwIO_masking_state_IO , testProperty "catch (IOSim)" @@ -1311,6 +1316,14 @@ 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' = once $ runSimOrThrow $ prop_fork_unmask ms ms' +unit_withAsyncWithUnmask_masking_state_IO :: MaskingState -> Property +unit_withAsyncWithUnmask_masking_state_IO = once . + ioProperty . prop_withAsyncWithUnmask_masking_state + +unit_withAsyncWithUnmask_masking_state_ST :: MaskingState -> Property +unit_withAsyncWithUnmask_masking_state_ST ms = once $ + runSimOrThrow (prop_withAsyncWithUnmask_masking_state ms) + unit_catch_throwIO_masking_state_IO :: MaskingState -> Property unit_catch_throwIO_masking_state_IO ms = once $ ioProperty $ prop_catch_throwIO_masking_state ms diff --git a/io-sim/test/Test/Control/Monad/Utils.hs b/io-sim/test/Test/Control/Monad/Utils.hs index fe673618..1c49d34c 100644 --- a/io-sim/test/Test/Control/Monad/Utils.hs +++ b/io-sim/test/Test/Control/Monad/Utils.hs @@ -10,6 +10,7 @@ import Data.List (sortBy) import Control.Monad import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI @@ -396,6 +397,32 @@ prop_fork_unmask ms ms' = ms'' <- atomically $ takeTMVar var return $ Unmasked === ms'' +-- | Check that a thread forked by one of the `withAsync*WithUnmask` functions +-- starts with the masking state of its parent, as in the @async@ package, and +-- that its 'unmask' function restores 'Unmasked' state. +-- +prop_withAsyncWithUnmask_masking_state :: forall m. + ( MonadAsync m + , MonadMask m + ) + => MaskingState -> m Property +prop_withAsyncWithUnmask_masking_state ms = + setMaskingState_ ms $ do + rs <- sequence + [ ("withAsyncWithUnmask",) + <$> withAsyncWithUnmask child wait + , ("withAsyncOnWithUnmask",) + <$> withAsyncOnWithUnmask 0 child wait + ] + return $ conjoin + [ counterexample name $ r === (ms, Unmasked) + | (name, r) <- rs + ] + where + -- the masking state in which the child starts, and the one set by 'unmask' + child :: (forall x. m x -> m x) -> m (MaskingState, MaskingState) + child unmask = (,) <$> getMaskingState <*> unmask getMaskingState + -- | A unit test which checks the masking state in the context of a catch -- handler. -- From 7b17b2fead0bd48277277ca63585802187da364b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 14 Nov 2026 15:21:40 +0100 Subject: [PATCH 2/3] UnshareClock: fixed a partial pattern match --- io-sim/src/Control/Monad/IOSimPOR/Internal.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index 921188e0..f0089323 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs @@ -477,7 +477,10 @@ schedule thread@Thread{ UnshareClock k -> do let clockid = threadClockId thread clockoff = clocks Map.! clockid - clockid' = let ThreadId i = tid in ClockId i -- reuse the thread id + -- reuse the thread id + clockid' = case tid of + RacyThreadId i -> ClockId i + ThreadId i -> ClockId i thread' = thread { threadControl = ThreadControl k ctl , threadClockId = clockid' } simstate' = simstate { clocks = Map.insert clockid' clockoff clocks } From 553d46233efcd4593b8612a88b194bff701eb283 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 13 Nov 2026 16:49:54 +0100 Subject: [PATCH 3/3] io-sim-por: added `explorationRacyByLabel` IOSimPOR can now select the threads which take par ti in race discovery by their label with the following rules: * threads must be started by one of `forkLabelledIO` or `asyncLabelled`, `withAsyncLabelled` and friends - this makes sure the thread label is available in `IOSim` when a thread is created rather than set by `labelThisThread` when it is scheduled * racy flag is sticky, e.g. threads started by a thread that are part of race discovery are part of the race discovery. You need to set the new `explorationRacyByLabel` field of `ExplorationOptions`, either directly or by using one of the two combinators: * `withRacyMainThread` - IOSimPOR will make all threads part of schedule exploration (this wasn't possible before) * `withRacyByLabel` - by passing a callback the simulation can select which threads will be part race exploration The test-suite is using now internal API, and thus depends on `io-sim` sources directly. This way we can keep internal API unexposed to the user. Almost all `IOSimPOR` tests are using now `withRacyMainThread` - for that reason we had to drop `withNumTests 1000` from two tests. New tests are included for labelled functions. --- io-classes/CHANGELOG.md | 29 +++ .../Control/Monad/Class/MonadAsync.hs | 157 ++++++++++++-- .../Control/Monad/Class/MonadFork.hs | 24 +++ .../src/Control/Monad/Class/MonadTimer/SI.hs | 8 +- io-sim/CHANGELOG.md | 15 ++ io-sim/io-sim.cabal | 5 +- io-sim/src/Control/Monad/IOSim.hs | 23 +- io-sim/src/Control/Monad/IOSim/CommonTypes.hs | 12 +- io-sim/src/Control/Monad/IOSim/Internal.hs | 4 +- io-sim/src/Control/Monad/IOSim/Types.hs | 121 +++++++++-- io-sim/src/Control/Monad/IOSimPOR/Internal.hs | 65 ++++-- io-sim/test/Test/Control/Monad/IOSim.hs | 38 ++++ io-sim/test/Test/Control/Monad/IOSimPOR.hs | 204 +++++++++++++----- io-sim/test/Test/Control/Monad/Utils.hs | 102 +++++++++ 14 files changed, 676 insertions(+), 131 deletions(-) diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index e6598cdf..e7be7144 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -1,5 +1,34 @@ # Revsion history of io-classes +## next + +### Breaking changes + +* `MonadFork` new api: + - `forkLabelledIO` + - `forkLabelledOn` + - `forkLabelledIOWithUnmask` + - `forkLabelledFinally` +* `MonadAsync` new api: + - `asyncLabelled` + - `asyncLabelledBound` + - `asyncLabelledOn` + - `withAsyncLabelled` + - `withAsyncLabelledBound` + - `withAsyncLabelledOn` + - `asyncLabelledWithUnmask` + - `asyncLabelledOnWithUnmask` + - `withAsyncLabelledWithUnmask` + - `withAsyncLabelledOnWithUnmask` + +These function allow to a precise control over which threads are part of +`IOSimPOR` schedule exploration. + +* `withAsyncWithUnmask` and `withAsyncOnWithUnmask` for `IOSim` are now + matching the masking state of the `IO` instances. + +### Non-breaking change + ## 1.11.0.0 ### Breaking changes diff --git a/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs b/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs index 617b5c97..bb7a7aaf 100644 --- a/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs +++ b/io-classes/io-classes/Control/Monad/Class/MonadAsync.hs @@ -56,7 +56,9 @@ class ( MonadSTM m ) => MonadAsync m where {-# MINIMAL async, asyncBound, asyncOn, asyncThreadId, cancel, cancelWith, - asyncWithUnmask, asyncOnWithUnmask, waitCatchSTM, pollSTM #-} + asyncWithUnmask, asyncOnWithUnmask, waitCatchSTM, pollSTM, + asyncLabelled, asyncLabelledBound, asyncLabelledOn, + asyncLabelledWithUnmask, asyncLabelledOnWithUnmask #-} -- | An asynchronous action -- @@ -200,6 +202,19 @@ class ( MonadSTM m -- | See 'Async.compareAsyncs'. compareAsyncs :: Async m a -> Async m b -> Ordering + -- non-standard APIs + + asyncLabelled :: String -> m a -> m (Async m a) + asyncLabelledBound :: String -> m a -> m (Async m a) + asyncLabelledOn :: String -> Int -> m a -> m (Async m a) + withAsyncLabelled :: String -> m a -> (Async m a -> m b) -> m b + withAsyncLabelledBound :: String -> m a -> (Async m a -> m b) -> m b + withAsyncLabelledOn :: String -> Int -> m a -> (Async m a -> m b) -> m b + asyncLabelledWithUnmask :: String -> ((forall b . m b -> m b) -> m a) -> m (Async m a) + asyncLabelledOnWithUnmask :: String -> Int -> ((forall b . m b -> m b) -> m a) -> m (Async m a) + withAsyncLabelledWithUnmask :: String -> ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b + withAsyncLabelledOnWithUnmask :: String -> Int -> ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b + -- default implementations default withAsync :: MonadMask m => m a -> (Async m a -> m b) -> m b default withAsyncBound:: MonadMask m => m a -> (Async m a -> m b) -> m b @@ -224,33 +239,22 @@ class ( MonadSTM m default compareAsyncs :: Ord (ThreadId m) => Async m a -> Async m b -> Ordering - withAsync action inner = mask $ \restore -> do - a <- async (restore action) - restore (inner a) - `finally` uninterruptibleCancel a - - withAsyncBound action inner = mask $ \restore -> do - a <- asyncBound (restore action) - restore (inner a) - `finally` uninterruptibleCancel a + withAsync action = + withAsyncUsing (\restore -> async (restore action)) - withAsyncOn n action inner = mask $ \restore -> do - a <- asyncOn n (restore action) - restore (inner a) - `finally` uninterruptibleCancel a + withAsyncBound action = + withAsyncUsing (\restore -> asyncBound (restore action)) + withAsyncOn n action = + withAsyncUsing (\restore -> asyncOn n (restore action)) -- the child runs in the masking state of the parent, as in the `async` -- package; `asyncWithUnmask` forks it masked, since we are inside `mask`. - withAsyncWithUnmask action inner = mask $ \restore -> do - a <- asyncWithUnmask (\unmask -> restore (action unmask)) - restore (inner a) - `finally` uninterruptibleCancel a + withAsyncWithUnmask action = + withAsyncUsing (\restore -> asyncWithUnmask (\unmask -> restore (action unmask))) - withAsyncOnWithUnmask n action inner = mask $ \restore -> do - a <- asyncOnWithUnmask n (\unmask -> restore (action unmask)) - restore (inner a) - `finally` uninterruptibleCancel a + withAsyncOnWithUnmask n action = + withAsyncUsing (\restore -> asyncOnWithUnmask n (\unmask -> restore (action unmask))) wait = atomically . waitSTM poll = atomically . pollSTM @@ -293,6 +297,50 @@ class ( MonadSTM m compareAsyncs a b = asyncThreadId a `compare` asyncThreadId b + default withAsyncLabelled :: MonadMask m => String -> m a -> (Async m a -> m b) -> m b + default withAsyncLabelledBound:: MonadMask m => String -> m a -> (Async m a -> m b) -> m b + default withAsyncLabelledOn :: MonadMask m => String -> Int -> m a -> (Async m a -> m b) -> m b + default withAsyncLabelledWithUnmask + :: MonadMask m => String + -> ((forall c. m c -> m c) -> m a) + -> (Async m a -> m b) -> m b + default withAsyncLabelledOnWithUnmask + :: MonadMask m => String + -> Int + -> ((forall c. m c -> m c) -> m a) + -> (Async m a -> m b) -> m b + + withAsyncLabelled lbl action = + withAsyncUsing (\restore -> asyncLabelled lbl (restore action)) + + withAsyncLabelledBound lbl action = + withAsyncUsing (\restore -> asyncLabelledBound lbl (restore action)) + + withAsyncLabelledOn lbl n action = + withAsyncUsing (\restore -> asyncLabelledOn lbl n (restore action)) + + withAsyncLabelledWithUnmask lbl action = + withAsyncUsing (\restore -> asyncLabelledWithUnmask lbl (\unmask -> restore (action unmask))) + + withAsyncLabelledOnWithUnmask lbl n action = + withAsyncUsing (\restore -> asyncLabelledOnWithUnmask lbl n (\unmask -> restore (action unmask))) + +-- | The bracket shared by the default `withAsync` family implementations. +-- +-- The first argument spawns the child thread; it runs inside `mask` and +-- receives its `restore`, which it must use to restore the parent's masking +-- state in the child. The inner action runs with the parent's masking state, +-- and the child is cancelled when it returns or throws. +-- +withAsyncUsing :: (MonadAsync m, MonadMask m) + => ((forall x. m x -> m x) -> m (Async m a)) + -> (Async m a -> m b) + -> m b +withAsyncUsing spawn inner = mask $ \restore -> do + a <- spawn restore + restore (inner a) + `finally` uninterruptibleCancel a + -- | Similar to 'Async.Concurrently' but which works for any 'MonadAsync' -- instance. -- @@ -410,6 +458,26 @@ instance MonadAsync IO where compareAsyncs = Async.compareAsyncs + asyncLabelled lbl = Async.async . (labelThisThread lbl >>) + asyncLabelledBound lbl = Async.asyncBound . (labelThisThread lbl >>) + asyncLabelledOn lbl n = Async.asyncOn n . (labelThisThread lbl >>) + asyncLabelledWithUnmask lbl k + = Async.asyncWithUnmask + (\unmask -> labelThisThread lbl >> k unmask) + asyncLabelledOnWithUnmask lbl n k + = Async.asyncOnWithUnmask n + (\unmask -> labelThisThread lbl >> k unmask) + + withAsyncLabelled lbl = Async.withAsync . (labelThisThread lbl >>) + withAsyncLabelledBound lbl = Async.withAsyncBound . (labelThisThread lbl >>) + withAsyncLabelledOn lbl n = Async.withAsyncOn n . (labelThisThread lbl >>) + withAsyncLabelledWithUnmask lbl k + = Async.withAsyncWithUnmask + (\unmask -> labelThisThread lbl >> k unmask) + withAsyncLabelledOnWithUnmask lbl n k + = Async.withAsyncOnWithUnmask n + (\unmask -> labelThisThread lbl >> k unmask) + -- -- Linking @@ -506,7 +574,7 @@ forkRepeat label action = case r of Left _ -> go _ -> return () - in forkIO (labelThisThread label >> go) + in forkLabelledIO label go tryAll :: MonadCatch m => m a -> m (Either SomeException a) tryAll = try @@ -601,6 +669,49 @@ instance ( MonadAsync m waitEither_ = on (lift .: waitEither_) getAsyncReaderT waitBoth = on (lift .: waitBoth) getAsyncReaderT + asyncLabelled lbl (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncLabelled lbl (ma r) + asyncLabelledBound lbl (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncLabelledBound lbl (ma r) + asyncLabelledOn lbl n (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncLabelledOn lbl n (ma r) + + asyncLabelledWithUnmask lbl f = ReaderT $ \r -> fmap AsyncReaderT + $ asyncLabelledWithUnmask lbl + $ \unmask -> runReaderT (f (liftF unmask)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + asyncLabelledOnWithUnmask lbl n f = ReaderT $ \r -> fmap AsyncReaderT + $ asyncLabelledOnWithUnmask lbl n + $ \unmask -> runReaderT (f (liftF unmask)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + withAsyncLabelled lbl (ReaderT ma) f = ReaderT $ \r -> withAsyncLabelled lbl (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + withAsyncLabelledBound lbl (ReaderT ma) f + = ReaderT $ \r -> withAsyncLabelledBound lbl (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + withAsyncLabelledOn lbl n (ReaderT ma) f + = ReaderT $ \r -> withAsyncLabelledOn lbl n (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + + withAsyncLabelledWithUnmask lbl action f = + ReaderT $ \r -> withAsyncLabelledWithUnmask lbl (\unmask -> case action (liftF unmask) of + ReaderT ma -> ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + withAsyncLabelledOnWithUnmask lbl n action f = + ReaderT $ \r -> withAsyncLabelledOnWithUnmask lbl n (\unmask -> case action (liftF unmask) of + ReaderT ma -> ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + -- -- Utilities diff --git a/io-classes/io-classes/Control/Monad/Class/MonadFork.hs b/io-classes/io-classes/Control/Monad/Class/MonadFork.hs index 88a07c8a..158df8e6 100644 --- a/io-classes/io-classes/Control/Monad/Class/MonadFork.hs +++ b/io-classes/io-classes/Control/Monad/Class/MonadFork.hs @@ -53,6 +53,14 @@ class MonadThread m => MonadFork m where getNumCapabilities :: m Int + -- non-standard API + -- + forkLabelledIO :: String -> m () -> m (ThreadId m) + forkLabelledOn :: String -> Int -> m () -> m (ThreadId m) + forkLabelledIOWithUnmask + :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + forkLabelledFinally :: String -> m a -> (Either SomeException a -> m ()) -> m (ThreadId m) + instance MonadThread IO where type ThreadId IO = IO.ThreadId @@ -74,6 +82,13 @@ instance MonadFork IO where yield = IO.yield getNumCapabilities = IO.getNumCapabilities + forkLabelledIO lbl = forkIO . (labelThisThread lbl >>) + forkLabelledOn lbl c = forkOn c . (labelThisThread lbl >>) + forkLabelledIOWithUnmask lbl k + = forkIOWithUnmask (\unmask -> labelThisThread lbl >> k unmask) + forkLabelledFinally lbl = forkFinally . (labelThisThread lbl >>) + + instance MonadThread m => MonadThread (ReaderT r m) where type ThreadId (ReaderT r m) = ThreadId m myThreadId = lift myThreadId @@ -93,3 +108,12 @@ instance MonadFork m => MonadFork (ReaderT e m) where yield = lift yield getNumCapabilities = lift getNumCapabilities + + forkLabelledIO lbl (ReaderT f) = ReaderT $ \e -> forkLabelledIO lbl (f e) + forkLabelledOn lbl n (ReaderT f) = ReaderT $ \e -> forkLabelledOn lbl n (f e) + forkLabelledIOWithUnmask lbl k = ReaderT $ \e -> forkLabelledIOWithUnmask lbl $ \restore -> + let restore' :: ReaderT e m a -> ReaderT e m a + restore' (ReaderT f) = ReaderT $ restore . f + in runReaderT (k restore') e + forkLabelledFinally lbl f k = ReaderT $ \e -> forkLabelledFinally lbl (runReaderT f e) + $ \err -> runReaderT (k err) e diff --git a/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs b/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs index fb6998e1..7819e29c 100644 --- a/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs +++ b/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs @@ -161,9 +161,8 @@ defaultRegisterDelay :: forall m timeout. -> m (TVar m Bool) defaultRegisterDelay newTimeout awaitTimeout d = do c <- getMonotonicTime - v <- atomically $ newTVar False - tid <- forkIO $ go v c (d `addTime` c) - labelThread tid "delay-thread" + v <- newTVarIO False + _ <- forkLabelledIO "register-delay-thread" $ go v c (d `addTime` c) return v where maxDelay :: DiffTime @@ -210,8 +209,7 @@ defaultRegisterDelayCancellable newTimeout _readTimeout _cancelTimeout awaitTime c <- getMonotonicTime -- timeout state v <- newTVarIO TimeoutPending - tid <- forkIO $ go v c (d `addTime` c) - labelThread tid "delay-thread" + _ <- forkLabelledIO "register-delay-thread" $ go v c (d `addTime` c) let cancel = atomically $ readTVar v >>= \case TimeoutCancelled -> return () TimeoutFired -> return () diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 9ad02b79..c4a13a7f 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -1,5 +1,20 @@ # Revision history of io-sim +## next + +### Breaking changes + +* Added `explorationRacyByLabel` with two combinators + - `withRacyMainThread` - make all threads part of schedule exploration + - `withRacyByLabel` - select which threads are part of schedule exploration + based on thread labels. For it one must use one of `forkLabelledIO`, + `asyncLabelled`, `withAsyncLabelled` or similar functions from `MonadFork` + and `MonadAsync` type classes. + - `controlSimTrace` now takes the `racyByLabel` callback, when replaying + a `ScheduleControl` you must use the same `racyByLabel`. + +### Non-breaking change + ## 1.11.0.0 ### Breaking changes diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal index ad0e6228..275b2a5d 100644 --- a/io-sim/io-sim.cabal +++ b/io-sim/io-sim.cabal @@ -105,9 +105,10 @@ test-suite test io-sim, QuickCheck, tasty, - tasty-quickcheck, tasty-hunit, - time + tasty-quickcheck, + time, + transformers ghc-options: -fno-ignore-asserts -rtsopts if impl(ghc >= 9.8) diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs index 53f9ad59..5521b67a 100644 --- a/io-sim/src/Control/Monad/IOSim.hs +++ b/io-sim/src/Control/Monad/IOSim.hs @@ -34,6 +34,8 @@ module Control.Monad.IOSim , withBranching , withStepTimelimit , withReplay + , withRacyByLabel + , withRacyMainThread -- * Lift ST computations , liftST -- * Simulation time @@ -527,8 +529,9 @@ runSimTrace mainAction = runST (runSimTraceST mainAction) -- much more state to track and hence it is slower). -- -- On property failure it will show the failing schedule (`ScheduleControl`) --- which can be passed to `controlSimTrace` to reproduce the failure without --- discovering the schedule. +-- which can be passed to `controlSimTrace` and the same +-- `explorationRacyByLabel` value to reproduce the failure without discovering +-- the schedule. -- exploreSimTrace :: forall a test. Testable test @@ -560,7 +563,10 @@ exploreSimTrace optsf mainAction k = -- finished with trace. let (readRaces, trace0) = detachTraceRaces (explorationDebugLevel opts) $ controlSimTrace - (explorationStepTimelimit opts) control mainAction + (explorationStepTimelimit opts) + control + (explorationRacyByLabel opts) + mainAction (sleeper,trace) = compareTraces passingTrace trace0 in ( counterexample ("Schedule control: " ++ show control) $ counterexample @@ -669,7 +675,10 @@ replaySimTrace :: forall a test. (Testable test) -> Property replaySimTrace opts mainAction control k = let (_,trace) = detachTraceRaces (explorationDebugLevel opts) $ - controlSimTrace (explorationStepTimelimit opts) control mainAction + controlSimTrace (explorationStepTimelimit opts) + control + (explorationRacyByLabel opts) + mainAction in property (k trace) -- | Run a simulation using a given schedule. This is useful to reproduce @@ -683,11 +692,13 @@ controlSimTrace :: forall a. -- ^ a schedule to replay -- -- /note/: must be either `ControlDefault` or `ControlAwait`. + -> (Maybe ThreadLabel -> Bool) + -- ^ See `explorationRacyByLabel`. -> (forall s. IOSim s a) -- ^ a simulation to run -> SimTrace a -controlSimTrace limit control main = - runST (IOSimPOR.controlSimTraceST limit control main) +controlSimTrace limit control racyByLabel main = + runST (IOSimPOR.controlSimTraceST limit control racyByLabel main) -- -- Utils diff --git a/io-sim/src/Control/Monad/IOSim/CommonTypes.hs b/io-sim/src/Control/Monad/IOSim/CommonTypes.hs index 31dd4bf3..e6f0498a 100644 --- a/io-sim/src/Control/Monad/IOSim/CommonTypes.hs +++ b/io-sim/src/Control/Monad/IOSim/CommonTypes.hs @@ -53,9 +53,15 @@ import Quiet -- | A thread id. -- -- /IOSimPOR/: 'RacyThreadId' indicates that this thread is taken into account --- when discovering races. A thread is marked as racy iff --- `Control.Monad.Class.MonadTest.exploreRaces` was --- executed in it or it's a thread forked by a racy thread. +-- when discovering races. A thread is marked as racy iff one of the following +-- conditions is satisfied: +-- +-- * `Control.Monad.Class.MonadTest.exploreRaces` was +-- executed in it; or +-- * it's a thread forked by a racy thread; or +-- * it is forked with one of `forkLabelledIO`, `asyncLabelled`, +-- `withAsyncLabelled` or similar, and `explorationRacyByLabel` callback match +-- the thread label. -- data IOSimThreadId = -- | A racy thread (`IOSimPOR` only), shown in the trace with curly braces, diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index dfe70e29..ece7bf92 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -470,7 +470,7 @@ schedule !thread@Thread{ let thread' = thread { threadControl = ThreadControl k ctl } schedule thread' simstate - Fork a k -> do + Fork threadLabel a k -> do let !nextId = threadNextTId thread !tid' = childThreadId tid nextId !thread' = thread { threadControl = ThreadControl (k tid') ctl @@ -482,7 +482,7 @@ schedule !thread@Thread{ , threadMasking = threadMasking thread , threadThrowTo = [] , threadClockId = threadClockId thread - , threadLabel = Nothing + , threadLabel , threadNextTId = 1 } !threads' = Map.insert tid' thread'' threads diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index afef532b..68309f91 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -36,6 +36,8 @@ module Control.Monad.IOSim.Types , withBranching , withStepTimelimit , withReplay + , withRacyByLabel + , withRacyMainThread , stdExplorationOptions , EventlogEvent (..) , EventlogMarker (..) @@ -182,7 +184,7 @@ data SimA s a where SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b Evaluate :: a -> (a -> SimA s b) -> SimA s b - Fork :: IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b + Fork :: Maybe ThreadLabel -> IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b GetThreadId :: (IOSimThreadId -> SimA s b) -> SimA s b LabelThread :: IOSimThreadId -> String -> SimA s b -> SimA s b GetThreadLabel :: IOSimThreadId -> (Maybe String -> SimA s b) -> SimA s b @@ -470,16 +472,36 @@ instance MonadThread (IOSim s) where labelThread t l = IOSim $ oneShot $ \k -> LabelThread t l (k ()) threadLabel t = IOSim $ oneShot $ \k -> GetThreadLabel t k +-- | Fork a thread, with an optional label. The label is passed to the +-- scheduler, so it is available when the thread is forked (see +-- `explorationRacyByLabel`). +-- +forkWith :: Maybe ThreadLabel -> IOSim s () -> IOSim s IOSimThreadId +forkWith lbl task = IOSim $ oneShot $ \k -> Fork lbl task k + +-- | `forkFinally` with an optional label. +-- +forkFinallyWith :: Maybe ThreadLabel + -> IOSim s a + -> (Either SomeException a -> IOSim s ()) + -> IOSim s IOSimThreadId +forkFinallyWith lbl task k = mask $ \restore -> + forkWith lbl $ try (restore task) >>= k + instance MonadFork (IOSim s) where - forkIO task = IOSim $ oneShot $ \k -> Fork task k - forkOn _ task = IOSim $ oneShot $ \k -> Fork task k - forkIOWithUnmask f = forkIO (f unblock) - forkFinally task k = mask $ \restore -> - forkIO $ try (restore task) >>= k + forkIO = forkWith Nothing + forkOn _ = forkWith Nothing + forkIOWithUnmask f = forkWith Nothing (f unblock) + forkFinally = forkFinallyWith Nothing throwTo tid e = IOSim $ oneShot $ \k -> ThrowTo (toException e) tid (k ()) yield = IOSim $ oneShot $ \k -> YieldSim (k ()) getNumCapabilities = return 1 + forkLabelledIO = forkWith . Just + forkLabelledOn lbl _ = forkWith (Just lbl) + forkLabelledIOWithUnmask lbl f = forkLabelledIO lbl (f unblock) + forkLabelledFinally = forkFinallyWith . Just + instance MonadTest (IOSim s) where exploreRaces = IOSim $ oneShot $ \k -> ExploreRaces (k ()) @@ -648,17 +670,22 @@ instance Ord (Async s a) where instance Functor (Async s) where fmap f (Async tid a) = Async tid (fmap f <$> a) -instance MonadAsync (IOSim s) where - type Async (IOSim s) = Async s - - async action = do +-- | `async` with an optional thread label. +-- +asyncWith :: Maybe ThreadLabel -> IOSim s a -> IOSim s (Async s a) +asyncWith lbl action = do var <- MonadSTM.newEmptyTMVarIO tid <- mask $ \restore -> - forkIO $ try (restore action) - >>= MonadSTM.atomically . MonadSTM.putTMVar var + forkWith lbl $ try (restore action) + >>= MonadSTM.atomically . MonadSTM.putTMVar var MonadSTM.labelTMVarIO var ("async-" ++ show tid) return (Async tid (MonadSTM.readTMVar var)) +instance MonadAsync (IOSim s) where + type Async (IOSim s) = Async s + + async = asyncWith Nothing + asyncOn _ = async asyncBound = async @@ -673,6 +700,13 @@ instance MonadAsync (IOSim s) where asyncWithUnmask k = async (k unblock) asyncOnWithUnmask _ k = async (k unblock) + asyncLabelled = asyncWith . Just + + asyncLabelledOn lbl _ = asyncLabelled lbl + asyncLabelledBound lbl = asyncLabelled lbl + asyncLabelledWithUnmask lbl k = asyncLabelled lbl (k unblock) + asyncLabelledOnWithUnmask lbl _ k = asyncLabelled lbl (k unblock) + -- | This provides access to (almost) everything from the -- @primitive@ package, but don't try to use the @MVar@s as that will not -- work as expected. @@ -1364,7 +1398,7 @@ data ExplorationOptions = ExplorationOptions{ -- ^ A schedule to replay. -- -- The default value is `Nothing`. - explorationDebugLevel :: Int + explorationDebugLevel :: Int, -- ^ Log detailed trace to stderr containing information on discovered -- races. The trace does not contain the result of the simulation, unless -- one will do that explicitly inside the simulation. @@ -1375,17 +1409,57 @@ data ExplorationOptions = ExplorationOptions{ -- -- NOTE: discovered schedules & races are not exposed to the user in the -- callback of `exploreSimTrace` or in the output of `controlSimTrace`. + explorationRacyByLabel :: Maybe ThreadLabel -> Bool + -- ^ Whenever we fork a new thread we call `explorationRacyByLabel` with the + -- label of the forked thread. For this you must use one of the + -- `forkLabelled` or `asyncLabelled` family of functions. The main thread is + -- labelled @"main"@. If `True` is returned all steps of the forked thread + -- will take part in race discovery. If a thread is racy, then all its + -- child threads are racy, regardless of the `explorationRacyByLabel` value + -- (e.g. racy flag is sticky). + -- + -- NOTE: you need the two possibly racing threads make racy to discover any + -- races between them. + } + +data ShowExplorationOptions_ = ExplorationOptions_ { + explorationScheduleBound_ :: Int, + explorationBranching_ :: Int, + explorationStepTimelimit_ :: Maybe Int, + explorationReplay_ :: Maybe ScheduleControl, + explorationDebugLevel_ :: Int } deriving Show +instance Show ExplorationOptions where + showsPrec d + ExplorationOptions { + explorationScheduleBound, + explorationBranching, + explorationStepTimelimit, + explorationReplay, + explorationDebugLevel, + explorationRacyByLabel = _ + } + = + showsPrec d + ExplorationOptions_ { + explorationScheduleBound_ = explorationScheduleBound, + explorationBranching_ = explorationBranching, + explorationStepTimelimit_ = explorationStepTimelimit, + explorationReplay_ = explorationReplay, + explorationDebugLevel_ = explorationDebugLevel + } + stdExplorationOptions :: ExplorationOptions stdExplorationOptions = ExplorationOptions{ explorationScheduleBound = 100, explorationBranching = 3, explorationStepTimelimit = Nothing, explorationReplay = Nothing, - explorationDebugLevel = 0 - } + explorationDebugLevel = 0, + explorationRacyByLabel = const False + } type ExplorationSpec = ExplorationOptions -> ExplorationOptions @@ -1400,3 +1474,20 @@ withStepTimelimit n e = e{explorationStepTimelimit = Just n} withReplay :: ScheduleControl -> ExplorationSpec withReplay r e = e{explorationReplay = Just r} + +-- | The thread and its sub-threads of return `True` all part of the race +-- discovery. +-- +-- NOTE: this function is called when a thread is forked, +-- you must use one of the `forkLabelledIO`, `asyncLabelled`, +-- `withAsyncLabelled` and friends for the label to be available when the +-- thread is forked. When using `labelThisThread`, the function was already +-- was invoked, so that label won't be seen. +withRacyByLabel :: (Maybe ThreadLabel -> Bool) + -> ExplorationSpec +withRacyByLabel racyByLabel e = e{explorationRacyByLabel = racyByLabel} + +-- | All threads, including the main thread are part of race discovery. +-- +withRacyMainThread :: ExplorationSpec +withRacyMainThread e = e{explorationRacyByLabel = const True} diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index f0089323..a2ad636f 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs @@ -39,6 +39,7 @@ module Control.Monad.IOSimPOR.Internal , controlSimTraceST , ScheduleControl (..) , ScheduleMod (..) + , isRacyThreadId ) where import Prelude hiding (read) @@ -122,11 +123,10 @@ threadStepId Thread{ threadId, threadStep } = (threadId, threadStep) isRacyThreadId :: IOSimThreadId -> Bool isRacyThreadId (RacyThreadId _) = True -isRacyThreadId _ = True +isRacyThreadId _ = False isNotRacyThreadId :: IOSimThreadId -> Bool -isNotRacyThreadId (ThreadId _) = True -isNotRacyThreadId _ = False +isNotRacyThreadId = not . isRacyThreadId bottomVClock :: VectorClock bottomVClock = VectorClock Map.empty @@ -208,7 +208,8 @@ data SimState s a = SimState { control0 :: !ScheduleControl, -- | limit on the computation time allowed per scheduling step, for -- catching infinite loops etc - perStepTimeLimit :: Maybe Int + perStepTimeLimit :: Maybe Int, + racyByLabel :: Maybe ThreadLabel -> Bool } @@ -226,7 +227,8 @@ initialState = races = noRaces, control = ControlDefault, control0 = ControlDefault, - perStepTimeLimit = Nothing + perStepTimeLimit = Nothing, + racyByLabel = const False } where epoch1970 = UTCTime (fromGregorian 1970 1 1) 0 @@ -279,7 +281,8 @@ schedule thread@Thread{ nextVid, nextTmid, nextUniq, curTime = time, control, - perStepTimeLimit + perStepTimeLimit, + racyByLabel } | controlTargets (tid,tstep) control = @@ -608,10 +611,11 @@ schedule thread@Thread{ let thread' = thread { threadControl = ThreadControl k ctl } schedule thread' simstate - Fork a k -> do + Fork threadLabel a k -> do let nextTId = threadNextTId thread - tid' | threadRacy thread = setRacyThread $ childThreadId tid nextTId - | otherwise = childThreadId tid nextTId + tid' | threadRacy thread = setRacyThread $ childThreadId tid nextTId + | racyByLabel threadLabel = setRacyThread $ childThreadId tid nextTId + | otherwise = childThreadId tid nextTId thread' = thread { threadControl = ThreadControl (k tid') ctl, threadNextTId = nextTId + 1, threadEffect = effect @@ -624,13 +628,13 @@ schedule thread@Thread{ , threadMasking = threadMasking thread , threadThrowTo = [] , threadClockId = threadClockId thread - , threadLabel = Nothing + , threadLabel , threadNextTId = 1 , threadStep = 0 , threadVClock = insertVClock tid' 0 $ vClock , threadEffect = mempty - , threadRacy = threadRacy thread + , threadRacy = isRacyThreadId tid' } threads' = Map.insert tid' thread'' threads -- A newly forked thread may have a higher priority, so we deschedule this one. @@ -1352,34 +1356,49 @@ lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads) -- more convenient way is exposed by 'runSimTrace'. -- runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a) -runSimTraceST mainAction = controlSimTraceST Nothing ControlDefault mainAction - -controlSimTraceST :: Maybe Int -> ScheduleControl -> IOSim s a -> ST s (SimTrace a) -controlSimTraceST limit control mainAction = +runSimTraceST mainAction = + controlSimTraceST + Nothing + ControlDefault + (const False) + mainAction + +controlSimTraceST :: Maybe Int + -> ScheduleControl + -> (Maybe ThreadLabel -> Bool) + -> IOSim s a + -> ST s (SimTrace a) +controlSimTraceST limit control racyByLabel mainAction = SimPORTrace (curTime initialState) - (threadId mainThread) + threadId 0 - (threadLabel mainThread) + threadLabel (EventSimStart control) <$> schedule mainThread initialState { control = control, control0 = control, - perStepTimeLimit = limit + perStepTimeLimit = limit, + racyByLabel } where - mainThread = + threadLabel = Just "main" + threadRacy = racyByLabel threadLabel + threadId = if threadRacy + then RacyThreadId [] + else ThreadId [] + mainThread = Thread { - threadId = ThreadId [], + threadId, threadControl = ThreadControl (runIOSim mainAction) MainFrame, threadStatus = ThreadRunning, threadMasking = Unmasked, threadThrowTo = [], threadClockId = ClockId [], - threadLabel = Just "main", + threadLabel, threadNextTId = 1, threadStep = 0, - threadVClock = insertVClock (ThreadId []) 0 bottomVClock, + threadVClock = insertVClock threadId 0 bottomVClock, threadEffect = mempty, - threadRacy = False + threadRacy } diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index b1c65a0b..5541bc58 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -27,9 +27,11 @@ import Data.Foldable (foldl') import Data.Functor (($>)) import Data.Time.Clock (picosecondsToDiffTime) +import Control.Concurrent (rtsSupportsBoundThreads) import Control.Exception (ArithException (..), AsyncException) import Control.Monad import Control.Monad.Fix +import Control.Monad.Trans.Reader (runReaderT) import System.IO.Error (ioeGetErrorString, isUserError) import Control.Concurrent.Class.MonadSTM.Strict @@ -143,6 +145,12 @@ tests = [ testProperty "1" unit_fork_1 , testProperty "2" unit_fork_2 ] + , testGroup "labelled threads" + [ testProperty "IO" unit_labelled_fork_IO + , testProperty "IOSim" unit_labelled_fork_ST + , testProperty "ReaderT IO" unit_labelled_fork_ReaderT_IO + , testProperty "ReaderT IOSim" unit_labelled_fork_ReaderT_ST + ] , testGroup "async exception unit tests" [ testProperty "1" unit_async_1 , testProperty "2" unit_async_2 @@ -1356,6 +1364,36 @@ unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property unit_catch_throwTo_masking_state_async_mayblock_ST ms = once $ runSimOrThrow (prop_catch_throwTo_masking_state_async_mayblock ms) +-- +-- Labelled threads +-- + +-- | Labelled `fork` and `async` functions which can run in `IO`: forking +-- a bound thread requires the threaded RTS. +-- +labelledForksIO :: [LabelledFork] +labelledForksIO = + [ fork + | fork <- [minBound .. maxBound] + , rtsSupportsBoundThreads || not (isBoundLabelledFork fork) + ] + +unit_labelled_fork_IO :: Property +unit_labelled_fork_IO = once $ ioProperty $ + conjoin <$> traverse prop_labelled_fork labelledForksIO + +unit_labelled_fork_ST :: Property +unit_labelled_fork_ST = once $ runSimOrThrow $ + conjoin <$> traverse prop_labelled_fork [minBound .. maxBound] + +unit_labelled_fork_ReaderT_IO :: Property +unit_labelled_fork_ReaderT_IO = once $ ioProperty $ flip runReaderT () $ + conjoin <$> traverse prop_labelled_fork labelledForksIO + +unit_labelled_fork_ReaderT_ST :: Property +unit_labelled_fork_ReaderT_ST = once $ runSimOrThrow $ flip runReaderT () $ + conjoin <$> traverse prop_labelled_fork [minBound .. maxBound] + -- -- MonadTimerCancellable -- diff --git a/io-sim/test/Test/Control/Monad/IOSimPOR.hs b/io-sim/test/Test/Control/Monad/IOSimPOR.hs index cce7fc40..b3ae9ae0 100644 --- a/io-sim/test/Test/Control/Monad/IOSimPOR.hs +++ b/io-sim/test/Test/Control/Monad/IOSimPOR.hs @@ -23,6 +23,7 @@ import System.IO.Error (ioeGetErrorString, isUserError) import Control.Exception (ArithException (..), AsyncException) import Control.Monad import Control.Monad.Fix +import Control.Monad.Trans.Reader (runReaderT) import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadAsync @@ -145,6 +146,14 @@ tests = , testProperty "tightening" prop_mfix_left_shrinking , testProperty "lazy" prop_mfix_lazy ] + , testGroup "racyByLabel" + [ testProperty "1" unit_racyByLabel_1 + , testProperty "2" unit_racyByLabel_2 + , testProperty "3" unit_racyByLabel_3 + , testProperty "4" unit_racyByLabel_4 + , testProperty "5" unit_racyByLabel_5 + , testProperty "6" unit_racyByLabel_6 + ] ] ] @@ -422,7 +431,7 @@ unit_issue113_nonDep = propPermutations :: Int -> Property propPermutations n = traceNoDuplicates $ \addTrace -> - exploreSimTrace (withScheduleBound 10000) (doit n) $ \_ trace -> + exploreSimTrace (withRacyMainThread . withScheduleBound 10000) (doit n) $ \_ trace -> addTrace trace $ let Right result = traceResult False trace in tabulate "Result" [show result] True @@ -430,7 +439,6 @@ propPermutations n = doit :: Int -> IOSim s [Int] doit n = do r <- newTVarIO [] - exploreRaces mapM_ (\i -> forkIO $ atomically $ modifyTVar r (++[i])) [1..n] threadDelay 1 readTVarIO r @@ -477,7 +485,7 @@ prop_explore_endless_simulation (Positive (Small finalTime)) = $ label (show (secondsToDiffTime finalTime)) $ within 15000000 -- 15 seconds $ exploreSimTrace - id sim $ \_ trace -> do + withRacyMainThread sim $ \_ trace -> do let l = takeWhile (\(t, _, _, _) -> t < Time (secondsToDiffTime finalTime)) . traceEvents $ trace @@ -493,9 +501,7 @@ prop_explore_endless_simulation (Positive (Small finalTime)) = thread sim :: forall s. IOSim s Void - sim = do - exploreRaces - withAsync thread wait + sim = withAsync thread wait -- -- IOSim reused properties @@ -552,7 +558,7 @@ prop_threadId_order_order_Sim n = -- prop_mfix_purity :: Positive Int -> Property prop_mfix_purity (Positive n) = - exploreSimTrace id (mfix (return . factorial)) $ \_ trace -> + exploreSimTrace withRacyMainThread (mfix (return . factorial)) $ \_ trace -> case traceResult False trace of Right f -> f n === fix factorial n Left e -> counterexample (show e) False @@ -564,13 +570,14 @@ prop_mfix_purity_2 :: [Positive Int] -> Property prop_mfix_purity_2 as = -- note: both 'IOSim' expressions are equivalent using 'Monad' and -- 'Applicative' laws only. - exploreSimTrace id (join $ mfix (return . recDelay) - <*> return as') (\_ trace -> + exploreSimTrace withRacyMainThread + (join $ mfix (return . recDelay) + <*> return as') (\_ trace -> case traceResult False trace of Right a -> a === expected Left e -> counterexample (show e) False) .&&. - exploreSimTrace id (mfix (return . recDelay) >>= ($ as')) (\_ trace -> + exploreSimTrace withRacyMainThread (mfix (return . recDelay) >>= ($ as')) (\_ trace -> case traceResult False trace of Right a -> a === expected Left e -> counterexample (show e) False) @@ -603,13 +610,15 @@ prop_mfix_left_shrinking n (NonNegative d) (Positive i) = mn = do say "" threadDelay (realToFrac d) return n - in exploreSimTrace id (mfix (\rec_ -> mn >>= \a -> + in exploreSimTrace withRacyMainThread + (mfix (\rec_ -> mn >>= \a -> + threadDelay (realToFrac d) $> a : rec_)) + (\_ trace1 -> + exploreSimTrace withRacyMainThread + (mn >>= \a -> + mfix (\rec_ -> threadDelay (realToFrac d) $> a : rec_)) - (\_ trace1 -> - exploreSimTrace id (mn >>= \a -> - mfix (\rec_ -> - threadDelay (realToFrac d) $> a : rec_)) - (\_ trace2 -> + (\_ trace2 -> case (traceResult False trace1, traceResult False trace2) of (Right a , Right b) -> take i a === take i b (Left e , Right _) -> counterexample (show e) False @@ -623,7 +632,7 @@ prop_mfix_left_shrinking n (NonNegative d) (Positive i) = prop_mfix_lazy :: NonEmptyList Char -> Property prop_mfix_lazy (NonEmpty env) = - exploreSimTrace id (withEnv (mfix . replicateHeadM)) (\_ trace -> + exploreSimTrace withRacyMainThread (withEnv (mfix . replicateHeadM)) (\_ trace -> case traceResult False trace of Right a -> take samples a === replicate samples (head env) Left e -> counterexample (show e) False) @@ -675,7 +684,7 @@ unit_catch_0, unit_catch_1, unit_catch_2, unit_catch_3, unit_catch_4, -- unhandled top level exception unit_catch_0 = - exploreSimTrace id example $ \_ trace -> + exploreSimTrace withRacyMainThread example $ \_ trace -> counterexample (List.intercalate "\n" $ map show $ traceEvents trace) $ counterexample (show $ selectTraceSay trace) $ selectTraceSay trace === ["before"] @@ -692,15 +701,16 @@ unit_catch_0 = -- normal execution of a catch frame unit_catch_1 = - exploreSimTrace id (do catch (say "inner") - (\(_e :: IOError) -> say "handler") - say "after") - $ \_ trace -> + exploreSimTrace withRacyMainThread + (do catch (say "inner") + (\(_e :: IOError) -> say "handler") + say "after") + $ \_ trace -> selectTraceSay trace === ["inner", "after"] -- catching an exception thrown in a catch frame unit_catch_2 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do catch (do say "inner1" _ <- throwIO DivideByZero say "inner2") @@ -711,7 +721,7 @@ unit_catch_2 = -- not catching an exception of the wrong type unit_catch_3 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do catch (do say "inner" throwIO DivideByZero) (\(_e :: IOError) -> say "handler") @@ -722,7 +732,7 @@ unit_catch_3 = -- catching an exception in an outer handler unit_catch_4 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do catch (catch (do say "inner" throwIO DivideByZero) (\(_e :: IOError) -> say "handler1")) @@ -734,7 +744,7 @@ unit_catch_4 = -- catching an exception in the inner handler unit_catch_5 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do catch (catch (do say "inner" throwIO DivideByZero) (\(_e :: ArithException) -> say "handler1")) @@ -745,7 +755,7 @@ unit_catch_5 = -- catching an exception in the inner handler, rethrowing and catching in outer unit_catch_6 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do catch (catch (do say "inner" throwIO DivideByZero) (\(e :: ArithException) -> do @@ -786,7 +796,7 @@ unit_evaluate_0 = -- 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" :: ()) - exploreSimTrace id (evaluate (error "boom" :: ())) $ \_ trace -> + exploreSimTrace withRacyMainThread (evaluate (error "boom" :: ())) $ \_ trace -> case traceResult False trace of Right _ -> counterexample "didn't fail" False Left _ -> property True @@ -795,7 +805,7 @@ unit_evaluate_0 = -- Try works and we can pass exceptions back from threads. -- And terminating with an exception is reported properly. unit_fork_1 = - exploreSimTrace id example $ \_ trace -> + exploreSimTrace withRacyMainThread example $ \_ trace -> selectTraceSay trace === ["parent", "user error (oh noes!)"] .&&. case traceResult True trace of Left (FailureException e) @@ -827,7 +837,7 @@ unit_async_1, unit_async_2, unit_async_3, unit_async_4, unit_async_1 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- myThreadId say "before" throwTo tid DivideByZero @@ -848,7 +858,7 @@ unit_async_2 = unit_async_3 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- forkIO $ say "child" threadDelay 1 -- child has already terminated when we throw the async exception @@ -859,7 +869,7 @@ unit_async_3 = unit_async_4 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- forkIO $ do say "child" catch (atomically retry) @@ -874,7 +884,7 @@ unit_async_4 = unit_async_5 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- forkIO $ mask_ $ do say "child" @@ -894,7 +904,7 @@ unit_async_5 = unit_async_6 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- forkIO $ mask_ $ do say "child" @@ -909,7 +919,7 @@ unit_async_6 = unit_async_7 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- forkIO $ do uninterruptibleMask_ $ do say "child" @@ -929,7 +939,7 @@ unit_async_7 = unit_async_8 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (uninterruptibleMask_ $ do tid <- forkIO $ atomically retry throwTo tid DivideByZero) $ \_ trace -> @@ -939,7 +949,7 @@ unit_async_8 = unit_async_9 = - exploreSimTrace id + exploreSimTrace withRacyMainThread (do tid <- forkIO $ do uninterruptibleMask_ $ do say "child" @@ -967,14 +977,14 @@ unit_async_9 = -- prop_stm_referenceSim :: SomeTerm -> Property prop_stm_referenceSim t = - exploreSimTrace id (prop_stm_referenceM t) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_stm_referenceM t) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False prop_timeout_no_deadlock_Sim :: Property prop_timeout_no_deadlock_Sim = -- runSimOrThrow prop_timeout_no_deadlockM - exploreSimTrace id prop_timeout_no_deadlockM $ \_ trace -> + exploreSimTrace withRacyMainThread prop_timeout_no_deadlockM $ \_ trace -> case traceResult False trace of Right a -> property a Left e -> counterexample (show e) False @@ -984,7 +994,7 @@ prop_timeout -> ActionDuration -> Property prop_timeout intendedTimeoutDuration intendedActionDuration = - exploreSimTrace id experiment $ \_ trace -> + exploreSimTrace withRacyMainThread experiment $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False @@ -997,7 +1007,7 @@ prop_timeout intendedTimeoutDuration intendedActionDuration = prop_timeouts :: [(TimeoutDuration, ActionDuration)] -> Property -prop_timeouts times = exploreSimTrace id experiment $ \_ trace -> +prop_timeouts times = exploreSimTrace withRacyMainThread experiment $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False @@ -1086,7 +1096,7 @@ unit_registerDelay_threadDelay = unit_timeouts_and_async_exceptions_1 :: Property unit_timeouts_and_async_exceptions_1 = - exploreSimTrace id experiment $ \_ trace -> + exploreSimTrace withRacyMainThread experiment $ \_ trace -> counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1108,7 +1118,7 @@ unit_timeouts_and_async_exceptions_1 = unit_timeouts_and_async_exceptions_2 :: Property unit_timeouts_and_async_exceptions_2 = - exploreSimTrace id experiment $ \_ trace -> + exploreSimTrace withRacyMainThread experiment $ \_ trace -> counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1130,7 +1140,7 @@ unit_timeouts_and_async_exceptions_2 = unit_timeouts_and_async_exceptions_3 :: Property unit_timeouts_and_async_exceptions_3 = - exploreSimTrace id experiment $ \_ trace -> + exploreSimTrace withRacyMainThread experiment $ \_ trace -> counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1155,56 +1165,146 @@ unit_timeouts_and_async_exceptions_3 = unit_set_masking_state_ST :: MaskingState -> Property unit_set_masking_state_ST ms = - exploreSimTrace id (prop_set_masking_state ms) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_set_masking_state ms) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_unmask_ST :: MaskingState -> MaskingState -> Property unit_unmask_ST ms ms' = - exploreSimTrace id (prop_unmask ms ms') $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_unmask ms ms') $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_fork_masking_state_ST :: MaskingState -> Property unit_fork_masking_state_ST ms = - exploreSimTrace id (prop_fork_masking_state ms) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_fork_masking_state ms) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_fork_unmask_ST :: MaskingState -> MaskingState -> Property unit_fork_unmask_ST ms ms' = - exploreSimTrace id (prop_fork_unmask ms ms') $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_fork_unmask ms ms') $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_catch_throwIO_masking_state_ST :: MaskingState -> Property unit_catch_throwIO_masking_state_ST ms = - exploreSimTrace id (prop_catch_throwIO_masking_state ms) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_catch_throwIO_masking_state ms) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_catch_throwTo_masking_state_ST :: MaskingState -> Property unit_catch_throwTo_masking_state_ST ms = - exploreSimTrace id (prop_catch_throwTo_masking_state ms) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_catch_throwTo_masking_state ms) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_catch_throwTo_masking_state_async_ST :: MaskingState -> Property unit_catch_throwTo_masking_state_async_ST ms = - exploreSimTrace id (prop_catch_throwTo_masking_state_async ms) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_catch_throwTo_masking_state_async ms) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property unit_catch_throwTo_masking_state_async_mayblock_ST ms = - exploreSimTrace id (prop_catch_throwTo_masking_state_async_mayblock ms) $ \_ trace -> + exploreSimTrace withRacyMainThread (prop_catch_throwTo_masking_state_async_mayblock ms) $ \_ trace -> case traceResult False trace of Right a -> a Left e -> counterexample (show e) False + + +prop_racyByLabel :: (Maybe ThreadLabel -> Bool) + -> Bool + -> (forall s. IOSim s IOSimThreadId) + -> Property +prop_racyByLabel racyByLabel expected sim = + exploreSimTrace (withRacyByLabel racyByLabel) + sim $ \_ trace -> + case traceResult False trace of + Right tid -> counterexample (ppTrace trace) + $ isRacyThreadId tid === expected + Left e -> counterexample (show e) False + where + isRacyThreadId RacyThreadId{} = True + isRacyThreadId ThreadId{} = False + + +unit_racyByLabel_1 + , unit_racyByLabel_2 + , unit_racyByLabel_3 + , unit_racyByLabel_4 :: Property + +unit_racyByLabel_1 = once $ + prop_racyByLabel + (\case Nothing -> False + Just "x" -> True + Just{} -> False + ) + True + sim + where + sim :: IOSim s IOSimThreadId + sim = forkLabelledIO "x" (pure ()) + +unit_racyByLabel_2 = once $ + prop_racyByLabel + (\case Nothing -> False + Just "x" -> True + Just{} -> False + ) + False + sim + where + sim :: IOSim s IOSimThreadId + sim = forkIO (labelThisThread "x") + +-- main thread is racy +unit_racyByLabel_3 = once $ + prop_racyByLabel + (const True) + True + sim + where + sim :: IOSim s IOSimThreadId + sim = myThreadId + +unit_racyByLabel_4 = once $ + prop_racyByLabel + (\case Nothing -> False + Just "x" -> True + Just{} -> False + ) + True + sim + where + sim :: IOSim s IOSimThreadId + sim = asyncThreadId <$> asyncLabelled "x" (pure ()) + +-- | Every labelled `fork` and `async` function passes the label to `Fork`. +-- +unit_racyByLabel_5 :: Property +unit_racyByLabel_5 = once $ conjoin + [ counterexample (show fork) + $ prop_racyByLabel (== Just "x") True + $ fst <$> runLabelledFork fork "x" (pure ()) + | fork <- [minBound .. maxBound] + ] + +-- | Like 'unit_racyByLabel_5' but in `ReaderT`, whose instances must pass the +-- label to the underlying monad rather than label the thread after it was +-- forked. +-- +unit_racyByLabel_6 :: Property +unit_racyByLabel_6 = once $ conjoin + [ counterexample (show fork) + $ prop_racyByLabel (== Just "x") True + $ fmap fst $ flip runReaderT () $ runLabelledFork fork "x" (pure ()) + | fork <- [minBound .. maxBound] + ] diff --git a/io-sim/test/Test/Control/Monad/Utils.hs b/io-sim/test/Test/Control/Monad/Utils.hs index 1c49d34c..a03a7557 100644 --- a/io-sim/test/Test/Control/Monad/Utils.hs +++ b/io-sim/test/Test/Control/Monad/Utils.hs @@ -413,6 +413,10 @@ prop_withAsyncWithUnmask_masking_state ms = <$> withAsyncWithUnmask child wait , ("withAsyncOnWithUnmask",) <$> withAsyncOnWithUnmask 0 child wait + , ("withAsyncLabelledWithUnmask",) + <$> withAsyncLabelledWithUnmask "label" child wait + , ("withAsyncLabelledOnWithUnmask",) + <$> withAsyncLabelledOnWithUnmask "label" 0 child wait ] return $ conjoin [ counterexample name $ r === (ms, Unmasked) @@ -514,6 +518,104 @@ prop_catch_throwTo_masking_state_async_mayblock ms = do throwTo tid (userError "error") atomically $ takeTMVar var +-- +-- Labelled threads +-- + +-- | The `forkLabelled` and `asyncLabelled` families of functions. +-- +data LabelledFork = + ForkLabelledIO + | ForkLabelledOn + | ForkLabelledIOWithUnmask + | ForkLabelledFinally + | AsyncLabelled + | AsyncLabelledBound + | AsyncLabelledOn + | AsyncLabelledWithUnmask + | AsyncLabelledOnWithUnmask + | WithAsyncLabelled + | WithAsyncLabelledBound + | WithAsyncLabelledOn + | WithAsyncLabelledWithUnmask + | WithAsyncLabelledOnWithUnmask + deriving (Show, Eq, Enum, Bounded) + +-- | Functions which fork a bound thread, in `IO` they require the threaded +-- RTS. +-- +isBoundLabelledFork :: LabelledFork -> Bool +isBoundLabelledFork AsyncLabelledBound = True +isBoundLabelledFork WithAsyncLabelledBound = True +isBoundLabelledFork _ = False + +-- | Run an action in a thread forked with the given function, and wait for +-- its result. +-- +runLabelledFork :: forall m a. + ( MonadAsync m + , MonadFork m + , MonadCatch m + ) + => LabelledFork + -> String + -- ^ label + -> m a + -> m (ThreadId m, a) +runLabelledFork fork lbl child = + case fork of + ForkLabelledIO -> viaTMVar $ \k -> + forkLabelledIO lbl (try child >>= k) + ForkLabelledOn -> viaTMVar $ \k -> + forkLabelledOn lbl 0 (try child >>= k) + ForkLabelledIOWithUnmask -> viaTMVar $ \k -> + forkLabelledIOWithUnmask lbl + (\unmask -> try (unmask child) >>= k) + ForkLabelledFinally -> viaTMVar $ + forkLabelledFinally lbl child + AsyncLabelled -> asyncLabelled lbl child >>= waitAsync + AsyncLabelledBound -> asyncLabelledBound lbl child >>= waitAsync + AsyncLabelledOn -> asyncLabelledOn lbl 0 child >>= waitAsync + AsyncLabelledWithUnmask -> asyncLabelledWithUnmask lbl + (\unmask -> unmask child) + >>= waitAsync + AsyncLabelledOnWithUnmask -> asyncLabelledOnWithUnmask lbl 0 + (\unmask -> unmask child) + >>= waitAsync + WithAsyncLabelled -> withAsyncLabelled lbl child waitAsync + WithAsyncLabelledBound -> withAsyncLabelledBound lbl child waitAsync + WithAsyncLabelledOn -> withAsyncLabelledOn lbl 0 child waitAsync + WithAsyncLabelledWithUnmask -> withAsyncLabelledWithUnmask lbl + (\unmask -> unmask child) + waitAsync + WithAsyncLabelledOnWithUnmask -> withAsyncLabelledOnWithUnmask lbl 0 + (\unmask -> unmask child) + waitAsync + where + viaTMVar :: ((Either SomeException a -> m ()) -> m (ThreadId m)) + -> m (ThreadId m, a) + viaTMVar forkFn = do + var <- newEmptyTMVarIO + tid <- forkFn (atomically . putTMVar var) + r <- atomically (takeTMVar var) + either throwIO (return . (tid,)) r + + waitAsync :: Async m a -> m (ThreadId m, a) + waitAsync a = (asyncThreadId a,) <$> wait a + +-- | Check that a thread forked with a labelled `fork` or `async` function is +-- labelled before it runs. +-- +prop_labelled_fork :: ( MonadAsync m + , MonadFork m + , MonadCatch m + ) + => LabelledFork -> m Property +prop_labelled_fork fork = do + (_, lbl) <- runLabelledFork fork "label" (threadLabel =<< myThreadId) + return $ counterexample (show fork) + $ lbl === Just "label" + -- -- MonadMask properties --