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

Commits:

9 changed files:

Changes:

  • changelog.d/27368
    1 
    +section: compiler
    2 
    +synopsis: Fix a ``setInfoTableStackMap`` panic caused by common block elimination
    3 
    +  leaving references to eliminated blocks.
    4 
    +issues: #27368
    5 
    +mrs: !16543

  • compiler/GHC/Cmm/CommonBlockElim.hs
    ... ... @@ -66,30 +66,20 @@ elimCommonBlocks g =
    66 66 
       where
    67 67 
          g' = replaceLabels env $ copyTicks env g
    68 68 
          env = iterate mapEmpty blocks_with_key
    69 
    -     -- The order of blocks doesn't matter here. While we could use
    70 
    -     -- revPostorder which drops unreachable blocks this is done in
    71 
    -     -- ContFlowOpt already which runs before this pass. So we use
    72 
    -     -- toBlockList since it is faster.
    73 
    -     -- One exception: The entry block most come first or we risk eliminating it
    74 
    -     -- in favour of another block. See Note [Retain entry block during common block elimination.]
    75 
    -     groups = groupByInt hash_block (toBlockListEntryFirst g) :: [[CmmBlock]]
    76 69 
          blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
    77 
    -
    78 
    --- Note [Retain entry block during common block elimination.]
    79 
    --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    80 
    --- At the stage we run common block elimination (CBE) we only have one info
    81 
    --- table for the entry label. Which means we can get away without applying the
    82 
    --- block label substitution to the info table *as long as we keep the first block*.
    83 
    --- When combining blocks the first block in the list of blocks is kept, and the later
    84 
    --- one eliminated, so we can achieve this by simply using toBlockListEntryFirst.
    85 
    ---
    86 
    --- If we don't we end up with #27722 where the entry block was eliminated in favour
    87 
    --- of another block.
    70 
    +     groups = groupByInt hash_block candidates :: [[CmmBlock]]
    71 
    +     -- The entry block must not be eliminated: #27722
    72 
    +     candidates = filter ((/= g_entry g) . entryLabel) (toBlockList g)
    88 73
    89 74 
     -- Invariant: The blocks in the list are pairwise distinct
    90 75 
     -- (so avoid comparing them again)
    91 76 
     type DistinctBlocks = [CmmBlock]
    92 77 
     type Key = [Label]
    78 
    +
    79 
    +-- | Maps each eliminated block to the block that replaces it.
    80 
    +--
    81 
    +-- Invariant: no value is a key, so a single lookup resolves any label.
    82 
    +-- See 'extendSubst'.
    93 83 
     type Subst = LabelMap BlockId
    94 84
    95 85 
     -- The outer list groups by hash. We retain this grouping throughout.
    ... ... @@ -108,9 +98,20 @@ iterate subst blocks
    108 98 
               where
    109 99 
                 (new_subst2, db) = mergeBlockList subst dbs
    110 100
    111 
    -    subst' = subst `mapUnion` new_substs
    101 
    +    subst' = extendSubst subst new_substs
    112 102 
         updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
    113 103
    104 
    +-- | Add the substitutions of one round of 'iterate'.
    105 
    +--
    106 
    +-- A block that won a merge in an earlier round may have lost one in this
    107 
    +-- round, so the older substitutions are rewritten through the new ones to
    108 
    +-- keep the result chain-free.
    109 
    +extendSubst :: Subst -> Subst -> Subst
    110 
    +extendSubst subst new = assert (chainFree subst') subst'
    111 
    +  where
    112 
    +    subst' = mapMap (lookupBid new) subst `mapUnion` new
    113 
    +    chainFree s = not (any (`mapMember` s) s)
    114 
    +
    114 115 
     -- Combine two lists of blocks.
    115 116 
     -- While they are internally distinct they can still share common blocks.
    116 117 
     mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
    ... ... @@ -218,9 +219,7 @@ dont_care _other = False
    218 219 
     eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
    219 220 
     eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
    220 221 
     lookupBid :: LabelMap BlockId -> BlockId -> BlockId
    221 
    -lookupBid subst bid = case mapLookup bid subst of
    222 
    -                        Just bid  -> lookupBid subst bid
    223 
    -                        Nothing -> bid
    222 
    +lookupBid subst bid = mapFindWithDefault bid bid subst
    224 223
    225 224 
     -- Middle nodes and expressions can contain BlockIds, in particular in
    226 225 
     -- CmmStackSlot and CmmBlock, so we have to use a special equality for

  • testsuite/tests/cmm/should_run/T27722.hs
    1 
    +foreign import ccall "zork_info_addr" zork_info_addr :: IO Word
    2 
    +
    3 
    +main :: IO ()
    4 
    +main = do
    5 
    +  addr <- zork_info_addr
    6 
    +  putStrLn (if addr /= 0 then "ok" else "no info table")

  • testsuite/tests/cmm/should_run/T27722.stdout
    1 
    +ok

  • testsuite/tests/cmm/should_run/T27722_c.c
    1 
    +#include <stdint.h>
    2 
    +
    3 
    +// Common block elimination used to drop the entry block together with
    4 
    +// its info table, so that this symbol went missing.
    5 
    +extern char zork_info[];
    6 
    +
    7 
    +uintptr_t zork_info_addr(void) { return (uintptr_t) zork_info; }

  • testsuite/tests/cmm/should_run/T27722_cmm.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// The then-blocks of E1 and E2 are duplicates of the entry block: they
    4 
    +// carry the same number of source notes (block and statement) as the
    5 
    +// entry block (proc and statement), which matters for the block hash.
    6 
    +// They get merged with each other in the first round of common block
    7 
    +// elimination, E1 and E2 in the second, and only then does the entry
    8 
    +// block have a duplicate.
    9 
    +INFO_TABLE_RET (zork, RET_SMALL)
    10 
    +    return ()
    11 
    +{
    12 
    +  bits64 x;
    13 
    +  x = 1 :: bits64;
    14 
    +  goto E1;
    15 
    +E1:
    16 
    +  if (x > 0 :: bits64) { x = 1 :: bits64; goto E2; } else { goto D; }
    17 
    +E2:
    18 
    +  if (x > 0 :: bits64) { x = 1 :: bits64; goto E2; } else { goto D; }
    19 
    +D:
    20 
    +  if (x > 1 :: bits64) goto E1;
    21 
    +  goto E2;
    22 
    +}

  • testsuite/tests/cmm/should_run/all.T
    ... ... @@ -60,3 +60,6 @@ test('T27447',
    60 60 
          ],
    61 61 
          multi_compile_and_run,
    62 62 
          ['T27447', [('T27447_cmm.cmm', '')], ''])
    63 
    +
    64 
    +test('T27722', [req_cmm], multi_compile_and_run,
    65 
    +     ['T27722', [('T27722_cmm.cmm', ''), ('T27722_c.c', '')], '-O'])

  • testsuite/tests/codeGen/should_compile/T27368.hs
    1 
    +-- Common block elimination merges the duplicated blocks over several
    2 
    +-- rounds. Compiling this at -O panicked in setInfoTableStackMap (#27368).
    3 
    +
    4 
    +module T27368 (f) where
    5 
    +
    6 
    +{-# NOINLINE put #-}
    7 
    +put :: Int -> Int -> IO ()
    8 
    +put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure ()
    9 
    +
    10 
    +data T = J Int | K
    11 
    +
    12 
    +f :: Int -> Bool -> T -> IO ()
    13 
    +f h a t = do
    14 
    +  if a
    15 
    +    then do put h 1; case t of { J _ -> put h 3; K -> put h 4 }; put h 0; put h 0
    16 
    +    else do put h 2; case t of { J _ -> put h 3; K -> put h 4 }; put h 0; put h 0
    17 
    +  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
    150 150 
     test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
    151 151 
     test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
    152 152 
     test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
    153 
    +
    154 
    +test('T27368', normal, compile, ['-O'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/883000905d0b87b1bbe7722ef99c91a40689ee43...4774e648765e6a1a24dc6d429b7196d4f89b8d48 at 1791085221