masked timeout fix

.github/workflows/haskell.yml

@@ -15,7 +15,13 @@ jobs:
       fail-fast: false
       matrix:
         ghc: ["9.6.6", "9.8", "9.10", "9.12", "9.14"]
-        os: [ubuntu-latest, macos-latest, windows-latest]
+        # macos-latest resolves to macOS 27 (Xcode 27) whose SDK .tbd stub
+        # files use an architecture token that GHC's linker rejects:
+        #   ld: tapi error: malformed file
+        #   MacOSX27.0.sdk/usr/lib/libiconv.2.tbd: unknown architecture
+        # Pin to macos-15 (Sequoia, Xcode 16) until haskell-actions/setup
+        # gains support for the new SDK.
+        os: [ubuntu-latest, macos-15, windows-latest]
 
     defaults:
       run:
@@ -30,7 +36,7 @@ jobs:
       id: setup-haskell
       with:
         ghc-version: ${{ matrix.ghc }}
-        cabal-version: "3.14.2.0"
+        cabal-version: "3.16.1.0"
 
     - name: Install LLVM (macOS)
       if: runner.os == 'macOS' && matrix.ghc == '8.10'

io-sim/CHANGELOG.md

@@ -1,5 +1,13 @@
 # Revision history of io-sim
 
+## next version
+
+### Non-breaking changes
+
+* Fixed `timeout` in `IOSim` and `IOSimPOR`: if the action finished when the
+  timeout fired, the timeout exception could be raised after `timeout`
+  returned (#269).
+
 ## 1.11.0.0
 
 ### Breaking changes

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -242,18 +242,31 @@ schedule !thread@Thread{
         -- We cannot do `tryPutMVar` in the `treadAction`, because we need to
         -- know if the `lock` is empty right now when we still have the frame.
         v <- execTryPutTMVar lock undefined
-        let -- Kill the assassin throwing thread then unmask exceptions and
-            -- carry on the continuation
-            threadAction :: IOSim s ()
-            threadAction =
-              if v then unsafeUnregisterTimeout tmid
-                   else atomically (takeTMVar lock) >>= killThread
-
-            thread' =
+        -- Either unregister the timeout, or kill the assassin throwing thread,
+        -- then carry on the continuation.
+        --
+        -- If the assassin holds the lock, we take it here rather than with
+        -- `atomically` in the `threadAction`: committing a transaction yields,
+        -- and the assassin could throw before we kill it, after the frame is
+        -- gone.  `killThread` does not yield before the exception is
+        -- delivered, and the assassin is unmasked, so it never blocks.
+        threadAction :: IOSim s () <-
+          if v then return (unsafeUnregisterTimeout tmid)
+               else killThread <$> execTakeTMVar lock
+        let thread' =
               thread { threadControl =
                         ThreadControl (case threadAction of
                                         IOSim k' -> k' (\() -> k (Just x)))
                                       ctl'
+                       -- If the assassin has already thrown, but we were not
+                       -- interruptible, its exception is pending.  Killing the
+                       -- assassin does not retract it (unlike in GHC's RTS),
+                       -- so we drop it here: otherwise it would be raised
+                       -- outside of the frame.
+                     , threadThrowTo =
+                         filter (\(e, _) -> fromException e
+                                         /= Just (TimeoutException tmid))
+                                (threadThrowTo thread)
                      }
         schedule thread' simstate
 
@@ -491,8 +504,7 @@ schedule !thread@Thread{
       return (SimTrace time tid tlbl (EventThreadForked tid') trace)
 
     Atomically a k ->
-      execAtomically time tid tlbl nextVid (runSTM a) $ \res ->
-      case res of
+      execAtomically time tid tlbl nextVid (runSTM a) $ \case
         StmTxCommitted x written _read created
                          tvarDynamicTraces tvarStringTraces nextVid' -> do
           (!wakeup, wokeby) <- threadsUnblockedByWrites written
@@ -897,6 +909,7 @@ forkTimeoutInterruptThreads timeoutExpired simState =
                             threadControl =
                               ThreadControl
                                (runIOSim $ do
+                                  -- assassin thread
                                   mtid <- myThreadId
                                   v2 <- atomically $ tryPutTMVar lock mtid
                                   when v2 $
@@ -1265,6 +1278,15 @@ execTryPutTMVar (TMVar var) a = do
       Just _  -> return False
 {-# INLINE execTryPutTMVar #-}
 
+execTakeTMVar :: TMVar (IOSim s) a -> ST s a
+execTakeTMVar (TMVar var) = do
+    v <- execReadTVar var
+    case v of
+      Just a  -> execWriteTVar var Nothing
+              >> return a
+      Nothing -> error "execTakeTMVar: empty TMVar"
+{-# INLINE execTakeTMVar #-}
+
 saveTVar :: TVar s a -> ST s ()
 saveTVar TVar{tvarCurrent, tvarUndo} = do
     -- push the current value onto the undo stack

io-sim/src/Control/Monad/IOSimPOR/Internal.hs

@@ -356,18 +356,31 @@ schedule thread@Thread{
           -- We cannot do `tryPutMVar` in the `treadAction`, because we need to
           -- know if the `lock` is empty right now when we still have the frame.
           v <- execTryPutTMVar lock undefined
-          let -- Kill the assassin throwing thread then unmask exceptions and
-              -- carry on the continuation
-              threadAction :: IOSim s ()
-              threadAction =
-                if v then unsafeUnregisterTimeout tmid
-                     else atomically (takeTMVar lock) >>= killThread
-
-              thread' =
+          -- Either unregister the timeout, or kill the assassin throwing
+          -- thread, then carry on the continuation.
+          --
+          -- If the assassin holds the lock, we take it here rather than with
+          -- `atomically` in the `threadAction`: committing a transaction
+          -- yields, and the assassin could throw before we kill it, after the
+          -- frame is gone.  `killThread` does not yield before the exception
+          -- is delivered, and the assassin is unmasked, so it never blocks.
+          threadAction :: IOSim s () <-
+            if v then return (unsafeUnregisterTimeout tmid)
+                 else killThread <$> execTakeTMVar lock
+          let thread' =
                 thread { threadControl =
                           ThreadControl (case threadAction of
                                           IOSim k' -> k' (\() -> k (Just x)))
                                         ctl'
+                         -- If the assassin has already thrown, but we were not
+                         -- interruptible, its exception is pending.  Killing
+                         -- the assassin does not retract it (unlike in GHC's
+                         -- RTS), so we drop it here: otherwise it would be
+                         -- raised outside of the frame.
+                       , threadThrowTo =
+                           filter (\(e, _, _) -> fromException e
+                                              /= Just (TimeoutException tmid))
+                                  (threadThrowTo thread)
                        }
           schedule thread' simstate
 
@@ -638,74 +651,73 @@ schedule thread@Thread{
                $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)
                $ trace
 
-      Atomically a k -> execAtomically time tid tlbl nextVid (runSTM a) $ \res ->
-        case res of
-          StmTxCommitted x written read created
-                           tvarDynamicTraces tvarStringTraces nextVid' -> do
-            (wakeup, wokeby) <- threadsUnblockedByWrites written
-            mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
-            vClockRead <- leastUpperBoundTVarVClocks read
-            read' <- mapM someTVarToLabelled read
-            written' <- mapM someTVarToLabelled written
-            let vClock'     = vClock `leastUpperBoundVClock` vClockRead
-                effect'     = effect
-                           <> readEffects read'
-                           <> writeEffects written'
-                           <> wakeupEffects unblocked
-                thread'     = thread { threadControl = ThreadControl (k x) ctl,
-                                       threadVClock  = vClock',
-                                       threadEffect  = effect' }
-                (unblocked,
-                 simstate') = unblockThreads True vClock' wakeup simstate
-            sequence_ [ modifySTRef (tvarVClock r) (leastUpperBoundVClock vClock')
-                      | SomeTVar r <- created ++ written ]
-            written'' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written
-            created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created
-            -- We deschedule a thread after a transaction... another may have woken up.
-            !trace <- deschedule Yield thread' simstate' { nextVid  = nextVid' }
-            return $
-              SimPORTrace time tid tstep tlbl (EventTxCommitted written'' created' (Just effect')) $
-              traceMany
-                [ (time, tid', (-1), tlbl', EventTxWakeup vids')
-                | tid' <- unblocked
-                , let tlbl' = lookupThreadLabel tid' threads
-                , let Just vids' = Set.toList <$> Map.lookup tid' wokeby ] $
-              traceMany
-                [ (time, tid, tstep, tlbl, EventLog tr)
-                | tr <- tvarDynamicTraces
-                ] $
-              traceMany
-                [ (time, tid, tstep, tlbl, EventSay str)
-                | str <- tvarStringTraces
-                ] $
-              SimPORTrace time tid tstep tlbl (EventUnblocked unblocked) $
-              SimPORTrace time tid tstep tlbl (EventDeschedule Yield) $
-                trace
-
-          StmTxAborted read e -> do
-            -- schedule this thread to immediately raise the exception
-            vClockRead <- leastUpperBoundTVarVClocks read
-            read' <- mapM someTVarToLabelled read
-            let effect' = effect <> readEffects read'
-                thread' = thread { threadControl = ThreadControl (Throw e) ctl,
-                                   threadVClock  = vClock `leastUpperBoundVClock` vClockRead,
-                                   threadEffect  = effect' }
-            trace <- schedule thread' simstate
-            return $ SimPORTrace time tid tstep tlbl (EventTxAborted (Just effect'))
-                   $ trace
+      Atomically a k -> execAtomically time tid tlbl nextVid (runSTM a) $ \case
+        StmTxCommitted x written read created
+                         tvarDynamicTraces tvarStringTraces nextVid' -> do
+          (wakeup, wokeby) <- threadsUnblockedByWrites written
+          mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
+          vClockRead <- leastUpperBoundTVarVClocks read
+          read' <- mapM someTVarToLabelled read
+          written' <- mapM someTVarToLabelled written
+          let vClock'     = vClock `leastUpperBoundVClock` vClockRead
+              effect'     = effect
+                         <> readEffects read'
+                         <> writeEffects written'
+                         <> wakeupEffects unblocked
+              thread'     = thread { threadControl = ThreadControl (k x) ctl,
+                                     threadVClock  = vClock',
+                                     threadEffect  = effect' }
+              (unblocked,
+               simstate') = unblockThreads True vClock' wakeup simstate
+          sequence_ [ modifySTRef (tvarVClock r) (leastUpperBoundVClock vClock')
+                    | SomeTVar r <- created ++ written ]
+          written'' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written
+          created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created
+          -- We deschedule a thread after a transaction... another may have woken up.
+          !trace <- deschedule Yield thread' simstate' { nextVid  = nextVid' }
+          return $
+            SimPORTrace time tid tstep tlbl (EventTxCommitted written'' created' (Just effect')) $
+            traceMany
+              [ (time, tid', (-1), tlbl', EventTxWakeup vids')
+              | tid' <- unblocked
+              , let tlbl' = lookupThreadLabel tid' threads
+              , let Just vids' = Set.toList <$> Map.lookup tid' wokeby ] $
+            traceMany
+              [ (time, tid, tstep, tlbl, EventLog tr)
+              | tr <- tvarDynamicTraces
+              ] $
+            traceMany
+              [ (time, tid, tstep, tlbl, EventSay str)
+              | str <- tvarStringTraces
+              ] $
+            SimPORTrace time tid tstep tlbl (EventUnblocked unblocked) $
+            SimPORTrace time tid tstep tlbl (EventDeschedule Yield) $
+              trace
+
+        StmTxAborted read e -> do
+          -- schedule this thread to immediately raise the exception
+          vClockRead <- leastUpperBoundTVarVClocks read
+          read' <- mapM someTVarToLabelled read
+          let effect' = effect <> readEffects read'
+              thread' = thread { threadControl = ThreadControl (Throw e) ctl,
+                                 threadVClock  = vClock `leastUpperBoundVClock` vClockRead,
+                                 threadEffect  = effect' }
+          trace <- schedule thread' simstate
+          return $ SimPORTrace time tid tstep tlbl (EventTxAborted (Just effect'))
+                 $ trace
 
-          StmTxBlocked read -> do
-            mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read
-            vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read
-            vClockRead <- leastUpperBoundTVarVClocks read
-            read' <- mapM someTVarToLabelled read
-            let effect' = effect <> readEffects read'
-                thread' = thread { threadVClock  = vClock `leastUpperBoundVClock` vClockRead,
-                                   threadEffect  = effect' }
-            !trace <- deschedule (Blocked BlockedOnSTM) thread' simstate
-            return $ SimPORTrace time tid tstep tlbl (EventTxBlocked vids (Just effect'))
-                   $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnSTM))
-                   $ trace
+        StmTxBlocked read -> do
+          mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read
+          vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read
+          vClockRead <- leastUpperBoundTVarVClocks read
+          read' <- mapM someTVarToLabelled read
+          let effect' = effect <> readEffects read'
+              thread' = thread { threadVClock  = vClock `leastUpperBoundVClock` vClockRead,
+                                 threadEffect  = effect' }
+          !trace <- deschedule (Blocked BlockedOnSTM) thread' simstate
+          return $ SimPORTrace time tid tstep tlbl (EventTxBlocked vids (Just effect'))
+                 $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnSTM))
+                 $ trace
 
       GetThreadId k -> do
         let thread' = thread { threadControl = ThreadControl (k tid) ctl }
@@ -1228,6 +1240,7 @@ forkTimeoutInterruptThreads timeoutExpired simState =
                            threadControl =
                             ThreadControl
                               (runIOSim $ do
+                                 -- assassin thread
                                  mtid <- myThreadId
                                  v2 <- atomically $ tryPutTMVar lock mtid
                                  when v2 $
@@ -1616,6 +1629,15 @@ execTryPutTMVar (TMVar var) a = do
       Just _  -> return False
 {-# INLINE execTryPutTMVar #-}
 
+execTakeTMVar :: TMVar (IOSim s) a -> ST s a
+execTakeTMVar (TMVar var) = do
+    v <- execReadTVar var
+    case v of
+      Just a  -> execWriteTVar var Nothing
+              >> return a
+      Nothing -> error "execTakeTMVar: empty TMVar"
+{-# INLINE execTakeTMVar #-}
+
 saveTVar :: TVar s a -> ST s ()
 saveTVar TVar{tvarCurrent, tvarUndo} = do
     -- push the current value onto the undo stack

io-sim/test/Test/Control/Monad/IOSim.hs

@@ -67,6 +67,10 @@ tests =
     , testProperty "async exceptions 1"     unit_timeouts_and_async_exceptions_1
     , testProperty "async exceptions 2"     unit_timeouts_and_async_exceptions_2
     , testProperty "async exceptions 3"     unit_timeouts_and_async_exceptions_3
+    , testProperty "assassin: pending throw"
+    $ forall_masking_states unit_timeout_assassin_pending_throw
+    , testProperty "assassin: holds the lock"
+    $ forall_masking_states unit_timeout_assassin_holds_lock
     , testProperty "threadDelay and STM"    unit_threadDelay_and_stm
     , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay
     , testProperty "throwTo and STM"        unit_throwTo_and_stm
@@ -1186,6 +1190,60 @@ unit_timeouts_and_async_exceptions_3 = once $
       return $ property True
 
 
+-- | The assassin of a `timeout` throws while the timed thread is masked and
+-- runnable, so its exception is pending when the action finishes.  It must
+-- not be raised after `timeout` returns (#269).
+--
+-- The flag is set when the timeout fires.  The writer runs first (woken by its
+-- timer), then the assassin (forked at the same time, queued after it), then
+-- the timed thread (woken by the write).
+--
+unit_timeout_assassin_pending_throw :: MaskingState -> Property
+unit_timeout_assassin_pending_throw ms = once $
+    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
+      flag <- newTVarIO False
+      _ <- forkIO $ threadDelay 1 >> atomically (writeTVar flag True)
+      r <- setMaskingState_ ms $
+             timeout 1 (atomically (readTVar flag >>= check))
+      return $ case ms of
+        -- the exception is delivered within the `timeout`
+        Unmasked -> r === Nothing
+        -- the exception is pending until the action finishes
+        _        -> r === Just ()
+
+
+-- | The assassin of a `timeout` takes the lock, but the action finishes
+-- before it throws.  The exception must not be raised after `timeout`
+-- returns (#269).
+--
+-- The timed thread is woken by its `threadDelay` timer before the assassin is
+-- forked, and yields once more (on `atomically`) before it finishes.  The
+-- assassin takes the lock in between.
+--
+unit_timeout_assassin_holds_lock :: MaskingState -> Property
+unit_timeout_assassin_holds_lock ms = once $
+    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
+      r <- setMaskingState_ ms $
+             timeout 1 (threadDelay 1 >> atomically (return ()))
+      -- let the assassin run, if it's still alive
+      threadDelay 1
+      return (r === Just ())
+
+
 -- | Verify that a thread blocked on `threadDelay` is not unblocked by an STM
 -- transaction.
 --