0811147eda1934ef1163b3a5cd6aec8993edd290
[ghc.git] / compiler / nativeGen / RegAlloc / Graph / SpillClean.hs
1
2 -- | Clean out unneeded spill\/reload instructions.
3 --
4 -- Handling of join points
5 -- ~~~~~~~~~~~~~~~~~~~~~~~
6 --
7 -- B1: B2:
8 -- ... ...
9 -- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1
10 -- ... A ... ... B ...
11 -- jump B3 jump B3
12 --
13 -- B3: ... C ...
14 -- RELOAD SLOT(0), %r1
15 -- ...
16 --
17 -- The Plan
18 -- ~~~~~~~~
19 -- As long as %r1 hasn't been written to in A, B or C then we don't need
20 -- the reload in B3.
21 --
22 -- What we really care about here is that on the entry to B3, %r1 will
23 -- always have the same value that is in SLOT(0) (ie, %r1 is _valid_)
24 --
25 -- This also works if the reloads in B1\/B2 were spills instead, because
26 -- spilling %r1 to a slot makes that slot have the same value as %r1.
27 --
28 module RegAlloc.Graph.SpillClean (
29 cleanSpills
30 ) where
31 import RegAlloc.Liveness
32 import Instruction
33 import Reg
34
35 import BlockId
36 import Hoopl
37 import Cmm
38 import UniqSet
39 import UniqFM
40 import Unique
41 import State
42 import Outputable
43 import Platform
44
45 import Data.List
46 import Data.Maybe
47 import Data.IntSet (IntSet)
48 import qualified Data.IntSet as IntSet
49
50
51 -- | The identification number of a spill slot.
52 -- A value is stored in a spill slot when we don't have a free
53 -- register to hold it.
54 type Slot = Int
55
56
57 -- | Clean out unneeded spill\/reloads from this top level thing.
58 cleanSpills
59 :: Instruction instr
60 => Platform
61 -> LiveCmmDecl statics instr
62 -> LiveCmmDecl statics instr
63
64 cleanSpills platform cmm
65 = evalState (cleanSpin platform 0 cmm) initCleanS
66
67
68 -- | Do one pass of cleaning.
69 cleanSpin
70 :: Instruction instr
71 => Platform
72 -> Int -- ^ Iteration number for the cleaner.
73 -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean.
74 -> CleanM (LiveCmmDecl statics instr)
75
76 cleanSpin platform spinCount code
77 = do
78 -- Initialise count of cleaned spill and reload instructions.
79 modify $ \s -> s
80 { sCleanedSpillsAcc = 0
81 , sCleanedReloadsAcc = 0
82 , sReloadedBy = emptyUFM }
83
84 code_forward <- mapBlockTopM (cleanBlockForward platform) code
85 code_backward <- cleanTopBackward code_forward
86
87 -- During the cleaning of each block we collected information about
88 -- what regs were valid across each jump. Based on this, work out
89 -- whether it will be safe to erase reloads after join points for
90 -- the next pass.
91 collateJoinPoints
92
93 -- Remember how many spill and reload instructions we cleaned in this pass.
94 spills <- gets sCleanedSpillsAcc
95 reloads <- gets sCleanedReloadsAcc
96 modify $ \s -> s
97 { sCleanedCount = (spills, reloads) : sCleanedCount s }
98
99 -- If nothing was cleaned in this pass or the last one
100 -- then we're done and it's time to bail out.
101 cleanedCount <- gets sCleanedCount
102 if take 2 cleanedCount == [(0, 0), (0, 0)]
103 then return code
104
105 -- otherwise go around again
106 else cleanSpin platform (spinCount + 1) code_backward
107
108
109 -------------------------------------------------------------------------------
110 -- | Clean out unneeded reload instructions,
111 -- while walking forward over the code.
112 cleanBlockForward
113 :: Instruction instr
114 => Platform
115 -> LiveBasicBlock instr
116 -> CleanM (LiveBasicBlock instr)
117
118 cleanBlockForward platform (BasicBlock blockId instrs)
119 = do
120 -- See if we have a valid association for the entry to this block.
121 jumpValid <- gets sJumpValid
122 let assoc = case lookupUFM jumpValid blockId of
123 Just assoc -> assoc
124 Nothing -> emptyAssoc
125
126 instrs_reload <- cleanForward platform blockId assoc [] instrs
127 return $ BasicBlock blockId instrs_reload
128
129
130
131 -- | Clean out unneeded reload instructions.
132 --
133 -- Walking forwards across the code
134 -- On a reload, if we know a reg already has the same value as a slot
135 -- then we don't need to do the reload.
136 --
137 cleanForward
138 :: Instruction instr
139 => Platform
140 -> BlockId -- ^ the block that we're currently in
141 -> Assoc Store -- ^ two store locations are associated if
142 -- they have the same value
143 -> [LiveInstr instr] -- ^ acc
144 -> [LiveInstr instr] -- ^ instrs to clean (in backwards order)
145 -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order)
146
147 cleanForward _ _ _ acc []
148 = return acc
149
150 -- Rewrite live range joins via spill slots to just a spill and a reg-reg move
151 -- hopefully the spill will be also be cleaned in the next pass
152 cleanForward platform blockId assoc acc (li1 : li2 : instrs)
153
154 | LiveInstr (SPILL reg1 slot1) _ <- li1
155 , LiveInstr (RELOAD slot2 reg2) _ <- li2
156 , slot1 == slot2
157 = do
158 modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
159 cleanForward platform blockId assoc acc
160 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing
161 : instrs
162
163 cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)
164 | Just (r1, r2) <- takeRegRegMoveInstr i1
165 = if r1 == r2
166 -- Erase any left over nop reg reg moves while we're here
167 -- this will also catch any nop moves that the previous case
168 -- happens to add.
169 then cleanForward platform blockId assoc acc instrs
170
171 -- If r1 has the same value as some slots and we copy r1 to r2,
172 -- then r2 is now associated with those slots instead
173 else do let assoc' = addAssoc (SReg r1) (SReg r2)
174 $ delAssoc (SReg r2)
175 $ assoc
176
177 cleanForward platform blockId assoc' (li : acc) instrs
178
179
180 cleanForward platform blockId assoc acc (li : instrs)
181
182 -- Update association due to the spill.
183 | LiveInstr (SPILL reg slot) _ <- li
184 = let assoc' = addAssoc (SReg reg) (SSlot slot)
185 $ delAssoc (SSlot slot)
186 $ assoc
187 in cleanForward platform blockId assoc' (li : acc) instrs
188
189 -- Clean a reload instr.
190 | LiveInstr (RELOAD{}) _ <- li
191 = do (assoc', mli) <- cleanReload platform blockId assoc li
192 case mli of
193 Nothing -> cleanForward platform blockId assoc' acc
194 instrs
195
196 Just li' -> cleanForward platform blockId assoc' (li' : acc)
197 instrs
198
199 -- Remember the association over a jump.
200 | LiveInstr instr _ <- li
201 , targets <- jumpDestsOfInstr instr
202 , not $ null targets
203 = do mapM_ (accJumpValid assoc) targets
204 cleanForward platform blockId assoc (li : acc) instrs
205
206 -- Writing to a reg changes its value.
207 | LiveInstr instr _ <- li
208 , RU _ written <- regUsageOfInstr platform instr
209 = let assoc' = foldr delAssoc assoc (map SReg $ nub written)
210 in cleanForward platform blockId assoc' (li : acc) instrs
211
212
213
214 -- | Try and rewrite a reload instruction to something more pleasing
215 cleanReload
216 :: Instruction instr
217 => Platform
218 -> BlockId
219 -> Assoc Store
220 -> LiveInstr instr
221 -> CleanM (Assoc Store, Maybe (LiveInstr instr))
222
223 cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)
224
225 -- If the reg we're reloading already has the same value as the slot
226 -- then we can erase the instruction outright.
227 | elemAssoc (SSlot slot) (SReg reg) assoc
228 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
229 return (assoc, Nothing)
230
231 -- If we can find another reg with the same value as this slot then
232 -- do a move instead of a reload.
233 | Just reg2 <- findRegOfSlot assoc slot
234 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
235
236 let assoc' = addAssoc (SReg reg) (SReg reg2)
237 $ delAssoc (SReg reg)
238 $ assoc
239
240 return ( assoc'
241 , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)
242
243 -- Gotta keep this instr.
244 | otherwise
245 = do -- Update the association.
246 let assoc'
247 = addAssoc (SReg reg) (SSlot slot)
248 -- doing the reload makes reg and slot the same value
249 $ delAssoc (SReg reg)
250 -- reg value changes on reload
251 $ assoc
252
253 -- Remember that this block reloads from this slot.
254 accBlockReloadsSlot blockId slot
255
256 return (assoc', Just li)
257
258 cleanReload _ _ _ _
259 = panic "RegSpillClean.cleanReload: unhandled instr"
260
261
262 -------------------------------------------------------------------------------
263 -- | Clean out unneeded spill instructions,
264 -- while walking backwards over the code.
265 --
266 -- If there were no reloads from a slot between a spill and the last one
267 -- then the slot was never read and we don't need the spill.
268 --
269 -- SPILL r0 -> s1
270 -- RELOAD s1 -> r2
271 -- SPILL r3 -> s1 <--- don't need this spill
272 -- SPILL r4 -> s1
273 -- RELOAD s1 -> r5
274 --
275 -- Maintain a set of
276 -- "slots which were spilled to but not reloaded from yet"
277 --
278 -- Walking backwards across the code:
279 -- a) On a reload from a slot, remove it from the set.
280 --
281 -- a) On a spill from a slot
282 -- If the slot is in set then we can erase the spill,
283 -- because it won't be reloaded from until after the next spill.
284 --
285 -- otherwise
286 -- keep the spill and add the slot to the set
287 --
288 -- TODO: This is mostly inter-block
289 -- we should really be updating the noReloads set as we cross jumps also.
290 --
291 -- TODO: generate noReloads from liveSlotsOnEntry
292 --
293 cleanTopBackward
294 :: Instruction instr
295 => LiveCmmDecl statics instr
296 -> CleanM (LiveCmmDecl statics instr)
297
298 cleanTopBackward cmm
299 = case cmm of
300 CmmData{}
301 -> return cmm
302
303 CmmProc info label live sccs
304 | LiveInfo _ _ _ liveSlotsOnEntry <- info
305 -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
306 return $ CmmProc info label live sccs'
307
308
309 cleanBlockBackward
310 :: Instruction instr
311 => BlockMap IntSet
312 -> LiveBasicBlock instr
313 -> CleanM (LiveBasicBlock instr)
314
315 cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)
316 = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs
317 return $ BasicBlock blockId instrs_spill
318
319
320
321 cleanBackward
322 :: Instruction instr
323 => BlockMap IntSet -- ^ Slots live on entry to each block
324 -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from
325 -> [LiveInstr instr] -- ^ acc
326 -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order)
327 -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order)
328
329 cleanBackward liveSlotsOnEntry noReloads acc lis
330 = do reloadedBy <- gets sReloadedBy
331 cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis
332
333
334 cleanBackward'
335 :: Instruction instr
336 => BlockMap IntSet
337 -> UniqFM [BlockId]
338 -> UniqSet Int
339 -> [LiveInstr instr]
340 -> [LiveInstr instr]
341 -> State CleanS [LiveInstr instr]
342
343 cleanBackward' _ _ _ acc []
344 = return acc
345
346 cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
347
348 -- If nothing ever reloads from this slot then we don't need the spill.
349 | LiveInstr (SPILL _ slot) _ <- li
350 , Nothing <- lookupUFM reloadedBy (SSlot slot)
351 = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
352 cleanBackward liveSlotsOnEntry noReloads acc instrs
353
354 | LiveInstr (SPILL _ slot) _ <- li
355 = if elementOfUniqSet slot noReloads
356
357 -- We can erase this spill because the slot won't be read until
358 -- after the next one
359 then do
360 modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
361 cleanBackward liveSlotsOnEntry noReloads acc instrs
362
363 else do
364 -- This slot is being spilled to, but we haven't seen any reloads yet.
365 let noReloads' = addOneToUniqSet noReloads slot
366 cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
367
368 -- if we reload from a slot then it's no longer unused
369 | LiveInstr (RELOAD slot _) _ <- li
370 , noReloads' <- delOneFromUniqSet noReloads slot
371 = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
372
373 -- If a slot is live in a jump target then assume it's reloaded there.
374 --
375 -- TODO: A real dataflow analysis would do a better job here.
376 -- If the target block _ever_ used the slot then we assume
377 -- it always does, but if those reloads are cleaned the slot
378 -- liveness map doesn't get updated.
379 | LiveInstr instr _ <- li
380 , targets <- jumpDestsOfInstr instr
381 = do
382 let slotsReloadedByTargets
383 = IntSet.unions
384 $ catMaybes
385 $ map (flip mapLookup liveSlotsOnEntry)
386 $ targets
387
388 let noReloads'
389 = foldl' delOneFromUniqSet noReloads
390 $ IntSet.toList slotsReloadedByTargets
391
392 cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
393
394 -- some other instruction
395 | otherwise
396 = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
397
398
399 -- | Combine the associations from all the inward control flow edges.
400 --
401 collateJoinPoints :: CleanM ()
402 collateJoinPoints
403 = modify $ \s -> s
404 { sJumpValid = mapUFM intersects (sJumpValidAcc s)
405 , sJumpValidAcc = emptyUFM }
406
407 intersects :: [Assoc Store] -> Assoc Store
408 intersects [] = emptyAssoc
409 intersects assocs = foldl1' intersectAssoc assocs
410
411
412 -- | See if we have a reg with the same value as this slot in the association table.
413 findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
414 findRegOfSlot assoc slot
415 | close <- closeAssoc (SSlot slot) assoc
416 , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close
417 -- See Note [Unique Determinism and code generation]
418 = Just reg
419
420 | otherwise
421 = Nothing
422
423
424 -------------------------------------------------------------------------------
425 -- | Cleaner monad.
426 type CleanM
427 = State CleanS
428
429 -- | Cleaner state.
430 data CleanS
431 = CleanS
432 { -- | Regs which are valid at the start of each block.
433 sJumpValid :: UniqFM (Assoc Store)
434
435 -- | Collecting up what regs were valid across each jump.
436 -- in the next pass we can collate these and write the results
437 -- to sJumpValid.
438 , sJumpValidAcc :: UniqFM [Assoc Store]
439
440 -- | Map of (slot -> blocks which reload from this slot)
441 -- used to decide if whether slot spilled to will ever be
442 -- reloaded from on this path.
443 , sReloadedBy :: UniqFM [BlockId]
444
445 -- | Spills and reloads cleaned each pass (latest at front)
446 , sCleanedCount :: [(Int, Int)]
447
448 -- | Spills and reloads that have been cleaned in this pass so far.
449 , sCleanedSpillsAcc :: Int
450 , sCleanedReloadsAcc :: Int }
451
452
453 -- | Construct the initial cleaner state.
454 initCleanS :: CleanS
455 initCleanS
456 = CleanS
457 { sJumpValid = emptyUFM
458 , sJumpValidAcc = emptyUFM
459
460 , sReloadedBy = emptyUFM
461
462 , sCleanedCount = []
463
464 , sCleanedSpillsAcc = 0
465 , sCleanedReloadsAcc = 0 }
466
467
468 -- | Remember the associations before a jump.
469 accJumpValid :: Assoc Store -> BlockId -> CleanM ()
470 accJumpValid assocs target
471 = modify $ \s -> s {
472 sJumpValidAcc = addToUFM_C (++)
473 (sJumpValidAcc s)
474 target
475 [assocs] }
476
477
478 accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
479 accBlockReloadsSlot blockId slot
480 = modify $ \s -> s {
481 sReloadedBy = addToUFM_C (++)
482 (sReloadedBy s)
483 (SSlot slot)
484 [blockId] }
485
486
487 -------------------------------------------------------------------------------
488 -- A store location can be a stack slot or a register
489 data Store
490 = SSlot Int
491 | SReg Reg
492
493
494 -- | Check if this is a reg store.
495 isStoreReg :: Store -> Bool
496 isStoreReg ss
497 = case ss of
498 SSlot _ -> False
499 SReg _ -> True
500
501
502 -- Spill cleaning is only done once all virtuals have been allocated to realRegs
503 instance Uniquable Store where
504 getUnique (SReg r)
505 | RegReal (RealRegSingle i) <- r
506 = mkRegSingleUnique i
507
508 | RegReal (RealRegPair r1 r2) <- r
509 = mkRegPairUnique (r1 * 65535 + r2)
510
511 | otherwise
512 = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"
513 ++ "only real regs expected."
514
515 getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok
516
517
518 instance Outputable Store where
519 ppr (SSlot i) = text "slot" <> int i
520 ppr (SReg r) = ppr r
521
522
523 -------------------------------------------------------------------------------
524 -- Association graphs.
525 -- In the spill cleaner, two store locations are associated if they are known
526 -- to hold the same value.
527 --
528 type Assoc a = UniqFM (UniqSet a)
529
530 -- | An empty association
531 emptyAssoc :: Assoc a
532 emptyAssoc = emptyUFM
533
534
535 -- | Add an association between these two things.
536 addAssoc :: Uniquable a
537 => a -> a -> Assoc a -> Assoc a
538
539 addAssoc a b m
540 = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b)
541 m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
542 in m2
543
544
545 -- | Delete all associations to a node.
546 delAssoc :: (Uniquable a)
547 => a -> Assoc a -> Assoc a
548
549 delAssoc a m
550 | Just aSet <- lookupUFM m a
551 , m1 <- delFromUFM m a
552 = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
553 -- It's OK to use nonDetFoldUFM here because deletion is commutative
554
555 | otherwise = m
556
557
558 -- | Delete a single association edge (a -> b).
559 delAssoc1 :: Uniquable a
560 => a -> a -> Assoc a -> Assoc a
561
562 delAssoc1 a b m
563 | Just aSet <- lookupUFM m a
564 = addToUFM m a (delOneFromUniqSet aSet b)
565
566 | otherwise = m
567
568
569 -- | Check if these two things are associated.
570 elemAssoc :: (Uniquable a)
571 => a -> a -> Assoc a -> Bool
572
573 elemAssoc a b m
574 = elementOfUniqSet b (closeAssoc a m)
575
576
577 -- | Find the refl. trans. closure of the association from this point.
578 closeAssoc :: (Uniquable a)
579 => a -> Assoc a -> UniqSet a
580
581 closeAssoc a assoc
582 = closeAssoc' assoc emptyUniqSet (unitUniqSet a)
583 where
584 closeAssoc' assoc visited toVisit
585 = case nonDetEltsUniqSet toVisit of
586 -- See Note [Unique Determinism and code generation]
587
588 -- nothing else to visit, we're done
589 [] -> visited
590
591 (x:_)
592 -- we've already seen this node
593 | elementOfUniqSet x visited
594 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
595
596 -- haven't seen this node before,
597 -- remember to visit all its neighbors
598 | otherwise
599 -> let neighbors
600 = case lookupUFM assoc x of
601 Nothing -> emptyUniqSet
602 Just set -> set
603
604 in closeAssoc' assoc
605 (addOneToUniqSet visited x)
606 (unionUniqSets toVisit neighbors)
607
608 -- | Intersect two associations.
609 intersectAssoc :: Assoc a -> Assoc a -> Assoc a
610 intersectAssoc a b
611 = intersectUFM_C (intersectUniqSets) a b
612