CmmCommonBlockElim.hs 12 KB
Newer Older
1
{-# LANGUAGE GADTs, BangPatterns #-}
2
module CmmCommonBlockElim
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
3 4 5 6 7
  ( elimCommonBlocks
  )
where


8
import BlockId
9
import Cmm
10
import CmmUtils
11
import CmmSwitch (eqSwitchTargetWith)
Simon Marlow's avatar
Simon Marlow committed
12
import CmmContFlowOpt
13
import Prelude hiding (iterate, succ, unzip, zip)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
14

Simon Marlow's avatar
Simon Marlow committed
15
import Hoopl hiding (ChangeFlag)
16
import Data.Bits
Peter Wortmann's avatar
Peter Wortmann committed
17
import Data.Maybe (mapMaybe)
Ian Lynagh's avatar
Ian Lynagh committed
18
import qualified Data.List as List
19
import Data.Word
Peter Wortmann's avatar
Peter Wortmann committed
20
import qualified Data.Map as M
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
21 22
import Outputable
import UniqFM
23 24
import Unique
import Control.Arrow (first, second)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
25

26 27 28
-- -----------------------------------------------------------------------------
-- Eliminate common blocks

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
29 30 31 32 33 34 35 36 37 38 39
-- 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.

40 41 42 43 44 45 46 47 48 49 50 51 52 53
-- 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.
--
-- The list of outgoing labels is updated as we merge blocks, and only blocks
-- that had different labels before are compared.
--
-- 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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
54 55
-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
Peter Wortmann's avatar
Peter Wortmann committed
56
elimCommonBlocks g = replaceLabels env $ copyTicks env g
57
  where
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
     env = iterate mapEmpty blocks_with_key
     groups = groupBy hash_block (postorderDfs g)
     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]
type Subst = BlockEnv BlockId

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

77 78 79 80 81 82
    merged_blocks :: [[(Key, DistinctBlocks)]]
    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
      where
        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
          where
            (new_subst2, db) = mergeBlockList subst dbs
83

84 85
    subst' = subst `mapUnion` new_substs
    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
86

87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
mergeBlocks subst existing new = go new
  where
    go [] = (mapEmpty, existing)
    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
  where
    go !new_subst1 b [] = (new_subst1, b)
    go !new_subst1 b1 (b2:bs) = go new_subst b bs
      where
        (new_subst2, b) =  mergeBlocks subst b1 b2
        new_subst = new_subst1 `mapUnion` new_subst2
106 107 108 109 110 111 112


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

-- Below here is mostly boilerplate: hashing blocks ignoring labels,
-- and comparing blocks modulo a label mapping.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
113 114 115 116

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

type HashCode = Int

120
hash_block :: CmmBlock -> HashCode
121 122
hash_block block =
  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
123
  -- UniqFM doesn't like negative Ints
124 125 126 127 128
  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
Peter Wortmann's avatar
Peter Wortmann committed
129
        hash_node n | dont_care n = 0 -- don't care
Peter Wortmann's avatar
Peter Wortmann committed
130
        hash_node (CmmUnwind _ e) = hash_e e
131 132 133
        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
134
        hash_node (CmmBranch _) = 23 -- NB. ignore the label
135
        hash_node (CmmCondBranch p _ _) = hash_e p
136
        hash_node (CmmCall e _ _ _ _ _) = hash_e e
137
        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
138
        hash_node (CmmSwitch e _) = hash_e e
Peter Wortmann's avatar
Peter Wortmann committed
139
        hash_node _ = error "hash_node: unknown Cmm node!"
140

141
        hash_reg :: CmmReg -> Word32
142
        hash_reg   (CmmLocal _) = 117
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
143
        hash_reg   (CmmGlobal _)    = 19
144

145
        hash_e :: CmmExpr -> Word32
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
146 147 148
        hash_e (CmmLit l) = hash_lit l
        hash_e (CmmLoad e _) = 67 + hash_e e
        hash_e (CmmReg r) = hash_reg r
149
        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
150
        hash_e (CmmRegOff r i) = hash_reg r + cvt i
151
        hash_e (CmmStackSlot _ _) = 13
152

153
        hash_lit :: CmmLit -> Word32
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
154 155
        hash_lit (CmmInt i _) = fromInteger i
        hash_lit (CmmFloat r _) = truncate r
156
        hash_lit (CmmVec ls) = hash_list hash_lit ls
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
157
        hash_lit (CmmLabel _) = 119 -- ugh
158 159
        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
160
        hash_lit (CmmBlock _) = 191 -- ugh
161
        hash_lit (CmmHighStackMark) = cvt 313
162

163 164
        hash_tgt (ForeignTarget e _) = hash_e e
        hash_tgt (PrimTarget _) = 31 -- lots of these
165 166 167

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

168
        cvt = fromInteger . toInteger
Peter Wortmann's avatar
Peter Wortmann committed
169 170 171 172 173 174 175

-- | Ignore these node types for equality
dont_care :: CmmNode O x -> Bool
dont_care CmmComment {}  = True
dont_care CmmTick {}     = True
dont_care _other         = False

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
176 177 178
-- Utilities: equality and substitution on the graph.

-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
179
eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
180
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
181
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
182
lookupBid subst bid = case mapLookup bid subst of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
183 184 185
                        Just bid  -> lookupBid subst bid
                        Nothing -> bid

186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
-- Middle nodes and expressions can contain BlockIds, in particular in
-- CmmStackSlot and CmmBlock, so we have to use a special equality for
-- these.
--
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)
  = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
eqMiddleWith _ _ _ = False

eqExprWith :: (BlockId -> BlockId -> Bool)
           -> CmmExpr -> CmmExpr -> Bool
eqExprWith eqBid = eq
 where
  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
  CmmReg r1          `eq` CmmReg r2          = r1==r2
  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
  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

  xs `eqs` ys = and (zipWith eq xs ys)

  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
222 223
-- Equality on the body of a block, modulo a function mapping block
-- IDs to block IDs.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
224
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
Simon Marlow's avatar
Simon Marlow committed
225
eqBlockBodyWith eqBid block block'
Peter Wortmann's avatar
Peter Wortmann committed
226
  = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
227
    eqLastWith eqBid l l'
Simon Marlow's avatar
Simon Marlow committed
228
  where (_,m,l)   = blockSplit block
Peter Wortmann's avatar
Peter Wortmann committed
229
        nodes     = filter (not . dont_care) (blockToList m)
Simon Marlow's avatar
Simon Marlow committed
230
        (_,m',l') = blockSplit block'
Peter Wortmann's avatar
Peter Wortmann committed
231
        nodes'    = filter (not . dont_care) (blockToList m')
232

233 234


235 236 237
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) (CmmCondBranch c2 t2 f2) =
238
  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
239 240
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
241 242
eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
243 244 245 246 247 248
eqLastWith _ _ _ = False

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
249 250 251 252 253 254 255 256

-- | 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.
copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
copyTicks env g
  | mapNull env = g
Peter Wortmann's avatar
Peter Wortmann committed
257 258 259
  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
  where -- Reverse block merge map
        blockMap = toBlockMap g
Peter Wortmann's avatar
Peter Wortmann committed
260 261
        revEnv = mapFoldWithKey insertRev M.empty env
        insertRev k x = M.insertWith (const (k:)) x [k]
Peter Wortmann's avatar
Peter Wortmann committed
262 263
        -- Copy ticks and scopes into the given block
        copyTo block = case M.lookup (entryLabel block) revEnv of
Peter Wortmann's avatar
Peter Wortmann committed
264
          Nothing -> block
Peter Wortmann's avatar
Peter Wortmann committed
265 266 267 268 269 270 271
          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)
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318

-- Group by [Label]
groupByLabel :: [(Key, a)] -> [(Key, [a])]
groupByLabel = go emptyILM
  where
    go !m [] = elemsILM m
    go !m ((k,v) : entries) = go (alterILM adjust m k') entries
      where k' = map getUnique k
            adjust Nothing       = Just (k,[v])
            adjust (Just (_,vs)) = Just (k,v:vs)

groupBy :: (a -> Int) -> [a] -> [[a]]
groupBy f xs = eltsUFM $ List.foldl' go emptyUFM xs
  where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)

-- Efficient lookup into [([Unique], a)]
data IntListMap a = ILM (Maybe a) (UniqFM (IntListMap a))

emptyILM :: IntListMap a
emptyILM = ILM Nothing emptyUFM

unitILM :: [Unique] -> a -> IntListMap a
unitILM [] a     = ILM (Just a) emptyUFM
unitILM (l:ls) a = ILM Nothing  (unitUFM l (unitILM ls a))


alterILM :: (Maybe a -> Maybe a) -> IntListMap a -> [Unique] ->  IntListMap a
alterILM f (ILM ma m)  []    = ILM (f ma) m
alterILM f (ILM ma m) (l:ls) = ILM ma (alterUFM go m l)
  where go Nothing    = fmap (unitILM ls) (f Nothing)
        go (Just ilm) = Just $ alterILM f ilm ls

{- currently unused
addToILM :: IntListMap a -> [Unique] -> a -> IntListMap a
addToILM (ILM _ m)  []     a = ILM (Just a) m
addToILM (ILM ma m) (l:ls) a = ILM ma $ alterUFM go m l
  where go Nothing    = Just $ unitILM ls a
        go (Just ilm) = Just $ addToILM ilm ls a

lookupILM :: IntListMap a -> [Unique] -> Maybe a
lookupILM (ILM ma _) [] = ma
lookupILM (ILM _ m) (l:ls) = lookupUFM m l >>= (\m -> lookupILM m ls)
-}

elemsILM :: IntListMap a -> [a]
elemsILM (ILM ma m) = maybe id (:) ma $ concatMap elemsILM $ eltsUFM m