From ffab18c0960fcec8d35fb882f83e252034a4b516 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Thu, 14 Dec 2023 17:16:54 +0000 Subject: [PATCH 1/6] Adds random scheduling via threadDelay --- io-sim/io-sim.cabal | 4 +- io-sim/src/Control/Monad/IOSim.hs | 21 +- io-sim/src/Control/Monad/IOSim/Internal.hs | 81 ++++- .../Control/Concurrent/Class/MonadMVar.hs | 140 ++++---- io-sim/test/Test/Control/Monad/IOSim.hs | 337 +++++++++--------- io-sim/test/Test/Control/Monad/IOSimPOR.hs | 25 +- io-sim/test/Test/Control/Monad/Utils.hs | 5 +- 7 files changed, 344 insertions(+), 269 deletions(-) diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal index b91d0e8c..83ea0e06 100644 --- a/io-sim/io-sim.cabal +++ b/io-sim/io-sim.cabal @@ -85,6 +85,7 @@ library si-timers ^>=1.3, time >=1.9.1 && <1.13, quiet, + random, QuickCheck, @@ -113,7 +114,8 @@ test-suite test tasty, tasty-quickcheck, tasty-hunit, - time + time, + random 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 45233afa..68666d95 100644 --- a/io-sim/src/Control/Monad/IOSim.hs +++ b/io-sim/src/Control/Monad/IOSim.hs @@ -131,6 +131,7 @@ import Test.QuickCheck import System.IO.Unsafe import qualified Debug.Trace as Debug +import System.Random (StdGen) selectTraceEvents @@ -394,19 +395,19 @@ instance Exception Failure where , "please report the issue at\n" , "https://github.com/input-output-hk/io-sim/issues" ] - + -- | 'IOSim' is a pure monad. -- -runSim :: forall a. (forall s. IOSim s a) -> Either Failure a -runSim mainAction = traceResult False (runSimTrace mainAction) +runSim :: forall a. StdGen -> (forall s. IOSim s a) -> Either Failure a +runSim stdGen mainAction = traceResult False (runSimTrace stdGen mainAction) -- | For quick experiments and tests it is often appropriate and convenient to -- simply throw failures as exceptions. -- -runSimOrThrow :: forall a. (forall s. IOSim s a) -> a -runSimOrThrow mainAction = - case runSim mainAction of +runSimOrThrow :: forall a. StdGen -> (forall s. IOSim s a) -> a +runSimOrThrow stdGen mainAction = + case runSim stdGen mainAction of Left e -> throw e Right x -> x @@ -414,8 +415,8 @@ runSimOrThrow mainAction = -- threads still running or blocked. If one is trying to follow a strict thread -- clean-up policy then this helps testing for that. -- -runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a -runSimStrictShutdown mainAction = traceResult True (runSimTrace mainAction) +runSimStrictShutdown :: forall a. StdGen -> (forall s. IOSim s a) -> Either Failure a +runSimStrictShutdown stdGen mainAction = traceResult True (runSimTrace stdGen mainAction) -- | Fold through the trace and return either a 'Failure' or the simulation -- result, i.e. the return value of the main thread. @@ -484,8 +485,8 @@ ppEvents events = -- | See 'runSimTraceST' below. -- -runSimTrace :: forall a. (forall s. IOSim s a) -> SimTrace a -runSimTrace mainAction = runST (runSimTraceST mainAction) +runSimTrace :: forall a. StdGen -> (forall s. IOSim s a) -> SimTrace a +runSimTrace stdGen mainAction = runST (runSimTraceST stdGen mainAction) -- -- IOSimPOR diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 4da5330d..17843395 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -76,12 +76,13 @@ import Control.Monad.Class.MonadSTM hiding (STM) import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar)) import Control.Monad.Class.MonadThrow hiding (getMaskingState) import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) +import Control.Monad.Class.MonadTimer.SI (TimeoutState (..), DiffTime, diffTimeToMicrosecondsAsInt, microsecondsAsIntToDiffTime) import Control.Monad.IOSim.InternalTypes import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent), Trace (SimPORTrace)) import Control.Monad.IOSim.Types (SimEvent) +import System.Random (StdGen, randomR, split) -- -- Simulation interpreter @@ -150,11 +151,12 @@ data SimState s a = SimState { -- | list of clocks clocks :: !(Map ClockId UTCTime), nextVid :: !TVarId, -- ^ next unused 'TVarId' - nextTmid :: !TimeoutId -- ^ next unused 'TimeoutId' + nextTmid :: !TimeoutId, -- ^ next unused 'TimeoutId' + stdGen :: !StdGen } -initialState :: SimState s a -initialState = +initialState :: StdGen -> SimState s a +initialState stdGen = SimState { runqueue = mempty, threads = Map.empty, @@ -162,7 +164,8 @@ initialState = timers = PSQ.empty, clocks = Map.singleton (ClockId []) epoch1970, nextVid = TVarId 0, - nextTmid = TimeoutId 0 + nextTmid = TimeoutId 0, + stdGen = stdGen } where epoch1970 = UTCTime (fromGregorian 1970 1 1) 0 @@ -189,6 +192,42 @@ invariant Nothing SimState{runqueue,threads,clocks} = timeSinceEpoch :: Time -> NominalDiffTime timeSinceEpoch (Time t) = fromRational (toRational t) +-- | This function receives a delay and adds jitter to it. The amount of +-- jitter added is proportional to how large the delay is so to not greatly +-- affect the indended behaviour of the function that calls it. +-- +-- This function is used in order to introduce random delays between +-- concurrent threads so that different thread schedulings might be found. +-- +-- This approach is nice because, since time is perfect (due to infinite +-- processing power of IOSim), IOSim will be able to introduce slight delays +-- that might lead to threads being scheduled differently. +-- +-- Note that this only enables IOSim to explore different thread schedules for +-- concurrent threads blocked on 'threadDelay'. For threads blocked on STM +-- IOSim employs a way to awake threads in a pseudo random way. +-- +-- Also note that it is safe to add jitter to 'threadDelay' because we only +-- have to guarantee that the thread is not woken up earlier than the delay +-- specified. +-- +jitterDelay :: StdGen -> DiffTime -> DiffTime +jitterDelay stdGen d = + let -- Convert delay from DiffTime to picoseconds + delayInMicrosecondsAsInt = diffTimeToMicrosecondsAsInt d + + -- Define the maximum jitter as a percentage of the delay + -- For example, 10% of the delay + maxJitter = delayInMicrosecondsAsInt `div` 10 + + -- Generate a random jitter value within the range + (jitterInMicrosecondsAsInt, _) = randomR (0, maxJitter) stdGen + + -- Convert jitter back to DiffTime + jitter = microsecondsAsIntToDiffTime jitterInMicrosecondsAsInt + + in -- Add jitter to the original delay + d + jitter -- | Schedule / run a thread. -- @@ -205,7 +244,8 @@ schedule !thread@Thread{ timers, clocks, nextVid, nextTmid, - curTime = time + curTime = time, + stdGen } = invariant (Just thread) simstate $ case action of @@ -390,12 +430,15 @@ schedule !thread@Thread{ !tvar <- execNewTVar nextVid (Just $! "<>") False - let !expiry = d `addTime` time + let !expiry = jitterDelay stdGen d `addTime` time !timers' = PSQ.insert nextTmid expiry (TimerRegisterDelay tvar) timers !thread' = thread { threadControl = ThreadControl (k tvar) ctl } + (_, !stdGen') = split stdGen trace <- schedule thread' simstate { timers = timers' , nextVid = succ nextVid - , nextTmid = succ nextTmid } + , nextTmid = succ nextTmid + , stdGen = stdGen' + } return (SimTrace time tid tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) trace) @@ -409,11 +452,14 @@ schedule !thread@Thread{ trace) ThreadDelay d k -> do - let !expiry = d `addTime` time + let !expiry = jitterDelay stdGen d `addTime` time !timers' = PSQ.insert nextTmid expiry (TimerThreadDelay tid nextTmid) timers !thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) } + (_, !stdGen') = split stdGen !trace <- deschedule (Blocked BlockedOnDelay) thread' simstate { timers = timers' - , nextTmid = succ nextTmid } + , nextTmid = succ nextTmid + , stdGen = stdGen' + } return (SimTrace time tid tlbl (EventThreadDelay nextTmid expiry) trace) -- we treat negative timers as cancelled ones; for the record we put @@ -432,13 +478,16 @@ schedule !thread@Thread{ !tvar <- execNewTVar nextVid (Just $! "<>") TimeoutPending - let !expiry = d `addTime` time + let !expiry = jitterDelay stdGen d `addTime` time !t = Timeout tvar nextTmid !timers' = PSQ.insert nextTmid expiry (Timer tvar) timers !thread' = thread { threadControl = ThreadControl (k t) ctl } + (_, !stdGen') = split stdGen trace <- schedule thread' simstate { timers = timers' , nextVid = succ nextVid - , nextTmid = succ nextTmid } + , nextTmid = succ nextTmid + , stdGen = stdGen' + } return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) trace) CancelTimeout (Timeout tvar tmid) k -> do @@ -861,9 +910,9 @@ forkTimeoutInterruptThreads timeoutExpired simState = where -- we launch a thread responsible for throwing an AsyncCancelled exception -- to the thread which timeout expired - throwToThread :: [(Thread s a, TMVar (IOSim s) IOSimThreadId)] + throwToThread :: [(Thread s a, TMVar (IOSim s) IOSimThreadId)] - (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired + (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired where fn :: SimState s a -> (IOSimThreadId, TimeoutId, TMVar (IOSim s) IOSimThreadId) @@ -997,8 +1046,8 @@ lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads) -- computation with 'Control.Monad.IOSim.traceEvents'. A slightly more -- convenient way is exposed by 'Control.Monad.IOSim.runSimTrace'. -- -runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a) -runSimTraceST mainAction = schedule mainThread initialState +runSimTraceST :: forall s a. StdGen -> IOSim s a -> ST s (SimTrace a) +runSimTraceST stdGen mainAction = schedule mainThread (initialState stdGen) where mainThread = Thread { diff --git a/io-sim/test/Test/Control/Concurrent/Class/MonadMVar.hs b/io-sim/test/Test/Control/Concurrent/Class/MonadMVar.hs index e0f52130..8a99e291 100644 --- a/io-sim/test/Test/Control/Concurrent/Class/MonadMVar.hs +++ b/io-sim/test/Test/Control/Concurrent/Class/MonadMVar.hs @@ -22,47 +22,48 @@ import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) +import System.Random (StdGen, mkStdGen) tests :: TestTree tests = testGroup "Control.Concurrent.Class.MonadMVar" [ testGroup "putMVar" [ testProperty "fairness (IOSim)" prop_putMVar_fairness_sim - , testCase "blocks on a full MVar (IOSim)" + , testProperty "blocks on a full MVar (IOSim)" unit_putMVar_blocks_on_full_sim , testCase "blocks on a full MVar (IO)" unit_putMVar_blocks_on_full_io ] , testGroup "takeMVar" [ testProperty "fairness (IOSim)" prop_takeMVar_fairness_sim - , testCase "blocks on an empty MVar (IOSim)" + , testProperty "blocks on an empty MVar (IOSim)" unit_takeMVar_blocks_on_empty_sim , testCase "blocks on an empty MVar (IO)" unit_takeMVar_blocks_on_empty_io ] , testGroup "tryTakeMVar" - [ testCase "does not block on an empty MVar (IOSim)" + [ testProperty "does not block on an empty MVar (IOSim)" unit_tryTakeMVar_empty - , testCase "does not block on a full MVar (IOSim)" + , testProperty "does not block on a full MVar (IOSim)" unit_tryTakeMVar_full - , testCase "return value on an empty MVar (IOSim)" + , testProperty "return value on an empty MVar (IOSim)" unit_tryTakeMVar_return_empty_sim - , testCase "return value on an full MVar (IOSim)" + , testProperty "return value on an full MVar (IOSim)" unit_tryTakeMVar_return_full_sim ] , testGroup "tryPutMVar" - [ testCase "does not block on an empty MVar (IOSim)" + [ testProperty "does not block on an empty MVar (IOSim)" unit_tryPutMVar_empty - , testCase "does not block on a full MVar (IOSim)" + , testProperty "does not block on a full MVar (IOSim)" unit_tryPutMVar_full - , testCase "return value on an empty MVar (IOSim)" + , testProperty "return value on an empty MVar (IOSim)" unit_tryPutMVar_return_empty_sim - , testCase "return value on an full MVar (IOSim)" + , testProperty "return value on an full MVar (IOSim)" unit_tryPutMVar_return_full_sim ] , testGroup "isEmptyMVar" - [ testCase "empty MVar is empty" unit_isEmptyMVar_empty_sim - , testCase "full MVar is not empty" unit_isEmptyMVar_full_sim + [ testProperty "empty MVar is empty" unit_isEmptyMVar_empty_sim + , testProperty "full MVar is not empty" unit_isEmptyMVar_full_sim ] ] @@ -91,10 +92,11 @@ putMVar_fairness_property n = do results <- sequence (replicate n (takeMVar v)) return $ results == [1..n] -prop_putMVar_fairness_sim :: Positive (Small Int) +prop_putMVar_fairness_sim :: Int + -> Positive (Small Int) -> Property -prop_putMVar_fairness_sim (Positive (Small n)) = - let trace = runSimTrace (putMVar_fairness_property n) +prop_putMVar_fairness_sim r (Positive (Small n)) = + let trace = runSimTrace (mkStdGen r) (putMVar_fairness_property n) in counterexample (ppTrace trace) $ case traceResult False trace of Left err -> counterexample (show err) False @@ -118,9 +120,10 @@ unit_putMVar_blocks_on_full = do end <- getMonotonicTime return (end `diffTime` start >= delta) -unit_putMVar_blocks_on_full_sim :: Assertion -unit_putMVar_blocks_on_full_sim = assertBool "did not block on an full MVar" $ - runSimOrThrow unit_putMVar_blocks_on_full +unit_putMVar_blocks_on_full_sim :: Int -> Property +unit_putMVar_blocks_on_full_sim r = + counterexample "did not block on an full MVar" + $ runSimOrThrow (mkStdGen r) unit_putMVar_blocks_on_full unit_putMVar_blocks_on_full_io :: Assertion unit_putMVar_blocks_on_full_io = @@ -151,10 +154,11 @@ takeMVar_fairness_property n = do results <- waitAll ts return $ results === [1..n] -prop_takeMVar_fairness_sim :: Positive (Small Int) +prop_takeMVar_fairness_sim :: Int + -> Positive (Small Int) -> Property -prop_takeMVar_fairness_sim (Positive (Small n)) = - runSimOrThrow (takeMVar_fairness_property n) +prop_takeMVar_fairness_sim r (Positive (Small n)) = + runSimOrThrow (mkStdGen r) (takeMVar_fairness_property n) unit_takeMVar_blocks_on_empty @@ -173,8 +177,10 @@ unit_takeMVar_blocks_on_empty = do end <- getMonotonicTime return (end `diffTime` start >= delta) -unit_takeMVar_blocks_on_empty_sim :: Assertion -unit_takeMVar_blocks_on_empty_sim = assertBool "did not block on an empty MVar" $ runSimOrThrow unit_takeMVar_blocks_on_empty +unit_takeMVar_blocks_on_empty_sim :: Int -> Property +unit_takeMVar_blocks_on_empty_sim r = + counterexample "did not block on an empty MVar" + $ runSimOrThrow (mkStdGen r) unit_takeMVar_blocks_on_empty unit_takeMVar_blocks_on_empty_io :: Assertion unit_takeMVar_blocks_on_empty_io = @@ -188,9 +194,9 @@ unit_takeMVar_blocks_on_empty_io = -- | Check that `IOSim`'s `tryTakeMVar` is non blocking. -- tryTakeMVar_non_blocking_property - :: Bool -> Bool -tryTakeMVar_non_blocking_property isEmpty = - validateTrace $ runSimTrace $ do + :: StdGen -> Bool -> Bool +tryTakeMVar_non_blocking_property stdGen isEmpty = + validateTrace $ runSimTrace stdGen $ do v <- if isEmpty then newEmptyMVar else newMVar () @@ -202,13 +208,15 @@ tryTakeMVar_non_blocking_property isEmpty = EventTxBlocked {} -> All False _ -> All True) -unit_tryTakeMVar_empty :: Assertion -unit_tryTakeMVar_empty = assertBool "blocked on an empty MVar" $ - tryTakeMVar_non_blocking_property False +unit_tryTakeMVar_empty :: Int -> Property +unit_tryTakeMVar_empty r = + counterexample "blocked on an empty MVar" + $ tryTakeMVar_non_blocking_property (mkStdGen r) False -unit_tryTakeMVar_full :: Assertion -unit_tryTakeMVar_full = assertBool "blocked on an empty MVar" $ - tryTakeMVar_non_blocking_property True +unit_tryTakeMVar_full :: Int -> Property +unit_tryTakeMVar_full r = + counterexample "blocked on an empty MVar" + $ tryTakeMVar_non_blocking_property (mkStdGen r) True tryTakeMVar_return_value @@ -222,15 +230,15 @@ tryTakeMVar_return_value isEmpty = a <- tryTakeMVar v return $ isNothing a == isEmpty -unit_tryTakeMVar_return_empty_sim :: Assertion -unit_tryTakeMVar_return_empty_sim = - assertBool "tryTakeMVar on an empty should return result" $ - runSimOrThrow (tryTakeMVar_return_value True) +unit_tryTakeMVar_return_empty_sim :: Int -> Property +unit_tryTakeMVar_return_empty_sim r = + counterexample "tryTakeMVar on an empty should return result" + $ runSimOrThrow (mkStdGen r) (tryTakeMVar_return_value True) -unit_tryTakeMVar_return_full_sim :: Assertion -unit_tryTakeMVar_return_full_sim = - assertBool "tryTakeMVar on an full should return result" $ - runSimOrThrow (tryTakeMVar_return_value False) +unit_tryTakeMVar_return_full_sim :: Int -> Property +unit_tryTakeMVar_return_full_sim r = + counterexample "tryTakeMVar on an full should return result" + $ runSimOrThrow (mkStdGen r) (tryTakeMVar_return_value False) -- -- tryPutMVar @@ -239,9 +247,9 @@ unit_tryTakeMVar_return_full_sim = -- | Check that `IOSim`'s `tryPutMVar` is non blocking. -- tryPutMVar_non_blocking_property - :: Bool -> Bool -tryPutMVar_non_blocking_property isEmpty = - validateTrace $ runSimTrace $ do + :: StdGen -> Bool -> Bool +tryPutMVar_non_blocking_property stdGen isEmpty = + validateTrace $ runSimTrace stdGen $ do v <- if isEmpty then newEmptyMVar else newMVar () @@ -253,13 +261,15 @@ tryPutMVar_non_blocking_property isEmpty = EventTxBlocked {} -> All False _ -> All True) -unit_tryPutMVar_empty :: Assertion -unit_tryPutMVar_empty = assertBool "blocked on an empty MVar" $ - tryPutMVar_non_blocking_property False +unit_tryPutMVar_empty :: Int -> Property +unit_tryPutMVar_empty r = + counterexample "blocked on an empty MVar" + $ tryPutMVar_non_blocking_property (mkStdGen r) False -unit_tryPutMVar_full :: Assertion -unit_tryPutMVar_full = assertBool "blocked on an empty MVar" $ - tryPutMVar_non_blocking_property True +unit_tryPutMVar_full :: Int -> Property +unit_tryPutMVar_full r = + counterexample "blocked on an empty MVar" + $ tryPutMVar_non_blocking_property (mkStdGen r) True tryPutMVar_return_value @@ -275,15 +285,15 @@ tryPutMVar_return_value isEmpty = do a <- tryPutMVar v () return $ a == isEmpty -unit_tryPutMVar_return_empty_sim :: Assertion -unit_tryPutMVar_return_empty_sim = - assertBool "tryPutMVar on an empty should return result" $ - runSimOrThrow (tryPutMVar_return_value True) +unit_tryPutMVar_return_empty_sim :: Int -> Property +unit_tryPutMVar_return_empty_sim r = + counterexample "tryPutMVar on an empty should return result" + $ runSimOrThrow (mkStdGen r) (tryPutMVar_return_value True) -unit_tryPutMVar_return_full_sim :: Assertion -unit_tryPutMVar_return_full_sim = - assertBool "tryPutMVar on an full should return result" $ - runSimOrThrow (tryPutMVar_return_value False) +unit_tryPutMVar_return_full_sim :: Int -> Property +unit_tryPutMVar_return_full_sim r = + counterexample "tryPutMVar on an full should return result" + $ runSimOrThrow (mkStdGen r) (tryPutMVar_return_value False) -- -- isEmptyMVar @@ -300,15 +310,15 @@ prop_isEmptyMVar isEmpty = do else newMVar () (isEmpty ==) <$> isEmptyMVar v -unit_isEmptyMVar_empty_sim :: Assertion -unit_isEmptyMVar_empty_sim = - assertBool "empty mvar must be empty" $ - runSimOrThrow (prop_isEmptyMVar True) +unit_isEmptyMVar_empty_sim :: Int -> Property +unit_isEmptyMVar_empty_sim r = + counterexample "empty mvar must be empty" + $ runSimOrThrow (mkStdGen r) (prop_isEmptyMVar True) -unit_isEmptyMVar_full_sim :: Assertion -unit_isEmptyMVar_full_sim = - assertBool "full mvar must not be empty" $ - runSimOrThrow (prop_isEmptyMVar False) +unit_isEmptyMVar_full_sim :: Int -> Property +unit_isEmptyMVar_full_sim r = + counterexample "full mvar must not be empty" + $ runSimOrThrow (mkStdGen r) (prop_isEmptyMVar False) -- -- Utils diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index 7cd0bec2..d8dfef77 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -50,6 +50,8 @@ import Test.QuickCheck import Test.Tasty hiding (after) import Test.Tasty.QuickCheck +import System.Random (mkStdGen) + tests :: TestTree tests = testGroup "IOSim" @@ -87,46 +89,46 @@ tests = [ testProperty "set (IO)" $ forall_masking_states unit_set_masking_state_IO , testProperty "set (IOSim)" - $ forall_masking_states unit_set_masking_state_ST + $ \r -> forall_masking_states (unit_set_masking_state_ST r) , testProperty "unmask (IO)" $ forall_masking_states $ \ms -> forall_masking_states $ \ms' -> unit_unmask_IO ms ms' , testProperty "unmask (IOSim)" - $ forall_masking_states $ \ms -> - forall_masking_states $ \ms' -> unit_unmask_ST ms ms' + $ \r -> forall_masking_states $ \ms -> + forall_masking_states $ \ms' -> unit_unmask_ST r ms ms' , testProperty "fork (IO)" $ forall_masking_states unit_fork_masking_state_IO , testProperty "fork (IOSim)" - $ forall_masking_states unit_fork_masking_state_ST + $ \r -> forall_masking_states (unit_fork_masking_state_ST r) , testProperty "fork unmask (IO)" $ forall_masking_states $ \ms -> forall_masking_states $ \ms' -> unit_fork_unmask_IO ms ms' , testProperty "fork unmask (IOSim)" - $ forall_masking_states $ \ms -> - forall_masking_states $ \ms' -> unit_fork_unmask_ST ms ms' + $ \r -> forall_masking_states $ \ms -> + forall_masking_states $ \ms' -> unit_fork_unmask_ST r ms ms' , testProperty "catch (IO)" $ forall_masking_states unit_catch_throwIO_masking_state_IO , testProperty "catch (IOSim)" - $ forall_masking_states unit_catch_throwIO_masking_state_ST + $ \r -> forall_masking_states (unit_catch_throwIO_masking_state_ST r) , testProperty "catch: throwTo (IO)" $ forall_masking_states unit_catch_throwTo_masking_state_IO , testProperty "catch: throwTo (IOSim)" - $ forall_masking_states unit_catch_throwTo_masking_state_ST + $ \r -> forall_masking_states (unit_catch_throwTo_masking_state_ST r) , testProperty "catch: throwTo async (IO)" $ forall_masking_states unit_catch_throwTo_masking_state_async_IO , testProperty "catch: throwTo async (IOSim)" - $ forall_masking_states unit_catch_throwTo_masking_state_async_ST + $ \r -> forall_masking_states (unit_catch_throwTo_masking_state_async_ST r) , testProperty "catch: throwTo async blocking (IO)" $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_IO , testProperty "catch: throwTo async blocking (IOSim)" - $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_ST + $ \r -> forall_masking_states (unit_catch_throwTo_masking_state_async_mayblock_ST r) ] , testProperty "evaluate unit test" unit_evaluate_0 , testGroup "forkIO unit tests" @@ -187,19 +189,19 @@ prop_stm_graph_io g = ioProperty $ prop_stm_graph g -prop_stm_graph_sim :: TestThreadGraph -> Bool -prop_stm_graph_sim g = - case runSim (prop_stm_graph g) of +prop_stm_graph_sim :: Int -> TestThreadGraph -> Bool +prop_stm_graph_sim r g = + case runSim (mkStdGen r) (prop_stm_graph g) of Right () -> True _ -> False -- TODO: Note that we do not use runSimStrictShutdown here to check -- that all other threads finished, but perhaps we should and structure -- the graph tests so that's the case. -prop_timers_ST :: TestMicro -> Property -prop_timers_ST (TestMicro xs) = +prop_timers_ST :: Int -> TestMicro -> Property +prop_timers_ST r (TestMicro xs) = let ds = map (realToFrac :: Micro -> DiffTime) xs - in runSimOrThrow $ test_timers ds + in runSimOrThrow (mkStdGen r) $ test_timers ds prop_timers_IO :: [Positive Int] -> Property prop_timers_IO = ioProperty . test_timers @@ -212,17 +214,17 @@ prop_timers_IO = ioProperty . test_timers -- Forking -- -prop_fork_order_ST :: Positive Int -> Property -prop_fork_order_ST n = runSimOrThrow $ test_fork_order n +prop_fork_order_ST :: Int -> Positive Int -> Property +prop_fork_order_ST r n = runSimOrThrow (mkStdGen r) $ test_fork_order n prop_fork_order_IO :: Positive Int -> Property prop_fork_order_IO = ioProperty . test_fork_order -prop_threadId_order_order_Sim :: Positive Int -> Property -prop_threadId_order_order_Sim n = runSimOrThrow $ test_threadId_order n +prop_threadId_order_order_Sim :: Int -> Positive Int -> Property +prop_threadId_order_order_Sim r n = runSimOrThrow (mkStdGen r) $ test_threadId_order n -prop_wakeup_order_ST :: Property -prop_wakeup_order_ST = runSimOrThrow $ test_wakeup_order +prop_wakeup_order_ST :: Int -> Property +prop_wakeup_order_ST r = runSimOrThrow (mkStdGen r) $ test_wakeup_order -- -- MonadFix properties @@ -237,21 +239,22 @@ prop_mfix_purity_m (Positive n) = factorial :: (Int -> Int) -> Int -> Int factorial = \rec_ k -> if k <= 1 then 1 else k * rec_ (k - 1) -prop_mfix_purity_IOSim :: Positive Int -> Bool -prop_mfix_purity_IOSim a = runSimOrThrow $ prop_mfix_purity_m a +prop_mfix_purity_IOSim :: Int -> Positive Int -> Bool +prop_mfix_purity_IOSim r a = runSimOrThrow (mkStdGen r) $ prop_mfix_purity_m a -prop_mfix_purity_STM:: Positive Int -> Bool -prop_mfix_purity_STM a = runSimOrThrow $ atomically $ prop_mfix_purity_m a +prop_mfix_purity_STM:: Int -> Positive Int -> Bool +prop_mfix_purity_STM r a = runSimOrThrow (mkStdGen r) $ atomically $ prop_mfix_purity_m a -prop_mfix_purity_2 :: [Positive Int] -> Bool -prop_mfix_purity_2 as = +prop_mfix_purity_2 :: Int -> [Positive Int] -> Bool +prop_mfix_purity_2 r as = -- note: both 'IOSim' expressions are equivalent using 'Monad' and -- 'Applicative' laws only. - runSimOrThrow (join $ mfix (return . recDelay) + runSimOrThrow (mkStdGen r) + (join $ mfix (return . recDelay) <*> return as') == expected && - runSimOrThrow (mfix (return . recDelay) >>= ($ as')) + runSimOrThrow (mkStdGen r) (mfix (return . recDelay) >>= ($ as')) == expected where as' :: [Int] @@ -275,22 +278,23 @@ prop_mfix_purity_2 as = prop_mfix_left_shrinking_IOSim :: Int + -> Int -> NonNegative Int -> Positive Int -> Bool -prop_mfix_left_shrinking_IOSim n (NonNegative d) (Positive i) = +prop_mfix_left_shrinking_IOSim r n (NonNegative d) (Positive i) = let mn :: IOSim s Int mn = do say "" threadDelay (realToFrac d) return n in take i - (runSimOrThrow $ + (runSimOrThrow (mkStdGen r) $ mfix (\rec_ -> mn >>= \a -> do threadDelay (realToFrac d) $> a : rec_)) == take i - (runSimOrThrow $ + (runSimOrThrow (mkStdGen r) $ mn >>= \a -> (mfix (\rec_ -> do threadDelay (realToFrac d) $> a : rec_))) @@ -298,19 +302,20 @@ prop_mfix_left_shrinking_IOSim n (NonNegative d) (Positive i) = prop_mfix_left_shrinking_STM :: Int + -> Int -> Positive Int -> Bool -prop_mfix_left_shrinking_STM n (Positive i) = +prop_mfix_left_shrinking_STM r n (Positive i) = let mn :: STMSim s Int mn = do say "" return n in take i - (runSimOrThrow $ atomically $ + (runSimOrThrow (mkStdGen r) $ atomically $ mfix (\rec_ -> mn >>= \a -> return $ a : rec_)) == take i - (runSimOrThrow $ atomically $ + (runSimOrThrow (mkStdGen r) $ atomically $ mn >>= \a -> (mfix (\rec_ -> return $ a : rec_))) @@ -319,11 +324,12 @@ prop_mfix_left_shrinking_STM n (Positive i) = -- | 'Example 8.2.1' in 'Value Recursion in Monadic Computations' -- -- -prop_mfix_lazy :: NonEmptyList Char +prop_mfix_lazy :: Int + -> NonEmptyList Char -> Bool -prop_mfix_lazy (NonEmpty env) = +prop_mfix_lazy r (NonEmpty env) = take samples - (runSimOrThrow (withEnv (mfix . replicateHeadM))) + (runSimOrThrow (mkStdGen r) (withEnv (mfix . replicateHeadM))) == replicate samples (head env) where samples :: Int @@ -368,10 +374,10 @@ prop_mfix_lazy (NonEmpty env) = -- | 'Example 8.2.3' in 'Value Recursion in Monadic Computations' -- -- -prop_mfix_recdata :: Property -prop_mfix_recdata = ioProperty $ do +prop_mfix_recdata :: Int -> Property +prop_mfix_recdata r = ioProperty $ do expected <- experiment - let res = runSimOrThrow experiment + let res = runSimOrThrow (mkStdGen r) experiment return $ take samples res == @@ -399,12 +405,12 @@ prop_mfix_recdata = ioProperty $ do unit_catch_0, unit_catch_1, unit_catch_2, unit_catch_3, unit_catch_4, unit_catch_5, unit_catch_6, unit_fork_1, unit_fork_2 - :: Property + :: Int -> Property -- unhandled top level exception -unit_catch_0 = - runSimTraceSay example === ["before"] - .&&. case traceResult True (runSimTrace example) of +unit_catch_0 r = + runSimTraceSay (mkStdGen r) example === ["before"] + .&&. case traceResult True (runSimTrace (mkStdGen r) example) of Left (FailureException e) -> property (maybe False (==DivideByZero) $ fromException e) _ -> property False @@ -416,8 +422,8 @@ unit_catch_0 = say "after" -- normal execution of a catch frame -unit_catch_1 = - runSimTraceSay +unit_catch_1 r = + runSimTraceSay (mkStdGen r) (do catch (say "inner") (\(_e :: IOError) -> say "handler") say "after" ) @@ -426,8 +432,8 @@ unit_catch_1 = -- catching an exception thrown in a catch frame -unit_catch_2 = - runSimTraceSay +unit_catch_2 r = + runSimTraceSay (mkStdGen r) (do catch (do say "inner1" _ <- throwIO DivideByZero say "inner2") @@ -439,8 +445,8 @@ unit_catch_2 = -- not catching an exception of the wrong type -unit_catch_3 = - runSimTraceSay +unit_catch_3 r = + runSimTraceSay (mkStdGen r) (do catch (do say "inner" throwIO DivideByZero) (\(_e :: IOError) -> say "handler") @@ -451,8 +457,8 @@ unit_catch_3 = -- catching an exception in an outer handler -unit_catch_4 = - runSimTraceSay +unit_catch_4 r = + runSimTraceSay (mkStdGen r) (do catch (catch (do say "inner" throwIO DivideByZero) (\(_e :: IOError) -> say "handler1")) @@ -464,8 +470,8 @@ unit_catch_4 = -- catching an exception in the inner handler -unit_catch_5 = - runSimTraceSay +unit_catch_5 r = + runSimTraceSay (mkStdGen r) (do catch (catch (do say "inner" throwIO DivideByZero) (\(_e :: ArithException) -> say "handler1")) @@ -477,8 +483,8 @@ unit_catch_5 = -- catching an exception in the inner handler, rethrowing and catching in outer -unit_catch_6 = - runSimTraceSay +unit_catch_6 r = + runSimTraceSay (mkStdGen r) (do catch (catch (do say "inner" throwIO DivideByZero) (\(e :: ArithException) -> do @@ -492,17 +498,17 @@ unit_catch_6 = -- evaluate should catch pure errors -unit_evaluate_0 :: Property -unit_evaluate_0 = +unit_evaluate_0 :: Int -> Property +unit_evaluate_0 r = -- 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" :: ()) + property $ isLeft $ runSim (mkStdGen r) $ evaluate (error "boom" :: ()) -- The sim terminates when the main thread terminates -unit_fork_1 = - runSimTraceSay example === ["parent"] - .&&. case traceResult True (runSimTrace example) of +unit_fork_1 r = + runSimTraceSay (mkStdGen r) example === ["parent"] + .&&. case traceResult True (runSimTrace (mkStdGen r) example) of Left FailureSloppyShutdown{} -> property True _ -> property False where @@ -513,9 +519,9 @@ unit_fork_1 = -- Try works and we can pass exceptions back from threads. -- And terminating with an exception is reported properly. -unit_fork_2 = - runSimTraceSay example === ["parent", "user error (oh noes!)"] - .&&. case traceResult True (runSimTrace example) of +unit_fork_2 r = + runSimTraceSay (mkStdGen r) example === ["parent", "user error (oh noes!)"] + .&&. case traceResult True (runSimTrace (mkStdGen r) example) of Left (FailureException e) | Just ioe <- fromException e , isUserError ioe @@ -542,11 +548,11 @@ unit_async_1, unit_async_2, unit_async_3, unit_async_4, unit_async_5, unit_async_6, unit_async_7, unit_async_8, unit_async_9, unit_async_10, unit_async_11, unit_async_12, unit_async_13, unit_async_14, unit_async_15, unit_async_16 - :: Property + :: Int -> Property -unit_async_1 = - runSimTraceSay +unit_async_1 r = + runSimTraceSay (mkStdGen r) (do mtid <- myThreadId say ("main " ++ show mtid) ctid <- forkIO $ do tid <- myThreadId @@ -558,8 +564,8 @@ unit_async_1 = ["main ThreadId []", "parent ThreadId [1]", "child ThreadId [1]"] -unit_async_2 = - runSimTraceSay +unit_async_2 r = + runSimTraceSay (mkStdGen r) (do tid <- myThreadId say "before" throwTo tid DivideByZero @@ -569,8 +575,8 @@ unit_async_2 = ["before"] -unit_async_3 = - runSimTraceSay +unit_async_3 r = + runSimTraceSay (mkStdGen r) (do tid <- myThreadId catch (do say "before" throwTo tid DivideByZero @@ -580,8 +586,8 @@ unit_async_3 = ["before", "handler"] -unit_async_4 = - runSimTraceSay +unit_async_4 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ say "child" threadDelay 1 -- child has already terminated when we throw the async exception @@ -591,8 +597,8 @@ unit_async_4 = ["child", "parent done"] -unit_async_5 = - runSimTraceSay +unit_async_5 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ do say "child" catch (atomically retry) @@ -606,8 +612,8 @@ unit_async_5 = ["child", "handler", "child done", "parent done"] -unit_async_6 = - runSimTraceSay +unit_async_6 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ mask_ $ do say "child" @@ -626,8 +632,8 @@ unit_async_6 = ["child", "child masked", "handler", "child done", "parent done"] -unit_async_7 = - runSimTraceSay +unit_async_7 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ mask $ \restore -> do say "child" @@ -646,8 +652,8 @@ unit_async_7 = ["child", "child masked", "handler", "child done", "parent done"] -unit_async_8 = - runSimTraceSay +unit_async_8 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ do catch (do mask_ $ do say "child" @@ -666,8 +672,8 @@ unit_async_8 = ["child", "child masked", "handler", "child done", "parent done"] -unit_async_9 = - runSimTraceSay +unit_async_9 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ mask_ $ do say "child" @@ -682,8 +688,8 @@ unit_async_9 = ["child", "parent done"] -unit_async_10 = - runSimTraceSay +unit_async_10 r = + runSimTraceSay (mkStdGen r) (do tid1 <- forkIO $ do mask_ $ do threadDelay 1 @@ -710,8 +716,8 @@ unit_async_10 = ["child 1", "child 2", "child 1 running", "parent done"] -unit_async_11 = - runSimTraceSay +unit_async_11 r = + runSimTraceSay (mkStdGen r) (do tid1 <- forkIO $ do mask_ $ do threadDelay 1 @@ -742,8 +748,8 @@ unit_async_11 = ["child 1", "child 2", "child 1 running", "parent done"] -unit_async_12 = - runSimTraceSay +unit_async_12 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ do uninterruptibleMask_ $ do say "child" @@ -763,8 +769,8 @@ unit_async_12 = ["child", "child masked", "child done", "parent done"] -unit_async_13 = - case runSim +unit_async_13 r = + case runSim (mkStdGen r) (uninterruptibleMask_ $ do tid <- forkIO $ atomically retry throwTo tid DivideByZero) @@ -772,8 +778,8 @@ unit_async_13 = _ -> property False -unit_async_14 = - runSimTraceSay +unit_async_14 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ do uninterruptibleMask_ $ do say "child" @@ -793,8 +799,8 @@ unit_async_14 = ["child", "child masked", "child done", "parent done"] -unit_async_15 = - runSimTraceSay +unit_async_15 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ uninterruptibleMask $ \restore -> do say "child" @@ -813,8 +819,8 @@ unit_async_15 = ["child", "child masked", "handler", "child done", "parent done"] -unit_async_16 = - runSimTraceSay +unit_async_16 r = + runSimTraceSay (mkStdGen r) (do tid <- forkIO $ do catch (do uninterruptibleMask_ $ do say "child" @@ -847,16 +853,16 @@ prop_stm_referenceIO t = -- | Compare the behaviour of the STM reference operational semantics with -- the behaviour of the IO simulator's STM implementation. -- -prop_stm_referenceSim :: SomeTerm -> Property -prop_stm_referenceSim t = - runSimOrThrow (prop_stm_referenceM t) +prop_stm_referenceSim :: Int -> SomeTerm -> Property +prop_stm_referenceSim r t = + runSimOrThrow (mkStdGen r) (prop_stm_referenceM t) -- -- MonadTimer -- -prop_timeout_no_deadlock_Sim :: Bool -prop_timeout_no_deadlock_Sim = runSimOrThrow prop_timeout_no_deadlockM +prop_timeout_no_deadlock_Sim :: Int -> Bool +prop_timeout_no_deadlock_Sim r = runSimOrThrow (mkStdGen r) prop_timeout_no_deadlockM prop_timeout_no_deadlock_IO :: Property prop_timeout_no_deadlock_IO = ioProperty prop_timeout_no_deadlockM @@ -992,26 +998,29 @@ experimentResult intendedTimeoutDuration prop_timeout - :: TimeoutDuration + :: Int + -> TimeoutDuration -> ActionDuration -> Property -prop_timeout intendedTimeoutDuration intendedActionDuration = - runSimOrThrow (withSanityCheck <$> +prop_timeout r intendedTimeoutDuration intendedActionDuration = + runSimOrThrow (mkStdGen r) + (withSanityCheck <$> singleTimeoutExperiment intendedTimeoutDuration intendedActionDuration) prop_timeouts - :: [(TimeoutDuration, ActionDuration)] + :: Int + -> [(TimeoutDuration, ActionDuration)] -> Property -prop_timeouts times = +prop_timeouts r times = counterexample (ppTrace_ trace) $ either (\e -> counterexample (show e) False) id $ traceResult False trace where trace = - runSimTrace $ + runSimTrace (mkStdGen r) $ conjoin' <$> sequence [ fmap (counterexample ("failure on timeout test #" ++ show n)) @@ -1031,12 +1040,13 @@ prop_timeouts times = (numFailures <= maxFailures) -prop_stacked_timeouts :: TimeoutDuration +prop_stacked_timeouts :: Int + -> TimeoutDuration -> TimeoutDuration -> ActionDuration -> Property -prop_stacked_timeouts timeout0 timeout1 actionDuration = - let trace = runSimTrace experiment in +prop_stacked_timeouts r timeout0 timeout1 actionDuration = + let trace = runSimTrace (mkStdGen r) experiment in counterexample (ppTrace_ trace) $ either (\e -> counterexample (show e) False) (=== predicted) (traceResult False trace) where @@ -1059,9 +1069,9 @@ prop_stacked_timeouts timeout0 timeout1 actionDuration = = Just Nothing -unit_timeouts_and_async_exceptions_1 :: Property -unit_timeouts_and_async_exceptions_1 = - let trace = runSimTrace experiment in +unit_timeouts_and_async_exceptions_1 :: Int -> Property +unit_timeouts_and_async_exceptions_1 r = + let trace = runSimTrace (mkStdGen r) experiment in counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1077,12 +1087,12 @@ unit_timeouts_and_async_exceptions_1 = threadDelay (delay / 2) killThread tid threadDelay 1 - return $ property True + return $ property True -unit_timeouts_and_async_exceptions_2 :: Property -unit_timeouts_and_async_exceptions_2 = - let trace = runSimTrace experiment in +unit_timeouts_and_async_exceptions_2 :: Int -> Property +unit_timeouts_and_async_exceptions_2 r = + let trace = runSimTrace (mkStdGen r) experiment in counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1098,12 +1108,12 @@ unit_timeouts_and_async_exceptions_2 = threadDelay (delay / 2) killThread tid threadDelay 1 - return $ property True + return $ property True -unit_timeouts_and_async_exceptions_3 :: Property -unit_timeouts_and_async_exceptions_3 = - let trace = runSimTrace experiment in +unit_timeouts_and_async_exceptions_3 :: Int -> Property +unit_timeouts_and_async_exceptions_3 r = + let trace = runSimTrace (mkStdGen r) experiment in counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1119,15 +1129,15 @@ unit_timeouts_and_async_exceptions_3 = threadDelay (delay / 2) killThread tid threadDelay 1 - return $ property True + return $ property True -- | Verify that a thread blocked on `threadDelay` is not unblocked by an STM -- transaction. -- -unit_threadDelay_and_stm :: Property -unit_threadDelay_and_stm = - let trace = runSimTrace experiment in +unit_threadDelay_and_stm :: Int -> Property +unit_threadDelay_and_stm r = + let trace = runSimTrace (mkStdGen r) experiment in counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1157,9 +1167,9 @@ unit_threadDelay_and_stm = -- | Verify that a thread blocked on `throwTo` is not unblocked by an STM -- transaction. -- -unit_throwTo_and_stm :: Property -unit_throwTo_and_stm = - let trace = runSimTrace experiment in +unit_throwTo_and_stm :: Int -> Property +unit_throwTo_and_stm r = + let trace = runSimTrace (mkStdGen r) experiment in counterexample (ppTrace_ trace) . either (\e -> counterexample (show e) False) id . traceResult False @@ -1195,61 +1205,61 @@ unit_set_masking_state_IO :: MaskingState -> Property unit_set_masking_state_IO = ioProperty . prop_set_masking_state -unit_set_masking_state_ST :: MaskingState -> Property -unit_set_masking_state_ST ms = - runSimOrThrow (prop_set_masking_state ms) +unit_set_masking_state_ST :: Int -> MaskingState -> Property +unit_set_masking_state_ST r ms = + runSimOrThrow (mkStdGen r) (prop_set_masking_state ms) unit_unmask_IO :: MaskingState -> MaskingState -> Property unit_unmask_IO ms ms' = ioProperty $ prop_unmask ms ms' -unit_unmask_ST :: MaskingState -> MaskingState -> Property -unit_unmask_ST ms ms' = runSimOrThrow $ prop_unmask ms ms' +unit_unmask_ST :: Int -> MaskingState -> MaskingState -> Property +unit_unmask_ST r ms ms' = runSimOrThrow (mkStdGen r) $ prop_unmask ms ms' unit_fork_masking_state_IO :: MaskingState -> Property unit_fork_masking_state_IO = ioProperty . prop_fork_masking_state -unit_fork_masking_state_ST :: MaskingState -> Property -unit_fork_masking_state_ST ms = - runSimOrThrow (prop_fork_masking_state ms) +unit_fork_masking_state_ST :: Int -> MaskingState -> Property +unit_fork_masking_state_ST r ms = + runSimOrThrow (mkStdGen r) (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_ST :: MaskingState -> MaskingState -> Property -unit_fork_unmask_ST ms ms' = runSimOrThrow $ prop_fork_unmask ms ms' +unit_fork_unmask_ST :: Int -> MaskingState -> MaskingState -> Property +unit_fork_unmask_ST r ms ms' = runSimOrThrow (mkStdGen r) $ prop_fork_unmask ms ms' unit_catch_throwIO_masking_state_IO :: MaskingState -> Property unit_catch_throwIO_masking_state_IO ms = ioProperty $ prop_catch_throwIO_masking_state ms -unit_catch_throwIO_masking_state_ST :: MaskingState -> Property -unit_catch_throwIO_masking_state_ST ms = - runSimOrThrow (prop_catch_throwIO_masking_state ms) +unit_catch_throwIO_masking_state_ST :: Int -> MaskingState -> Property +unit_catch_throwIO_masking_state_ST r ms = + runSimOrThrow (mkStdGen r) (prop_catch_throwIO_masking_state ms) unit_catch_throwTo_masking_state_IO :: MaskingState -> Property unit_catch_throwTo_masking_state_IO = ioProperty . prop_catch_throwTo_masking_state -unit_catch_throwTo_masking_state_ST :: MaskingState -> Property -unit_catch_throwTo_masking_state_ST ms = - runSimOrThrow $ prop_catch_throwTo_masking_state ms +unit_catch_throwTo_masking_state_ST :: Int -> MaskingState -> Property +unit_catch_throwTo_masking_state_ST r ms = + runSimOrThrow (mkStdGen r) $ prop_catch_throwTo_masking_state ms unit_catch_throwTo_masking_state_async_IO :: MaskingState -> Property unit_catch_throwTo_masking_state_async_IO = ioProperty . prop_catch_throwTo_masking_state_async -unit_catch_throwTo_masking_state_async_ST :: MaskingState -> Property -unit_catch_throwTo_masking_state_async_ST ms = - runSimOrThrow (prop_catch_throwTo_masking_state_async ms) +unit_catch_throwTo_masking_state_async_ST :: Int -> MaskingState -> Property +unit_catch_throwTo_masking_state_async_ST r ms = + runSimOrThrow (mkStdGen r) (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 = 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 = - runSimOrThrow (prop_catch_throwTo_masking_state_async_mayblock ms) +unit_catch_throwTo_masking_state_async_mayblock_ST :: Int -> MaskingState -> Property +unit_catch_throwTo_masking_state_async_mayblock_ST r ms = + runSimOrThrow (mkStdGen r) (prop_catch_throwTo_masking_state_async_mayblock ms) -- -- MonadTimerCancellable @@ -1288,16 +1298,17 @@ instance Arbitrary DelayWithCancel where maxDelay = microsecondsAsIntToDiffTime maxBound prop_registerDelayCancellable - :: (forall s. DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ())) - -- ^ implementation + :: Int + -> (forall s. DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ())) + -- ^ implementation -> DelayWithCancel -> Property -prop_registerDelayCancellable registerDelayCancellableImpl +prop_registerDelayCancellable rnd registerDelayCancellableImpl (DelayWithCancel delay mbCancel) = -- 'within' covers the case where `registerDelayCancellable` would not -- make progress awaiting for the timeout (a live lock). within 50_000 $ -- 50ms - let trace = runSimTrace sim + let trace = runSimTrace (mkStdGen rnd) sim in case traceResult True trace of Left err -> counterexample (ppTrace trace) . counterexample (show err) @@ -1335,13 +1346,13 @@ prop_registerDelayCancellable registerDelayCancellableImpl -- `registerDelayCancellable` -- prop_registerDelayCancellable_IOSim, prop_registerDelayCancellable_IO - :: DelayWithCancel -> Property + :: Int -> DelayWithCancel -> Property -prop_registerDelayCancellable_IOSim = - prop_registerDelayCancellable registerDelayCancellable +prop_registerDelayCancellable_IOSim r = + prop_registerDelayCancellable r registerDelayCancellable -prop_registerDelayCancellable_IO = - prop_registerDelayCancellable $ +prop_registerDelayCancellable_IO r = + prop_registerDelayCancellable r $ defaultRegisterDelayCancellable (newTimeout . microsecondsAsIntToDiffTime) readTimeout diff --git a/io-sim/test/Test/Control/Monad/IOSimPOR.hs b/io-sim/test/Test/Control/Monad/IOSimPOR.hs index 754f14d2..5cb894fc 100644 --- a/io-sim/test/Test/Control/Monad/IOSimPOR.hs +++ b/io-sim/test/Test/Control/Monad/IOSimPOR.hs @@ -49,6 +49,7 @@ import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck import qualified Data.List.Trace as Trace +import System.Random (mkStdGen) tests :: TestTree tests = @@ -330,16 +331,16 @@ maxTaskValue (WhenSet m _:_) = m maxTaskValue (_:t) = maxTaskValue t maxTaskValue [] = 0 -propSimulates :: Compare -> Shrink2 Tasks -> Property -propSimulates cmp (Shrink2 (Tasks tasks)) = +propSimulates :: Int -> Compare -> Shrink2 Tasks -> Property +propSimulates r cmp (Shrink2 (Tasks tasks)) = any (not . null . (\(Task steps)->steps)) tasks ==> - let trace = runSimTrace (runTasks cmp tasks) in + let trace = runSimTrace (mkStdGen r) (runTasks cmp tasks) in case traceResult False trace of Right (m,a) -> property (m >= a) Left (FailureInternal msg) -> counterexample msg False Left x -> counterexample (ppTrace trace) - $ counterexample (show x) True + $ counterexample (show x) True -- NOTE: This property needs to be executed sequentially, otherwise it fails -- undeterministically, which `exploreSimTraceST` does. @@ -736,7 +737,7 @@ unit_fork_1 = -- Asyncronous exceptions -- -unit_async_1, unit_async_2, unit_async_3, unit_async_4, +unit_async_1, unit_async_3, unit_async_4, unit_async_5, unit_async_6, unit_async_7, unit_async_8, unit_async_9 :: Property @@ -751,9 +752,9 @@ unit_async_1 = ) $ \_ trace -> selectTraceSay trace === ["before"] - -unit_async_2 = - runSimTraceSay +unit_async_2 :: Int -> Property +unit_async_2 r = + runSimTraceSay (mkStdGen r) (do tid <- myThreadId catch (do say "before" throwTo tid DivideByZero @@ -899,7 +900,7 @@ prop_timeout :: TimeoutDuration -> ActionDuration -> Property -prop_timeout intendedTimeoutDuration intendedActionDuration = +prop_timeout intendedTimeoutDuration intendedActionDuration = exploreSimTrace id experiment $ \_ trace -> case traceResult False trace of Right a -> a @@ -990,7 +991,7 @@ unit_timeouts_and_async_exceptions_1 = threadDelay (delay / 2) killThread tid threadDelay 1 - return $ property True + return $ property True unit_timeouts_and_async_exceptions_2 :: Property @@ -1012,7 +1013,7 @@ unit_timeouts_and_async_exceptions_2 = threadDelay (delay / 2) killThread tid threadDelay 1 - return $ property True + return $ property True unit_timeouts_and_async_exceptions_3 :: Property @@ -1034,7 +1035,7 @@ unit_timeouts_and_async_exceptions_3 = threadDelay (delay / 2) killThread tid threadDelay 1 - return $ property True + return $ property True -- -- MonadMask properties diff --git a/io-sim/test/Test/Control/Monad/Utils.hs b/io-sim/test/Test/Control/Monad/Utils.hs index 4bd0e4dc..4f95f0b5 100644 --- a/io-sim/test/Test/Control/Monad/Utils.hs +++ b/io-sim/test/Test/Control/Monad/Utils.hs @@ -22,6 +22,7 @@ import Test.Control.Monad.STM import Test.QuickCheck +import System.Random (StdGen) -- -- Read/Write graph -- @@ -501,8 +502,8 @@ forall_masking_states prop = -- Utils -- -runSimTraceSay :: (forall s. IOSim s a) -> [String] -runSimTraceSay action = selectTraceSay (runSimTrace action) +runSimTraceSay :: StdGen -> (forall s. IOSim s a) -> [String] +runSimTraceSay stdGen action = selectTraceSay (runSimTrace stdGen action) selectTraceSay :: SimTrace a -> [String] selectTraceSay (SimTrace _ _ _ (EventSay msg) trace) = msg : selectTraceSay trace From ad93f94e26c73da5c28fabff4baae5ce989665cd Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Fri, 15 Dec 2023 13:54:04 +0000 Subject: [PATCH 2/6] Shuffle runqueue everytime we unblock threads --- io-sim/src/Control/Monad/IOSim/Internal.hs | 22 +++++++++++++++++++--- io-sim/src/Data/Deque/Strict.hs | 3 +++ 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 17843395..9878b4aa 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -849,14 +849,17 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } = timeoutSTMAction TimerTimeout{} = return () unblockThreads :: Bool -> [IOSimThreadId] -> SimState s a -> ([IOSimThreadId], SimState s a) -unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads} = +unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads, stdGen} = -- To preserve our invariants (that threadBlocked is correct) -- we update the runqueue and threads together here (unblocked, simstate { - runqueue = runqueue <> Deque.fromList unblocked, - threads = threads' + runqueue = Deque.fromList shuffledRunqueue, + threads = threads', + stdGen = stdGen' }) where + !(shuffledRunqueue, stdGen') = fisherYatesShuffle stdGen runqueue' + !runqueue' = Deque.toList $ runqueue <> Deque.fromList unblocked -- can only unblock if the thread exists and is blocked (not running) !unblocked = [ tid | tid <- wakeup @@ -873,6 +876,19 @@ unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads} = threads unblocked + -- Fisher-Yates shuffle implementation + fisherYatesShuffle :: StdGen -> [a] -> ([a], StdGen) + fisherYatesShuffle gen [] = ([], gen) + fisherYatesShuffle gen l = + let (l', gen') = go (length l - 1) l gen + in (l', gen') + where + go 0 lst g = (lst, g) + go n lst g = let (k, newGen) = randomR (0, n) g + (x:xs) = drop k lst + swapped = take k lst ++ [lst !! n] ++ drop (k + 1) lst + in go (n - 1) (take n swapped ++ [x] ++ drop n xs) newGen + -- | This function receives a list of TimerTimeout values that represent threads -- for which the timeout expired and kills the running thread if needed. -- diff --git a/io-sim/src/Data/Deque/Strict.hs b/io-sim/src/Data/Deque/Strict.hs index 9588df6a..20d34c3e 100644 --- a/io-sim/src/Data/Deque/Strict.hs +++ b/io-sim/src/Data/Deque/Strict.hs @@ -39,3 +39,6 @@ uncons = \case filter :: (a -> Bool) -> Deque a -> Deque a filter f (Deque head tail) = Deque (List.filter f head) (List.filter f tail) + +toList :: Deque a -> [a] +toList = foldr (:) [] From 6a781b9a23b9e42604257b632eacf8a464fe5893 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Fri, 15 Dec 2023 16:14:18 +0000 Subject: [PATCH 3/6] Only shuffle at most the first half of the runqueue --- io-sim/src/Control/Monad/IOSim/Internal.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 9878b4aa..cd508d48 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -853,13 +853,17 @@ unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads, stdGen} = -- To preserve our invariants (that threadBlocked is correct) -- we update the runqueue and threads together here (unblocked, simstate { - runqueue = Deque.fromList shuffledRunqueue, + runqueue = Deque.fromList (shuffledRunqueue ++ rest), threads = threads', - stdGen = stdGen' + stdGen = stdGen'' }) where - !(shuffledRunqueue, stdGen') = fisherYatesShuffle stdGen runqueue' - !runqueue' = Deque.toList $ runqueue <> Deque.fromList unblocked + !(shuffledRunqueue, stdGen'') = fisherYatesShuffle stdGen' toShuffle + !((toShuffle, rest), stdGen') = + let runqueueList = Deque.toList $ runqueue <> Deque.fromList unblocked + runqueueListLength = max 1 (length runqueueList) + (ix, newGen) = randomR (0, runqueueListLength `div` 2) stdGen + in (splitAt ix runqueueList, newGen) -- can only unblock if the thread exists and is blocked (not running) !unblocked = [ tid | tid <- wakeup From 9fe5c5e8164fa050415594c3b3448f3c2b5ce1c0 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Fri, 15 Dec 2023 17:01:21 +0000 Subject: [PATCH 4/6] Only shuffle 20% of the time --- io-sim/src/Control/Monad/IOSim/Internal.hs | 65 ++++++++++++++-------- 1 file changed, 42 insertions(+), 23 deletions(-) diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index cd508d48..f62a95b9 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -48,6 +48,8 @@ module Control.Monad.IOSim.Internal import Prelude hiding (read) +import Data.Deque.Strict (Deque) +import qualified Data.Deque.Strict as Deque import Data.Dynamic import Data.Foldable (foldlM, toList, traverse_) import qualified Data.List as List @@ -60,8 +62,6 @@ import qualified Data.OrdPSQ as PSQ import Data.Set (Set) import qualified Data.Set as Set import Data.Time (UTCTime (..), fromGregorian) -import Data.Deque.Strict (Deque) -import qualified Data.Deque.Strict as Deque import Control.Exception (NonTermination (..), assert, throw) import Control.Monad (join, when) @@ -76,13 +76,16 @@ import Control.Monad.Class.MonadSTM hiding (STM) import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar)) import Control.Monad.Class.MonadThrow hiding (getMaskingState) import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer.SI (TimeoutState (..), DiffTime, diffTimeToMicrosecondsAsInt, microsecondsAsIntToDiffTime) +import Control.Monad.Class.MonadTimer.SI (DiffTime, TimeoutState (..), + diffTimeToMicrosecondsAsInt, microsecondsAsIntToDiffTime) import Control.Monad.IOSim.InternalTypes import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent), Trace (SimPORTrace)) import Control.Monad.IOSim.Types (SimEvent) -import System.Random (StdGen, randomR, split) +import Data.Bifunctor (first) +import Data.Ord (comparing) +import System.Random (StdGen, randomR, split) -- -- Simulation interpreter @@ -849,31 +852,47 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } = timeoutSTMAction TimerTimeout{} = return () unblockThreads :: Bool -> [IOSimThreadId] -> SimState s a -> ([IOSimThreadId], SimState s a) -unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads, stdGen} = +unblockThreads !onlySTM !wakeup simstate@SimState {runqueue, threads, stdGen} = -- To preserve our invariants (that threadBlocked is correct) -- we update the runqueue and threads together here (unblocked, simstate { - runqueue = Deque.fromList (shuffledRunqueue ++ rest), + runqueue = runqueue <> Deque.fromList unblocked, threads = threads', stdGen = stdGen'' }) where - !(shuffledRunqueue, stdGen'') = fisherYatesShuffle stdGen' toShuffle - !((toShuffle, rest), stdGen') = - let runqueueList = Deque.toList $ runqueue <> Deque.fromList unblocked - runqueueListLength = max 1 (length runqueueList) - (ix, newGen) = randomR (0, runqueueListLength `div` 2) stdGen - in (splitAt ix runqueueList, newGen) -- can only unblock if the thread exists and is blocked (not running) - !unblocked = [ tid - | tid <- wakeup - , case Map.lookup tid threads of - Just Thread { threadStatus = ThreadBlocked BlockedOnSTM } - -> True - Just Thread { threadStatus = ThreadBlocked _ } - -> not onlySTM - _ -> False - ] + !blockedOnOther = [ (tid, ix) + | (tid, ix) <- zip wakeup [0 :: Int ..] + , case Map.lookup tid threads of + Just Thread { threadStatus = ThreadBlocked BlockedOnSTM } + -> False + Just Thread { threadStatus = ThreadBlocked _ } + -> not onlySTM + _ -> False + ] + + !blockedOnSTM = [ (tid, ix) + | (tid, ix) <- zip wakeup [0 :: Int ..] + , case Map.lookup tid threads of + Just Thread { threadStatus = ThreadBlocked BlockedOnSTM } + -> True + _ -> False + ] + + mergeByIndex :: Ord a => [(b, a)] -> [(b, a)] -> [b] + mergeByIndex a b = map fst $ List.sortBy (comparing snd) (a ++ b) + + -- Shuffle only 1/5th of the time + (shouldShuffle, !stdGen') = + first (== 0) $ randomR (0 :: Int, 5) stdGen + + (!shuffledBlockedOnSTM, !stdGen'') + | shouldShuffle = fisherYatesShuffle stdGen' blockedOnSTM + | otherwise = (blockedOnSTM, stdGen') + + !unblocked = mergeByIndex blockedOnOther shuffledBlockedOnSTM + -- and in which case we mark them as now running !threads' = List.foldl' (flip (Map.adjust (\t -> t { threadStatus = ThreadRunning }))) @@ -889,8 +908,8 @@ unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads, stdGen} = where go 0 lst g = (lst, g) go n lst g = let (k, newGen) = randomR (0, n) g - (x:xs) = drop k lst - swapped = take k lst ++ [lst !! n] ++ drop (k + 1) lst + (x:xs) = drop k lst + swapped = take k lst ++ [lst !! n] ++ drop (k + 1) lst in go (n - 1) (take n swapped ++ [x] ++ drop n xs) newGen -- | This function receives a list of TimerTimeout values that represent threads From 5f838588df1dfb3cdac3b6cfa1856b58494fdfa0 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 18 Dec 2023 11:24:51 +0000 Subject: [PATCH 5/6] fx --- io-sim/src/Control/Monad/IOSim/Internal.hs | 60 ++++++++-------------- 1 file changed, 22 insertions(+), 38 deletions(-) diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index f62a95b9..3a4ca117 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -84,7 +84,6 @@ import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent), Trace (SimPORTrace)) import Control.Monad.IOSim.Types (SimEvent) import Data.Bifunctor (first) -import Data.Ord (comparing) import System.Random (StdGen, randomR, split) -- @@ -856,42 +855,31 @@ unblockThreads !onlySTM !wakeup simstate@SimState {runqueue, threads, stdGen} = -- To preserve our invariants (that threadBlocked is correct) -- we update the runqueue and threads together here (unblocked, simstate { - runqueue = runqueue <> Deque.fromList unblocked, + runqueue = Deque.fromList shuffledRunqueue, threads = threads', stdGen = stdGen'' }) where -- can only unblock if the thread exists and is blocked (not running) - !blockedOnOther = [ (tid, ix) - | (tid, ix) <- zip wakeup [0 :: Int ..] - , case Map.lookup tid threads of - Just Thread { threadStatus = ThreadBlocked BlockedOnSTM } - -> False - Just Thread { threadStatus = ThreadBlocked _ } - -> not onlySTM - _ -> False - ] - - !blockedOnSTM = [ (tid, ix) - | (tid, ix) <- zip wakeup [0 :: Int ..] - , case Map.lookup tid threads of - Just Thread { threadStatus = ThreadBlocked BlockedOnSTM } - -> True - _ -> False - ] - - mergeByIndex :: Ord a => [(b, a)] -> [(b, a)] -> [b] - mergeByIndex a b = map fst $ List.sortBy (comparing snd) (a ++ b) + !unblocked = [ tid + | tid <- wakeup + , case Map.lookup tid threads of + Just Thread { threadStatus = ThreadBlocked BlockedOnSTM } + -> True + Just Thread { threadStatus = ThreadBlocked _ } + -> not onlySTM + _ -> False + ] + + !runQueueList = Deque.toList (runqueue <> Deque.fromList unblocked) -- Shuffle only 1/5th of the time (shouldShuffle, !stdGen') = first (== 0) $ randomR (0 :: Int, 5) stdGen - (!shuffledBlockedOnSTM, !stdGen'') - | shouldShuffle = fisherYatesShuffle stdGen' blockedOnSTM - | otherwise = (blockedOnSTM, stdGen') - - !unblocked = mergeByIndex blockedOnOther shuffledBlockedOnSTM + (!shuffledRunqueue, !stdGen'') + | shouldShuffle = shuffle runQueueList stdGen' + | otherwise = (runQueueList, stdGen') -- and in which case we mark them as now running !threads' = List.foldl' @@ -899,18 +887,14 @@ unblockThreads !onlySTM !wakeup simstate@SimState {runqueue, threads, stdGen} = threads unblocked - -- Fisher-Yates shuffle implementation - fisherYatesShuffle :: StdGen -> [a] -> ([a], StdGen) - fisherYatesShuffle gen [] = ([], gen) - fisherYatesShuffle gen l = - let (l', gen') = go (length l - 1) l gen - in (l', gen') + shuffle :: [a] -> StdGen -> ([a], StdGen) + shuffle xs0 gen0 = go (length xs0) xs0 gen0 where - go 0 lst g = (lst, g) - go n lst g = let (k, newGen) = randomR (0, n) g - (x:xs) = drop k lst - swapped = take k lst ++ [lst !! n] ++ drop (k + 1) lst - in go (n - 1) (take n swapped ++ [x] ++ drop n xs) newGen + go 0 xs gen = (xs, gen) + go n xs gen = let (k, newGen) = randomR (0, n-1) gen + (left, selected:right) = splitAt k xs + (shuffled, finalGen) = go (n-1) (left ++ right) newGen + in (selected:shuffled, finalGen) -- | This function receives a list of TimerTimeout values that represent threads -- for which the timeout expired and kills the running thread if needed. From 2e5de225e3e033c60482ce8022683a7e4aa1cf1a Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 18 Dec 2023 12:22:31 +0000 Subject: [PATCH 6/6] fx --- io-sim/src/Control/Monad/IOSim/Internal.hs | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 3a4ca117..73bec5ce 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -83,7 +83,6 @@ import Control.Monad.IOSim.InternalTypes import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent), Trace (SimPORTrace)) import Control.Monad.IOSim.Types (SimEvent) -import Data.Bifunctor (first) import System.Random (StdGen, randomR, split) -- @@ -855,7 +854,7 @@ unblockThreads !onlySTM !wakeup simstate@SimState {runqueue, threads, stdGen} = -- To preserve our invariants (that threadBlocked is correct) -- we update the runqueue and threads together here (unblocked, simstate { - runqueue = Deque.fromList shuffledRunqueue, + runqueue = Deque.fromList shuffledUnblocked <> runqueue, threads = threads', stdGen = stdGen'' }) @@ -871,15 +870,7 @@ unblockThreads !onlySTM !wakeup simstate@SimState {runqueue, threads, stdGen} = _ -> False ] - !runQueueList = Deque.toList (runqueue <> Deque.fromList unblocked) - - -- Shuffle only 1/5th of the time - (shouldShuffle, !stdGen') = - first (== 0) $ randomR (0 :: Int, 5) stdGen - - (!shuffledRunqueue, !stdGen'') - | shouldShuffle = shuffle runQueueList stdGen' - | otherwise = (runQueueList, stdGen') + (!shuffledUnblocked, !stdGen'') = shuffle unblocked stdGen -- and in which case we mark them as now running !threads' = List.foldl'