PageRenderTime 55ms CodeModel.GetById 29ms RepoModel.GetById 0ms app.codeStats 0ms

/compiler/cmm/CmmCommonBlockElim.hs

https://bitbucket.org/khibino/ghc-hack
Haskell | 175 lines | 125 code | 24 blank | 26 comment | 22 complexity | 94c488dd60ef25f4cbf0b6096eaba769 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0
  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. module CmmCommonBlockElim
  7. ( elimCommonBlocks
  8. )
  9. where
  10. import BlockId
  11. import Cmm
  12. import CmmUtils
  13. import Prelude hiding (iterate, succ, unzip, zip)
  14. import Compiler.Hoopl
  15. import Data.Bits
  16. import qualified Data.List as List
  17. import Data.Word
  18. import FastString
  19. import Control.Monad
  20. import Outputable
  21. import UniqFM
  22. import Unique
  23. my_trace :: String -> SDoc -> a -> a
  24. my_trace = if False then pprTrace else \_ _ a -> a
  25. -- Eliminate common blocks:
  26. -- If two blocks are identical except for the label on the first node,
  27. -- then we can eliminate one of the blocks. To ensure that the semantics
  28. -- of the program are preserved, we have to rewrite each predecessor of the
  29. -- eliminated block to proceed with the block we keep.
  30. -- The algorithm iterates over the blocks in the graph,
  31. -- checking whether it has seen another block that is equal modulo labels.
  32. -- If so, then it adds an entry in a map indicating that the new block
  33. -- is made redundant by the old block.
  34. -- Otherwise, it is added to the useful blocks.
  35. -- TODO: Use optimization fuel
  36. elimCommonBlocks :: CmmGraph -> CmmGraph
  37. elimCommonBlocks g =
  38. upd_graph g . snd $ iterate common_block reset hashed_blocks
  39. (emptyUFM, mapEmpty)
  40. where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
  41. reset (_, subst) = (emptyUFM, subst)
  42. -- Iterate over the blocks until convergence
  43. iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
  44. iterate upd reset blocks state =
  45. case foldl upd' (False, state) blocks of
  46. (True, state') -> iterate upd reset blocks (reset state')
  47. (False, state') -> state'
  48. where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
  49. -- Try to find a block that is equal (or ``common'') to b.
  50. type BidMap = BlockEnv BlockId
  51. type State = (UniqFM [CmmBlock], BidMap)
  52. common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State)
  53. common_block (bmap, subst) (hash, b) =
  54. case lookupUFM bmap hash of
  55. Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
  56. mapLookup bid subst) of
  57. (Just b', Nothing) -> addSubst b'
  58. (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
  59. _ -> (False, (addToUFM bmap hash (b : bs), subst))
  60. Nothing -> (False, (addToUFM bmap hash [b], subst))
  61. where bid = entryLabel b
  62. addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
  63. (True, (bmap, mapInsert bid (entryLabel b') subst))
  64. -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
  65. upd_graph :: CmmGraph -> BidMap -> CmmGraph
  66. upd_graph g subst = mapGraphNodes (id, middle, last) g
  67. where middle = mapExpDeep exp
  68. last l = last' (mapExpDeep exp l)
  69. last' :: CmmNode O C -> CmmNode O C
  70. last' (CmmBranch bid) = CmmBranch $ sub bid
  71. last' (CmmCondBranch p t f) = cond p (sub t) (sub f)
  72. last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
  73. last' l@(CmmCall _ Nothing _ _ _) = l
  74. last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
  75. last' (CmmSwitch e bs) = CmmSwitch e $ map (liftM sub) bs
  76. cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
  77. exp (CmmStackSlot (CallArea (Young id)) off) =
  78. CmmStackSlot (CallArea (Young (sub id))) off
  79. exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
  80. exp e = e
  81. sub = lookupBid subst
  82. -- To speed up comparisons, we hash each basic block modulo labels.
  83. -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
  84. -- but it should be fast and good enough.
  85. hash_block :: CmmBlock -> Int
  86. hash_block block =
  87. fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
  88. -- UniqFM doesn't like negative Ints
  89. where hash_fst _ h = h
  90. hash_mid m h = hash_node m + h `shiftL` 1
  91. hash_lst m h = hash_node m + h `shiftL` 1
  92. hash_node :: CmmNode O x -> Word32
  93. hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
  94. hash_node (CmmAssign r e) = hash_reg r + hash_e e
  95. hash_node (CmmStore e e') = hash_e e + hash_e e'
  96. hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
  97. hash_node (CmmBranch _) = 23 -- would be great to hash these properly
  98. hash_node (CmmCondBranch p _ _) = hash_e p
  99. hash_node (CmmCall e _ _ _ _) = hash_e e
  100. hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
  101. hash_node (CmmSwitch e _) = hash_e e
  102. hash_reg :: CmmReg -> Word32
  103. hash_reg (CmmLocal _) = 117
  104. hash_reg (CmmGlobal _) = 19
  105. hash_e :: CmmExpr -> Word32
  106. hash_e (CmmLit l) = hash_lit l
  107. hash_e (CmmLoad e _) = 67 + hash_e e
  108. hash_e (CmmReg r) = hash_reg r
  109. hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
  110. hash_e (CmmRegOff r i) = hash_reg r + cvt i
  111. hash_e (CmmStackSlot _ _) = 13
  112. hash_lit :: CmmLit -> Word32
  113. hash_lit (CmmInt i _) = fromInteger i
  114. hash_lit (CmmFloat r _) = truncate r
  115. hash_lit (CmmLabel _) = 119 -- ugh
  116. hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
  117. hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
  118. hash_lit (CmmBlock _) = 191 -- ugh
  119. hash_lit (CmmHighStackMark) = cvt 313
  120. hash_tgt (ForeignTarget e _) = hash_e e
  121. hash_tgt (PrimTarget _) = 31 -- lots of these
  122. hash_list f = foldl (\z x -> f x + z) (0::Word32)
  123. cvt = fromInteger . toInteger
  124. -- Utilities: equality and substitution on the graph.
  125. -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
  126. eqBid :: BidMap -> BlockId -> BlockId -> Bool
  127. eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
  128. lookupBid :: BidMap -> BlockId -> BlockId
  129. lookupBid subst bid = case mapLookup bid subst of
  130. Just bid -> lookupBid subst bid
  131. Nothing -> bid
  132. -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
  133. eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
  134. eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
  135. where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block
  136. (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
  137. eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
  138. eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
  139. eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
  140. c1 == c2 && eqBid t1 t2 && eqBid f1 f2
  141. eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
  142. t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
  143. eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
  144. e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
  145. eqLastWith _ _ _ = False
  146. eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
  147. eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
  148. eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
  149. eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
  150. eqMaybeWith _ Nothing Nothing = True
  151. eqMaybeWith _ _ _ = False