Simon Jakobi pushed to branch wip/sjakobi/T27448 at Glasgow Haskell Compiler / GHC Commits: 29ba0c3b by Simon Jakobi at 2026-06-28T13:06:17+02:00 NCG: optimize loopInfo.mkDomMap Previously, mkDomMap built an intermediate association list with (++) and a recursive concatMap before handing it to mapFromList. The concatMap re-copied each node's list once per ancestor, so the work was O(n^2) in the depth of the dominator tree. The new code builds the LabelMap directly, with one mapInsert per dominator-tree node, so each node is handled once. This reduces allocation when compiling the new ManyBasicBlocks test by ~27% at -O1 and -O2. (At -O0, static control-flow prediction is disabled.) This also fixes a small inconsistency: previously a leaf of the dominator tree included itself in its dominator set, while interior nodes did not. The map is consumed only by isBackEdge, so the only observable effect was that a self-loop edge was treated as a back edge iff its block was a dominator-tree leaf. domMap now holds each block's strict dominators, excluding the entry. Closes #27448 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,16 @@ test ('T26989', multimod_compile, ['T26989', '-v0 -O']) +# A single Cmm procedure with thousands of basic blocks (diamonds plus periodic +# backedges), stressing the control-flow handling of the NCG and Wasm backends. +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,140 @@ +#!/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. +# +# 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/29ba0c3b0cf354c1b08feadf40992b42... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29ba0c3b0cf354c1b08feadf40992b42... You're receiving this email because of your account on gitlab.haskell.org.