diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 9efc9bcd..ae565322 100644 --- a/.github/workflows/haskell.yml +++ b/.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' diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 9ad02b79..b043142e 100644 --- a/io-sim/CHANGELOG.md +++ b/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 diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index dfe70e29..6bb02cf1 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/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 diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index 921188e0..644033d5 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/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 diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index 03b1dbac..13c87493 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/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. -- diff --git a/io-sim/test/Test/Control/Monad/IOSimPOR.hs b/io-sim/test/Test/Control/Monad/IOSimPOR.hs index cce7fc40..1fce80a8 100644 --- a/io-sim/test/Test/Control/Monad/IOSimPOR.hs +++ b/io-sim/test/Test/Control/Monad/IOSimPOR.hs @@ -77,6 +77,10 @@ tests = , testProperty "timeouts" prop_timeouts , testProperty "stacked timeouts" prop_stacked_timeouts , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay + , 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 "infinite simulation" prop_explore_endless_simulation , testProperty "threadId order (IOSim)" (withNumTests 1000 prop_threadId_order_order_Sim) @@ -1149,6 +1153,58 @@ unit_timeouts_and_async_exceptions_3 = threadDelay 1 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). +-- +-- `timeout` runs in a forked thread, so that the steps of its assassin are +-- racy as well. +-- +unit_timeout_assassin_pending_throw :: MaskingState -> Property +unit_timeout_assassin_pending_throw ms = + exploreSimTrace id experiment $ \_ trace -> + counterexample (ppTrace_ trace) + . either (\e -> counterexample (show e) False) id + . traceResult False + $ trace + where + experiment :: IOSim s Property + experiment = do + exploreRaces + flag <- newTVarIO False + _ <- forkIO $ threadDelay 1 >> atomically (writeTVar flag True) + r <- waitCatch =<< async (setMaskingState_ ms $ + timeout 1 (atomically (readTVar flag >>= check))) + return $ case r of + Left e -> counterexample (show e) False + Right _ -> property True + + +-- | 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). +-- +-- `timeout` runs in a forked thread, so that the steps of its assassin are +-- racy as well. +-- +unit_timeout_assassin_holds_lock :: MaskingState -> Property +unit_timeout_assassin_holds_lock ms = + exploreSimTrace id experiment $ \_ trace -> + counterexample (ppTrace_ trace) + . either (\e -> counterexample (show e) False) id + . traceResult False + $ trace + where + experiment :: IOSim s Property + experiment = do + exploreRaces + r <- waitCatch =<< async (setMaskingState_ ms $ + timeout 1 (threadDelay 1 >> atomically (return ()))) + return $ case r of + Left e -> counterexample (show e) False + Right _ -> property True + -- -- MonadMask properties --