CmmCommonBlockElim.hs 6.61 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
16
import Prelude hiding (iterate, succ, unzip, zip)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
17

18
import Compiler.Hoopl
19
import Data.Bits
Ian Lynagh's avatar
Ian Lynagh committed
20
import qualified Data.List as List
21
import Data.Word
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
22
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
23
import Control.Monad
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
24 25 26 27 28
import Outputable
import UniqFM
import Unique

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

31 32 33
-- -----------------------------------------------------------------------------
-- Eliminate common blocks

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
34 35 36 37 38 39 40 41 42 43 44 45 46
-- 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
47 48 49 50
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
51 52

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

-- Try to find a block that is equal (or ``common'') to b.
66 67
common_block :: State -> (HashCode, CmmBlock) -> State
common_block (old_change, bmap, subst) (hash, b) =
68
  case lookupUFM bmap hash of
Ian Lynagh's avatar
Ian Lynagh committed
69
    Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
70 71 72
                     mapLookup bid subst) of
                 (Just b', Nothing)                         -> addSubst b'
                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
73 74
                 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
    Nothing -> (old_change, (addToUFM bmap hash [b], subst))
75 76
  where bid = entryLabel b
        addSubst b' = my_trace "found new common block" (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 145 146
                        Just bid  -> lookupBid subst bid
                        Nothing -> bid

-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
147 148 149 150 151 152 153
eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
  where (_, middles , JustC last  :: MaybeC C (CmmNode O C)) = blockToNodeList block
        (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'

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

161 162
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
163 164 165 166 167

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