Simon Jakobi pushed to branch wip/sjakobi/T27368-cbe-expand-subst at Glasgow Haskell Compiler / GHC Commits: b4fc993b by Simon Jakobi at 2026-10-04T04:49:43+02:00 Cmm: keep the common block elimination substitution chain-free A block that won a merge in one round of elimCommonBlocks can lose one in a later round, so the substitution could map a label to another eliminated label. replaceLabels looks up each label only once and so left edges to eliminated blocks in the graph, which later made setInfoTableStackMap panic (#27368). Now each round's substitutions are applied to the existing ones as they are added (extendSubst), so every label maps directly to a surviving block and lookupBid no longer needs to chase chains. Fixes #27368. Assisted-by: Claude Fable 5.1 - - - - - 4774e648 by Simon Jakobi at 2026-10-04T05:40:08+02:00 Cmm: exclude the entry block from common block elimination toBlockListEntryFirst only made the entry block win merges in the first round of elimCommonBlocks. Later rounds regroup the blocks by their substituted successors in an order unrelated to the entry, so the entry block could still lose a merge, leaving the proc's info table keyed by an eliminated label (#27722). Instead, the entry block is no longer a candidate for elimination at all. The downside is that blocks identical to the entry block are no longer merged into it. Only hand-written Cmm is affected, as the entry block of every Haskell-generated proc contains the proc's stack check, which no other block of the graph can contain. Fixes #27722. Assisted-by: Claude Fable 5.1 - - - - - 9 changed files: - + changelog.d/27368 - compiler/GHC/Cmm/CommonBlockElim.hs - + testsuite/tests/cmm/should_run/T27722.hs - + testsuite/tests/cmm/should_run/T27722.stdout - + testsuite/tests/cmm/should_run/T27722_c.c - + testsuite/tests/cmm/should_run/T27722_cmm.cmm - testsuite/tests/cmm/should_run/all.T - + testsuite/tests/codeGen/should_compile/T27368.hs - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== changelog.d/27368 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a ``setInfoTableStackMap`` panic caused by common block elimination + leaving references to eliminated blocks. +issues: #27368 +mrs: !16543 ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -66,30 +66,20 @@ elimCommonBlocks g = where g' = replaceLabels env $ copyTicks env g env = iterate mapEmpty blocks_with_key - -- The order of blocks doesn't matter here. While we could use - -- revPostorder which drops unreachable blocks this is done in - -- ContFlowOpt already which runs before this pass. So we use - -- toBlockList since it is faster. - -- One exception: The entry block most come first or we risk eliminating it - -- in favour of another block. See Note [Retain entry block during common block elimination.] - groups = groupByInt hash_block (toBlockListEntryFirst g) :: [[CmmBlock]] blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] - --- Note [Retain entry block during common block elimination.] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- At the stage we run common block elimination (CBE) we only have one info --- table for the entry label. Which means we can get away without applying the --- block label substitution to the info table *as long as we keep the first block*. --- When combining blocks the first block in the list of blocks is kept, and the later --- one eliminated, so we can achieve this by simply using toBlockListEntryFirst. --- --- If we don't we end up with #27722 where the entry block was eliminated in favour --- of another block. + groups = groupByInt hash_block candidates :: [[CmmBlock]] + -- The entry block must not be eliminated: #27722 + candidates = filter ((/= g_entry g) . entryLabel) (toBlockList g) -- Invariant: The blocks in the list are pairwise distinct -- (so avoid comparing them again) type DistinctBlocks = [CmmBlock] type Key = [Label] + +-- | Maps each eliminated block to the block that replaces it. +-- +-- Invariant: no value is a key, so a single lookup resolves any label. +-- See 'extendSubst'. type Subst = LabelMap BlockId -- The outer list groups by hash. We retain this grouping throughout. @@ -108,9 +98,20 @@ iterate subst blocks where (new_subst2, db) = mergeBlockList subst dbs - subst' = subst `mapUnion` new_substs + subst' = extendSubst subst new_substs updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks +-- | Add the substitutions of one round of 'iterate'. +-- +-- A block that won a merge in an earlier round may have lost one in this +-- round, so the older substitutions are rewritten through the new ones to +-- keep the result chain-free. +extendSubst :: Subst -> Subst -> Subst +extendSubst subst new = assert (chainFree subst') subst' + where + subst' = mapMap (lookupBid new) subst `mapUnion` new + chainFree s = not (any (`mapMember` s) s) + -- Combine two lists of blocks. -- While they are internally distinct they can still share common blocks. mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks) @@ -218,9 +219,7 @@ dont_care _other = False eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' lookupBid :: LabelMap BlockId -> BlockId -> BlockId -lookupBid subst bid = case mapLookup bid subst of - Just bid -> lookupBid subst bid - Nothing -> bid +lookupBid subst bid = mapFindWithDefault bid bid subst -- Middle nodes and expressions can contain BlockIds, in particular in -- CmmStackSlot and CmmBlock, so we have to use a special equality for ===================================== testsuite/tests/cmm/should_run/T27722.hs ===================================== @@ -0,0 +1,6 @@ +foreign import ccall "zork_info_addr" zork_info_addr :: IO Word + +main :: IO () +main = do + addr <- zork_info_addr + putStrLn (if addr /= 0 then "ok" else "no info table") ===================================== testsuite/tests/cmm/should_run/T27722.stdout ===================================== @@ -0,0 +1 @@ +ok ===================================== testsuite/tests/cmm/should_run/T27722_c.c ===================================== @@ -0,0 +1,7 @@ +#include <stdint.h> + +// Common block elimination used to drop the entry block together with +// its info table, so that this symbol went missing. +extern char zork_info[]; + +uintptr_t zork_info_addr(void) { return (uintptr_t) zork_info; } ===================================== testsuite/tests/cmm/should_run/T27722_cmm.cmm ===================================== @@ -0,0 +1,22 @@ +#include "Cmm.h" + +// The then-blocks of E1 and E2 are duplicates of the entry block: they +// carry the same number of source notes (block and statement) as the +// entry block (proc and statement), which matters for the block hash. +// They get merged with each other in the first round of common block +// elimination, E1 and E2 in the second, and only then does the entry +// block have a duplicate. +INFO_TABLE_RET (zork, RET_SMALL) + return () +{ + bits64 x; + x = 1 :: bits64; + goto E1; +E1: + if (x > 0 :: bits64) { x = 1 :: bits64; goto E2; } else { goto D; } +E2: + if (x > 0 :: bits64) { x = 1 :: bits64; goto E2; } else { goto D; } +D: + if (x > 1 :: bits64) goto E1; + goto E2; +} ===================================== testsuite/tests/cmm/should_run/all.T ===================================== @@ -60,3 +60,6 @@ test('T27447', ], multi_compile_and_run, ['T27447', [('T27447_cmm.cmm', '')], '']) + +test('T27722', [req_cmm], multi_compile_and_run, + ['T27722', [('T27722_cmm.cmm', ''), ('T27722_c.c', '')], '-O']) ===================================== testsuite/tests/codeGen/should_compile/T27368.hs ===================================== @@ -0,0 +1,17 @@ +-- Common block elimination merges the duplicated blocks over several +-- rounds. Compiling this at -O panicked in setInfoTableStackMap (#27368). + +module T27368 (f) where + +{-# NOINLINE put #-} +put :: Int -> Int -> IO () +put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure () + +data T = J Int | K + +f :: Int -> Bool -> T -> IO () +f h a t = do + if a + then do put h 1; case t of { J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + else do put h 2; case t of { J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + put h 0 ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -150,3 +150,5 @@ test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppres test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +test('T27368', normal, compile, ['-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/883000905d0b87b1bbe7722ef99c91a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/883000905d0b87b1bbe7722ef99c91a... 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