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/81866207d70bb1baca184746436f3c85... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81866207d70bb1baca184746436f3c85... You're receiving this email because of your account on gitlab.haskell.org.