Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base 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. - - - - - 1ca7779f by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Add test for `base` being buildable with released GHCs - - - - - 513398d2 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Switch to GHC 9.14.2 - - - - - 2725c438 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Make .gitlab/base-ci.sh` executable - - - - - 9dd666d9 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Change the GHC version number back to 9.14.1 - - - - - 451374da by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Enable error propagation in `.gitlab/base-ci.sh` - - - - - c8706244 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Remove the accidental restriction to exactly one GHC - - - - - 50d76e7a by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Make relative directories absolute - - - - - 5304a399 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Make `${project_root}` available to all code - - - - - 9bf0096c by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Add missing newline escaping - - - - - a105b512 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Fix the GHC installation path - - - - - 800eefcc by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Move the definition of `withEmptyCallStack` into `base` - - - - - 89e3c08e by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Change tag `x86_64-windows` to `new-x86_64-windows` - - - - - 685b19d6 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Change the actual installation procedure for Windows - - - - - 3b6990fe by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Switch to using a `Setup.hs` file - - - - - ee663f66 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Add conditional import of `GHC.Essentials` - - - - - 595c5829 by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Make the use of `-frebindable-known-names` conditional - - - - - bdcd39aa by Wolfgang Jeltsch at 2026-09-09T18:36:39+03:00 Disable the inclusion of `GHC.Essentials` for older GHCs - - - - - 28 changed files: - .gitlab-ci.yml - + .gitlab/base-ci.sh - + changelog.d/fix-parallel-gc-selector-race-27477 - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Extension/Pass.hs - hadrian/src/Builder.hs - libraries/base/base.cabal.in - libraries/base/src/GHC/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack.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: ===================================== .gitlab-ci.yml ===================================== @@ -69,7 +69,7 @@ stages: - quick-build # A very quick smoke-test to weed out broken commits - full-build # Build all the things - packaging # Source distribution, etc. - - testing # head.hackage correctness and compiler performance testing + - testing # Various tests - deploy # push documentation # Note [The CI Story] @@ -1162,6 +1162,44 @@ ghc-wasm-meta-unreg: UPSTREAM_GHC_FLAVOUR: unreg UPSTREAM_GHC_JOB_NAME: x86_64-linux-alpine3_23-wasm-unreg-cross_wasm32-wasi-release+host_fully_static+text_simdutf +############################################################ +# Testing the compatibility of `base` with other GHCs +############################################################ + +base-with-other-ghcs-linux: + stage: testing + needs: + - job: x86_64-linux-deb13-validate + optional: true + - job: nightly-x86_64-linux-deb13-validate + optional: true + - job: release-x86_64-linux-deb13-release + optional: true + dependencies: null + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12:$DOCKER_REV" + tags: + - x86_64-linux + script: .gitlab/base-ci.sh x86_64-deb12-linux 9.14.1 + rules: + - *full-ci + +base-with-other-ghcs-windows: + stage: testing + needs: + - job: x86_64-windows-validate + optional: true + - job: nightly-x86_64-windows-validate + optional: true + - job: release-x86_64-windows-release + optional: true + dependencies: null + image: null + tags: + - new-x86_64-windows + script: bash .gitlab/base-ci.sh x86_64-unknown-mingw32 9.14.1 + rules: + - *full-ci + ############################################################ # Documentation deployment via GitLab Pages ############################################################ ===================================== .gitlab/base-ci.sh ===================================== @@ -0,0 +1,75 @@ +#!/usr/bin/env bash + +# This script supports testing the compatibility of the in-tree `base` with +# different non-in-tree GHCs. We deliberately use a script separate from +# `.gitlab/ci.sh` for this purspose, because such support is supposed to become +# part of the CI infrastructure of a separately maintained `base`. +# +# Currently, this script can only test that the in-tree `base` can be *built* +# with certain *released* GHCs. +# +# This script can run on both Unix and Windows. Since GHC’s infrastructure does +# not offer Cabal pre-installed on Windows, this script uses a `Setup.hs` file +# to build `base`, which works across operating systems. + +# Establish error propagation +set -e -o pipefail + +# Process arguments +if [ $# -lt 1 ] +then + echo 'Build `base` with released GHCs' + echo "Usage: base-ci ⟨platform⟩ ⟨ghc-version⟩ …" + exit 1 +fi >&2 +platform=$1 +shift +ghc_versions=$* + +# Save project root +project_root=$PWD + +# Create directories for other GHCs +mkdir other-ghcs +mkdir other-ghcs/src +mkdir other-ghcs/opt + +# Amend the `base` sources +cd libraries/base +sed -E -e 's/^( *ghc-internal)[^[:alnum:]-].*(,|$)/\1\2/' \ + < base.cabal.in \ + > base.cabal +cat <<. >Setup.hs +import Distribution.Simple +main = defaultMain +. +cd ${project_root} + +# Build `base` with the different GHCs +for ghc_version in ${ghc_versions} +do + # Install the GHC + ghc_installation=${project_root}/other-ghcs/opt/${ghc_version} + cd other-ghcs/src + archive_file=ghc-${ghc_version}-${platform}.tar.xz + curl https://downloads.haskell.org/~ghc/${ghc_version}/${archive_file} \ + >${ghc_version}.tar.xz + tar -xJf ${ghc_version}.tar.xz + if [ -f ghc-${ghc_version}-*/configure ] + then # Unix + cd ghc-${ghc_version}-* + ./configure --prefix "${ghc_installation}" + make install + else # Windows + mv ghc-${ghc_version}-* "${ghc_installation}" + fi + cd ${project_root} + + # Build `base` with the installed GHC + cd libraries/base + "${ghc_installation}/bin/runghc" Setup.hs configure \ + --with-compiler "${ghc_installation}/bin/ghc" \ + -O0 + "${ghc_installation}/bin/runghc" Setup.hs build + cd ${project_root} +done ===================================== 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" ===================================== libraries/base/base.cabal.in ===================================== @@ -33,9 +33,10 @@ Library ghc-internal == @ProjectVersionForLib@.*, ghc-prim, - -- Set -frebindable-known-names, - -- since GHC.Essentials isn't available yet - ghc-options: -frebindable-known-names + if impl(ghc >= 10.1) + -- Set -frebindable-known-names, + -- since GHC.Essentials isn't available yet + ghc-options: -frebindable-known-names exposed-modules: Control.Applicative @@ -307,9 +308,11 @@ Library other-modules: Data.List.NubOrdSet - GHC.Essentials System.CPUTime.Unsupported System.CPUTime.Utils + if impl(ghc >= 10.1) + other-modules: + GHC.Essentials if os(windows) other-modules: System.CPUTime.Windows ===================================== libraries/base/src/GHC/Stack.hs ===================================== @@ -1,5 +1,9 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImplicitParams #-} + -- | -- -- Module : GHC.Stack @@ -51,3 +55,26 @@ module GHC.Stack ) where import GHC.Internal.Stack + +#if __GLASGOW_HASKELL__ > 1000 + +import GHC.Essentials as Rebindable + +#endif + +-- | Explicitly bring the empty call stack into scope. +-- +-- Mostly useful for silencing warnings generated by @-Wdefaulted-callstack@ in +-- places such as: +-- +-- - The body of a class method in an instance of an externally defined type +-- class whose type signature doesn't contain a 'HasCallStack' constraint. +-- +-- - The body of the @main@ function. +-- +-- @since 4.24.0.0 +withEmptyCallStack :: (HasCallStack => a) -> a +withEmptyCallStack do_this = + -- See Note [Warn about defaulted CallStacks] + let ?callStack = emptyCallStack + in do_this ===================================== libraries/ghc-internal/src/GHC/Internal/Stack.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Internal.Stack ( -- * HasCallStack call stacks CallStack, HasCallStack, callStack, emptyCallStack, freezeCallStack, fromCallSiteList, getCallStack, popCallStack, - pushCallStack, withFrozenCallStack, withEmptyCallStack, + pushCallStack, withFrozenCallStack, prettyCallStackLines, prettyCallStack, -- * Source locations @@ -105,23 +105,6 @@ withFrozenCallStack do_this = let ?callStack = freezeCallStack (popCallStack callStack) in do_this --- | Explicitly bring the empty call stack into scope. --- --- Mostly useful for silencing warnings generated by @-Wdefaulted-callstack@ in --- places such as: --- --- - The body of a class method in an instance of an externally defined type --- class whose type signature doesn't contain a 'HasCallStack' constraint. --- --- - The body of the @main@ function. --- --- @since 4.24.0.0 -withEmptyCallStack :: (HasCallStack => a) -> a -withEmptyCallStack do_this = - -- See Note [Warn about defaulted CallStacks] - let ?callStack = emptyCallStack - in do_this - -- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot -- files. See Note [Definition of CallStack] ===================================== 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/3fb46764503ae051f152940410a0d1c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3fb46764503ae051f152940410a0d1c... 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