Erik de Castro Lopo pushed to branch wip/fix-9809 at Glasgow Haskell Compiler / GHC
Commits:
-
cb573bc9
by Moritz Angermann at 2026-10-28T16:56:18+11:00
2 changed files:
- testsuite/tests/rts/pause-resume/all.T
- testsuite/tests/rts/pause-resume/pause_resume_via_safe_ffi_concurrent.hs
Changes:
| ... | ... | @@ -14,6 +14,8 @@ test('pause_resume_via_safe_ffi_concurrent', |
| 14 | 14 | [ only_ways(['threaded1', 'threaded2'])
|
| 15 | 15 | , req_c
|
| 16 | 16 | , extra_files(['pause_resume.c','pause_resume.h'])
|
| 17 | + # Internal watchdog is 60s; give the harness room on loaded Darwin CI.
|
|
| 18 | + , run_timeout_multiplier(2)
|
|
| 17 | 19 | ],
|
| 18 | 20 | multi_compile_and_run, ['pause_resume_via_safe_ffi_concurrent', [('pause_resume.c','')], ''])
|
| 19 | 21 | test('pause_and_use_rts_api',
|
| ... | ... | @@ -8,6 +8,7 @@ import Foreign.Marshal.Alloc |
| 8 | 8 | import Foreign.Ptr
|
| 9 | 9 | import Foreign.Storable
|
| 10 | 10 | import System.Exit
|
| 11 | +import System.IO (hFlush, stdout)
|
|
| 11 | 12 | import System.Timeout
|
| 12 | 13 | |
| 13 | 14 | foreign import ccall safe "pause_resume.h pauseAndResume"
|
| ... | ... | @@ -38,11 +39,17 @@ main = do |
| 38 | 39 | countPtr
|
| 39 | 40 | putMVar mvar ()
|
| 40 | 41 | |
| 41 | - -- Wait (at least 2n seconds to be safe) for all threads to finish.
|
|
| 42 | - result <- timeout (2 * n * 1000000) (mapM_ takeMVar mvars)
|
|
| 42 | + -- Each pause holds the RTS for about a second, so n concurrent
|
|
| 43 | + -- calls serialize to ~n seconds. 2n (10s) was enough on Linux but
|
|
| 44 | + -- a false deadlock on Darwin CI: rts_pause waits for every
|
|
| 45 | + -- capability, and the counter threads keep hitting the timer
|
|
| 46 | + -- manager via threadDelay. Keep a watchdog so a real hang still
|
|
| 47 | + -- fails, but give 60s of slack.
|
|
| 48 | + result <- timeout (60 * 1000000) (mapM_ takeMVar mvars)
|
|
| 43 | 49 | case result of
|
| 44 | 50 | Nothing -> do
|
| 45 | 51 | putStrLn "Not all rts_pause/rts_resume threads have finished. Assuming deadlocked and failing test."
|
| 52 | + hFlush stdout
|
|
| 46 | 53 | exitFailure
|
| 47 | 54 | Just () -> do
|
| 48 | 55 | putStrLn "All threads finished"
|