CmmCommonBlockElim.hs 7.94 KB
Newer Older
1 2
{-# LANGUAGE GADTs #-}
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
Simon Marlow's avatar
Simon Marlow committed
11
import CmmContFlowOpt
12
import Prelude hiding (iterate, succ, unzip, zip)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
13

Simon Marlow's avatar
Simon Marlow committed
14
import Hoopl hiding (ChangeFlag)
15
import Data.Bits
Ian Lynagh's avatar
Ian Lynagh committed
16
import qualified Data.List as List
17
import Data.Word
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
18 19 20 21
import Outputable
import UniqFM

my_trace :: String -> SDoc -> a -> a
22
my_trace = if False then pprTrace else \_ _ a -> a
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
23

24 25 26
-- -----------------------------------------------------------------------------
-- Eliminate common blocks

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
27 28 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.

-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
40 41 42 43
elimCommonBlocks g = replaceLabels env g
  where
     env = iterate hashed_blocks mapEmpty
     hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
44 45

-- Iterate over the blocks until convergence
46 47 48 49 50 51 52 53 54 55 56
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
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
57 58

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

-- 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.
83
hash_block :: CmmBlock -> HashCode
84 85
hash_block block =
  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
86
  -- UniqFM doesn't like negative Ints
87 88 89 90 91
  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
92
        hash_node (CmmComment _) = 0 -- don't care
93 94 95
        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
96
        hash_node (CmmBranch _) = 23 -- NB. ignore the label
97
        hash_node (CmmCondBranch p _ _) = hash_e p
98
        hash_node (CmmCall e _ _ _ _ _) = hash_e e
99 100 101
        hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
        hash_node (CmmSwitch e _) = hash_e e

102
        hash_reg :: CmmReg -> Word32
103
        hash_reg   (CmmLocal _) = 117
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
104
        hash_reg   (CmmGlobal _)    = 19
105

106
        hash_e :: CmmExpr -> Word32
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
107 108 109
        hash_e (CmmLit l) = hash_lit l
        hash_e (CmmLoad e _) = 67 + hash_e e
        hash_e (CmmReg r) = hash_reg r
110
        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
111
        hash_e (CmmRegOff r i) = hash_reg r + cvt i
112
        hash_e (CmmStackSlot _ _) = 13
113

114
        hash_lit :: CmmLit -> Word32
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
115 116
        hash_lit (CmmInt i _) = fromInteger i
        hash_lit (CmmFloat r _) = truncate r
117
        hash_lit (CmmVec ls) = hash_list hash_lit ls
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
118
        hash_lit (CmmLabel _) = 119 -- ugh
119 120
        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
121
        hash_lit (CmmBlock _) = 191 -- ugh
122
        hash_lit (CmmHighStackMark) = cvt 313
123

124 125
        hash_tgt (ForeignTarget e _) = hash_e e
        hash_tgt (PrimTarget _) = 31 -- lots of these
126 127 128

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

129
        cvt = fromInteger . toInteger
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
130 131 132
-- Utilities: equality and substitution on the graph.

-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
133
eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
134
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
135
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
136
lookupBid subst bid = case mapLookup bid subst of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
137 138 139
                        Just bid  -> lookupBid subst bid
                        Nothing -> bid

140 141 142 143 144 145
-- 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
146
eqMiddleWith _ (CmmComment _) (CmmComment _) = True
147 148 149 150 151 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
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
177 178
-- 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
179
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
Simon Marlow's avatar
Simon Marlow committed
180
eqBlockBodyWith eqBid block block'
181 182
  = and (zipWith (eqMiddleWith eqBid) (blockToList m) (blockToList m')) &&
    eqLastWith eqBid l l'
Simon Marlow's avatar
Simon Marlow committed
183 184
  where (_,m,l)   = blockSplit block
        (_,m',l') = blockSplit block'
185

186 187


188 189 190
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) =
191
  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
192 193
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
194 195
eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
  e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
196 197
eqLastWith _ _ _ = False

198 199
eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
200 201 202 203 204

eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
eqMaybeWith _ Nothing Nothing = True
eqMaybeWith _ _ _ = False