CmmCommonBlockElim.hs 6.63 KB
Newer Older
1
{-# LANGUAGE GADTs #-}
Ian Lynagh's avatar
Ian Lynagh committed
2
-- ToDo: remove -fno-warn-warnings-deprecations
3
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
Ian Lynagh's avatar
Ian Lynagh committed
4
-- ToDo: remove -fno-warn-incomplete-patterns
5 6 7
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module CmmCommonBlockElim
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
8 9 10 11 12
  ( elimCommonBlocks
  )
where


13
import BlockId
14
import Cmm
15
import CmmUtils
Simon Marlow's avatar
Simon Marlow committed
16
import CmmContFlowOpt
17
import Prelude hiding (iterate, succ, unzip, zip)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
18

Simon Marlow's avatar
Simon Marlow committed
19
import Hoopl hiding (ChangeFlag)
20
import Data.Bits
Ian Lynagh's avatar
Ian Lynagh committed
21
import qualified Data.List as List
22
import Data.Word
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
23 24 25 26 27
import FastString
import Outputable
import UniqFM

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

30 31 32
-- -----------------------------------------------------------------------------
-- Eliminate common blocks

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

-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
46 47 48 49
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
50 51

-- Iterate over the blocks until convergence
52 53 54 55 56 57 58 59 60 61 62
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
63 64

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

-- 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.
89
hash_block :: CmmBlock -> HashCode
90 91
hash_block block =
  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
92
  -- UniqFM doesn't like negative Ints
93 94 95 96 97 98 99 100 101
  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 (CmmComment (FastString u _ _ _ _)) = cvt u
        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
102
        hash_node (CmmBranch _) = 23 -- NB. ignore the label
103 104 105 106 107
        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

108
        hash_reg :: CmmReg -> Word32
109
        hash_reg   (CmmLocal _) = 117
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
110
        hash_reg   (CmmGlobal _)    = 19
111

112
        hash_e :: CmmExpr -> Word32
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
113 114 115
        hash_e (CmmLit l) = hash_lit l
        hash_e (CmmLoad e _) = 67 + hash_e e
        hash_e (CmmReg r) = hash_reg r
116
        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
117
        hash_e (CmmRegOff r i) = hash_reg r + cvt i
118
        hash_e (CmmStackSlot _ _) = 13
119

120
        hash_lit :: CmmLit -> Word32
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
121 122 123
        hash_lit (CmmInt i _) = fromInteger i
        hash_lit (CmmFloat r _) = truncate r
        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
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
135 136 137
-- Utilities: equality and substitution on the graph.

-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
138
eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
139
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
140
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
141
lookupBid subst bid = case mapLookup bid subst of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
142 143 144
                        Just bid  -> lookupBid subst bid
                        Nothing -> bid

Simon Marlow's avatar
Simon Marlow committed
145 146
-- 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
147
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
Simon Marlow's avatar
Simon Marlow committed
148 149 150 151
eqBlockBodyWith eqBid block block'
  = blockToList m == blockToList m' && eqLastWith eqBid l l'
  where (_,m,l)   = blockSplit block
        (_,m',l') = blockSplit block'
152 153 154 155

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) =
156
  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
157
eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
158
  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
159 160
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
161 162
eqLastWith _ _ _ = False

163 164
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
165 166 167 168 169

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