Merge branch 'refs/heads/vect-avoid' into vect-avoid-merge
[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 Outputable
24 import UniqFM
25
26 my_trace :: String -> SDoc -> a -> a
27 my_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
44 elimCommonBlocks :: CmmGraph -> CmmGraph
45 elimCommonBlocks 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
51 iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
52 iterate blocks subst =
53 case foldl common_block (False, emptyUFM, subst) blocks of
54 (changed, _, subst)
55 | changed -> iterate blocks subst
56 | otherwise -> subst
57
58 type State = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
59
60 type ChangeFlag = Bool
61 type HashCode = Int
62
63 -- Try to find a block that is equal (or ``common'') to b.
64 common_block :: State -> (HashCode, CmmBlock) -> State
65 common_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.
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 _) = 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 (CmmVec ls) = hash_list hash_lit ls
123 hash_lit (CmmLabel _) = 119 -- ugh
124 hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
125 hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
126 hash_lit (CmmBlock _) = 191 -- ugh
127 hash_lit (CmmHighStackMark) = cvt 313
128
129 hash_tgt (ForeignTarget e _) = hash_e e
130 hash_tgt (PrimTarget _) = 31 -- lots of these
131
132 hash_list f = foldl (\z x -> f x + z) (0::Word32)
133
134 cvt = fromInteger . toInteger
135 -- Utilities: equality and substitution on the graph.
136
137 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
138 eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
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
142 Just bid -> lookupBid subst bid
143 Nothing -> bid
144
145 -- Middle nodes and expressions can contain BlockIds, in particular in
146 -- CmmStackSlot and CmmBlock, so we have to use a special equality for
147 -- these.
148 --
149 eqMiddleWith :: (BlockId -> BlockId -> Bool)
150 -> CmmNode O O -> CmmNode O O -> Bool
151 eqMiddleWith _ (CmmComment _) (CmmComment _) = True
152 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
153 = r1 == r2 && eqExprWith eqBid e1 e2
154 eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
155 = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
156 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
157 (CmmUnsafeForeignCall t2 r2 a2)
158 = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
159 eqMiddleWith _ _ _ = False
160
161 eqExprWith :: (BlockId -> BlockId -> Bool)
162 -> CmmExpr -> CmmExpr -> Bool
163 eqExprWith eqBid = eq
164 where
165 CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2
166 CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2
167 CmmReg r1 `eq` CmmReg r2 = r1==r2
168 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2
169 CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2
170 CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
171 _e1 `eq` _e2 = False
172
173 xs `eqs` ys = and (zipWith eq xs ys)
174
175 eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
176 eqLit l1 l2 = l1 == l2
177
178 eqArea Old Old = True
179 eqArea (Young id1) (Young id2) = eqBid id1 id2
180 eqArea _ _ = False
181
182 -- Equality on the body of a block, modulo a function mapping block
183 -- IDs to block IDs.
184 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
185 eqBlockBodyWith eqBid block block'
186 = and (zipWith (eqMiddleWith eqBid) (blockToList m) (blockToList m')) &&
187 eqLastWith eqBid l l'
188 where (_,m,l) = blockSplit block
189 (_,m',l') = blockSplit block'
190
191
192
193 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
194 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
195 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
196 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
197 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
198 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
199 eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
200 e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
201 eqLastWith _ _ _ = False
202
203 eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
204 eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
205
206 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
207 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
208 eqMaybeWith _ Nothing Nothing = True
209 eqMaybeWith _ _ _ = False