CommonBlockElim.hs 12.5 KB
Newer Older
1 2
{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}

3
module GHC.Cmm.CommonBlockElim
4 5 6 7 8
  ( elimCommonBlocks
  )
where


9 10
import GhcPrelude hiding (iterate, succ, unzip, zip)

11 12 13 14 15
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch (eqSwitchTargetWith)
import GHC.Cmm.ContFlowOpt
16

17 18 19 20
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
21
import Data.Bits
Peter Wortmann's avatar
Peter Wortmann committed
22
import Data.Maybe (mapMaybe)
23
import qualified Data.List as List
24
import Data.Word
Peter Wortmann's avatar
Peter Wortmann committed
25
import qualified Data.Map as M
26
import Outputable
niteria's avatar
niteria committed
27
import qualified TrieMap as TM
28
import UniqFM
29 30
import Unique
import Control.Arrow (first, second)
31

32 33 34
-- -----------------------------------------------------------------------------
-- Eliminate common blocks

35 36 37 38 39 40 41 42 43 44 45
-- If two blocks are identical except for the label on the first node,
-- then we can eliminate one of the blocks. To ensure that the semantics
-- of the program are preserved, we have to rewrite each predecessor of the
-- eliminated block to proceed with the block we keep.

-- The algorithm iterates over the blocks in the graph,
-- checking whether it has seen another block that is equal modulo labels.
-- If so, then it adds an entry in a map indicating that the new block
-- is made redundant by the old block.
-- Otherwise, it is added to the useful blocks.

46 47 48 49 50 51 52
-- To avoid comparing every block with every other block repeatedly, we group
-- them by
--   * a hash of the block, ignoring labels (explained below)
--   * the list of outgoing labels
-- The hash is invariant under relabeling, so we only ever compare within
-- the same group of blocks.
--
53 54
-- The list of outgoing labels is updated as we merge blocks (that is why they
-- are not included in the hash, which we want to calculate only once).
55 56 57 58 59
--
-- All in all, two blocks should never be compared if they have different
-- hashes, and at most once otherwise. Previously, we were slower, and people
-- rightfully complained: #10397

60 61 62
-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g = replaceLabels env $ copyTicks env g
63
  where
64
     env = iterate mapEmpty blocks_with_key
65 66 67 68 69
     -- 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.
     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
70 71 72 73 74 75
     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]

-- Invariant: The blocks in the list are pairwise distinct
-- (so avoid comparing them again)
type DistinctBlocks = [CmmBlock]
type Key = [Label]
76
type Subst = LabelMap BlockId
77 78

-- The outer list groups by hash. We retain this grouping throughout.
79 80
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
iterate subst blocks
81
    | mapNull new_substs = subst
82
    | otherwise = iterate subst' updated_blocks
83 84 85
  where
    grouped_blocks :: [[(Key, [DistinctBlocks])]]
    grouped_blocks = map groupByLabel blocks
86

87
    merged_blocks :: [[(Key, DistinctBlocks)]]
88
    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
89 90 91
      where
        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
          where
92
            (new_subst2, db) = mergeBlockList subst dbs
93

94 95
    subst' = subst `mapUnion` new_substs
    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
96

97 98
-- Combine two lists of blocks.
-- While they are internally distinct they can still share common blocks.
99 100
mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
mergeBlocks subst existing new = go new
101 102
  where
    go [] = (mapEmpty, existing)
103 104 105 106 107 108 109 110 111
    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
        -- This block is a duplicate. Drop it, and add it to the substitution
        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
        -- This block is not a duplicate, keep it.
        Nothing -> second (b:) $ go bs

mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
mergeBlockList _ [] = pprPanic "mergeBlockList" empty
mergeBlockList subst (b:bs) = go mapEmpty b bs
112 113 114 115
  where
    go !new_subst1 b [] = (new_subst1, b)
    go !new_subst1 b1 (b2:bs) = go new_subst b bs
      where
116
        (new_subst2, b) =  mergeBlocks subst b1 b2
117
        new_subst = new_subst1 `mapUnion` new_subst2
118 119 120 121 122 123 124


-- -----------------------------------------------------------------------------
-- Hashing and equality on blocks

-- Below here is mostly boilerplate: hashing blocks ignoring labels,
-- and comparing blocks modulo a label mapping.
125

126
-- To speed up comparisons, we hash each basic block modulo jump labels.
127 128
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.
129

130 131 132 133
-- We want to get as many small buckets as possible, as comparing blocks is
-- expensive. So include as much as possible in the hash. Ideally everything
-- that is compared with (==) in eqBlockBodyWith.

134 135
type HashCode = Int

136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
hash_block :: CmmBlock -> HashCode
hash_block block =
  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
  -- UniqFM doesn't like negative Ints
  where hash_fst _ h = h
        hash_mid m h = hash_node m + h `shiftL` 1
        hash_lst m h = hash_node m + h `shiftL` 1

        hash_node :: CmmNode O x -> Word32
        hash_node n | dont_care n = 0 -- don't care
        hash_node (CmmAssign r e) = hash_reg r + hash_e e
        hash_node (CmmStore e e') = hash_e e + hash_e e'
        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
        hash_node (CmmBranch _) = 23 -- NB. ignore the label
        hash_node (CmmCondBranch p _ _ _) = hash_e p
        hash_node (CmmCall e _ _ _ _ _) = hash_e e
        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
        hash_node (CmmSwitch e _) = hash_e e
        hash_node _ = error "hash_node: unknown Cmm node!"

        hash_reg :: CmmReg -> Word32
        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
        hash_reg   (CmmGlobal _)    = 19

        hash_e :: CmmExpr -> Word32
        hash_e (CmmLit l) = hash_lit l
        hash_e (CmmLoad e _) = 67 + hash_e e
        hash_e (CmmReg r) = hash_reg r
        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
        hash_e (CmmRegOff r i) = hash_reg r + cvt i
        hash_e (CmmStackSlot _ _) = 13
167

168
        hash_lit :: CmmLit -> Word32
169 170
        hash_lit (CmmInt i _) = fromInteger i
        hash_lit (CmmFloat r _) = truncate r
171
        hash_lit (CmmVec ls) = hash_list hash_lit ls
172
        hash_lit (CmmLabel _) = 119 -- ugh
173
        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
174
        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i
175
        hash_lit (CmmBlock _) = 191 -- ugh
176
        hash_lit (CmmHighStackMark) = cvt 313
177

178 179
        hash_tgt (ForeignTarget e _) = hash_e e
        hash_tgt (PrimTarget _) = 31 -- lots of these
180

181
        hash_list f = foldl' (\z x -> f x + z) (0::Word32)
182

183
        cvt = fromInteger . toInteger
Peter Wortmann's avatar
Peter Wortmann committed
184

185 186 187
        hash_unique :: Uniquable a => a -> Word32
        hash_unique = cvt . getKey . getUnique

Peter Wortmann's avatar
Peter Wortmann committed
188 189 190 191
-- | Ignore these node types for equality
dont_care :: CmmNode O x -> Bool
dont_care CmmComment {}  = True
dont_care CmmTick {}     = True
192
dont_care CmmUnwind {}   = True
Peter Wortmann's avatar
Peter Wortmann committed
193 194
dont_care _other         = False

195 196 197
-- Utilities: equality and substitution on the graph.

-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
198
eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
199
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
200
lookupBid :: LabelMap BlockId -> BlockId -> BlockId
201
lookupBid subst bid = case mapLookup bid subst of
202 203 204
                        Just bid  -> lookupBid subst bid
                        Nothing -> bid

205 206 207 208
-- Middle nodes and expressions can contain BlockIds, in particular in
-- CmmStackSlot and CmmBlock, so we have to use a special equality for
-- these.
--
209 210 211 212 213 214 215 216
eqMiddleWith :: (BlockId -> BlockId -> Bool)
             -> CmmNode O O -> CmmNode O O -> Bool
eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
  = r1 == r2 && eqExprWith eqBid e1 e2
eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
                   (CmmUnsafeForeignCall t2 r2 a2)
217
  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2
218
eqMiddleWith _ _ _ = False
219

220
eqExprWith :: (BlockId -> BlockId -> Bool)
221 222
           -> CmmExpr -> CmmExpr -> Bool
eqExprWith eqBid = eq
223 224 225
 where
  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
226 227
  CmmReg r1          `eq` CmmReg r2          = r1==r2
  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
228 229 230 231
  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
  _e1                `eq` _e2                = False

232
  xs `eqs` ys = eqListWith eq xs ys
233

234 235 236 237 238 239 240
  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
  eqLit l1 l2 = l1 == l2

  eqArea Old Old = True
  eqArea (Young id1) (Young id2) = eqBid id1 id2
  eqArea _ _ = False

Simon Marlow's avatar
Simon Marlow committed
241 242
-- Equality on the body of a block, modulo a function mapping block
-- IDs to block IDs.
243 244
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith eqBid block block'
245 246 247 248
  {-
  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
  -}
Ben Gamari's avatar
Ben Gamari committed
249
  = equal
Simon Marlow's avatar
Simon Marlow committed
250
  where (_,m,l)   = blockSplit block
Peter Wortmann's avatar
Peter Wortmann committed
251
        nodes     = filter (not . dont_care) (blockToList m)
Simon Marlow's avatar
Simon Marlow committed
252
        (_,m',l') = blockSplit block'
Peter Wortmann's avatar
Peter Wortmann committed
253
        nodes'    = filter (not . dont_care) (blockToList m')
254

255
        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&
256 257 258 259 260 261 262 263 264 265 266 267
                eqLastWith eqBid l l'


eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
eqLastWith _ _ _ = False
268 269 270 271 272

eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
eqMaybeWith _ Nothing Nothing = True
eqMaybeWith _ _ _ = False
Peter Wortmann's avatar
Peter Wortmann committed
273

274 275 276 277 278
eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs
eqListWith _ []       []       = True
eqListWith _ _        _        = False

Peter Wortmann's avatar
Peter Wortmann committed
279 280 281 282
-- | Given a block map, ensure that all "target" blocks are covered by
-- the same ticks as the respective "source" blocks. This not only
-- means copying ticks, but also adjusting tick scopes where
-- necessary.
283
copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
Peter Wortmann's avatar
Peter Wortmann committed
284 285
copyTicks env g
  | mapNull env = g
Peter Wortmann's avatar
Peter Wortmann committed
286 287 288
  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
  where -- Reverse block merge map
        blockMap = toBlockMap g
289 290
        revEnv = mapFoldlWithKey insertRev M.empty env
        insertRev m k x = M.insertWith (const (k:)) x [k] m
Peter Wortmann's avatar
Peter Wortmann committed
291 292
        -- Copy ticks and scopes into the given block
        copyTo block = case M.lookup (entryLabel block) revEnv of
Peter Wortmann's avatar
Peter Wortmann committed
293
          Nothing -> block
Peter Wortmann's avatar
Peter Wortmann committed
294 295 296 297 298 299 300
          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
        copy from to =
          let ticks = blockTicks from
              CmmEntry  _   scp0        = firstNode from
              (CmmEntry lbl scp1, code) = blockSplitHead to
          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
             foldr blockCons code (map CmmTick ticks)
301 302

-- Group by [Label]
303 304 305 306 307 308 309 310 311 312
-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
groupByLabel =
  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
    where
      go !m [] = TM.foldTM (:) m []
      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
        where --k' = map (getKey . getUnique) k
              adjust Nothing       = Just (k,[v])
              adjust (Just (_,vs)) = Just (k,v:vs)
313

314
groupByInt :: (a -> Int) -> [a] -> [[a]]
315
groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
316 317 318 319 320
   -- See Note [Unique Determinism and code generation]
  where
    go m x = alterUFM addEntry m (f x)
      where
        addEntry xs = Just $! maybe [x] (x:) xs