- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-2
by Alan Zimmerman (＠alanz) 27 Jun '26

27 Jun '26

Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-2 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-2 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27448] NCG: reduce allocation in loopInfo.mkDomMap (#27448)
by Simon Jakobi (＠sjakobi2) 27 Jun '26

27 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27448 at Glasgow Haskell Compiler / GHC Commits: 81866207 by Simon Jakobi at 2026-06-27T15:12:32+02:00 NCG: reduce allocation in loopInfo.mkDomMap (#27448) mkDomMap built an intermediate association list with (++)/concatMap before handing it to mapFromList. The recursive concatMap re-copied each node's list once for every ancestor, so deep dominator trees -- the shape that control-flow-heavy code produces -- made the work grow quadratically (#27448). With this patch the LabelMap is built directly instead, with one insert per dominator-tree node, so each node is handled once. The allocation reduction is checked by a new perf test, ManyBasicBlocks, a large Cmm procedure that stresses the NCG pipeline. -O1: 3,260,976,336 -> 2,378,768,080 bytes (-27.1%) -O2: 3,266,691,984 -> 2,384,484,040 bytes (-27.0%) The saving only appears at -O1 and above, where static control-flow prediction (Opt_CmmStaticPred) -- and hence loopInfo/mkDomMap -- runs. This also drops an accidental quirk of the old code: leaves of the dominator tree included themselves in their dominator set (other nodes did not), because the leaf case re-emitted an entry whose set already contained the node and mapFromList's last-wins let it override. The set is consumed only by isBackEdge, so the sole effect was that a self-loop edge was classified as a back edge iff its block happened to be a dominator-tree leaf. domMap now holds only each block's strict dominators (excluding the entry). Assisted-by: Claude Opus 4.8 - - - - - 3 changed files: - compiler/GHC/CmmToAsm/CFG.hs - testsuite/tests/perf/compiler/all.T - + testsuite/tests/perf/compiler/genManyBasicBlocks Changes: ===================================== compiler/GHC/CmmToAsm/CFG.hs ===================================== @@ -885,17 +885,11 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] mkDomMap :: Tree BlockId -> LabelMap LabelSet - mkDomMap root = mapFromList $ go setEmpty root + mkDomMap (Node _root children) = foldl' (go setEmpty) mapEmpty children where - go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)] - go parents (Node lbl []) - = [(lbl, parents)] - go parents (Node _ leaves) - = let nodes = map rootLabel leaves - entries = map (\x -> (x,parents)) nodes - in entries ++ concatMap - (\n -> go (setInsert (rootLabel n) parents) n) - leaves + go :: LabelSet -> LabelMap LabelSet -> Tree BlockId -> LabelMap LabelSet + go doms acc (Node lbl kids) + = foldl' (go (setInsert lbl doms)) (mapInsert lbl doms acc) kids -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -857,3 +857,17 @@ test ('T26989', multimod_compile, ['T26989', '-v0 -O']) +# A single Cmm procedure with thousands of basic blocks (diamonds plus periodic +# backedges), stressing the NCG's CFG construction, edge-weight estimation, +# register allocation and block layout. +test('ManyBasicBlocks', + [ only_ways(['optasm']), + unless(have_ncg(), skip), + cmm_src, + collect_compiler_stats('bytes allocated', 2), + pre_cmd('./genManyBasicBlocks'), + extra_files(['genManyBasicBlocks']), + ], + compile, + ['-O2 -v0']) + ===================================== testsuite/tests/perf/compiler/genManyBasicBlocks ===================================== @@ -0,0 +1,142 @@ +#!/usr/bin/env bash +set -euo pipefail + +# Generate a Cmm source file that is intentionally heavy on control flow. +# +# The benchmark shape is one large procedure containing: +# - many split/left/right/join diamonds +# - periodic backedges that make each chunk a natural loop +# +# It produces thousands of actual basic blocks in a single Cmm graph (rather +# than merely a very large source file), stressing the native code generator's +# CFG construction, edge-weight estimation, register allocation and block +# layout. +# +# Based on GitLab snippet #6044 +# +# Tuning knobs: +# STAGES Number of diamond stages to generate. Default: 2048 +# LOOP_PERIOD Number of stages per loop chunk. Default: 16 +# LOOP_TRIPS Runtime trip count for each chunk. Default: 2 +# OUT Output file. Default: ManyBasicBlocks.cmm + +: "${STAGES:=2048}" +: "${LOOP_PERIOD:=16}" +: "${LOOP_TRIPS:=2}" +: "${OUT:=ManyBasicBlocks.cmm}" + +die() { + printf '%s\n' "$*" >&2 + exit 1 +} + +check_nat() { + local value=$1 + local name=$2 + + [[ $value =~ ^[0-9]+$ ]] || die "$name must be a non-negative integer" +} + +check_nat "$STAGES" STAGES +check_nat "$LOOP_PERIOD" LOOP_PERIOD +check_nat "$LOOP_TRIPS" LOOP_TRIPS + +(( STAGES > 0 )) || die "STAGES must be greater than zero" +(( LOOP_PERIOD > 0 )) || die "LOOP_PERIOD must be greater than zero" +(( LOOP_TRIPS > 0 )) || die "LOOP_TRIPS must be greater than zero" + +chunk_count=$(( (STAGES + LOOP_PERIOD - 1) / LOOP_PERIOD )) +block_count=$(( 1 + 4 * STAGES + chunk_count )) + +emit() { + printf '%s\n' "$*" +} + +{ + emit "// Generated by genManyBasicBlocks" + emit "//" + emit "// Parameters:" + emit "// STAGES=${STAGES}" + emit "// LOOP_PERIOD=${LOOP_PERIOD}" + emit "// LOOP_TRIPS=${LOOP_TRIPS}" + emit "//" + emit "// Approximate block count: ${block_count}" + emit "#include \"Cmm.h\"" + emit + emit "many_basic_blocks (W_ seed) {" + emit " W_ acc;" + emit " W_ mix;" + for ((chunk = 0; chunk < chunk_count; chunk++)); do + emit " W_ trip${chunk};" + done + emit + emit "entry:" + emit " acc = seed;" + emit " mix = seed + (17 :: W_);" + for ((chunk = 0; chunk < chunk_count; chunk++)); do + emit " trip${chunk} = 0;" + done + emit " goto split0;" + emit + + for ((stage = 0; stage < STAGES; stage++)); do + next_stage=$(( stage + 1 )) + chunk=$(( stage / LOOP_PERIOD )) + stage1=$(( 4 * stage + 1 )) + stage2=$(( 4 * stage + 2 )) + stage3=$(( 4 * stage + 3 )) + stage4=$(( 4 * stage + 4 )) + + emit "split${stage}:" + emit " mix = mix + (${stage1} :: W_);" + emit " if (((mix + (${stage2} :: W_)) % (7 :: W_)) < (3 :: W_)) {" + emit " goto left${stage};" + emit " }" + emit " goto right${stage};" + emit + + emit "left${stage}:" + emit " acc = acc + (${stage3} :: W_);" + emit " mix = mix + (${stage4} :: W_);" + emit " goto join${stage};" + emit + + emit "right${stage}:" + emit " acc = acc + (${stage4} :: W_);" + emit " mix = mix + (${stage3} :: W_);" + emit " goto join${stage};" + emit + + emit "join${stage}:" + emit " acc = acc + mix + (${stage1} :: W_);" + if (( next_stage == STAGES || next_stage % LOOP_PERIOD == 0 )); then + emit " goto latch${chunk};" + else + emit " goto split${next_stage};" + fi + emit + done + + for ((chunk = 0; chunk < chunk_count; chunk++)); do + loop_start=$(( chunk * LOOP_PERIOD )) + next_stage=$(( (chunk + 1) * LOOP_PERIOD )) + latch_mix=$(( 1000000 + chunk )) + latch_acc=$(( 2000000 + chunk )) + + emit "latch${chunk}:" + emit " trip${chunk} = trip${chunk} + (1 :: W_);" + emit " mix = mix + (${latch_mix} :: W_);" + emit " acc = acc + (${latch_acc} :: W_);" + emit " if (trip${chunk} < (${LOOP_TRIPS} :: W_)) {" + emit " goto split${loop_start};" + emit " }" + if (( next_stage < STAGES )); then + emit " goto split${next_stage};" + else + emit " return (acc);" + fi + emit + done + + emit "}" +} > "$OUT" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81866207d70bb1baca184746436f3c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81866207d70bb1baca184746436f3c8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27448] NCG: reduce allocation in loopInfo.mkDomMap (#27448)
by Simon Jakobi (＠sjakobi2) 27 Jun '26

27 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27448 at Glasgow Haskell Compiler / GHC Commits: cb938ec5 by Simon Jakobi at 2026-06-27T12:29:37+02:00 NCG: reduce allocation in loopInfo.mkDomMap (#27448) mkDomMap built an intermediate association list with (++)/concatMap before handing it to mapFromList; in control-flow-heavy code the (++) accounted for a large share of compiler allocation (#27448). This commit builds the LabelMap directly with one insert per dominator-tree node. Add a perf test, ManyBasicBlocks: it compiles a generated Cmm procedure with thousands of basic blocks (~8300 at STAGES=2048, LOOP_PERIOD=16) formed from split/join diamonds and periodic backedges, to track NCG allocation. It compiles with -O2, exercising the full NCG pipeline. The change in loopInfo.mkDomMap cuts total compiler heap allocation for this test by ~27%: -O1: 3,260,976,336 -> 2,378,768,080 bytes (-27.1%) -O2: 3,266,691,984 -> 2,384,484,040 bytes (-27.0%) The saving only appears at -O1 and above, where static control-flow prediction (Opt_CmmStaticPred) -- and hence loopInfo/mkDomMap -- runs. This also drops an accidental quirk of the old code: leaves of the dominator tree included themselves in their dominator set (other nodes did not), because the leaf case re-emitted an entry whose set already contained the node and mapFromList's last-wins let it override. The set is consumed only by isBackEdge, so the sole effect was that a self-loop edge was classified as a back edge iff its block happened to be a dominator-tree leaf. domMap now holds only each block's strict dominators (excluding the entry). Assisted-by: Claude Opus 4.8 - - - - - 3 changed files: - compiler/GHC/CmmToAsm/CFG.hs - testsuite/tests/perf/compiler/all.T - + testsuite/tests/perf/compiler/genManyBasicBlocks Changes: ===================================== compiler/GHC/CmmToAsm/CFG.hs ===================================== @@ -885,17 +885,11 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] mkDomMap :: Tree BlockId -> LabelMap LabelSet - mkDomMap root = mapFromList $ go setEmpty root + mkDomMap (Node _root children) = foldl' (go setEmpty) mapEmpty children where - go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)] - go parents (Node lbl []) - = [(lbl, parents)] - go parents (Node _ leaves) - = let nodes = map rootLabel leaves - entries = map (\x -> (x,parents)) nodes - in entries ++ concatMap - (\n -> go (setInsert (rootLabel n) parents) n) - leaves + go :: LabelSet -> LabelMap LabelSet -> Tree BlockId -> LabelMap LabelSet + go doms acc (Node lbl kids) + = foldl' (go (setInsert lbl doms)) (mapInsert lbl doms acc) kids -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -857,3 +857,18 @@ test ('T26989', multimod_compile, ['T26989', '-v0 -O']) +# A single Cmm procedure with thousands of basic blocks (diamonds plus periodic +# backedges), stressing the native code generator's CFG construction, edge-weight +# estimation, register allocation and block layout. Works with all NCG backends +# (X86, AArch64, WASM, etc.). See #27448. +test('ManyBasicBlocks', + [ only_ways(['optasm']), + unless(have_ncg(), skip), + cmm_src, + collect_compiler_stats('bytes allocated', 2), + pre_cmd('./genManyBasicBlocks'), + extra_files(['genManyBasicBlocks']), + ], + compile, + ['-O2 -v0']) + ===================================== testsuite/tests/perf/compiler/genManyBasicBlocks ===================================== @@ -0,0 +1,142 @@ +#!/usr/bin/env bash +set -euo pipefail + +# Generate a Cmm source file that is intentionally heavy on control flow. +# +# The benchmark shape is one large procedure containing: +# - many split/left/right/join diamonds +# - periodic backedges that make each chunk a natural loop +# +# It produces thousands of actual basic blocks in a single Cmm graph (rather +# than merely a very large source file), stressing the native code generator's +# CFG construction, edge-weight estimation, register allocation and block +# layout. +# +# Based on GitLab snippet #6044 +# +# Tuning knobs: +# STAGES Number of diamond stages to generate. Default: 2048 +# LOOP_PERIOD Number of stages per loop chunk. Default: 16 +# LOOP_TRIPS Runtime trip count for each chunk. Default: 2 +# OUT Output file. Default: ManyBasicBlocks.cmm + +: "${STAGES:=2048}" +: "${LOOP_PERIOD:=16}" +: "${LOOP_TRIPS:=2}" +: "${OUT:=ManyBasicBlocks.cmm}" + +die() { + printf '%s\n' "$*" >&2 + exit 1 +} + +check_nat() { + local value=$1 + local name=$2 + + [[ $value =~ ^[0-9]+$ ]] || die "$name must be a non-negative integer" +} + +check_nat "$STAGES" STAGES +check_nat "$LOOP_PERIOD" LOOP_PERIOD +check_nat "$LOOP_TRIPS" LOOP_TRIPS + +(( STAGES > 0 )) || die "STAGES must be greater than zero" +(( LOOP_PERIOD > 0 )) || die "LOOP_PERIOD must be greater than zero" +(( LOOP_TRIPS > 0 )) || die "LOOP_TRIPS must be greater than zero" + +chunk_count=$(( (STAGES + LOOP_PERIOD - 1) / LOOP_PERIOD )) +block_count=$(( 1 + 4 * STAGES + chunk_count )) + +emit() { + printf '%s\n' "$*" +} + +{ + emit "// Generated by genManyBasicBlocks" + emit "//" + emit "// Parameters:" + emit "// STAGES=${STAGES}" + emit "// LOOP_PERIOD=${LOOP_PERIOD}" + emit "// LOOP_TRIPS=${LOOP_TRIPS}" + emit "//" + emit "// Approximate block count: ${block_count}" + emit "#include \"Cmm.h\"" + emit + emit "many_basic_blocks (W_ seed) {" + emit " W_ acc;" + emit " W_ mix;" + for ((chunk = 0; chunk < chunk_count; chunk++)); do + emit " W_ trip${chunk};" + done + emit + emit "entry:" + emit " acc = seed;" + emit " mix = seed + (17 :: W_);" + for ((chunk = 0; chunk < chunk_count; chunk++)); do + emit " trip${chunk} = 0;" + done + emit " goto split0;" + emit + + for ((stage = 0; stage < STAGES; stage++)); do + next_stage=$(( stage + 1 )) + chunk=$(( stage / LOOP_PERIOD )) + stage1=$(( 4 * stage + 1 )) + stage2=$(( 4 * stage + 2 )) + stage3=$(( 4 * stage + 3 )) + stage4=$(( 4 * stage + 4 )) + + emit "split${stage}:" + emit " mix = mix + (${stage1} :: W_);" + emit " if (((mix + (${stage2} :: W_)) % (7 :: W_)) < (3 :: W_)) {" + emit " goto left${stage};" + emit " }" + emit " goto right${stage};" + emit + + emit "left${stage}:" + emit " acc = acc + (${stage3} :: W_);" + emit " mix = mix + (${stage4} :: W_);" + emit " goto join${stage};" + emit + + emit "right${stage}:" + emit " acc = acc + (${stage4} :: W_);" + emit " mix = mix + (${stage3} :: W_);" + emit " goto join${stage};" + emit + + emit "join${stage}:" + emit " acc = acc + mix + (${stage1} :: W_);" + if (( next_stage == STAGES || next_stage % LOOP_PERIOD == 0 )); then + emit " goto latch${chunk};" + else + emit " goto split${next_stage};" + fi + emit + done + + for ((chunk = 0; chunk < chunk_count; chunk++)); do + loop_start=$(( chunk * LOOP_PERIOD )) + next_stage=$(( (chunk + 1) * LOOP_PERIOD )) + latch_mix=$(( 1000000 + chunk )) + latch_acc=$(( 2000000 + chunk )) + + emit "latch${chunk}:" + emit " trip${chunk} = trip${chunk} + (1 :: W_);" + emit " mix = mix + (${latch_mix} :: W_);" + emit " acc = acc + (${latch_acc} :: W_);" + emit " if (trip${chunk} < (${LOOP_TRIPS} :: W_)) {" + emit " goto split${loop_start};" + emit " }" + if (( next_stage < STAGES )); then + emit " goto split${next_stage};" + else + emit " return (acc);" + fi + emit + done + + emit "}" +} > "$OUT" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb938ec5e728f9bf4e64f994d26cffe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb938ec5e728f9bf4e64f994d26cffe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sg/first-class-strict] 7 commits: Strict: add the wired-in unlifted box type
by Sebastian Graf (＠sgraf812) 27 Jun '26

27 Jun '26

Sebastian Graf pushed to branch wip/sg/first-class-strict at Glasgow Haskell Compiler / GHC Commits: 8fadf2e0 by I-Al-Istannen at 2026-06-27T12:09:51+02:00 Strict: add the wired-in unlifted box type Adds the wired-in type Strict :: Type -> UnliftedType with its single strict constructor MkStrict, an evaluated-and-properly-tagged box for strict fields, and the isStrictTy predicate. See Note [The Strict type]. Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com> - - - - - 1f961f09 by I-Al-Istannen at 2026-06-27T12:09:52+02:00 Strict: make demand analysis and CPR transparent to the box Demand and CPR analysis look through Strict/MkStrict so that a product demand on Strict a is passed to the wrapped field and CPR information flows likewise, and exprIsTrivial / unfolding sizing treat MkStrict on a value as trivial. Accepts the resulting signature churn in the test suite. Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com> - - - - - 8a89b9ef by I-Al-Istannen at 2026-06-27T12:09:52+02:00 Strict: unbox strict arguments through the box in worker/wrapper Worker/wrapper marks each strictified worker argument with Strict, so the wrapper passes an evaluated value and the worker need not re-force it, and unboxes the wrapped type when profitable. Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com> - - - - - 0eaa66ed by I-Al-Istannen at 2026-06-27T12:09:52+02:00 Desugar: only reconstruct constructor fields used by the body Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com> - - - - - 4165000f by I-Al-Istannen at 2026-06-27T12:09:52+02:00 CorePrep: erase MkStrict via a representational cast MkStrict is erased in CorePrep: a producer becomes the field cast to Strict a with a heterogeneous representational coercion, forcing the field first when it is not already a value; a consumer match becomes the scrutinee cast back. Core Lint tolerates the resulting out-of-scope type variables and the Strict coercion. See Note [The Strict type]. Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com> - - - - - 7d62101e by I-Al-Istannen at 2026-06-27T12:09:52+02:00 Strict: STG representation and code generation Treats Strict a as a single unlifted heap pointer through RepType, unarisation, STG lint, tag inference and StgToCmm: an unlifted box is already evaluated and properly tagged, so it is returned directly unless applied as a function. An STG Lint check flags an evaluated binder lowered to an updatable indirection. Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com> - - - - - 335c17b6 by Sebastian Graf at 2026-06-27T12:09:52+02:00 Strict: add a should_run test for the strict-field machinery StrictBox exercises a strict value field built from a thunk (forced to an evaluated, properly-tagged value), a strict field of function type that is applied, worker/wrapper unboxing of a strict argument, and a strict field holding another boxed value. Run with -dtag-inference-checks so that a strict field that is not properly tagged aborts at runtime. - - - - - 64 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Config/Core/Lint/Interactive.hs - compiler/GHC/Driver/Config/CoreToStg/Prep.hs - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/TagCheck.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/codeGen/should_compile/T25166.stdout-ws-64 - + testsuite/tests/codeGen/should_run/StrictBox.hs - + testsuite/tests/codeGen/should_run/StrictBox.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/cpranal/should_compile/T18109.stderr - testsuite/tests/cpranal/should_compile/T18174.stderr - testsuite/tests/dmdanal/should_compile/T10482.stderr - testsuite/tests/dmdanal/should_compile/T10482a.stderr - testsuite/tests/dmdanal/sigs/T16197b.stderr - testsuite/tests/dmdanal/sigs/T16859.stderr - testsuite/tests/dmdanal/sigs/T17932.stderr - testsuite/tests/dmdanal/sigs/T22241.stderr - testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout - testsuite/tests/ghci.debugger/scripts/print007.stdout - testsuite/tests/ghci.debugger/scripts/print022.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout - + testsuite/tests/perf/should_run/StrictBuilderFusion.hs - + testsuite/tests/perf/should_run/StrictBuilderFusion.stdout - testsuite/tests/perf/should_run/all.T - testsuite/tests/profiling/should_compile/prof-late-cc3.stderr - testsuite/tests/simplCore/should_compile/T18013.stderr - testsuite/tests/simplCore/should_compile/T22309.stderr - testsuite/tests/simplCore/should_compile/T24359a.stderr - testsuite/tests/simplCore/should_compile/T26615.stderr - testsuite/tests/simplCore/should_compile/T4081.stderr - testsuite/tests/simplStg/should_compile/T15226b.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f47fb1b36c37cfe259548779371219… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f47fb1b36c37cfe259548779371219… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27448] 3 commits: Reg.Linear: drop Platform argument from most FR (FreeRegs) methods
by Simon Jakobi (＠sjakobi2) 27 Jun '26

27 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27448 at Glasgow Haskell Compiler / GHC Commits: 6813f002 by Simon Jakobi at 2026-06-26T04:51:47-04:00 Reg.Linear: drop Platform argument from most FR (FreeRegs) methods The FR class has one instance per CPU architecture, so any architecture-constant information its methods derived from the Platform argument can instead be baked into the instance. This removes the now needless Platform argument from frAllocateReg, frGetFreeRegs and frReleaseReg. frInitFreeRegs keeps its Platform argument: the initial allocatable set is genuinely platform-dependent, see Note [Aarch64 Register x18 at Darwin and Windows]. Fixes #26665 Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 3b2a9409 by Zubin Duggal at 2026-06-26T04:52:39-04:00 testsuite: Report fragile failures as skipped in JUnit output - - - - - 980b9f36 by Simon Jakobi at 2026-06-27T11:53:13+02:00 NCG: reduce allocation in loopInfo.mkDomMap (#27448) mkDomMap built an intermediate association list with (++)/concatMap before handing it to mapFromList; in control-flow-heavy code the (++) accounted for a large share of compiler allocation (#27448). Build the LabelMap directly with one insert per dominator-tree node instead. Add a perf test, ManyBasicBlocks: it compiles a generated Cmm procedure with thousands of basic blocks (~8300 at STAGES=2048, LOOP_PERIOD=16) formed from split/join diamonds and periodic backedges, to track native code generator allocation. Compiling it cuts total compiler heap allocation by ~882 MB: -O1: 3,260,976,336 -> 2,378,768,080 bytes (-27.1%) -O2: 3,266,691,984 -> 2,384,484,040 bytes (-27.0%) The saving only appears at -O1 and above, where static control-flow prediction (Opt_CmmStaticPred) -- and hence loopInfo/mkDomMap -- runs. This also drops an accidental quirk of the old code: leaves of the dominator tree included themselves in their dominator set (other nodes did not), because the leaf case re-emitted an entry whose set already contained the node and mapFromList's last-wins let it override. The set is consumed only by isBackEdge, so the sole effect was that a self-loop edge was classified as a back edge iff its block happened to be a dominator-tree leaf -- inconsistent and unintended. domMap now holds each block's strict dominators (excluding the entry) uniformly. Assisted-by: Claude Opus 4.8 - - - - - 11 changed files: - compiler/GHC/CmmToAsm/CFG.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs - compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs - compiler/GHC/CmmToAsm/Reg/Linear/X86.hs - compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs - compiler/GHC/CmmToAsm/X86/RegInfo.hs - compiler/GHC/CmmToAsm/X86/Regs.hs - testsuite/driver/junit.py - testsuite/tests/perf/compiler/all.T - + testsuite/tests/perf/compiler/genManyBasicBlocks Changes: ===================================== compiler/GHC/CmmToAsm/CFG.hs ===================================== @@ -885,17 +885,15 @@ loopInfo cfg root = LoopInfo { liBackEdges = backEdges in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] mkDomMap :: Tree BlockId -> LabelMap LabelSet - mkDomMap root = mapFromList $ go setEmpty root + -- The entry/root dominates every block and is deliberately excluded, so its + -- children start from the empty dominator set. + mkDomMap (Node _root children) = foldl' (go setEmpty) mapEmpty children where - go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)] - go parents (Node lbl []) - = [(lbl, parents)] - go parents (Node _ leaves) - = let nodes = map rootLabel leaves - entries = map (\x -> (x,parents)) nodes - in entries ++ concatMap - (\n -> go (setInsert (rootLabel n) parents) n) - leaves + -- `doms`: the dominators of `lbl`, i.e. its ancestors in the dominator + -- tree excluding the tree root. + go :: LabelSet -> LabelMap LabelSet -> Tree BlockId -> LabelMap LabelSet + go doms acc (Node lbl kids) + = foldl' (go (setInsert lbl doms)) (mapInsert lbl doms acc) kids -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) ===================================== compiler/GHC/CmmToAsm/Reg/Linear.hs ===================================== @@ -367,7 +367,7 @@ initBlock id block_live Nothing -> setFreeRegsR (frInitFreeRegs platform) Just live -> - setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) + setFreeRegsR $ foldl' (flip frAllocateReg) (frInitFreeRegs platform) (nonDetEltsUniqSet $ takeRealRegs $ getRegs live) -- See Note [Unique Determinism and code generation] setAssigR emptyRegMap @@ -638,20 +638,19 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do - platform <- getPlatform assig <- getAssigR free <- getFreeRegsR let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs loop assig !free (r:rs) = case lookupUFM assig r of Just (Loc (InBoth real _) _) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs + (frReleaseReg real free) rs Just (Loc (InReg real) _) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs + (frReleaseReg real free) rs _ -> loop (delFromUFM assig r) free rs loop assig free regs @@ -716,7 +715,7 @@ saveClobberedTemps clobbered dying freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg - freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs + freeRegs_thisClass = frGetFreeRegs regclass freeRegs case filter (`notElem` clobbered) freeRegs_thisClass of @@ -724,7 +723,7 @@ saveClobberedTemps clobbered dying -- clobbered by this instruction; use it to save the -- clobbered value. (my_reg : _) -> do - setFreeRegsR (frAllocateReg platform my_reg freeRegs) + setFreeRegsR (frAllocateReg my_reg freeRegs) let new_assign = addToUFM_Directly assig temp (Loc (InReg my_reg) fmt) let instr = mkRegRegMoveInstr config fmt @@ -763,13 +762,13 @@ clobberRegs clobbered Unified -> Unified.allRegClasses Separate -> Separate.allRegClasses NoVectors -> NoVectors.allRegClasses - allFreeRegs = foldMap (\ rc -> frGetFreeRegs platform rc freeregs) allRegClasses + allFreeRegs = foldMap (\ rc -> frGetFreeRegs rc freeregs) allRegClasses let extra_clobbered = [ r | r <- clobbered, r `elem` allFreeRegs ] - setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered + setFreeRegsR $! foldl' (flip frAllocateReg) freeregs extra_clobbered - -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered + -- setFreeRegsR $! foldl' (flip frAllocateReg) freeregs clobbered assig <- getAssigR setAssigR $! clobber assig (nonDetUFMToList assig) @@ -896,7 +895,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr vrF = do platform <- getPlatform freeRegs <- getFreeRegsR let regclass = classOfVirtualReg (platformArch platform) vr - freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs :: [RealReg] + freeRegs_thisClass = frGetFreeRegs regclass freeRegs :: [RealReg] -- Can we put the variable into a register it already was? pref_reg <- findPrefRealReg vr @@ -915,7 +914,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr vrF setAssigR $ toRegMap $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg vrFmt) - setFreeRegsR $ frAllocateReg platform final_reg freeRegs + setFreeRegsR $ frAllocateReg final_reg freeRegs allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs ===================================== compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs ===================================== @@ -43,49 +43,51 @@ import qualified GHC.CmmToAsm.RV64.Instr as RV64.Instr import qualified GHC.CmmToAsm.LA64.Instr as LA64.Instr class Show freeRegs => FR freeRegs where - frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs - frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] + frAllocateReg :: RealReg -> freeRegs -> freeRegs + frGetFreeRegs :: RegClass -> freeRegs -> [RealReg] + -- | The initial allocatable set is platform-dependent. See Note + -- [Aarch64 Register x18 at Darwin and Windows]. frInitFreeRegs :: Platform -> freeRegs - frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs + frReleaseReg :: RealReg -> freeRegs -> freeRegs instance FR X86.FreeRegs where - frAllocateReg = \_ -> X86.allocateReg + frAllocateReg = X86.allocateReg frGetFreeRegs = X86.getFreeRegs frInitFreeRegs = X86.initFreeRegs - frReleaseReg = \_ -> X86.releaseReg + frReleaseReg = X86.releaseReg instance FR X86_64.FreeRegs where - frAllocateReg = \_ -> X86_64.allocateReg + frAllocateReg = X86_64.allocateReg frGetFreeRegs = X86_64.getFreeRegs frInitFreeRegs = X86_64.initFreeRegs - frReleaseReg = \_ -> X86_64.releaseReg + frReleaseReg = X86_64.releaseReg instance FR PPC.FreeRegs where - frAllocateReg = \_ -> PPC.allocateReg - frGetFreeRegs = \_ -> PPC.getFreeRegs + frAllocateReg = PPC.allocateReg + frGetFreeRegs = PPC.getFreeRegs frInitFreeRegs = PPC.initFreeRegs - frReleaseReg = \_ -> PPC.releaseReg + frReleaseReg = PPC.releaseReg instance FR AArch64.FreeRegs where - frAllocateReg = \_ -> AArch64.allocateReg - frGetFreeRegs = \_ -> AArch64.getFreeRegs + frAllocateReg = AArch64.allocateReg + frGetFreeRegs = AArch64.getFreeRegs frInitFreeRegs = AArch64.initFreeRegs - frReleaseReg = \_ -> AArch64.releaseReg + frReleaseReg = AArch64.releaseReg instance FR RV64.FreeRegs where - frAllocateReg = const RV64.allocateReg - frGetFreeRegs = const RV64.getFreeRegs + frAllocateReg = RV64.allocateReg + frGetFreeRegs = RV64.getFreeRegs frInitFreeRegs = RV64.initFreeRegs - frReleaseReg = const RV64.releaseReg + frReleaseReg = RV64.releaseReg instance FR LA64.FreeRegs where - frAllocateReg = \_ -> LA64.allocateReg - frGetFreeRegs = \_ -> LA64.getFreeRegs + frAllocateReg = LA64.allocateReg + frGetFreeRegs = LA64.getFreeRegs frInitFreeRegs = LA64.initFreeRegs - frReleaseReg = \_ -> LA64.releaseReg + frReleaseReg = LA64.releaseReg allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg] -allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses +allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs rcls fr) allRegClasses where allRegClasses = case registerArch (platformArch plat) of ===================================== compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs ===================================== @@ -15,7 +15,6 @@ import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr -import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types import GHC.Platform.Reg @@ -132,12 +131,9 @@ joinToTargets_first block_live new_blocks block_id instr dest dests block_assig src_assig to_free - = do config <- getConfig - let platform = ncgPlatform config - - -- free up the regs that are not live on entry to this block. + = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR - let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free + let freeregs' = foldl' (flip frReleaseReg) freeregs to_free -- remember the current assignment on entry to this block. setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig) ===================================== compiler/GHC/CmmToAsm/Reg/Linear/X86.hs ===================================== @@ -25,17 +25,17 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs f) = case cls of RcInteger -> [ RealRegSingle i - | i <- intregnos platform + | i <- intregnos PW4 , testBit f i ] RcFloatOrVector -> [ RealRegSingle i - | i <- xmmregnos platform + | i <- xmmregnos PW4 , testBit f i ] ===================================== compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs ===================================== @@ -25,17 +25,17 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs f) = case cls of RcInteger -> [ RealRegSingle i - | i <- intregnos platform + | i <- intregnos PW8 , testBit f i ] RcFloatOrVector -> [ RealRegSingle i - | i <- xmmregnos platform + | i <- xmmregnos PW8 , testBit f i ] ===================================== compiler/GHC/CmmToAsm/X86/RegInfo.hs ===================================== @@ -41,9 +41,11 @@ regColors platform = listToUFM (normalRegColors platform) normalRegColors :: Platform -> [(RealReg,String)] normalRegColors platform = - zip (map realRegSingle [0..lastint platform]) colors - ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys + zip (map realRegSingle [0..lastint wordSize]) colors + ++ zip (map realRegSingle [firstxmm..lastxmm wordSize]) greys where + wordSize = platformWordSize platform + -- 16 colors - enough for amd64 gp regs colors = ["#800000","#ff0000","#808000","#ffff00","#008000" ,"#00ff00","#008080","#00ffff","#000080","#0000ff" ===================================== compiler/GHC/CmmToAsm/X86/Regs.hs ===================================== @@ -194,27 +194,23 @@ spRel platform n firstxmm :: RegNo firstxmm = 16 --- on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available -lastxmm :: Platform -> RegNo -lastxmm platform - | target32Bit platform = firstxmm + 7 -- xmm0 - xmmm7 - | otherwise = firstxmm + 15 -- xmm0 -xmm15 +-- on 32bit platforms, only the first 8 XMM/YMM/ZMM registers are available +lastxmm :: PlatformWordSize -> RegNo +lastxmm PW4 = firstxmm + 7 -- xmm0 - xmm7 +lastxmm PW8 = firstxmm + 15 -- xmm0 - xmm15 -lastint :: Platform -> RegNo -lastint platform - | target32Bit platform = 7 -- not %r8..%r15 - | otherwise = 15 +lastint :: PlatformWordSize -> RegNo +lastint PW4 = 7 -- not %r8..%r15 +lastint PW8 = 15 -intregnos :: Platform -> [RegNo] -intregnos platform = [0 .. lastint platform] +intregnos :: PlatformWordSize -> [RegNo] +intregnos wordSize = [0 .. lastint wordSize] - - -xmmregnos :: Platform -> [RegNo] -xmmregnos platform = [firstxmm .. lastxmm platform] +xmmregnos :: PlatformWordSize -> [RegNo] +xmmregnos wordSize = [firstxmm .. lastxmm wordSize] floatregnos :: Platform -> [RegNo] -floatregnos platform = xmmregnos platform +floatregnos platform = xmmregnos (platformWordSize platform) -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty. @@ -224,7 +220,7 @@ argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" -- | The complete set of machine registers. allMachRegNos :: Platform -> [RegNo] -allMachRegNos platform = intregnos platform ++ floatregnos platform +allMachRegNos platform = intregnos (platformWordSize platform) ++ floatregnos platform -- | Take the class of a register. {-# INLINE classOfRealReg #-} @@ -236,9 +232,11 @@ classOfRealReg :: Platform -> RealReg -> RegClass classOfRealReg platform reg = case reg of RealRegSingle i - | i <= lastint platform -> RcInteger - | i <= lastxmm platform -> RcFloatOrVector + | i <= lastint wordSize -> RcInteger + | i <= lastxmm wordSize -> RcFloatOrVector | otherwise -> panic "X86.Reg.classOfRealReg registerSingle too high" + where + wordSize = platformWordSize platform -- machine specific ------------------------------------------------------------ ===================================== testsuite/driver/junit.py ===================================== @@ -14,12 +14,13 @@ def junit(t: TestRun) -> ET.ElementTree: + len(t.unexpected_stat_failures) + len(t.unexpected_passes)), errors = str(len(t.framework_failures)), + skipped = str(len(t.fragile_failures)), timestamp = datetime.now().isoformat()) - for res_type, group in [('stat failure', t.unexpected_stat_failures), - ('unexpected failure', t.unexpected_failures), - ('unexpected pass', t.unexpected_passes), - ('fragile failure', t.fragile_failures)]: + for kind, res_type, group in [('failure', 'stat failure', t.unexpected_stat_failures), + ('failure', 'unexpected failure', t.unexpected_failures), + ('failure', 'unexpected pass', t.unexpected_passes), + ('skipped', 'fragile failure', t.fragile_failures)]: for tr in group: testcase = ET.SubElement(testsuite, 'testcase', classname = tr.way, @@ -30,7 +31,7 @@ def junit(t: TestRun) -> ET.ElementTree: if tr.stderr: message += ['', 'stderr:', '==========', tr.stderr] - result = ET.SubElement(testcase, 'failure', + result = ET.SubElement(testcase, kind, type = res_type, message = tr.reason) result.text = '\n'.join(message) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -857,3 +857,18 @@ test ('T26989', multimod_compile, ['T26989', '-v0 -O']) +# A single Cmm procedure with thousands of basic blocks (diamonds plus periodic +# backedges), stressing the native code generator's CFG construction, edge-weight +# estimation, register allocation and block layout. Works with all NCG backends +# (X86, AArch64, WASM, etc.). See #27448. +test('ManyBasicBlocks', + [ only_ways(['optasm']), + unless(have_ncg(), skip), + cmm_src, + collect_compiler_stats('bytes allocated', 2), + pre_cmd('./genManyBasicBlocks'), + extra_files(['genManyBasicBlocks']), + ], + compile, + ['-O -v0']) + ===================================== testsuite/tests/perf/compiler/genManyBasicBlocks ===================================== @@ -0,0 +1,142 @@ +#!/usr/bin/env bash +set -euo pipefail + +# Generate a Cmm source file that is intentionally heavy on control flow. +# +# The benchmark shape is one large procedure containing: +# - many split/left/right/join diamonds +# - periodic backedges that make each chunk a natural loop +# +# It produces thousands of actual basic blocks in a single Cmm graph (rather +# than merely a very large source file), stressing the native code generator's +# CFG construction, edge-weight estimation, register allocation and block +# layout. +# +# Based on GitLab snippet #6044 +# +# Tuning knobs: +# STAGES Number of diamond stages to generate. Default: 2048 +# LOOP_PERIOD Number of stages per loop chunk. Default: 16 +# LOOP_TRIPS Runtime trip count for each chunk. Default: 2 +# OUT Output file. Default: ManyBasicBlocks.cmm + +: "${STAGES:=2048}" +: "${LOOP_PERIOD:=16}" +: "${LOOP_TRIPS:=2}" +: "${OUT:=ManyBasicBlocks.cmm}" + +die() { + printf '%s\n' "$*" >&2 + exit 1 +} + +check_nat() { + local value=$1 + local name=$2 + + [[ $value =~ ^[0-9]+$ ]] || die "$name must be a non-negative integer" +} + +check_nat "$STAGES" STAGES +check_nat "$LOOP_PERIOD" LOOP_PERIOD +check_nat "$LOOP_TRIPS" LOOP_TRIPS + +(( STAGES > 0 )) || die "STAGES must be greater than zero" +(( LOOP_PERIOD > 0 )) || die "LOOP_PERIOD must be greater than zero" +(( LOOP_TRIPS > 0 )) || die "LOOP_TRIPS must be greater than zero" + +chunk_count=$(( (STAGES + LOOP_PERIOD - 1) / LOOP_PERIOD )) +block_count=$(( 1 + 4 * STAGES + chunk_count )) + +emit() { + printf '%s\n' "$*" +} + +{ + emit "// Generated by genManyBasicBlocks" + emit "//" + emit "// Parameters:" + emit "// STAGES=${STAGES}" + emit "// LOOP_PERIOD=${LOOP_PERIOD}" + emit "// LOOP_TRIPS=${LOOP_TRIPS}" + emit "//" + emit "// Approximate block count: ${block_count}" + emit "#include \"Cmm.h\"" + emit + emit "many_basic_blocks (W_ seed) {" + emit " W_ acc;" + emit " W_ mix;" + for ((chunk = 0; chunk < chunk_count; chunk++)); do + emit " W_ trip${chunk};" + done + emit + emit "entry:" + emit " acc = seed;" + emit " mix = seed + (17 :: W_);" + for ((chunk = 0; chunk < chunk_count; chunk++)); do + emit " trip${chunk} = 0;" + done + emit " goto split0;" + emit + + for ((stage = 0; stage < STAGES; stage++)); do + next_stage=$(( stage + 1 )) + chunk=$(( stage / LOOP_PERIOD )) + stage1=$(( 4 * stage + 1 )) + stage2=$(( 4 * stage + 2 )) + stage3=$(( 4 * stage + 3 )) + stage4=$(( 4 * stage + 4 )) + + emit "split${stage}:" + emit " mix = mix + (${stage1} :: W_);" + emit " if (((mix + (${stage2} :: W_)) % (7 :: W_)) < (3 :: W_)) {" + emit " goto left${stage};" + emit " }" + emit " goto right${stage};" + emit + + emit "left${stage}:" + emit " acc = acc + (${stage3} :: W_);" + emit " mix = mix + (${stage4} :: W_);" + emit " goto join${stage};" + emit + + emit "right${stage}:" + emit " acc = acc + (${stage4} :: W_);" + emit " mix = mix + (${stage3} :: W_);" + emit " goto join${stage};" + emit + + emit "join${stage}:" + emit " acc = acc + mix + (${stage1} :: W_);" + if (( next_stage == STAGES || next_stage % LOOP_PERIOD == 0 )); then + emit " goto latch${chunk};" + else + emit " goto split${next_stage};" + fi + emit + done + + for ((chunk = 0; chunk < chunk_count; chunk++)); do + loop_start=$(( chunk * LOOP_PERIOD )) + next_stage=$(( (chunk + 1) * LOOP_PERIOD )) + latch_mix=$(( 1000000 + chunk )) + latch_acc=$(( 2000000 + chunk )) + + emit "latch${chunk}:" + emit " trip${chunk} = trip${chunk} + (1 :: W_);" + emit " mix = mix + (${latch_mix} :: W_);" + emit " acc = acc + (${latch_acc} :: W_);" + emit " if (trip${chunk} < (${LOOP_TRIPS} :: W_)) {" + emit " goto split${loop_start};" + emit " }" + if (( next_stage < STAGES )); then + emit " goto split${next_stage};" + else + emit " return (acc);" + fi + emit + done + + emit "}" +} > "$OUT" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f80b0d6056d77eae0444fb4a7a526a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f80b0d6056d77eae0444fb4a7a526a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/sol/rename-mc-diagnostics
by Simon Hengel (＠sol) 27 Jun '26

27 Jun '26

Simon Hengel deleted branch wip/sol/rename-mc-diagnostics at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/sol/remove-ddump-json-flag
by Simon Hengel (＠sol) 27 Jun '26

27 Jun '26

Simon Hengel deleted branch wip/sol/remove-ddump-json-flag at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] 16 commits: Reg.Linear: drop Platform argument from most FR (FreeRegs) methods
by Simon Hengel (＠sol) 27 Jun '26

27 Jun '26

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 6813f002 by Simon Jakobi at 2026-06-26T04:51:47-04:00 Reg.Linear: drop Platform argument from most FR (FreeRegs) methods The FR class has one instance per CPU architecture, so any architecture-constant information its methods derived from the Platform argument can instead be baked into the instance. This removes the now needless Platform argument from frAllocateReg, frGetFreeRegs and frReleaseReg. frInitFreeRegs keeps its Platform argument: the initial allocatable set is genuinely platform-dependent, see Note [Aarch64 Register x18 at Darwin and Windows]. Fixes #26665 Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 3b2a9409 by Zubin Duggal at 2026-06-26T04:52:39-04:00 testsuite: Report fragile failures as skipped in JUnit output - - - - - 27463426 by Rodrigo Mesquita at 2026-06-26T20:54:58-04:00 perf: Share Module in Iface Symbol Table This commit modifies the structure of the serialized `SymbolTable Name` to then re-use and share the `Module` (both on disk and in memory) across all `Name`s from the same module. The new structure looks like: <total name count> $modules.size for (mod, names) in $modules: $mod $names.size for table_ix, occ in $names $table_ix $occ i.e. we put the module just once, followed by all names in that module. When deserializing, we deserialize the module just once, and all the following `Name`s are constructed with a pointer to that same decoded `Module`. In `hoogle-test`, we must use `DNameEnv` rather than `Map Name`, otherwise the output fixities order was susceptible to changes in the uniques assigned to each Names, which is not stable. Fixes #27401 ------------------------- Metric Decrease: InstanceMatching LinkableUsage01 LinkableUsage02 hard_hole_fits ------------------------- - - - - - 412f1675 by Simon Hengel at 2026-06-26T20:55:41-04:00 Rename `MCDiagnostic` to `InternalMCDiagnostic` `MCDiagnostic` is meant to be used for compiler diagnostics. Any code that creates `MCDiagnostic` directly, without going through `GHC.Driver.Errors.printMessage`, sidesteps `-fdiagnostics-as-json` (see e.g. !14616, !14475, !14492 !14548). To avoid this in the future, this change more narrowly controls who creates `MCDiagnostic` (see #24113). - - - - - 6f212121 by Facundo Domínguez at 2026-06-26T20:56:27-04:00 Encapsulate options of occurAnalysePgm in a record - - - - - adfbb179 by Facundo Domínguez at 2026-06-26T20:56:27-04:00 Allow to configure the occurrence analyser to retain some dead bindings This is needed by plugins that are the only consumers of a binding which is otherwise unused in the program. See Note [Controlling elimination of dead bindings in occurrence analysis] added in this commit, or https://gitlab.haskell.org/ghc/ghc/-/issues/27240 for more discussion. - - - - - c745b11f by Copilot at 2026-06-26T20:56:27-04:00 Address documentation feedback - - - - - 2c2a4a2a by Copilot at 2026-06-26T20:56:27-04:00 Keep the imp_rules parameter of occurPgmAnalysePgm and add occ_opts to OccEnv - - - - - e2262b0e by Copilot at 2026-06-26T20:56:27-04:00 Strengthen T27240.hs with a binding that should be removed - - - - - 5f9d9268 by Copilot at 2026-06-26T20:56:27-04:00 Move the reference #27240 to a related paragraph - - - - - d86d2644 by Simon Hengel at 2026-06-26T20:57:10-04:00 Remove deprecated flag `-ddump-json` (see #24113) This was first deprecated in 9.10.1. - - - - - e6470796 by Simon Hengel at 2026-06-27T13:59:35+07:00 Add SrcSpan to MCDiagnostic - - - - - b64a6d78 by Simon Hengel at 2026-06-27T13:59:39+07:00 Get rid of mkLocMessage - - - - - ac58180e by Simon Hengel at 2026-06-27T13:59:39+07:00 Add Message data type - - - - - 63f0d2bb by Simon Hengel at 2026-06-27T13:59:39+07:00 Get rid of MessageClass - - - - - 9f33490d by Simon Hengel at 2026-06-27T13:59:39+07:00 Remove JSON logging - - - - - 65 changed files: - + changelog.d/add_can_drop_to_occurence_analyser - + changelog.d/remove-ddump-json-flag - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs - compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs - compiler/GHC/CmmToAsm/Reg/Linear/X86.hs - compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs - compiler/GHC/CmmToAsm/X86/RegInfo.hs - compiler/GHC/CmmToAsm/X86/Regs.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - − compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/SourceError.hs - compiler/GHC/Unit/Module/Env.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - testsuite/driver/junit.py - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr - + testsuite/tests/ghc-api/T27240.hs - testsuite/tests/ghc-api/T7478/T7478.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout - testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs - testsuite/tests/rename/should_compile/T1792_imports.stdout - testsuite/tests/rename/should_compile/T18264.stdout - testsuite/tests/rename/should_compile/T4239.stdout - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/DocsInHiFileTH.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - utils/check-exact/Main.hs - utils/check-exact/Preprocess.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcf52d24aafa78a9ed9705d8310146… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcf52d24aafa78a9ed9705d8310146… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Remove deprecated flag `-ddump-json` (see #24113)
by Marge Bot (＠marge-bot) 27 Jun '26

27 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d86d2644 by Simon Hengel at 2026-06-26T20:57:10-04:00 Remove deprecated flag `-ddump-json` (see #24113) This was first deprecated in 9.10.1. - - - - - 13 changed files: - + changelog.d/remove-ddump-json-flag - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr Changes: ===================================== changelog.d/remove-ddump-json-flag ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Remove deprecated flag `-ddump-json` +issues: #24113 +mrs: !16258 ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -527,7 +527,6 @@ data DumpFlag | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug - | Opt_D_dump_json | Opt_D_ppr_debug | Opt_D_no_debug_output | Opt_D_dump_faststrings ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1694,9 +1694,6 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoBignumRules)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) - , make_dep_flag defGhcFlag "ddump-json" - (setDumpFlag Opt_D_dump_json) - "Use `-fdiagnostics-as-json` instead" , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -558,15 +558,6 @@ instance ToJson Severity where json SevWarning = JSString "Warning" json SevError = JSString "Error" -instance ToJson MessageClass where - json MCOutput = JSString "MCOutput" - json MCFatal = JSString "MCFatal" - json MCInteractive = JSString "MCInteractive" - json MCDump = JSString "MCDump" - json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason code) = - JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) - instance ToJson DiagnosticCode where json c = JSInt (fromIntegral (diagnosticCodeNumber c)) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -95,7 +95,6 @@ import GHC.Utils.Panic import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -360,7 +359,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger --- See Note [JSON Error Messages] defaultLogJsonAction :: LogJsonAction defaultLogJsonAction logflags msg_class jsdoc = case msg_class of @@ -377,33 +375,6 @@ defaultLogJsonAction logflags msg_class jsdoc = putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout msg = renderJSON jsdoc --- See Note [JSON Error Messages] --- this is to be removed -jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message -jsonLogActionWithHandle out logflags msg_class srcSpan msg - = - defaultLogActionHPutStrDoc logflags True out - (withPprStyle PprCode (doc $$ text "")) - where - str = renderWithContext (log_default_user_context logflags) msg - doc = renderJSON $ - JSObject [ ( "span", spanToDumpJSON srcSpan ) - , ( "doc" , JSString str ) - , ( "messageClass", json msg_class ) - ] - spanToDumpJSON :: SrcSpan -> JsonDoc - spanToDumpJSON s = case s of - (RealSrcSpan rss _) -> JSObject [ ("file", json file) - , ("startLine", json $ srcSpanStartLine rss) - , ("startCol", json $ srcSpanStartCol rss) - , ("endLine", json $ srcSpanEndLine rss) - , ("endCol", json $ srcSpanEndCol rss) - ] - where file = unpackFS $ srcSpanFile rss - GeneratedSrcSpan{} -> JSNull - UnhelpfulSpan{} -> JSNull - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -415,8 +386,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction defaultLogActionWithHandles out err logflags msg_class srcSpan msg - | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg - | otherwise = case msg_class of + = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) MCInteractive -> putStrSDoc msg @@ -442,10 +412,6 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg -- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For -- that reason we can not decorate the message in `defaultLogActionWithHandles`. -- --- See also Note [JSON Error Messages]: --- --- `jsonLogAction` should be removed along with -ddump-json --- -- Also note that (1) is the reason why some parts of the compiler produce -- diagnostics that don't respect `-fdiagnostics-as-json`. -- @@ -493,28 +459,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d -- calls to this log-action can output all on the same line = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d --- --- Note [JSON Error Messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. --- --- The recent work here replaces the purpose of flag -ddump-json with --- -fdiagnostics-as-json. For temporary backwards compatibility while --- -ddump-json is being deprecated, `jsonLogAction` has been added in, but --- it should be removed along with -ddump-json. Similarly, the guard in --- `defaultLogAction` should be removed. This cleanup is tracked in #24113. - -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction defaultDumpAction dumps log_action logflags sty flag title _fmt doc = ===================================== docs/users_guide/debugging.rst ===================================== @@ -55,13 +55,6 @@ Dumping out compiler intermediate structures ``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the output of one way with the output of another. -.. ghc-flag:: -ddump-json - :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead - :type: dynamic - - This flag was previously used to generated JSON formatted GHC diagnostics, - but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`. - .. ghc-flag:: -dshow-passes :shortdesc: Print out each pass name as it happens :type: dynamic ===================================== ghc/GHCi/UI.hs ===================================== @@ -508,8 +508,6 @@ interactiveUI config baseDFlags srcs maybe_exprs = do installInteractiveHomeUnits baseDFlags - -- Update the LogAction. Ensure we don't override the user's log action lest - -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] pushLogHookM (ghciLogAction lastErrLocationsRef) ===================================== testsuite/tests/driver/T16167.stderr ===================================== @@ -1 +1 @@ -*** Exception: ExitFailure 1 +{"version":"1.2","ghcVersion":"ghc-9.15.20250819","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"rendered":"T16167.hs:1:8: error: [GHC-58481] parse error on input \u2018f\u2019\n","message":["parse error on input \u2018f\u2019"],"hints":[]} ===================================== testsuite/tests/driver/T16167.stdout deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"} ===================================== testsuite/tests/driver/all.T ===================================== @@ -271,12 +271,10 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef']) test('T12955', normal, makefile_test, []) test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, []) -test('json_dump', normal, compile_fail, ['-ddump-json']) test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json']) test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial']) -test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version']) -test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command, - ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs']) +test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version']) +test('T16167', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json']) test('T13604', [], makefile_test, []) test('T13604a', [ js_broken(22261) # require HPC support ===================================== testsuite/tests/driver/json2.stderr ===================================== @@ -1,2 +1,4 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"} +TYPE SIGNATURES + foo :: forall a. a -> a +Dependent modules: [] +Dependent packages: [(normal, base-4.21.0.0)] ===================================== testsuite/tests/driver/json_dump.hs deleted ===================================== @@ -1,6 +0,0 @@ -module Foo where - -import Data.List - -id1 :: a -> a -id1 = 5 ===================================== testsuite/tests/driver/json_dump.stderr deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d86d2644a05263d23f592549a718fd0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d86d2644a05263d23f592549a718fd0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 6 commits: Encapsulate options of occurAnalysePgm in a record
by Marge Bot (＠marge-bot) 27 Jun '26

27 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6f212121 by Facundo Domínguez at 2026-06-26T20:56:27-04:00 Encapsulate options of occurAnalysePgm in a record - - - - - adfbb179 by Facundo Domínguez at 2026-06-26T20:56:27-04:00 Allow to configure the occurrence analyser to retain some dead bindings This is needed by plugins that are the only consumers of a binding which is otherwise unused in the program. See Note [Controlling elimination of dead bindings in occurrence analysis] added in this commit, or https://gitlab.haskell.org/ghc/ghc/-/issues/27240 for more discussion. - - - - - c745b11f by Copilot at 2026-06-26T20:56:27-04:00 Address documentation feedback - - - - - 2c2a4a2a by Copilot at 2026-06-26T20:56:27-04:00 Keep the imp_rules parameter of occurPgmAnalysePgm and add occ_opts to OccEnv - - - - - e2262b0e by Copilot at 2026-06-26T20:56:27-04:00 Strengthen T27240.hs with a binding that should be removed - - - - - 5f9d9268 by Copilot at 2026-06-26T20:56:27-04:00 Move the reference #27240 to a related paragraph - - - - - 7 changed files: - + changelog.d/add_can_drop_to_occurence_analyser - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Driver/Config.hs - + testsuite/tests/ghc-api/T27240.hs - testsuite/tests/ghc-api/all.T Changes: ===================================== changelog.d/add_can_drop_to_occurence_analyser ===================================== @@ -0,0 +1,19 @@ +section: ghc-lib +synopsis: Add ``oa_can_drop`` option to the occurrence analyser which selects + bindings to preserve. + +issues: #27240 +mrs: !16253 + +description: { + This is only relevant to clients of the GHC API. + + The ``oa_can_drop`` option of the occurrence analyser indicates whether a + binding is ok to drop. The option is also exposed in the simple optimiser as + ``so_can_drop``. + + In addition, the function ``occurAnalysePgm`` earned a record parameter of + type ``OccurAnalOpts`` which aggregates former parameters of the function. + The record type ``OccEnv`` in turn, replaces its fields ``occ_unf_act`` and + ``occ_rule_act`` with a field ``occ_opts`` of type ``OccurAnalOpts``. +} ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -26,6 +26,7 @@ core expression with (hopefully) improved usage information. -} module GHC.Core.Opt.OccurAnal ( + OccurAnalOpts(..), occurAnalysePgm, occurAnalyseExpr, occurAnalyseBndrsAndExpr, occurAnalyseExpr_Prep, @@ -103,12 +104,21 @@ occurAnalyseExpr_Prep expr = expr' where WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr +-- | Options for occurrence analysis of a program +data OccurAnalOpts = OccurAnalOpts + { oa_active_unf :: Id -> Bool -- ^ Active unfoldings + , oa_active_rule :: ActivationGhc -> Bool -- ^ Active rules + , oa_can_drop :: Id -> Bool + -- ^ Can we drop this Id if it is dead? + -- See Note [Controlling elimination of dead bindings in occurrence analysis]. + } + occurAnalysePgm :: Module -- Used only in debug output - -> (Id -> Bool) -- Active unfoldings - -> (ActivationGhc -> Bool) -- Active rules - -> [CoreRule] -- Local rules for imported Ids - -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_unf active_rule imp_rules binds + -> OccurAnalOpts + -> [CoreRule] -- Local rules for imported Ids + -> CoreProgram + -> CoreProgram +occurAnalysePgm this_mod opts imp_rules binds | isEmptyDetails final_usage = occ_anald_binds @@ -116,8 +126,7 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage)) occ_anald_glommed_binds where - init_env = initOccEnv { occ_rule_act = active_rule - , occ_unf_act = active_unf } + init_env = initOccEnv { occ_opts = opts } WUD final_usage occ_anald_binds = go binds init_env WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel @@ -1033,6 +1042,27 @@ Note [Occurrences in stable unfoldings and RULES]: occurrences in an unfolding or RULE are treated as ManyOcc anyway. But NB that tail-call info is preserved so that we don't thereby lose join points. + +Note [Controlling elimination of dead bindings in occurrence analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, plugins might want to retain dead bindings. + +For instance, Liquid Haskell might be the sole consumer of a binding that is +providing a proof. Or it might provide a lemma that is needed to check other +parts of the program. Or it might provide a value that is only referred from a +refinement type, but not from the Haskell code itself. See #27240 for more +details. + +For this reason, the occurrence analyser can be configured to retain +some bindings even if they are dead. This is done by setting the `oa_can_drop` +field of `OccAnalOpts` to a function that returns `False` for the bindings that +should be retained. All calls to the occurrence analyser from within GHC itself +use `const True` for this predicate; only calls from plugins might return +`False` in some cases. + +Alternatively, the plugin could avoid running the occurrence analyser, but that +would also disable other effects, such as the split of the program in strongly +connected components. -} ------------------------------------------------------------------ @@ -1078,7 +1108,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine !(WUD body_uds (occ, body)) = occAnalNonRecBody env_body bndr' $ \env -> thing_inside (addJoinPoint env bndr' rhs_uds) in - if isDeadOcc occ -- Drop dead code; see Note [Dead code] + if isDeadOcc occ && oa_can_drop (occ_opts env) bndr -- Drop dead code; see Note [Dead code] then WUD body_uds body else WUD (combineJoinPointUDs env rhs_uds body_uds) -- Note `orUDs` (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs'] @@ -1088,7 +1118,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine -- Analyse the body and /then/ the RHS | let env_body = addLocalLet env lvl bndr , WUD body_uds (occ,body) <- occAnalNonRecBody env_body bndr thing_inside - = if isDeadOcc occ -- Drop dead code; see Note [Dead code] + = if isDeadOcc occ && oa_can_drop (occ_opts env) bndr -- Drop dead code; see Note [Dead code] then WUD body_uds body else let -- Get the join info from the *new* decision; NB: bndr is not already a JoinId @@ -1225,10 +1255,10 @@ occAnalRec :: OccEnv -> TopLevelFlag -> WithUsageDetails [CoreBind] -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec !_ lvl +occAnalRec !env lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) (WUD body_uds binds) - | isDeadOcc occ -- Check for dead code: see Note [Dead code] + | isDeadOcc occ && oa_can_drop (occ_opts env) bndr -- Check for dead code: see Note [Dead code] = WUD body_uds binds | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr @@ -1463,8 +1493,8 @@ However, tagZero can only be inlined in phase 1 and later, while the RULE is only active *before* phase 1. So there's no problem. To make this work, we look for the RHS free vars only for -*active* rules. That's the reason for the occ_rule_act field -of the OccEnv. +*active* rules. That's the reason for the oa_active_rule field +of occ_opts in OccEnv. Note [loopBreakNodes] ~~~~~~~~~~~~~~~~~~~~~ @@ -1854,7 +1884,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs) -- of Note [Join arity prediction based on joinRhsArity] --------- IMP-RULES -------- - is_active = occ_rule_act env :: ActivationGhc -> Bool + is_active = oa_active_rule (occ_opts env) :: ActivationGhc -> Bool imp_rule_info = lookupImpRules imp_rule_edges bndr imp_rule_uds = impRulesScopeUsage imp_rule_info imp_rule_fvs = impRulesActiveFvs is_active bndr_set imp_rule_info @@ -1963,8 +1993,8 @@ nodeScore !env new_bndr lb_deps | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers = (0, 0, True) -- See Note [Self-recursion and loop breakers] - | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has - = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + | not (oa_active_unf (occ_opts env) old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker | exprIsTrivial rhs = mk_score 10 -- Practically certain to be inlined @@ -2985,8 +3015,7 @@ scrutinised y). data OccEnv = OccEnv { occ_encl :: !OccEncl -- Enclosing context information , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active - , occ_rule_act :: ActivationGhc -> Bool -- Which rules are active + , occ_opts :: !OccurAnalOpts -- See Note [Finding rule RHS free vars] , occ_allow_weak_joins :: !Bool @@ -3055,18 +3084,19 @@ initOccEnv :: OccEnv initOccEnv = OccEnv { occ_encl = OccVanilla , occ_one_shots = [] - - -- To be conservative, we say that all - -- inlines and rules are active - , occ_unf_act = \_ -> True - , occ_rule_act = \_ -> True - , occ_allow_weak_joins = False - , occ_join_points = emptyVarEnv , occ_bs_env = emptyVarEnv , occ_bs_rng = emptyVarSet - , occ_nested_lets = emptyVarSet } + , occ_nested_lets = emptyVarSet + -- To be conservative, we say that all + -- inlines and rules are active + , occ_opts = OccurAnalOpts + { oa_active_rule = \_ -> True + , oa_active_unf = \_ -> True + , oa_can_drop = \_ -> True + } + } noBinderSwaps :: OccEnv -> Bool noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -12,7 +12,7 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Rules import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal ( OccurAnalOpts(..), occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) import GHC.Core.FVs ( exprFreeVars ) import GHC.Core.Utils ( mkTicks, stripTicksTop ) @@ -252,8 +252,15 @@ simplifyPgm logger unit_env name_ppr_ctx opts = do { -- Occurrence analysis let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule - local_rules binds + occurAnalysePgm + this_mod + OccurAnalOpts + { oa_active_unf = active_unf + , oa_active_rule = active_rule + , oa_can_drop = const True + } + local_rules + binds } ; Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Make -import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) +import GHC.Core.Opt.OccurAnal( OccurAnalOpts(..), occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon import GHC.Core.Coercion.Opt ( optCoercion, optTransCo, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList @@ -208,6 +208,8 @@ data SimpleOpts = SimpleOpts -- used-once things -- -- See Note [Controlling inlining in the simple optimiser] + , so_can_drop :: !(Var -> Bool) -- ^ True <=> can drop the given binding if it is dead + -- See 'oa_can_drop' in 'OccurAnalOpts'. } -- | Default options for the Simple optimiser. @@ -217,6 +219,7 @@ defaultSimpleOpts = SimpleOpts , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } , so_eta_red = False , so_inline = const True + , so_can_drop = const True } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -282,10 +285,15 @@ simpleOptPgm :: SimpleOpts simpleOptPgm opts this_mod binds rules = (reverse binds', rules', occ_anald_binds) where - occ_anald_binds = occurAnalysePgm this_mod - (\_ -> True) {- All unfoldings active -} - (\_ -> False) {- No rules active -} - rules binds + occ_anald_binds = occurAnalysePgm + this_mod + OccurAnalOpts + { oa_active_unf = \_ -> True {- All unfoldings active -} + , oa_active_rule = \_ -> False {- No rules active -} + , oa_can_drop = so_can_drop opts + } + rules + binds (final_env, binds') = foldl' do_one (emptyEnv opts, []) occ_anald_binds final_subst = soe_subst final_env ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -27,6 +27,7 @@ initSimpleOpts dflags = SimpleOpts , so_co_opts = initOptCoercionOpts dflags , so_eta_red = gopt Opt_DoEtaReduction dflags , so_inline = const True + , so_can_drop = const True } -- | Instruct the interpreter evaluation to break... ===================================== testsuite/tests/ghc-api/T27240.hs ===================================== @@ -0,0 +1,128 @@ + +-- This test checks that bindings are preserved when configuring the occurrence +-- analyzer and the simple optimizer to not drop dead bindings with names +-- selected by a predicate. +-- +-- This feature is important for the LiquidHaskell plugin, which relies on the +-- simple optimizer to make core programs easier to read, but needs to preserve +-- bindings that are relevant for verification. +-- +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/27240 for the full discussion. +-- + +import Control.Monad +import Data.List (find) +import Data.Time (getCurrentTime) +import GHC +import GHC.Core +import GHC.Core.SimpleOpt +import GHC.Data.StringBuffer +import GHC.Driver.Config +import GHC.Driver.DynFlags +import GHC.Driver.Env.Types +import GHC.Types.Name +import GHC.Unit.Module.ModGuts +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Outputable + +import System.Environment (getArgs) + + +main :: IO () +main = + testLocalBindingsDesugaring + +testLocalBindingsDesugaring :: IO () +testLocalBindingsDesugaring = do + let inputSource = unlines + [ "module LocalDeadBindingsDesugaring where" + , "f :: ()" + , "f = ()" + , " where" + , " w = ()" + , " z = ()" + ] + + isExpectedDesugaring p = case findExpr "f" p of + Just (Let (NonRec b _) _) + -> isIdNamed "z" b + _ -> False + + isIdNamed name v = occNameString (occName v) == name + + coreProgram <- + compileToCore + (not . isIdNamed "z") + "LocalDeadBindingsDesugaring" + inputSource + unless (isExpectedDesugaring coreProgram) $ + fail $ unlines $ + "Unexpected desugaring: No local binding for `z` found in the Core program." + : map showPprQualified coreProgram + +-- | Find the Core expression bound to the given name. +findExpr :: String -> CoreProgram -> Maybe CoreExpr +findExpr _ [] = + Nothing +findExpr name (p:ps) = case p of + NonRec b e + | occNameString (occName b) == name + -> Just e + Rec binds + | Just (_, e) <- find (\(b, _e) -> occNameString (occName b) == name) binds + -> Just e + _ -> findExpr name ps + +showPprQualified :: Outputable a => a -> String +showPprQualified = showSDocQualified . ppr + +showSDocQualified :: SDoc -> String +showSDocQualified = renderWithContext ctx + where + ctx = defaultSDocContext { sdocStyle = cmdlineParserStyle } + + + +compileToCore :: (Id -> Bool) -> String -> String -> IO [CoreBind] +compileToCore canDrop modName inputSource = do + [libdir] <- getArgs + now <- getCurrentTime + runGhc (Just libdir) $ do + df1 <- getSessionDynFlags + GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend } + let target = Target { + targetId = TargetFile (modName ++ ".hs") Nothing + , targetUnitId = homeUnitId_ df1 + , targetAllowObjCode = False + , targetContents = Just (stringToStringBuffer inputSource, now) + } + setTargets [target] + void $ GHC.depanal [] False + + dsMod <- getModSummary + (mkModule mainUnit (mkModuleName modName)) + >>= parseModule + >>= typecheckModule NoTcMPlugins + >>= desugarModule + hsc_env <- getSession + return $ mg_binds $ simpleOptimize canDrop hsc_env $ dm_core_module dsMod + +-- Run the simple optimizer +simpleOptimize :: (Id -> Bool) -> GHC.HscEnv -> ModGuts -> ModGuts +simpleOptimize canDrop hsc_env guts@(ModGuts + { mg_module = mgmod + , mg_binds = binds + , mg_rules = rules + }) = + let dflags = hsc_dflags hsc_env + simpl_opts = (initSimpleOpts dflags) + { so_inline = canDrop + , so_can_drop = canDrop + } + (binds2, rules2, _occ_anald_binds) = + simpleOptPgm simpl_opts mgmod binds rules + in guts + { mg_binds = binds2 + , mg_rules = rules2 + } ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -82,6 +82,7 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) test('T25121_status', normal, compile_and_run, ['-package ghc']) test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) +test('T27240', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) test('T27273', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/412f16756dff9d3b71ba1c4646c8bc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/412f16756dff9d3b71ba1c4646c8bc… You're receiving this email because of your account on gitlab.haskell.org.

1 0