GitLab

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

 +#!/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

 +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

  {-# 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

 +{-# 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

 +{-# 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

+300

testsuite/tests/bytecode/T27633/T27633b.hs

 +{-# 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

+300

testsuite/tests/bytecode/T27633/all.T

 +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

 +{-# 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

 +: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

 +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

 +{-# 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

 +{-# 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

+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