PageRenderTime 21ms CodeModel.GetById 10ms app.highlight 7ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/cmm/CmmCommonBlockElim.hs

https://bitbucket.org/carter/ghc
Haskell | 208 lines | 137 code | 36 blank | 35 comment | 29 complexity | a4dc7125b5d68bd9487af338c8a91ec4 MD5 | raw file
  1{-# LANGUAGE GADTs #-}
  2-- ToDo: remove -fno-warn-warnings-deprecations
  3{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
  4-- ToDo: remove -fno-warn-incomplete-patterns
  5{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
  6
  7module CmmCommonBlockElim
  8  ( elimCommonBlocks
  9  )
 10where
 11
 12
 13import BlockId
 14import Cmm
 15import CmmUtils
 16import CmmContFlowOpt
 17import Prelude hiding (iterate, succ, unzip, zip)
 18
 19import Hoopl hiding (ChangeFlag)
 20import Data.Bits
 21import qualified Data.List as List
 22import Data.Word
 23import Outputable
 24import UniqFM
 25
 26my_trace :: String -> SDoc -> a -> a
 27my_trace = if False then pprTrace else \_ _ a -> a
 28
 29-- -----------------------------------------------------------------------------
 30-- Eliminate common blocks
 31
 32-- If two blocks are identical except for the label on the first node,
 33-- then we can eliminate one of the blocks. To ensure that the semantics
 34-- of the program are preserved, we have to rewrite each predecessor of the
 35-- eliminated block to proceed with the block we keep.
 36
 37-- The algorithm iterates over the blocks in the graph,
 38-- checking whether it has seen another block that is equal modulo labels.
 39-- If so, then it adds an entry in a map indicating that the new block
 40-- is made redundant by the old block.
 41-- Otherwise, it is added to the useful blocks.
 42
 43-- TODO: Use optimization fuel
 44elimCommonBlocks :: CmmGraph -> CmmGraph
 45elimCommonBlocks g = replaceLabels env g
 46  where
 47     env = iterate hashed_blocks mapEmpty
 48     hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
 49
 50-- Iterate over the blocks until convergence
 51iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
 52iterate blocks subst =
 53  case foldl common_block (False, emptyUFM, subst) blocks of
 54    (changed,  _, subst)
 55       | changed   -> iterate blocks subst
 56       | otherwise -> subst
 57
 58type State  = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
 59
 60type ChangeFlag = Bool
 61type HashCode = Int
 62
 63-- Try to find a block that is equal (or ``common'') to b.
 64common_block :: State -> (HashCode, CmmBlock) -> State
 65common_block (old_change, bmap, subst) (hash, b) =
 66  case lookupUFM bmap hash of
 67    Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
 68                     mapLookup bid subst) of
 69                 (Just b', Nothing)                         -> addSubst b'
 70                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
 71                                     | otherwise -> (old_change, bmap, subst)
 72                 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
 73    Nothing -> (old_change, addToUFM bmap hash [b], subst)
 74  where bid = entryLabel b
 75        addSubst b' = my_trace "found new common block" (ppr bid <> char '=' <> ppr (entryLabel b')) $
 76                      (True, bmap, mapInsert bid (entryLabel b') subst)
 77
 78
 79-- -----------------------------------------------------------------------------
 80-- Hashing and equality on blocks
 81
 82-- Below here is mostly boilerplate: hashing blocks ignoring labels,
 83-- and comparing blocks modulo a label mapping.
 84
 85-- To speed up comparisons, we hash each basic block modulo labels.
 86-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 87-- but it should be fast and good enough.
 88hash_block :: CmmBlock -> HashCode
 89hash_block block =
 90  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
 91  -- UniqFM doesn't like negative Ints
 92  where hash_fst _ h = h
 93        hash_mid m h = hash_node m + h `shiftL` 1
 94        hash_lst m h = hash_node m + h `shiftL` 1
 95
 96        hash_node :: CmmNode O x -> Word32
 97        hash_node (CmmComment _) = 0 -- don't care
 98        hash_node (CmmAssign r e) = hash_reg r + hash_e e
 99        hash_node (CmmStore e e') = hash_e e + hash_e e'
100        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
101        hash_node (CmmBranch _) = 23 -- NB. ignore the label
102        hash_node (CmmCondBranch p _ _) = hash_e p
103        hash_node (CmmCall e _ _ _ _ _) = hash_e e
104        hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
105        hash_node (CmmSwitch e _) = hash_e e
106
107        hash_reg :: CmmReg -> Word32
108        hash_reg   (CmmLocal _) = 117
109        hash_reg   (CmmGlobal _)    = 19
110
111        hash_e :: CmmExpr -> Word32
112        hash_e (CmmLit l) = hash_lit l
113        hash_e (CmmLoad e _) = 67 + hash_e e
114        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        hash_lit (CmmInt i _) = fromInteger i
121        hash_lit (CmmFloat r _) = truncate r
122        hash_lit (CmmLabel _) = 119 -- ugh
123        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
124        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
125        hash_lit (CmmBlock _) = 191 -- ugh
126        hash_lit (CmmHighStackMark) = cvt 313
127
128        hash_tgt (ForeignTarget e _) = hash_e e
129        hash_tgt (PrimTarget _) = 31 -- lots of these
130
131        hash_list f = foldl (\z x -> f x + z) (0::Word32)
132
133        cvt = fromInteger . toInteger
134-- Utilities: equality and substitution on the graph.
135
136-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
137eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
138eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
139lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
140lookupBid subst bid = case mapLookup bid subst of
141                        Just bid  -> lookupBid subst bid
142                        Nothing -> bid
143
144-- Middle nodes and expressions can contain BlockIds, in particular in
145-- CmmStackSlot and CmmBlock, so we have to use a special equality for
146-- these.
147--
148eqMiddleWith :: (BlockId -> BlockId -> Bool)
149             -> CmmNode O O -> CmmNode O O -> Bool
150eqMiddleWith _ (CmmComment _) (CmmComment _) = True
151eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
152  = r1 == r2 && eqExprWith eqBid e1 e2
153eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
154  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
155eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
156                   (CmmUnsafeForeignCall t2 r2 a2)
157  = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
158eqMiddleWith _ _ _ = False
159
160eqExprWith :: (BlockId -> BlockId -> Bool)
161           -> CmmExpr -> CmmExpr -> Bool
162eqExprWith eqBid = eq
163 where
164  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
165  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
166  CmmReg r1          `eq` CmmReg r2          = r1==r2
167  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
168  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
169  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
170  _e1                `eq` _e2                = False
171
172  xs `eqs` ys = and (zipWith eq xs ys)
173
174  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
175  eqLit l1 l2 = l1 == l2
176
177  eqArea Old Old = True
178  eqArea (Young id1) (Young id2) = eqBid id1 id2
179  eqArea _ _ = False
180
181-- Equality on the body of a block, modulo a function mapping block
182-- IDs to block IDs.
183eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
184eqBlockBodyWith eqBid block block'
185  = and (zipWith (eqMiddleWith eqBid) (blockToList m) (blockToList m')) &&
186    eqLastWith eqBid l l'
187  where (_,m,l)   = blockSplit block
188        (_,m',l') = blockSplit block'
189
190
191
192eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
193eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
194eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
195  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
196eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
197  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
198eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
199  e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
200eqLastWith _ _ _ = False
201
202eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
203eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
204
205eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
206eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
207eqMaybeWith _ Nothing Nothing = True
208eqMaybeWith _ _ _ = False