Duncan Coutts pushed to branch wip/io-manager-deadlock-detection at Glasgow Haskell Compiler / GHC Commits: 58cdfab9 by Duncan Coutts at 2025-09-12T12:34:07+01:00 Add a test for deadlock detection, issue #26408 - - - - - 3 changed files: - + testsuite/tests/rts/T26408.hs - + testsuite/tests/rts/T26408.stderr - testsuite/tests/rts/all.T Changes: ===================================== testsuite/tests/rts/T26408.hs ===================================== @@ -0,0 +1,33 @@ +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad + +-- | Test to make sure that deadlock detection works even when there are other +-- unrelated threads that are blocked on I\/O (or timeouts). +-- Historically however this did affect things in the non-threaded RTS which +-- would only do deadlock detection if there were no runnable threads /and/ +-- no pending I\/O. See https://gitlab.haskell.org/ghc/ghc/-/issues/26408 +main :: IO () +main = do + + -- Set up two threads that are blocked on each other + aDone <- newTVarIO False + bDone <- newTVarIO False + let blockingThread theirDone ourDone = + atomically $ do + done <- readTVar theirDone + guard done + writeTVar ourDone True + _ <- forkIO (blockingThread bDone aDone) + _ <- forkIO (blockingThread aDone bDone) + + -- Set up another thread that is blocked on I/O + _ <- forkIO $ threadWaitRead 0 + + -- Wait on the deadlocked threads to terminate. We now expect that the threads + -- that are deadlocked are detected as such and an exception is raised. + -- Note that if this fails, this test may itself deadlock and rely on the + -- test framework's timeout. + atomically $ do + status <- mapM readTVar [aDone, bDone] + guard (or status) ===================================== testsuite/tests/rts/T26408.stderr ===================================== @@ -0,0 +1,3 @@ +T26408: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.BlockedIndefinitelyOnSTM: + +thread blocked indefinitely in an STM transaction ===================================== testsuite/tests/rts/all.T ===================================== @@ -647,3 +647,5 @@ test('T22859', when(arch('wasm32'), skip), omit_ways(llvm_ways)], compile_and_run, ['-with-rtsopts -A8K']) + +test('T26408', [exit_code(1)], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58cdfab98694ac982a28e955361eebe1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58cdfab98694ac982a28e955361eebe1... You're receiving this email because of your account on gitlab.haskell.org.