Add support for producing position-independent executables
[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.Block
17 import Hoopl.Graph
18 import Hoopl.Label
19 import Hoopl.Collections
20 import Data.Bits
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 Outputable
26 import UniqFM
27 import UniqDFM
28 import qualified TrieMap as TM
29 import 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 groups = groupByInt hash_block (postorderDfs g)
66 blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
67
68 -- Invariant: The blocks in the list are pairwise distinct
69 -- (so avoid comparing them again)
70 type DistinctBlocks = [CmmBlock]
71 type Key = [Label]
72 type Subst = LabelMap BlockId
73
74 -- The outer list groups by hash. We retain this grouping throughout.
75 iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
76 iterate subst blocks
77 | mapNull new_substs = subst
78 | otherwise = iterate subst' updated_blocks
79 where
80 grouped_blocks :: [[(Key, [DistinctBlocks])]]
81 grouped_blocks = map groupByLabel blocks
82
83 merged_blocks :: [[(Key, DistinctBlocks)]]
84 (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
85 where
86 go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
87 where
88 (new_subst2, db) = mergeBlockList subst dbs
89
90 subst' = subst `mapUnion` new_substs
91 updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
92
93 mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
94 mergeBlocks subst existing new = go new
95 where
96 go [] = (mapEmpty, existing)
97 go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
98 -- This block is a duplicate. Drop it, and add it to the substitution
99 Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
100 -- This block is not a duplicate, keep it.
101 Nothing -> second (b:) $ go bs
102
103 mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
104 mergeBlockList _ [] = pprPanic "mergeBlockList" empty
105 mergeBlockList subst (b:bs) = go mapEmpty b bs
106 where
107 go !new_subst1 b [] = (new_subst1, b)
108 go !new_subst1 b1 (b2:bs) = go new_subst b bs
109 where
110 (new_subst2, b) = mergeBlocks subst b1 b2
111 new_subst = new_subst1 `mapUnion` new_subst2
112
113
114 -- -----------------------------------------------------------------------------
115 -- Hashing and equality on blocks
116
117 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
118 -- and comparing blocks modulo a label mapping.
119
120 -- To speed up comparisons, we hash each basic block modulo jump labels.
121 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
122 -- but it should be fast and good enough.
123
124 -- We want to get as many small buckets as possible, as comparing blocks is
125 -- expensive. So include as much as possible in the hash. Ideally everything
126 -- that is compared with (==) in eqBlockBodyWith.
127
128 type HashCode = Int
129
130 hash_block :: CmmBlock -> HashCode
131 hash_block block =
132 fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
133 -- UniqFM doesn't like negative Ints
134 where hash_fst _ h = h
135 hash_mid m h = hash_node m + h `shiftL` 1
136 hash_lst m h = hash_node m + h `shiftL` 1
137
138 hash_node :: CmmNode O x -> Word32
139 hash_node n | dont_care n = 0 -- don't care
140 hash_node (CmmAssign r e) = hash_reg r + hash_e e
141 hash_node (CmmStore e e') = hash_e e + hash_e e'
142 hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
143 hash_node (CmmBranch _) = 23 -- NB. ignore the label
144 hash_node (CmmCondBranch p _ _ _) = hash_e p
145 hash_node (CmmCall e _ _ _ _ _) = hash_e e
146 hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
147 hash_node (CmmSwitch e _) = hash_e e
148 hash_node _ = error "hash_node: unknown Cmm node!"
149
150 hash_reg :: CmmReg -> Word32
151 hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
152 hash_reg (CmmGlobal _) = 19
153
154 hash_e :: CmmExpr -> Word32
155 hash_e (CmmLit l) = hash_lit l
156 hash_e (CmmLoad e _) = 67 + hash_e e
157 hash_e (CmmReg r) = hash_reg r
158 hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
159 hash_e (CmmRegOff r i) = hash_reg r + cvt i
160 hash_e (CmmStackSlot _ _) = 13
161
162 hash_lit :: CmmLit -> Word32
163 hash_lit (CmmInt i _) = fromInteger i
164 hash_lit (CmmFloat r _) = truncate r
165 hash_lit (CmmVec ls) = hash_list hash_lit ls
166 hash_lit (CmmLabel _) = 119 -- ugh
167 hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
168 hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
169 hash_lit (CmmBlock _) = 191 -- ugh
170 hash_lit (CmmHighStackMark) = cvt 313
171
172 hash_tgt (ForeignTarget e _) = hash_e e
173 hash_tgt (PrimTarget _) = 31 -- lots of these
174
175 hash_list f = foldl (\z x -> f x + z) (0::Word32)
176
177 cvt = fromInteger . toInteger
178
179 hash_unique :: Uniquable a => a -> Word32
180 hash_unique = cvt . getKey . getUnique
181
182 -- | Ignore these node types for equality
183 dont_care :: CmmNode O x -> Bool
184 dont_care CmmComment {} = True
185 dont_care CmmTick {} = True
186 dont_care CmmUnwind {} = True
187 dont_care _other = False
188
189 -- Utilities: equality and substitution on the graph.
190
191 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
192 eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
193 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
194 lookupBid :: LabelMap BlockId -> BlockId -> BlockId
195 lookupBid subst bid = case mapLookup bid subst of
196 Just bid -> lookupBid subst bid
197 Nothing -> bid
198
199 -- Middle nodes and expressions can contain BlockIds, in particular in
200 -- CmmStackSlot and CmmBlock, so we have to use a special equality for
201 -- these.
202 --
203 eqMiddleWith :: (BlockId -> BlockId -> Bool)
204 -> CmmNode O O -> CmmNode O O -> Bool
205 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
206 = r1 == r2 && eqExprWith eqBid e1 e2
207 eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
208 = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
209 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
210 (CmmUnsafeForeignCall t2 r2 a2)
211 = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
212 eqMiddleWith _ _ _ = False
213
214 eqExprWith :: (BlockId -> BlockId -> Bool)
215 -> CmmExpr -> CmmExpr -> Bool
216 eqExprWith eqBid = eq
217 where
218 CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2
219 CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2
220 CmmReg r1 `eq` CmmReg r2 = r1==r2
221 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2
222 CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2
223 CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
224 _e1 `eq` _e2 = False
225
226 xs `eqs` ys = and (zipWith eq xs ys)
227
228 eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
229 eqLit l1 l2 = l1 == l2
230
231 eqArea Old Old = True
232 eqArea (Young id1) (Young id2) = eqBid id1 id2
233 eqArea _ _ = False
234
235 -- Equality on the body of a block, modulo a function mapping block
236 -- IDs to block IDs.
237 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
238 eqBlockBodyWith eqBid block block'
239 {-
240 | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True
241 | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
242 -}
243 = equal
244 where (_,m,l) = blockSplit block
245 nodes = filter (not . dont_care) (blockToList m)
246 (_,m',l') = blockSplit block'
247 nodes' = filter (not . dont_care) (blockToList m')
248
249 equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
250 eqLastWith eqBid l l'
251
252
253 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
254 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
255 eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
256 c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
257 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
258 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
259 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
260 e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
261 eqLastWith _ _ _ = False
262
263 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
264 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
265 eqMaybeWith _ Nothing Nothing = True
266 eqMaybeWith _ _ _ = False
267
268 -- | Given a block map, ensure that all "target" blocks are covered by
269 -- the same ticks as the respective "source" blocks. This not only
270 -- means copying ticks, but also adjusting tick scopes where
271 -- necessary.
272 copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
273 copyTicks env g
274 | mapNull env = g
275 | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
276 where -- Reverse block merge map
277 blockMap = toBlockMap g
278 revEnv = mapFoldWithKey insertRev M.empty env
279 insertRev k x = M.insertWith (const (k:)) x [k]
280 -- Copy ticks and scopes into the given block
281 copyTo block = case M.lookup (entryLabel block) revEnv of
282 Nothing -> block
283 Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
284 copy from to =
285 let ticks = blockTicks from
286 CmmEntry _ scp0 = firstNode from
287 (CmmEntry lbl scp1, code) = blockSplitHead to
288 in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
289 foldr blockCons code (map CmmTick ticks)
290
291 -- Group by [Label]
292 groupByLabel :: [(Key, a)] -> [(Key, [a])]
293 groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a)
294 where
295 go !m [] = TM.foldTM (:) m []
296 go !m ((k,v) : entries) = go (TM.alterTM k' adjust m) entries
297 where k' = map getUnique k
298 adjust Nothing = Just (k,[v])
299 adjust (Just (_,vs)) = Just (k,v:vs)
300
301
302 groupByInt :: (a -> Int) -> [a] -> [[a]]
303 groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
304 -- See Note [Unique Determinism and code generation]
305 where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)