From d143bd53e5e519e41cfe8acfb1eb24c4064d0b22 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 14 Feb 2024 13:08:52 +0100 Subject: [PATCH] Prevent STM waking up threads blocked on `threadDelay` The first argument of `unblockThreads`, `onlySTM`, indicates that only threads actually blocked on STM are woken up. This change correctly sets it to `True` when necessary. Co-authored-by: Armando Santos --- io-sim/CHANGELOG.md | 2 ++ io-sim/src/Control/Monad/IOSim/Internal.hs | 6 ++-- io-sim/src/Control/Monad/IOSimPOR/Internal.hs | 6 ++-- io-sim/test/Test/Control/Monad/IOSim.hs | 29 ++++++++++++++++++ io-sim/test/Test/Control/Monad/IOSimPOR.hs | 30 +++++++++++++++++++ 5 files changed, 69 insertions(+), 4 deletions(-) diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 7e4096e8..d4e622cf 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -2,6 +2,8 @@ ## next version (1.4.1.0) +* Prevent STM waking up threads blocked on `threadDelay`. + ### Non-breaking changes * QuickCheck monadic combinators: `monadicIOSim`, `monadicIOSim_` and `runIOSimGen`. diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 198bac1e..2eb8e3f0 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -747,8 +747,10 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } = -- Check all fired threadDelays let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ] - wakeup = fst `fmap` wakeupThreadDelay ++ wakeupSTM - (_, !simstate') = unblockThreads False wakeup simstate + !simstate' = + snd . unblockThreads False (fst `fmap` wakeupThreadDelay) + . snd . unblockThreads True wakeupSTM + $ simstate -- For each 'timeout' action where the timeout has fired, start a -- new thread to execute throwTo to interrupt the action. diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index ac0273b4..581c5cfc 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs @@ -1033,9 +1033,11 @@ reschedule simstate@SimState{ threads, timers, curTime = time, races } = mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ] - wakeup = fst `fmap` wakeupThreadDelay ++ wakeupSTM -- TODO: the vector clock below cannot be right, can it? - (_, !simstate') = unblockThreads False bottomVClock wakeup simstate + !simstate' = + snd . unblockThreads False bottomVClock (fst `fmap` wakeupThreadDelay) + . snd . unblockThreads True bottomVClock wakeupSTM + $ simstate -- For each 'timeout' action where the timeout has fired, start a -- new thread to execute throwTo to interrupt the action. diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index 37957507..a325e3e0 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -68,6 +68,7 @@ tests = , testProperty "async exceptions 2" unit_timeouts_and_async_exceptions_2 , testProperty "async exceptions 3" unit_timeouts_and_async_exceptions_3 , testProperty "threadDelay and STM" unit_threadDelay_and_stm + , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay , testProperty "throwTo and STM" unit_throwTo_and_stm ] , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) @@ -1159,6 +1160,34 @@ unit_threadDelay_and_stm = return (t1 `diffTime` t0 === delay) +unit_registerDelay_threadDelay :: Property +unit_registerDelay_threadDelay = + let trace = runSimTrace experiment in + counterexample (ppTrace_ trace) + . either (\e -> counterexample (show e) False) id + . traceResult False + $ trace + where + experiment :: IOSim s Property + experiment = do + v0 <- registerDelay 2 + v1 <- newTVarIO False + + _ <- forkIO $ do + threadDelay 1 + atomically $ writeTVar v1 True + + atomically $ do + b0 <- LazySTM.readTVar v0 + b1 <- readTVar v1 + check $ b0 || b1 + + let delay = 2 + t0 <- getMonotonicTime + threadDelay delay + t1 <- getMonotonicTime + + return (t1 `diffTime` t0 === delay) -- | Verify that a thread blocked on `throwTo` is not unblocked by an STM -- transaction. diff --git a/io-sim/test/Test/Control/Monad/IOSimPOR.hs b/io-sim/test/Test/Control/Monad/IOSimPOR.hs index 9b0eb3e8..f46cec88 100644 --- a/io-sim/test/Test/Control/Monad/IOSimPOR.hs +++ b/io-sim/test/Test/Control/Monad/IOSimPOR.hs @@ -70,6 +70,7 @@ tests = , testProperty "timeout" prop_timeout , testProperty "timeouts" prop_timeouts , testProperty "stacked timeouts" prop_stacked_timeouts + , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay ] , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST) @@ -970,6 +971,35 @@ prop_stacked_timeouts timeout0 timeout1 actionDuration = | otherwise -- i.e. timeout0 >= timeout1 = Just Nothing +unit_registerDelay_threadDelay :: Property +unit_registerDelay_threadDelay = + exploreSimTrace id experiment $ \_ trace -> + counterexample (ppTrace_ trace) + . either (\e -> counterexample (show e) False) id + . traceResult False + $ trace + where + experiment :: IOSim s Property + experiment = do + v0 <- registerDelay 2 + v1 <- newTVarIO False + + _ <- forkIO $ do + threadDelay 1 + atomically $ writeTVar v1 True + + atomically $ do + b0 <- readTVar v0 + b1 <- readTVar v1 + check $ b0 || b1 + + let delay = 2 + t0 <- getMonotonicTime + threadDelay delay + t1 <- getMonotonicTime + + return (t1 `diffTime` t0 === delay) + unit_timeouts_and_async_exceptions_1 :: Property unit_timeouts_and_async_exceptions_1 = exploreSimTrace id experiment $ \_ trace ->