Simon Jakobi pushed to branch wip/sjakobi/T27368-cbe-expand-subst at Glasgow Haskell Compiler / GHC Commits: 63c9eb84 by Simon Jakobi at 2026-10-05T00:58:03+02:00 Cmm: keep the CBE substitution chain-free When blocks are merged over multiple rounds during common block elimination, a block that won a merge in an earlier round can still lose a merge in a later round. The substitution used to record this as a chain: the earlier loser mapped to a block that was itself eliminated. Applying such a substitution left edges to eliminated blocks in the Cmm graph, eventually leading to a 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 - - - - - 4 changed files: - + changelog.d/27368 - compiler/GHC/Cmm/CommonBlockElim.hs - + 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 ===================================== @@ -90,6 +90,10 @@ elimCommonBlocks g = -- (so avoid comparing them again) type DistinctBlocks = [CmmBlock] type Key = [Label] + +-- | A substitution maps each eliminated block to its replacement. +-- +-- Invariant: no value is a key, i.e. there are no chains @x->y->z@. type Subst = LabelMap BlockId -- The outer list groups by hash. We retain this grouping throughout. @@ -108,9 +112,19 @@ 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 updated 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 +232,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/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 = N | J Int | K + +f :: Int -> Bool -> T -> IO () +f h a t = do + if a + then do put h 1; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0; put h 0; put h 0 + else do put h 2; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0; 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/-/commit/63c9eb8459bfab4d6829763d06f72c7c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63c9eb8459bfab4d6829763d06f72c7c... 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