Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 192be0b6 by Luite Stegeman at 2026-09-07T19:43:36-04:00 rts: fix ctoi_tuple_spill_words getting out of sync Fix a few places that were not updating ctoi_tuple_spill_words correctly, leading to corruption/crashes when dealing with large unboxed tuples in bytecode: - captureContinuationAndAbort - findRetryFrameHelper/findAtomicallyFrameHelper - interpretBCO bci_BRK_FUN fixes #27633 - - - - - 604eb43c by Simon Jakobi at 2026-09-07T19:44:15-04:00 Hadrian: don't capture the testsuite driver's output (#27780) a6061455d54 switched the Testsuite RunTest case from Shake's cmd to the cmd' wrapper. cmd' always captures stdout and stderr, and since the caller asks for Exit, it returns without dumping what it captured. As a result the testsuite output no longer appears in CI job logs: failures, performance metrics and the summary were lost with the job. Use cmdExe, the uncaptured cmd, as the other plain-cmd sites in that commit do. Fixes #27780. Assisted-by: Claude Fable 5.1 - - - - - 06eee015 by Luite Stegeman at 2026-09-08T06:03:06+02:00 rts: Fix missing memory barrier in eval_thunk_selector (#27477) unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the indirectee, leading to segfaults and corruption during GC on weakly-ordered architectures. Fixes #27477 - - - - - 7ab270a2 by Alan Zimmerman at 2026-09-08T03:58:07-04:00 EPA Fix HsCmdDo exact print with comments Exact printing of HsCmdDo was ignoring the location for the do statements, and this is an annotation that can have comments in it. Update it so we print the statements as a unit, including any comments. Also add the result of auditing that we capture comments in all needed places, noting that the remaining Anno SrcSpan instances are benign. - - - - - 23 changed files: - + changelog.d/fix-parallel-gc-selector-race-27477 - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Extension/Pass.hs - hadrian/src/Builder.hs - rts/Continuation.c - rts/Interpreter.c - rts/Schedule.c - rts/sm/Evac.c - + testsuite/tests/bytecode/T27633/Obj.hs - + testsuite/tests/bytecode/T27633/T27633a.hs - + testsuite/tests/bytecode/T27633/T27633a.stdout - + testsuite/tests/bytecode/T27633/T27633b.hs - + testsuite/tests/bytecode/T27633/T27633b.stdout - + testsuite/tests/bytecode/T27633/all.T - + testsuite/tests/ghci.debugger/scripts/T27633c.hs - + testsuite/tests/ghci.debugger/scripts/T27633c.script - + testsuite/tests/ghci.debugger/scripts/T27633c.stdout - + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs - testsuite/tests/ghci.debugger/scripts/all.T - + testsuite/tests/rts/T27477.hs - + testsuite/tests/rts/T27477.stdout - testsuite/tests/rts/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== changelog.d/fix-parallel-gc-selector-race-27477 ===================================== @@ -0,0 +1,10 @@ +section: rts +synopsis: Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap +description: + On weakly-ordered architectures such as AArch64 programs using + could crash during parallel garbage collection (segmentation fault + or ``internal error: eval_thunk_selector: strange selectee <n>``) or + continue running with silently corrupted heap data, due to a missing + memory barrier in the parallel GC. +mrs: !16488 +issues: #27477 ===================================== compiler/GHC/Hs/Doc.hs ===================================== @@ -58,6 +58,7 @@ import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name +-- Exact print annotations ignore LHsDoc, so bare SrcSpan is fine type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass pass)) = SrcSpan deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass) ===================================== compiler/GHC/Hs/Extension/Pass.hs ===================================== @@ -46,6 +46,7 @@ type instance XRec (GhcPass p) a = XRecGhc a -- but pass-independent, source location type XRecGhc a = GenLocated (Anno a) a +-- Exact print annotations ignore LHsDoc, so bare SrcSpan is fine type instance Anno (HsDocString (GhcPass _)) = SrcSpan type instance Anno HsDocStringChunk = SrcSpan ===================================== hadrian/src/Builder.hs ===================================== @@ -387,7 +387,7 @@ instance H.Builder Builder where -- RunTest produces a very large amount of (colorised) output; -- Don't attempt to capture it. Testsuite RunTest -> do - Exit code <- cmd' prog buildArgs buildOptions + Exit code <- cmdExe prog buildArgs buildOptions when (code /= ExitSuccess) $ do fail "tests failed" ===================================== rts/Continuation.c ===================================== @@ -392,6 +392,10 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT const StgInfoTable *apply_mask_frame = NULL; StgWord mask_frame_offset = 0; + // see Note [GHCi unboxed tuples stack spills] + bool seen_ctoi_tuple_frame = false; + StgWord ctoi_tuple_spill_words = 0; + /* --- Phase 1: Find the matching prompt frame ---------------------------- */ IF_DEBUG(continuation, @@ -459,7 +463,8 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT // see Note [GHCi unboxed tuples stack spills] if (info_ptr == &stg_ctoi_t_info) { - tso->ctoi_tuple_spill_words = frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; + seen_ctoi_tuple_frame = true; + ctoi_tuple_spill_words = frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; } // Advance to the next frame. @@ -475,6 +480,11 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT dirty_TSO(cap, tso); dirty_STACK(cap, stack); + // see Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm + if (seen_ctoi_tuple_frame) { + tso->ctoi_tuple_spill_words = ctoi_tuple_spill_words; + } + StgContinuation *cont = (StgContinuation *)allocate(cap, CONTINUATION_sizeW(total_words)); SET_HDR(cont, &stg_CONTINUATION_info, stack->header.prof.ccs); cont->apply_mask_frame = apply_mask_frame; ===================================== rts/Interpreter.c ===================================== @@ -1982,6 +1982,20 @@ run_BCO: for (i = 0; i < size_words; i++) { new_aps->payload[i] = (StgClosure *)ReadSpW(i); } + + /* The stg_ctoi_t frame we copied is entered again when + execution resumes, but tso->ctoi_tuple_spill_words + holds the enclosing frame's count: it was restored + from old_spill when this case continuation was entered + (bci_RETURN_T). Put back the count belonging to this + frame, so the invariant holds while the thread sits at + the breakpoint. + + See Note [GHCi unboxed tuples stack spills] */ + if (ReadSpW(size_returned_frame) == (W_)&stg_ctoi_t_info) { + cap->r.rCurrentTSO->ctoi_tuple_spill_words = + ReadSpW(size_returned_frame + CTOI_TUPLE_INFO_OFFSET) >> 24; + } } else { ===================================== rts/Schedule.c ===================================== @@ -3271,6 +3271,10 @@ findRetryFrameHelper (Capability *cap, StgTSO *tso) default: ASSERT(info->i.type != CATCH_FRAME); ASSERT(info->i.type != STOP_FRAME); + // see Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm + if (*p == (StgWord)&stg_ctoi_t_info) { + tso->ctoi_tuple_spill_words = p[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; // restore old_spill + } p = next; continue; } @@ -3332,6 +3336,10 @@ findAtomicallyFrameHelper (Capability *cap, StgTSO *tso) default: ASSERT(info->i.type != CATCH_FRAME); ASSERT(info->i.type != STOP_FRAME); + // see Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm + if (*p == (StgWord)&stg_ctoi_t_info) { + tso->ctoi_tuple_spill_words = p[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; // restore old_spill + } p = next; continue; } ===================================== rts/sm/Evac.c ===================================== @@ -1361,7 +1361,11 @@ selector_loop: // from-space during marking, for example. We rely on the property // that evacuate() doesn't mind if it gets passed a to-space pointer. - info = RELAXED_LOAD((StgInfoTable**) &selectee->header.info); + // NB. this load must be ordered: the selectee may be updated + // concurrently by another GC thread's unchain_thunk_selectors(), + // which publishes an indirection by writing the indirectee and + // then RELEASE-storing the info pointer. See #27477. + info = ACQUIRE_LOAD((StgInfoTable**) &selectee->header.info); if (IS_FORWARDING_PTR(info)) { // We don't follow pointers into to-space; the constructor ===================================== testsuite/tests/bytecode/T27633/Obj.hs ===================================== @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fobject-code #-} +{-# LANGUAGE UnboxedTuples, MagicHash #-} +module Obj where + +import GHC.Exts + +-- Compiled to object code; returns a large unboxed tuple, so the return +-- into an interpreted caller goes through the native stg_ctoi_t entry code, +-- which reads tso->ctoi_tuple_spill_words. +-- See Note [GHCi unboxed tuples stack spills] in rts/StgMiscClosures.cmm. +mkT :: State# RealWorld -> (# State# RealWorld, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +mkT s = (# s, 1#, 2#, 3#, 4#, 5#, 6#, 7#, 8#, 9#, 10#, 11#, 12#, 13#, 14#, 15#, 16#, 17#, 18#, 19#, 20#, 21#, 22#, 23#, 24# #) +{-# NOINLINE mkT #-} ===================================== testsuite/tests/bytecode/T27633/T27633a.hs ===================================== @@ -0,0 +1,34 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fbyte-code #-} + +-- Regression test for #27633 (bug 1): a failed control0# capture must not +-- clobber tso->ctoi_tuple_spill_words while a generic stg_ctoi_t frame is +-- still live on the stack. +-- See Note [GHCi unboxed tuples stack spills] in rts/StgMiscClosures.cmm. + +module Main where + +import Control.Exception +import GHC.Exts +import GHC.IO (IO(..)) +import Obj + +unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #) +unIO (IO f) = f + +-- control0# with a tag that has no matching prompt anywhere on the stack; +-- the resulting exception is caught right here, above the stg_ctoi_t frame, +-- so the unwind stops before reaching the frame. +failing :: IO () +failing = IO (\s0 -> case newPromptTag# s0 of + (# s1, tag #) -> control0# tag (\_ s -> (# s, () #)) s1) + `catch` \(SomeException _) -> return () + +scrut :: State# RealWorld -> (# State# RealWorld, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +scrut s0 = case unIO failing s0 of (# s1, _ #) -> mkT s1 +{-# NOINLINE scrut #-} + +main :: IO () +main = IO (\s0 -> case scrut s0 of + (# s1, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24 #) -> + unIO (print (I# (x1 +# x2 +# x3 +# x4 +# x5 +# x6 +# x7 +# x8 +# x9 +# x10 +# x11 +# x12 +# x13 +# x14 +# x15 +# x16 +# x17 +# x18 +# x19 +# x20 +# x21 +# x22 +# x23 +# x24))) s1) ===================================== testsuite/tests/bytecode/T27633/T27633a.stdout ===================================== @@ -0,0 +1 @@ +300 ===================================== testsuite/tests/bytecode/T27633/T27633b.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fbyte-code #-} + +-- Regression test for #27633 (bug 2): STM retry unwinding +-- (findRetryFrameHelper/findAtomicallyFrameHelper) must restore +-- tso->ctoi_tuple_spill_words when it discards a generic stg_ctoi_t frame. +-- See Note [GHCi unboxed tuples stack spills] in rts/StgMiscClosures.cmm. + +module Main where + +import GHC.Conc (STM(..), atomically, orElse) +import GHC.Exts +import GHC.IO (IO(..)) +import Obj + +unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #) +unIO (IO f) = f + +-- Inside the transaction: case on a 16-field tuple (different spill count +-- than the outer 24-field one), then retry. The generic stg_ctoi_t frame +-- pushed for this case is discarded by findRetryFrameHelper. +innerScrut :: State# RealWorld -> (# State# RealWorld, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +innerScrut s0 = case retry# s0 of (# s1, () #) -> (# s1, 1#, 2#, 3#, 4#, 5#, 6#, 7#, 8#, 9#, 10#, 11#, 12#, 13#, 14#, 15#, 16# #) +{-# NOINLINE innerScrut #-} + +stmBody :: STM () +stmBody = STM (\s0 -> case innerScrut s0 of + (# s1, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16 #) -> (# s1, () #)) + +outerScrut :: State# RealWorld -> (# State# RealWorld, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +outerScrut s0 = + case unIO (atomically (stmBody `orElse` return ())) s0 of + (# s1, _ #) -> mkT s1 +{-# NOINLINE outerScrut #-} + +main :: IO () +main = IO (\s0 -> case outerScrut s0 of + (# s1, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24 #) -> + unIO (print (I# (x1 +# x2 +# x3 +# x4 +# x5 +# x6 +# x7 +# x8 +# x9 +# x10 +# x11 +# x12 +# x13 +# x14 +# x15 +# x16 +# x17 +# x18 +# x19 +# x20 +# x21 +# x22 +# x23 +# x24))) s1) ===================================== testsuite/tests/bytecode/T27633/T27633b.stdout ===================================== @@ -0,0 +1 @@ +300 ===================================== testsuite/tests/bytecode/T27633/all.T ===================================== @@ -0,0 +1,21 @@ +test('T27633a', + [ extra_files(['Obj.hs']), + req_interp, + req_bco, + only_ways(ghci_ways), + extra_ways(ghci_ways), + ], + compile_and_run, + [''] + ) + +test('T27633b', + [ extra_files(['Obj.hs']), + req_interp, + req_bco, + only_ways(ghci_ways), + extra_ways(ghci_ways), + ], + compile_and_run, + [''] + ) ===================================== testsuite/tests/ghci.debugger/scripts/T27633c.hs ===================================== @@ -0,0 +1,29 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} + +-- Stopping at a breakpoint in the case continuation of a large unboxed +-- tuple return (generic stg_ctoi_t frame) and resuming must re-enter the +-- frame with the correct tso->ctoi_tuple_spill_words. The continuation +-- breakpoint is activated via :stepout. +-- See Note [GHCi unboxed tuples stack spills] in rts/StgMiscClosures.cmm. + +module Main where + +import GHC.Exts +import GHC.IO (IO(..)) +import T27633c_obj + +unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #) +unIO (IO f) = f + +poke :: Int -> IO Int +poke x = + return (x + 1) -- line 20: initial breakpoint + +scrut :: State# RealWorld -> (# State# RealWorld, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +scrut s0 = case unIO (poke 41) s0 of (# s1, _ #) -> mkT s1 +{-# NOINLINE scrut #-} + +main :: IO () +main = IO (\s0 -> case scrut s0 of + (# s1, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24 #) -> + unIO (print (I# (x1 +# x2 +# x3 +# x4 +# x5 +# x6 +# x7 +# x8 +# x9 +# x10 +# x11 +# x12 +# x13 +# x14 +# x15 +# x16 +# x17 +# x18 +# x19 +# x20 +# x21 +# x22 +# x23 +# x24))) s1) ===================================== testsuite/tests/ghci.debugger/scripts/T27633c.script ===================================== @@ -0,0 +1,13 @@ +:load T27633c.hs +-- break inside poke, while the generic stg_ctoi_t frame from main's +-- 24-field tuple case is live on the stack +:break 20 +main +-- step out to the small case continuation in scrut +:stepout +-- step out again: activates the breakpoint of main's tuple case +-- continuation BCO, entered through the generic stg_ctoi_t frame +:stepout +-- resuming re-enters the stg_ctoi_t frame; with a stale +-- tso->ctoi_tuple_spill_words this segfaulted +:continue ===================================== testsuite/tests/ghci.debugger/scripts/T27633c.stdout ===================================== @@ -0,0 +1,9 @@ +Breakpoint 0 activated at T27633c.hs:20:3-16 +Stopped in Main.poke, T27633c.hs:20:3-16 +_result :: IO Int = _ +x :: Int = 41 +Stopped in Main.scrut, T27633c.hs:23:17-33 +_result :: (# State# RealWorld, Int #) = _ +Stopped in Main.main, T27633c.hs:(27,19)-(29,193) +_result :: (# State# RealWorld, () #) = _ +300 ===================================== testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs ===================================== @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fobject-code #-} +{-# LANGUAGE UnboxedTuples, MagicHash #-} +module T27633c_obj where + +import GHC.Exts + +-- Compiled to object code; returns a large unboxed tuple, so the return +-- into an interpreted caller goes through the native stg_ctoi_t entry code, +-- which reads tso->ctoi_tuple_spill_words. +mkT :: State# RealWorld -> (# State# RealWorld, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +mkT s = (# s, 1#, 2#, 3#, 4#, 5#, 6#, 7#, 8#, 9#, 10#, 11#, 12#, 13#, 14#, 15#, 16#, 17#, 18#, 19#, 20#, 21#, 22#, 23#, 24# #) +{-# NOINLINE mkT #-} ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -153,3 +153,5 @@ test('T26042e', extra_files(['T26042e.hs']), ghci_script, ['T26042e.script']) test('T26042f1', extra_files(['T26042f.hs', 'T26042f.script']), ghci_script, ['T26042f.script']) # >> is not inlined, so stepout has nowhere to stop test('T26042f2', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042f.hs', 'T26042f.script'])], ghci_script, ['T26042f.script']) test('T26042g', extra_files(['T26042g.hs']), ghci_script, ['T26042g.script']) + +test('T27633c', extra_files(['T27633c_obj.hs']), ghci_script, ['T27633c.script']) ===================================== testsuite/tests/rts/T27477.hs ===================================== @@ -0,0 +1,169 @@ +{-# LANGUAGE BangPatterns #-} + +-- Stress test for #27477: missing ACQUIRE in eval_thunk_selector +-- (rts/sm/Evac.c). +-- +-- With the bug present this test crashes or reports value mismatches +-- within a few seconds on AArch64; on strongly-ordered targets +-- it just passes. + +module Main (main) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.IORef +import System.Environment +import System.Exit +import System.IO +import System.Mem (performMinorGC) + +data T = T { nxt :: T, val :: !Int } + +-- expected values and the cells that should evaluate to them +type Batch = ([Int], [T]) + +tailD, branchD, branchesPerCell :: Int +tailD = 12 -- shared tail length per cluster +branchD = 3 -- private branch length +branchesPerCell = 2 +-- tailD + branchD must stay below MAX_THUNK_SELECTOR_DEPTH (16) + +{-# NOINLINE spineEnd #-} +spineEnd :: T +spineEnd = errorWithoutStackTrace "spine end reached" + +-- Fully evaluated spine of constructors; cell i from the head has val i+1. +buildSpine :: Int -> IO T +buildSpine len = evaluate (go len (T spineEnd 0)) + where + go :: Int -> T -> T + go 0 acc = acc + go k acc = go (k - 1) (T acc k) + +-- k selector thunks, shallow-first: cell i selects from cell i-1, +-- cell 0 selects from t. If t evaluates to spine cell m (val m+1), +-- cell i evaluates to spine cell m+1+i (val m+2+i). +{-# NOINLINE selChain #-} +selChain :: Int -> T -> [T] +selChain 0 _ = [] +selChain k t = let t' = nxt t in t' : selChain (k - 1) t' + +lenL :: [a] -> Int +lenL = go 0 + where + go !n [] = n + go !n (_ : xs) = go (n + 1) xs + +everyN :: Int -> [a] -> [a] +everyN _ [] = [] +everyN n (x : xs) = x : everyN n (drop (n - 1) xs) + +-- One branch hanging off tail cell tj (which evaluates to val jval): +-- branch cell i evaluates to jval+1+i. Returned deepest-first. +{-# NOINLINE mkBranch #-} +mkBranch :: Int -> T -> IO Batch +mkBranch jval tj = do + let cells = selChain branchD tj + _ <- evaluate (lenL cells) + let expected = [ jval + 1 + i | i <- [0 .. branchD - 1] ] + pure (reverse expected, reverse cells) + +-- A cluster: one private spine, one shared tail of selectors over it, +-- branchesPerCell branches of selectors converging on every tail cell. +-- Neither the spine nor the tail is returned: they must stay reachable +-- only through the branch selectors. +buildCluster :: IO [Batch] +buildCluster = do + sp <- buildSpine (tailD + branchD + 4) + let tails = selChain tailD sp + _ <- evaluate (lenL tails) + bss <- forM (zip [0 ..] tails) $ \(j, tj) -> + replicateM branchesPerCell (mkBranch (j + 2) tj) + pure (concat bss) + +verifyBatch :: IORef Int -> Int -> Batch -> IO () +verifyBatch errs wid (es0, ts0) = go es0 ts0 + where + go (e : es) (t : ts) = do + v <- evaluate (val t) + when (v /= e) $ do + hPutStrLn stderr $ + "MISMATCH worker=" ++ show wid + ++ " expected=" ++ show e ++ " got=" ++ show v + modifyIORef' errs (+ 1) + go es ts + go _ _ = pure () + +-- simple cyclic barrier +newtype Barrier = Barrier (MVar (Int, [MVar ()])) + +newBarrier :: IO Barrier +newBarrier = Barrier <$> newMVar (0, []) + +awaitBarrier :: Barrier -> Int -> IO () +awaitBarrier (Barrier st) total = do + w <- newEmptyMVar + join $ modifyMVar st $ \(k, ws) -> + if k + 1 == total + then pure ((0, []), mapM_ (\m -> putMVar m ()) ws) + else pure ((k + 1, w : ws), takeMVar w) + +worker :: Int -> Int -> Int -> Barrier -> [IORef [Batch]] -> IORef Int -> Int -> IO () +worker rounds clusters nWorkers bar slots errs wid = + forM_ [1 .. rounds] $ \(_r :: Int) -> do + -- build fresh selector clusters, publish them + batches <- concat <$> replicateM clusters buildCluster + writeIORef (slots !! wid) batches + awaitBarrier bar nWorkers + -- root each branch's deepest cell via fresh cons cells in our own + -- nursery (so our GC thread evacuates the shared cells itself), in + -- a per-worker interleaved order so that different GC threads + -- sweep different branches of the same shared tails concurrently + published <- mapM readIORef slots + let allBatches = concat published + ordered + | nWorkers > 1 = + concat [ everyN nWorkers (drop ((wid + k) `mod` nWorkers) allBatches) + | k <- [0 .. nWorkers - 1] ] + | otherwise = allBatches + deepTs = [ t | (_, t : _) <- ordered ] + deepEs = [ e | (e : _, _) <- ordered ] + _ <- evaluate (lenL deepTs) + _ <- evaluate (lenL deepEs) + awaitBarrier bar nWorkers + -- run a parallel GC with everything live + when (wid == 0) performMinorGC + awaitBarrier bar nWorkers + -- force everything and check the values + verifyBatch errs wid (deepEs, deepTs) + awaitBarrier bar nWorkers + +main :: IO () +main = do + hSetBuffering stderr LineBuffering + args <- getArgs + let atDef d i = if length args > i then read (args !! i) else d + rounds = atDef 600 0 + clusters = atDef 48 1 + n <- getNumCapabilities + bar <- newBarrier + slots <- replicateM n (newIORef []) + errs <- newIORef 0 + dones <- forM [0 .. n - 1] $ \i -> do + done <- newEmptyMVar + _ <- forkOn i $ + (worker rounds clusters n bar slots errs i >> putMVar done Nothing) + `catch` \e -> putMVar done (Just (e :: SomeException)) + pure done + results <- mapM takeMVar dones + forM_ results $ \r -> case r of + Just e -> do + hPutStrLn stderr ("worker exception: " ++ show e) + exitWith (ExitFailure 2) + Nothing -> pure () + ec <- readIORef errs + when (ec > 0) $ do + hPutStrLn stderr ("FAILED: " ++ show ec ++ " mismatches") + exitWith (ExitFailure 2) + putStrLn "OK" ===================================== testsuite/tests/rts/T27477.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/rts/all.T ===================================== @@ -720,3 +720,12 @@ test('T27585', , extra_run_opts('+RTS -i0 -RTS') ], compile_and_run, ['-O -rtsopts']) + +test('T27477', + [ extra_run_opts('600 24 +RTS -N4 -A1m -RTS') + , req_ghc_smp + , req_target_smp + , only_ways(['threaded1', 'threaded2']) + ], + compile_and_run, ['-O2']) + ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -3404,13 +3404,13 @@ instance ExactPrint (HsCmd GhcPs) where e' <- markAnnotated e return (HsCmdLet (tkLet', tkIn') binds' e') - exact (HsCmdDo (an0,loc) (L l es)) = do + exact (HsCmdDo (an0,loc) es) = do debugM $ "HsCmdDo" loc' <- printStringAtAA loc "do" (an1,es') <- markAnnList' an0 $ do - ee <- mapM markAnnotated es + ee <- markAnnotated es return ee - return (HsCmdDo (an1,loc') (L l es')) + return (HsCmdDo (an1,loc') es') -- --------------------------------------------------------------------- @@ -4508,10 +4508,10 @@ instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] whe Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do debugM $ "LocatedL [ExprLStmt: snocView" ls' <- markAnnotated ls - initStmts' <- markAnnotated initStmts + initStmts' <- mapM markAnnotated initStmts return (initStmts' ++ [ls']) _ -> do - stmts' <- markAnnotated stmts + stmts' <- mapM markAnnotated stmts return stmts' instance ExactPrint [Located HsDocStringChunk] where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/48c23c948d104356bc05f28fd12a171... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/48c23c948d104356bc05f28fd12a171... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help