CmmCommonBlockElim: Improve hash function
[ghc.git] / compiler / cmm / CmmCommonBlockElim.hs
1 {-# LANGUAGE GADTs, BangPatterns #-}
2 module CmmCommonBlockElim
3 ( elimCommonBlocks
4 )
5 where
6
7
8 import BlockId
9 import Cmm
10 import CmmUtils
11 import CmmSwitch (eqSwitchTargetWith)
12 import CmmContFlowOpt
13 -- import PprCmm ()
14 import Prelude hiding (iterate, succ, unzip, zip)
15
16 import Hoopl hiding (ChangeFlag)
17 import Data.Bits
18 import Data.Maybe (mapMaybe)
19 import qualified Data.List as List
20 import Data.Word
21 import qualified Data.Map as M
22 import Outputable
23 import UniqFM
24 import Unique
25 import Control.Arrow (first, second)
26
27 -- -----------------------------------------------------------------------------
28 -- Eliminate common blocks
29
30 -- If two blocks are identical except for the label on the first node,
31 -- then we can eliminate one of the blocks. To ensure that the semantics
32 -- of the program are preserved, we have to rewrite each predecessor of the
33 -- eliminated block to proceed with the block we keep.
34
35 -- The algorithm iterates over the blocks in the graph,
36 -- checking whether it has seen another block that is equal modulo labels.
37 -- If so, then it adds an entry in a map indicating that the new block
38 -- is made redundant by the old block.
39 -- Otherwise, it is added to the useful blocks.
40
41 -- To avoid comparing every block with every other block repeatedly, we group
42 -- them by
43 -- * a hash of the block, ignoring labels (explained below)
44 -- * the list of outgoing labels
45 -- The hash is invariant under relabeling, so we only ever compare within
46 -- the same group of blocks.
47 --
48 -- The list of outgoing labels is updated as we merge blocks (that is why they
49 -- are not included in the hash, which we want to calculate only once).
50 --
51 -- All in all, two blocks should never be compared if they have different
52 -- hashes, and at most once otherwise. Previously, we were slower, and people
53 -- rightfully complained: #10397
54
55 -- TODO: Use optimization fuel
56 elimCommonBlocks :: CmmGraph -> CmmGraph
57 elimCommonBlocks g = replaceLabels env $ copyTicks env g
58 where
59 env = iterate mapEmpty blocks_with_key
60 groups = groupByInt hash_block (postorderDfs g)
61 blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
62
63 -- Invariant: The blocks in the list are pairwise distinct
64 -- (so avoid comparing them again)
65 type DistinctBlocks = [CmmBlock]
66 type Key = [Label]
67 type Subst = BlockEnv BlockId
68
69 -- The outer list groups by hash. We retain this grouping throughout.
70 iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
71 iterate subst blocks
72 | mapNull new_substs = subst
73 | otherwise = iterate subst' updated_blocks
74 where
75 grouped_blocks :: [[(Key, [DistinctBlocks])]]
76 grouped_blocks = map groupByLabel blocks
77
78 merged_blocks :: [[(Key, DistinctBlocks)]]
79 (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
80 where
81 go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
82 where
83 (new_subst2, db) = mergeBlockList subst dbs
84
85 subst' = subst `mapUnion` new_substs
86 updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
87
88 mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
89 mergeBlocks subst existing new = go new
90 where
91 go [] = (mapEmpty, existing)
92 go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
93 -- This block is a duplicate. Drop it, and add it to the substitution
94 Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
95 -- This block is not a duplicate, keep it.
96 Nothing -> second (b:) $ go bs
97
98 mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
99 mergeBlockList _ [] = pprPanic "mergeBlockList" empty
100 mergeBlockList subst (b:bs) = go mapEmpty b bs
101 where
102 go !new_subst1 b [] = (new_subst1, b)
103 go !new_subst1 b1 (b2:bs) = go new_subst b bs
104 where
105 (new_subst2, b) = mergeBlocks subst b1 b2
106 new_subst = new_subst1 `mapUnion` new_subst2
107
108
109 -- -----------------------------------------------------------------------------
110 -- Hashing and equality on blocks
111
112 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
113 -- and comparing blocks modulo a label mapping.
114
115 -- To speed up comparisons, we hash each basic block modulo jump labels.
116 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
117 -- but it should be fast and good enough.
118
119 -- We want to get as many small buckets as possible, as comparing blocks is
120 -- expensive. So include as much as possible in the hash. Ideally everything
121 -- that is compared with (==) in eqBlockBodyWith.
122
123 type HashCode = Int
124
125 hash_block :: CmmBlock -> HashCode
126 hash_block block =
127 fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
128 -- UniqFM doesn't like negative Ints
129 where hash_fst _ h = h
130 hash_mid m h = hash_node m + h `shiftL` 1
131 hash_lst m h = hash_node m + h `shiftL` 1
132
133 hash_node :: CmmNode O x -> Word32
134 hash_node n | dont_care n = 0 -- don't care
135 hash_node (CmmUnwind _ e) = hash_e e
136 hash_node (CmmAssign r e) = hash_reg r + hash_e e
137 hash_node (CmmStore e e') = hash_e e + hash_e e'
138 hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
139 hash_node (CmmBranch _) = 23 -- NB. ignore the label
140 hash_node (CmmCondBranch p _ _) = hash_e p
141 hash_node (CmmCall e _ _ _ _ _) = hash_e e
142 hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
143 hash_node (CmmSwitch e _) = hash_e e
144 hash_node _ = error "hash_node: unknown Cmm node!"
145
146 hash_reg :: CmmReg -> Word32
147 hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
148 hash_reg (CmmGlobal _) = 19
149
150 hash_e :: CmmExpr -> Word32
151 hash_e (CmmLit l) = hash_lit l
152 hash_e (CmmLoad e _) = 67 + hash_e e
153 hash_e (CmmReg r) = hash_reg r
154 hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
155 hash_e (CmmRegOff r i) = hash_reg r + cvt i
156 hash_e (CmmStackSlot _ _) = 13
157
158 hash_lit :: CmmLit -> Word32
159 hash_lit (CmmInt i _) = fromInteger i
160 hash_lit (CmmFloat r _) = truncate r
161 hash_lit (CmmVec ls) = hash_list hash_lit ls
162 hash_lit (CmmLabel _) = 119 -- ugh
163 hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
164 hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
165 hash_lit (CmmBlock _) = 191 -- ugh
166 hash_lit (CmmHighStackMark) = cvt 313
167
168 hash_tgt (ForeignTarget e _) = hash_e e
169 hash_tgt (PrimTarget _) = 31 -- lots of these
170
171 hash_list f = foldl (\z x -> f x + z) (0::Word32)
172
173 cvt = fromInteger . toInteger
174
175 hash_unique :: Uniquable a => a -> Word32
176 hash_unique = cvt . getKey . getUnique
177
178 -- | Ignore these node types for equality
179 dont_care :: CmmNode O x -> Bool
180 dont_care CmmComment {} = True
181 dont_care CmmTick {} = True
182 dont_care _other = False
183
184 -- Utilities: equality and substitution on the graph.
185
186 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
187 eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool
188 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
189 lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
190 lookupBid subst bid = case mapLookup bid subst of
191 Just bid -> lookupBid subst bid
192 Nothing -> bid
193
194 -- Middle nodes and expressions can contain BlockIds, in particular in
195 -- CmmStackSlot and CmmBlock, so we have to use a special equality for
196 -- these.
197 --
198 eqMiddleWith :: (BlockId -> BlockId -> Bool)
199 -> CmmNode O O -> CmmNode O O -> Bool
200 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
201 = r1 == r2 && eqExprWith eqBid e1 e2
202 eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
203 = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
204 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
205 (CmmUnsafeForeignCall t2 r2 a2)
206 = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
207 eqMiddleWith _ _ _ = False
208
209 eqExprWith :: (BlockId -> BlockId -> Bool)
210 -> CmmExpr -> CmmExpr -> Bool
211 eqExprWith eqBid = eq
212 where
213 CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2
214 CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2
215 CmmReg r1 `eq` CmmReg r2 = r1==r2
216 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2
217 CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2
218 CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
219 _e1 `eq` _e2 = False
220
221 xs `eqs` ys = and (zipWith eq xs ys)
222
223 eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
224 eqLit l1 l2 = l1 == l2
225
226 eqArea Old Old = True
227 eqArea (Young id1) (Young id2) = eqBid id1 id2
228 eqArea _ _ = False
229
230 -- Equality on the body of a block, modulo a function mapping block
231 -- IDs to block IDs.
232 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
233 eqBlockBodyWith eqBid block block'
234 {-
235 | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True
236 | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
237 -}
238 = equal
239 where (_,m,l) = blockSplit block
240 nodes = filter (not . dont_care) (blockToList m)
241 (_,m',l') = blockSplit block'
242 nodes' = filter (not . dont_care) (blockToList m')
243
244 equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
245 eqLastWith eqBid l l'
246
247
248 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
249 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
250 eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
251 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
252 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
253 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
254 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
255 e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
256 eqLastWith _ _ _ = False
257
258 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
259 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
260 eqMaybeWith _ Nothing Nothing = True
261 eqMaybeWith _ _ _ = False
262
263 -- | Given a block map, ensure that all "target" blocks are covered by
264 -- the same ticks as the respective "source" blocks. This not only
265 -- means copying ticks, but also adjusting tick scopes where
266 -- necessary.
267 copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
268 copyTicks env g
269 | mapNull env = g
270 | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
271 where -- Reverse block merge map
272 blockMap = toBlockMap g
273 revEnv = mapFoldWithKey insertRev M.empty env
274 insertRev k x = M.insertWith (const (k:)) x [k]
275 -- Copy ticks and scopes into the given block
276 copyTo block = case M.lookup (entryLabel block) revEnv of
277 Nothing -> block
278 Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
279 copy from to =
280 let ticks = blockTicks from
281 CmmEntry _ scp0 = firstNode from
282 (CmmEntry lbl scp1, code) = blockSplitHead to
283 in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
284 foldr blockCons code (map CmmTick ticks)
285
286 -- Group by [Label]
287 groupByLabel :: [(Key, a)] -> [(Key, [a])]
288 groupByLabel = go M.empty
289 where
290 go !m [] = M.elems m
291 go !m ((k,v) : entries) = go (M.alter adjust k' m) entries
292 where k' = map getUnique k
293 adjust Nothing = Just (k,[v])
294 adjust (Just (_,vs)) = Just (k,v:vs)
295
296
297 groupByInt :: (a -> Int) -> [a] -> [[a]]
298 groupByInt f xs = eltsUFM $ List.foldl' go emptyUFM xs
299 where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)