Simon Jakobi pushed to branch wip/sjakobi/T27448 at Glasgow Haskell Compiler / GHC Commits: 99f98637 by Simon Jakobi at 2026-11-04T20:17:20+01:00 NCG: Rewrite loopInfo.mkDomMap mkDomMap used to build an intermediate association list with (++) and a recursive concatMap before handing it to mapFromList, performing work proportional to the number of blocks times the depth of the dominator tree. The new code builds the LabelMap directly, with one mapInsert per dominator-tree node. This reduces allocations when compiling the new ManyBasicBlocks test by roughly 27% at -O1 and -O2. The map now holds each block's dominators, including the block itself and the procedure entry. This changes which edges loopInfo reports as back edges in two ways: - Previously, a self-loop was reported as a back edge only if its block was a leaf of the dominator tree. - Loops headed by the entry block are now detected too (#28083). Closes #27448, closes #28083. Assisted-by: Claude Opus 5.5 - - - - - 8 changed files: - compiler/GHC/CmmToAsm/CFG.hs - + testsuite/tests/cmm/should_compile/T28083.cmm - + testsuite/tests/cmm/should_compile/T28083.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/cmm/should_compile/selfloop_weights.cmm - + testsuite/tests/cmm/should_compile/selfloop_weights.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/perf/compiler/genManyBasicBlocks Changes: ===================================== compiler/GHC/CmmToAsm/CFG.hs ===================================== @@ -885,17 +885,12 @@ 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 = go setEmpty mapEmpty 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 children) + = let !doms' = setInsert lbl doms + in foldl' (go doms') (mapInsert lbl doms' acc) children -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) ===================================== testsuite/tests/cmm/should_compile/T28083.cmm ===================================== @@ -0,0 +1,14 @@ +#include "Cmm.h" + +// The entry is a bare goto, so the Cmm control-flow optimiser makes L the +// entry, heading the loop L -> B -> L. Expected: L -> B outweighs the exit +// edge. Without loop detection they tie. +stg_loop { + goto L; +L: + if (R1 > 0) { goto B; } + jump stg_loop [R1]; +B: + R1 = R1 - 1; + goto L; +} ===================================== testsuite/tests/cmm/should_compile/T28083.stderr ===================================== @@ -0,0 +1,7 @@ +==================== CFG Weights - Final ==================== +stg_loop: +digraph { + c1 -> c4[label="0.25000",weight="0.25000"]; + c1 -> c2[label="0.75000",weight="0.75000"]; + c2 -> c1[label="0.75000",weight="0.75000"]; +} ===================================== testsuite/tests/cmm/should_compile/all.T ===================================== @@ -21,3 +21,13 @@ test('T24474-cmm-opt-order', cmm_src, compile, ['-optc-DFOO ' '-optCmmP-UFOO ' '-optCmmP-UBAR ' '-optc-DBAR']) +test('T28083', [cmm_src, only_ways(['optasm']), + unless(arch('x86_64'), skip), + when(leading_underscore(), skip), + multiline_grep_errmsg(r'=+ CFG Weights - Final[^}]*}')], + compile, ['-no-hs-main -ddump-cfg-weights']) +test('selfloop_weights', [cmm_src, only_ways(['optasm']), + unless(arch('x86_64'), skip), + when(leading_underscore(), skip), + multiline_grep_errmsg(r'=+ CFG Weights - Final[^}]*}')], + compile, ['-no-hs-main -ddump-cfg-weights']) ===================================== testsuite/tests/cmm/should_compile/selfloop_weights.cmm ===================================== @@ -0,0 +1,13 @@ +#include "Cmm.h" + +// S is a self-loop. The entry does work, so it isn't merged into S. +// Expected: the self edge outweighs the exit edge. Without loop detection +// both get weight 0. +stg_self { + R1 = R1 + 1; + goto S; +S: + R1 = R1 - 1; + if (R1 > 0) { goto S; } + jump stg_self [R1]; +} ===================================== testsuite/tests/cmm/should_compile/selfloop_weights.stderr ===================================== @@ -0,0 +1,7 @@ +==================== CFG Weights - Final ==================== +stg_self: +digraph { + c1 -> c4[label="1.00000",weight="1.00000"]; + c5 -> c1[label="1.00000",weight="1.00000"]; + c1 -> c1[label="7.00000",weight="7.00000"]; +} ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -890,3 +890,14 @@ test ('T26989', multimod_compile, ['T26989', '-v0 -O']) +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,206 @@ +#!/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, +# stressing the control-flow handling of the NCG and Wasm backends. +# +# 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 +# +# With STAGES=2, LOOP_PERIOD=2, LOOP_TRIPS=2 the output looks like: +# +# #include "Cmm.h" +# +# many_basic_blocks (W_ seed) { +# W_ acc; +# W_ mix; +# W_ trip0; +# +# entry: +# acc = seed; +# mix = seed + (17 :: W_); +# trip0 = 0; +# goto split0; +# +# split0: +# mix = mix + (1 :: W_); +# if (((mix + (2 :: W_)) % (7 :: W_)) < (3 :: W_)) { +# goto left0; +# } +# goto right0; +# +# left0: +# acc = acc + (3 :: W_); +# mix = mix + (4 :: W_); +# goto join0; +# +# right0: +# acc = acc + (4 :: W_); +# mix = mix + (3 :: W_); +# goto join0; +# +# join0: +# acc = acc + mix + (1 :: W_); +# goto split1; +# +# split1: +# mix = mix + (5 :: W_); +# if (((mix + (6 :: W_)) % (7 :: W_)) < (3 :: W_)) { +# goto left1; +# } +# goto right1; +# +# left1: +# acc = acc + (7 :: W_); +# mix = mix + (8 :: W_); +# goto join1; +# +# right1: +# acc = acc + (8 :: W_); +# mix = mix + (7 :: W_); +# goto join1; +# +# join1: +# acc = acc + mix + (5 :: W_); +# goto latch0; +# +# latch0: +# trip0 = trip0 + (1 :: W_); +# mix = mix + (1000000 :: W_); +# acc = acc + (2000000 :: W_); +# if (trip0 < (2 :: W_)) { +# goto split0; +# } +# return (acc); +# +# } + +: "${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/99f9863731f035ae8e2df3718d96763a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/99f9863731f035ae8e2df3718d96763a... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help