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