Alan Zimmerman pushed to branch wip/az/epa-print-gadt-condecl 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 - - - - - f8b2bd8f by Alan Zimmerman at 2026-09-08T09:39:12-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. - - - - - c67d43d6 by Alan Zimmerman at 2026-09-08T20:14:17+01:00 EPA: Exact print ConDeclGADT without custom enterAnn !16321 brought in explicit capture of parens in a ConDeclGADT. The ExactPrint update introduced a modification of the fundamental function in exact printing, `enterAnn`, by splitting it into a version allowing injection of functionality normally handled by the ExactPrint class methods. This commit refactors that code, to restore the prior `enterAnn` version, by following the convention in ExactPrint of introducing a helper data structure with its own `ExactPrint` instance to achieve the same effect. - - - - - 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 ===================================== @@ -370,10 +370,6 @@ cua CanUpdateAnchor f = f cua CanUpdateAnchorOnly _ = return [] cua NoCanUpdateAnchor _ = return [] -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn = enterAnnWith exact setAnnotationAnchor - -{-# INLINE enterAnnWith #-} -- | "Enter" an annotation, by using the associated 'anchor' field as -- the new reference point for calculating all DeltaPos positions. -- This is the heart of the exact printing process. @@ -381,17 +377,14 @@ enterAnn = enterAnnWith exact setAnnotationAnchor -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. -enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) => - (a -> EP w m b) -> -- exact - (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor - Entry -> a -> EP w m b -enterAnnWith exactVia _ NoEntryVal a = do +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn NoEntryVal a = do p <- getPosP debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exactVia a + r <- exact a debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) return r -enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do +enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do acceptSpan <- getAcceptSpan setAcceptSpan False case anchor' of @@ -502,7 +495,7 @@ enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpd advance edp debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') - a' <- exactVia a + a' <- exact a debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') -- Core recursive exactprint done, start end of Entry processing @@ -556,8 +549,8 @@ enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpd EpaSpan s -> EpaDelta s edp [] _ -> EpaDelta noSrcSpan edp [] let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) - CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments + CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments NoCanUpdateAnchor -> a' return r @@ -3404,13 +3397,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') -- --------------------------------------------------------------------- @@ -4264,26 +4257,13 @@ instance ExactPrint (ConDecl GhcPs) where epTokensToComments "(" ops epTokensToComments ")" cps - -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 outer_bndrs' <- case outer_bndrs of L _ (HsOuterImplicit _) -> return outer_bndrs _ -> markAnnotated outer_bndrs - (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do - mcxt' <- markAnnotated mcxt - args' <- - case args of - (PrefixConGADT x args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT x args0') - (RecConGADT (oc,cc,rarr) fields) -> do - oc' <- markEpToken oc - fields' <- markAnnotated fields - cc' <- markEpToken cc - rarr' <- markEpUniToken rarr - return (RecConGADT (oc',cc',rarr') fields') - res_ty' <- markAnnotated res_ty - return (mcxt', args', res_ty') + let ib = toInnerBindings inner_bndrs (mcxt, args, res_ty) + ib' <- markAnnotated ib + let (inner_bndrs', (mcxt', args', res_ty')) = fromInnerBindings ib' return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' @@ -4293,43 +4273,54 @@ instance ExactPrint (ConDecl GhcPs) where , con_modifiers = mods' , con_res_ty = res_ty', con_doc = doc }) --- | Exact print the inner binders of a GADT signature. --- --- It's that complicated because we need to mark comments/trailing anns --- stored inside `L` and mark closing parenthesis _after_ we mark inner --- type: --- --- data T a b where --- MkT :: --- forall a. ( -- mark inside `markGadtArgs` --- forall b. some type -> T a b -- mark everything there --- ) -- mark inside `markGadtArgs` --- --- We don't have the same problem for `HsArgPar` because we ignore it --- during exact-print, "Does not appear in original source" -markGadtArgs :: (Monad m, Monoid w, Typeable a) - => [LHsGadtTelescope GhcPs] -> EP w m a - -> EP w m ([LHsGadtTelescope GhcPs], a) -markGadtArgs args inner_action = go args +-- --------------------------------------------------------------------- + +data InnerBindings + = InnerMore (LHsGadtTelescope GhcPs) InnerBindings + | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) + +toInnerBindings :: [LHsGadtTelescope GhcPs] + -> (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) -> InnerBindings +toInnerBindings [] inner = InnerDone inner +toInnerBindings (b:bs) inner = InnerMore b (toInnerBindings bs inner) + +fromInnerBindings :: InnerBindings -> ([LHsGadtTelescope GhcPs], (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs)) +fromInnerBindings = go [] where - go [] = do - r <- inner_action - return ([], r) - go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg + go acc (InnerMore b n) = go (b:acc) n + go acc (InnerDone x) = (acc,x) - exact_arg xs (L l (HsGadtForAll _ tele)) = do - tele' <- markAnnotated tele - (xs', r) <- go xs - return (L l (HsGadtForAll noExtField tele') : xs', r) - exact_arg xs (L l (HsGadtPar (lp, rp))) = do - lp' <- markEpToken lp - (xs', r) <- go xs - rp' <- markEpToken rp - return (L l (HsGadtPar (lp',rp')) : xs', r) +instance ExactPrint InnerBindings where + getAnnotationEntry (InnerMore (L li _) _) = fromAnn li + getAnnotationEntry (InnerDone _) = NoEntryVal - -- The binder just entered is the head of the returned list - setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r) - setAnchor ([], r) _ _ _ = ([], r) + setAnnotationAnchor (InnerMore li n) anc ts cs = InnerMore (setAnchorAn li anc ts cs) n + setAnnotationAnchor (InnerDone x) _ _ _ = InnerDone x + + exact (InnerMore (L li (HsGadtForAll x tele)) n) = do + tele' <- markAnnotated tele + n' <- markAnnotated n + return (InnerMore (L li (HsGadtForAll x tele')) n') + exact (InnerMore (L l (HsGadtPar (lp, rp))) xs) = do + lp' <- markEpToken lp + xs' <- markAnnotated xs + rp' <- markEpToken rp + return (InnerMore (L l (HsGadtPar (lp',rp'))) xs') + exact (InnerDone (mcxt, args, res_ty)) = do + mcxt' <- markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT (oc,cc,rarr) fields) -> do + oc' <- markEpToken oc + fields' <- markAnnotated fields + cc' <- markEpToken cc + rarr' <- markEpUniToken rarr + return (RecConGADT (oc',cc',rarr') fields') + res_ty' <- markAnnotated res_ty + return (InnerDone (mcxt', args', res_ty')) -- --------------------------------------------------------------------- @@ -4508,10 +4499,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/a10571e52ffc1a43d2b48ffc63334c7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a10571e52ffc1a43d2b48ffc63334c7... 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