Prevent STM waking up threads blocked on threadDelay

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`.

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.

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.

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.

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 ->