CmmCommonBlockElim.hs 9.31 KB
Newer Older
1 2
{-# LANGUAGE GADTs #-}
module CmmCommonBlockElim
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)
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)
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
21 22 23 24
import Outputable
import UniqFM

my_trace :: String -> SDoc -> a -> a
25
my_trace = if False then pprTrace else \_ _ a -> a
26

27 28 29
-- -----------------------------------------------------------------------------
-- Eliminate common blocks

30 31 32 33 34 35 36 37 38 39 40 41 42
-- 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.

-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
Peter Wortmann's avatar
Peter Wortmann committed
43
elimCommonBlocks g = replaceLabels env $ copyTicks env g
44 45 46
  where
     env = iterate hashed_blocks mapEmpty
     hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
47 48

-- Iterate over the blocks until convergence
49 50 51 52 53 54 55 56 57 58 59
iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
iterate blocks subst =
  case foldl common_block (False, emptyUFM, subst) blocks of
    (changed,  _, subst)
       | changed   -> iterate blocks subst
       | otherwise -> subst

type State  = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)

type ChangeFlag = Bool
type HashCode = Int
60 61

-- Try to find a block that is equal (or ``common'') to b.
62 63
common_block :: State -> (HashCode, CmmBlock) -> State
common_block (old_change, bmap, subst) (hash, b) =
64
  case lookupUFM bmap hash of
65
    Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
66 67 68
                     mapLookup bid subst) of
                 (Just b', Nothing)                         -> addSubst b'
                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
69
                                     | otherwise -> (old_change, bmap, subst)
70
                 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
Simon Marlow's avatar
Simon Marlow committed
71
    Nothing -> (old_change, addToUFM bmap hash [b], subst)
72
  where bid = entryLabel b
73
        addSubst b' = my_trace "found new common block" (ppr bid <> char '=' <> ppr (entryLabel b')) $
74 75 76 77 78 79 80 81
                      (True, bmap, mapInsert bid (entryLabel b') subst)


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

-- Below here is mostly boilerplate: hashing blocks ignoring labels,
-- and comparing blocks modulo a label mapping.
82 83 84 85

-- 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.
86
hash_block :: CmmBlock -> HashCode
87 88
hash_block block =
  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
89
  -- UniqFM doesn't like negative Ints
90 91 92 93 94
  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
95
        hash_node n | dont_care n = 0 -- don't care
96
        hash_node (CmmUnwind _ e) = hash_e e
97 98 99
        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
100
        hash_node (CmmBranch _) = 23 -- NB. ignore the label
101
        hash_node (CmmCondBranch p _ _) = hash_e p
102
        hash_node (CmmCall e _ _ _ _ _) = hash_e e
103
        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
104
        hash_node (CmmSwitch e _) = hash_e e
Peter Wortmann's avatar
Peter Wortmann committed
105
        hash_node _ = error "hash_node: unknown Cmm node!"
106

107
        hash_reg :: CmmReg -> Word32
108
        hash_reg   (CmmLocal _) = 117
109
        hash_reg   (CmmGlobal _)    = 19
110

111
        hash_e :: CmmExpr -> Word32
112 113 114
        hash_e (CmmLit l) = hash_lit l
        hash_e (CmmLoad e _) = 67 + hash_e e
        hash_e (CmmReg r) = hash_reg r
115
        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
116
        hash_e (CmmRegOff r i) = hash_reg r + cvt i
117
        hash_e (CmmStackSlot _ _) = 13
118

119
        hash_lit :: CmmLit -> Word32
120 121
        hash_lit (CmmInt i _) = fromInteger i
        hash_lit (CmmFloat r _) = truncate r
122
        hash_lit (CmmVec ls) = hash_list hash_lit ls
123
        hash_lit (CmmLabel _) = 119 -- ugh
124 125
        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
126
        hash_lit (CmmBlock _) = 191 -- ugh
127
        hash_lit (CmmHighStackMark) = cvt 313
128

129 130
        hash_tgt (ForeignTarget e _) = hash_e e
        hash_tgt (PrimTarget _) = 31 -- lots of these
131 132 133

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

134
        cvt = fromInteger . toInteger
Peter Wortmann's avatar
Peter Wortmann committed
135 136 137 138 139 140 141

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

142 143 144
-- Utilities: equality and substitution on the graph.

-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
145
eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
146
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
147
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
148
lookupBid subst bid = case mapLookup bid subst of
149 150 151
                        Just bid  -> lookupBid subst bid
                        Nothing -> bid

152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
-- 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
188 189
-- Equality on the body of a block, modulo a function mapping block
-- IDs to block IDs.
190
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
Simon Marlow's avatar
Simon Marlow committed
191
eqBlockBodyWith eqBid block block'
Peter Wortmann's avatar
Peter Wortmann committed
192
  = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
193
    eqLastWith eqBid l l'
Simon Marlow's avatar
Simon Marlow committed
194
  where (_,m,l)   = blockSplit block
Peter Wortmann's avatar
Peter Wortmann committed
195
        nodes     = filter (not . dont_care) (blockToList m)
Simon Marlow's avatar
Simon Marlow committed
196
        (_,m',l') = blockSplit block'
Peter Wortmann's avatar
Peter Wortmann committed
197
        nodes'    = filter (not . dont_care) (blockToList m')
198

199 200


201 202 203
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) =
204
  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
205 206
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
207 208
eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
209 210 211 212 213 214
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
215 216 217 218 219 220 221 222

-- | 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
223 224 225
  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
  where -- Reverse block merge map
        blockMap = toBlockMap g
Peter Wortmann's avatar
Peter Wortmann committed
226 227
        revEnv = mapFoldWithKey insertRev M.empty env
        insertRev k x = M.insertWith (const (k:)) x [k]
Peter Wortmann's avatar
Peter Wortmann committed
228 229
        -- Copy ticks and scopes into the given block
        copyTo block = case M.lookup (entryLabel block) revEnv of
Peter Wortmann's avatar
Peter Wortmann committed
230
          Nothing -> block
Peter Wortmann's avatar
Peter Wortmann committed
231 232 233 234 235 236 237
          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)