GitLab

Simon Jakobi pushed to branch wip/sjakobi/T27368-cbe-expand-subst at Glasgow Haskell Compiler / GHC

Commits:

c02fe2c9

by Simon Jakobi at 2026-10-05T01:18:46+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

 +section: compiler
 +synopsis: Fix a ``setInfoTableStackMap`` panic caused by common block elimination
 +  leaving references to eliminated blocks.
 +issues: #27368
 +mrs: !16765

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

 +-- 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'])