Snapshot
[ghc.git] / compiler / cmm / CmmCommonBlockElim.hs
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
7 module CmmCommonBlockElim
8 ( elimCommonBlocks
9 )
10 where
11
12
13 import BlockId
14 import Cmm
15 import CmmUtils
16 import CmmContFlowOpt
17 import Prelude hiding (iterate, succ, unzip, zip)
18
19 import Hoopl hiding (ChangeFlag)
20 import Data.Bits
21 import qualified Data.List as List
22 import Data.Word
23 import FastString
24 import Outputable
25 import UniqFM
26
27 my_trace :: String -> SDoc -> a -> a
28 my_trace = if False then pprTrace else \_ _ a -> a
29
30 -- -----------------------------------------------------------------------------
31 -- Eliminate common blocks
32
33 -- If two blocks are identical except for the label on the first node,
34 -- then we can eliminate one of the blocks. To ensure that the semantics
35 -- of the program are preserved, we have to rewrite each predecessor of the
36 -- eliminated block to proceed with the block we keep.
37
38 -- The algorithm iterates over the blocks in the graph,
39 -- checking whether it has seen another block that is equal modulo labels.
40 -- If so, then it adds an entry in a map indicating that the new block
41 -- is made redundant by the old block.
42 -- Otherwise, it is added to the useful blocks.
43
44 -- TODO: Use optimization fuel
45 elimCommonBlocks :: CmmGraph -> CmmGraph
46 elimCommonBlocks g = replaceLabels env g
47 where
48 env = iterate hashed_blocks mapEmpty
49 hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
50
51 -- Iterate over the blocks until convergence
52 iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
53 iterate blocks subst =
54 case foldl common_block (False, emptyUFM, subst) blocks of
55 (changed, _, subst)
56 | changed -> iterate blocks subst
57 | otherwise -> subst
58
59 type State = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
60
61 type ChangeFlag = Bool
62 type HashCode = Int
63
64 -- Try to find a block that is equal (or ``common'') to b.
65 common_block :: State -> (HashCode, CmmBlock) -> State
66 common_block (old_change, bmap, subst) (hash, b) =
67 case lookupUFM bmap hash of
68 Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
69 mapLookup bid subst) of
70 (Just b', Nothing) -> addSubst b'
71 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
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 (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.
88 hash_block :: CmmBlock -> HashCode
89 hash_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 (FastString u _ _ _ _)) = cvt u
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.
137 eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
138 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
139 lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
140 lookupBid subst bid = case mapLookup bid subst of
141 Just bid -> lookupBid subst bid
142 Nothing -> bid
143
144 -- Equality on the body of a block, modulo a function mapping block
145 -- IDs to block IDs.
146 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
147 eqBlockBodyWith eqBid block block'
148 = blockToList m == blockToList m' && eqLastWith eqBid l l'
149 where (_,m,l) = blockSplit block
150 (_,m',l') = blockSplit block'
151
152 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
153 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
154 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
155 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
156 eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
157 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
158 eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
159 e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
160 eqLastWith _ _ _ = False
161
162 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
163 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
164
165 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
166 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
167 eqMaybeWith _ Nothing Nothing = True
168 eqMaybeWith _ _ _ = False