More CPP removal: pprDynamicLinkerAsmLabel in CLabel
[ghc.git] / compiler / nativeGen / RegAlloc / Liveness.hs
1 -----------------------------------------------------------------------------
2 --
3 -- The register liveness determinator
4 --
5 -- (c) The University of Glasgow 2004
6 --
7 -----------------------------------------------------------------------------
8 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
9
10 module RegAlloc.Liveness (
11 RegSet,
12 RegMap, emptyRegMap,
13 BlockMap, emptyBlockMap,
14 LiveCmmDecl,
15 InstrSR (..),
16 LiveInstr (..),
17 Liveness (..),
18 LiveInfo (..),
19 LiveBasicBlock,
20
21 mapBlockTop, mapBlockTopM, mapSCCM,
22 mapGenBlockTop, mapGenBlockTopM,
23 stripLive,
24 stripLiveBlock,
25 slurpConflicts,
26 slurpReloadCoalesce,
27 eraseDeltasLive,
28 patchEraseLive,
29 patchRegsLiveInstr,
30 reverseBlocksInTops,
31 regLiveness,
32 natCmmTopToLive
33 ) where
34 import Reg
35 import Instruction
36
37 import BlockId
38 import OldCmm hiding (RegSet)
39 import OldPprCmm()
40
41 import Digraph
42 import Outputable
43 import Platform
44 import Unique
45 import UniqSet
46 import UniqFM
47 import UniqSupply
48 import Bag
49 import State
50 import FastString
51
52 import Data.List
53 import Data.Maybe
54 import Data.Map (Map)
55 import Data.Set (Set)
56 import qualified Data.Map as Map
57
58 -----------------------------------------------------------------------------
59 type RegSet = UniqSet Reg
60
61 type RegMap a = UniqFM a
62
63 emptyRegMap :: UniqFM a
64 emptyRegMap = emptyUFM
65
66 type BlockMap a = BlockEnv a
67
68
69 -- | A top level thing which carries liveness information.
70 type LiveCmmDecl statics instr
71 = GenCmmDecl
72 statics
73 LiveInfo
74 [SCC (LiveBasicBlock instr)]
75
76
77 -- | The register allocator also wants to use SPILL/RELOAD meta instructions,
78 -- so we'll keep those here.
79 data InstrSR instr
80 -- | A real machine instruction
81 = Instr instr
82
83 -- | spill this reg to a stack slot
84 | SPILL Reg Int
85
86 -- | reload this reg from a stack slot
87 | RELOAD Int Reg
88
89 instance Instruction instr => Instruction (InstrSR instr) where
90 regUsageOfInstr i
91 = case i of
92 Instr instr -> regUsageOfInstr instr
93 SPILL reg _ -> RU [reg] []
94 RELOAD _ reg -> RU [] [reg]
95
96 patchRegsOfInstr i f
97 = case i of
98 Instr instr -> Instr (patchRegsOfInstr instr f)
99 SPILL reg slot -> SPILL (f reg) slot
100 RELOAD slot reg -> RELOAD slot (f reg)
101
102 isJumpishInstr i
103 = case i of
104 Instr instr -> isJumpishInstr instr
105 _ -> False
106
107 jumpDestsOfInstr i
108 = case i of
109 Instr instr -> jumpDestsOfInstr instr
110 _ -> []
111
112 patchJumpInstr i f
113 = case i of
114 Instr instr -> Instr (patchJumpInstr instr f)
115 _ -> i
116
117 mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
118 mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
119
120 takeDeltaInstr i
121 = case i of
122 Instr instr -> takeDeltaInstr instr
123 _ -> Nothing
124
125 isMetaInstr i
126 = case i of
127 Instr instr -> isMetaInstr instr
128 _ -> False
129
130 mkRegRegMoveInstr platform r1 r2
131 = Instr (mkRegRegMoveInstr platform r1 r2)
132
133 takeRegRegMoveInstr i
134 = case i of
135 Instr instr -> takeRegRegMoveInstr instr
136 _ -> Nothing
137
138 mkJumpInstr target = map Instr (mkJumpInstr target)
139
140
141
142 -- | An instruction with liveness information.
143 data LiveInstr instr
144 = LiveInstr (InstrSR instr) (Maybe Liveness)
145
146 -- | Liveness information.
147 -- The regs which die are ones which are no longer live in the *next* instruction
148 -- in this sequence.
149 -- (NB. if the instruction is a jump, these registers might still be live
150 -- at the jump target(s) - you have to check the liveness at the destination
151 -- block to find out).
152
153 data Liveness
154 = Liveness
155 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
156 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
157 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
158
159
160 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
161 data LiveInfo
162 = LiveInfo
163 (Maybe CmmStatics) -- cmm info table static stuff
164 (Maybe BlockId) -- id of the first block
165 (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block
166 (Map BlockId (Set Int)) -- stack slots live on entry to this block
167
168
169 -- | A basic block with liveness information.
170 type LiveBasicBlock instr
171 = GenBasicBlock (LiveInstr instr)
172
173
174 instance PlatformOutputable instr
175 => PlatformOutputable (InstrSR instr) where
176
177 pprPlatform platform (Instr realInstr)
178 = pprPlatform platform realInstr
179
180 pprPlatform _ (SPILL reg slot)
181 = hcat [
182 ptext (sLit "\tSPILL"),
183 char ' ',
184 ppr reg,
185 comma,
186 ptext (sLit "SLOT") <> parens (int slot)]
187
188 pprPlatform _ (RELOAD slot reg)
189 = hcat [
190 ptext (sLit "\tRELOAD"),
191 char ' ',
192 ptext (sLit "SLOT") <> parens (int slot),
193 comma,
194 ppr reg]
195
196 instance PlatformOutputable instr
197 => PlatformOutputable (LiveInstr instr) where
198
199 pprPlatform platform (LiveInstr instr Nothing)
200 = pprPlatform platform instr
201
202 pprPlatform platform (LiveInstr instr (Just live))
203 = pprPlatform platform instr
204 $$ (nest 8
205 $ vcat
206 [ pprRegs (ptext (sLit "# born: ")) (liveBorn live)
207 , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
208 , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
209 $+$ space)
210
211 where pprRegs :: SDoc -> RegSet -> SDoc
212 pprRegs name regs
213 | isEmptyUniqSet regs = empty
214 | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
215
216 instance PlatformOutputable LiveInfo where
217 pprPlatform platform (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry)
218 = (maybe empty (pprPlatform platform) mb_static)
219 $$ text "# firstId = " <> ppr firstId
220 $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
221 $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
222
223
224
225 -- | map a function across all the basic blocks in this code
226 --
227 mapBlockTop
228 :: (LiveBasicBlock instr -> LiveBasicBlock instr)
229 -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
230
231 mapBlockTop f cmm
232 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
233
234
235 -- | map a function across all the basic blocks in this code (monadic version)
236 --
237 mapBlockTopM
238 :: Monad m
239 => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
240 -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
241
242 mapBlockTopM _ cmm@(CmmData{})
243 = return cmm
244
245 mapBlockTopM f (CmmProc header label sccs)
246 = do sccs' <- mapM (mapSCCM f) sccs
247 return $ CmmProc header label sccs'
248
249 mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
250 mapSCCM f (AcyclicSCC x)
251 = do x' <- f x
252 return $ AcyclicSCC x'
253
254 mapSCCM f (CyclicSCC xs)
255 = do xs' <- mapM f xs
256 return $ CyclicSCC xs'
257
258
259 -- map a function across all the basic blocks in this code
260 mapGenBlockTop
261 :: (GenBasicBlock i -> GenBasicBlock i)
262 -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
263
264 mapGenBlockTop f cmm
265 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
266
267
268 -- | map a function across all the basic blocks in this code (monadic version)
269 mapGenBlockTopM
270 :: Monad m
271 => (GenBasicBlock i -> m (GenBasicBlock i))
272 -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
273
274 mapGenBlockTopM _ cmm@(CmmData{})
275 = return cmm
276
277 mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
278 = do blocks' <- mapM f blocks
279 return $ CmmProc header label (ListGraph blocks')
280
281
282 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
283 -- Slurping of conflicts and moves is wrapped up together so we don't have
284 -- to make two passes over the same code when we want to build the graph.
285 --
286 slurpConflicts
287 :: Instruction instr
288 => LiveCmmDecl statics instr
289 -> (Bag (UniqSet Reg), Bag (Reg, Reg))
290
291 slurpConflicts live
292 = slurpCmm (emptyBag, emptyBag) live
293
294 where slurpCmm rs CmmData{} = rs
295 slurpCmm rs (CmmProc info _ sccs)
296 = foldl' (slurpSCC info) rs sccs
297
298 slurpSCC info rs (AcyclicSCC b)
299 = slurpBlock info rs b
300
301 slurpSCC info rs (CyclicSCC bs)
302 = foldl' (slurpBlock info) rs bs
303
304 slurpBlock info rs (BasicBlock blockId instrs)
305 | LiveInfo _ _ (Just blockLive) _ <- info
306 , Just rsLiveEntry <- mapLookup blockId blockLive
307 , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
308 = (consBag rsLiveEntry conflicts, moves)
309
310 | otherwise
311 = panic "Liveness.slurpConflicts: bad block"
312
313 slurpLIs rsLive (conflicts, moves) []
314 = (consBag rsLive conflicts, moves)
315
316 slurpLIs rsLive rs (LiveInstr _ Nothing : lis)
317 = slurpLIs rsLive rs lis
318
319 slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
320 = let
321 -- regs that die because they are read for the last time at the start of an instruction
322 -- are not live across it.
323 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
324
325 -- regs live on entry to the next instruction.
326 -- be careful of orphans, make sure to delete dying regs _after_ unioning
327 -- in the ones that are born here.
328 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
329 `minusUniqSet` (liveDieWrite live)
330
331 -- orphan vregs are the ones that die in the same instruction they are born in.
332 -- these are likely to be results that are never used, but we still
333 -- need to assign a hreg to them..
334 rsOrphans = intersectUniqSets
335 (liveBorn live)
336 (unionUniqSets (liveDieWrite live) (liveDieRead live))
337
338 --
339 rsConflicts = unionUniqSets rsLiveNext rsOrphans
340
341 in case takeRegRegMoveInstr instr of
342 Just rr -> slurpLIs rsLiveNext
343 ( consBag rsConflicts conflicts
344 , consBag rr moves) lis
345
346 Nothing -> slurpLIs rsLiveNext
347 ( consBag rsConflicts conflicts
348 , moves) lis
349
350
351 -- | For spill\/reloads
352 --
353 -- SPILL v1, slot1
354 -- ...
355 -- RELOAD slot1, v2
356 --
357 -- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
358 -- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
359 --
360 --
361 slurpReloadCoalesce
362 :: forall statics instr. Instruction instr
363 => LiveCmmDecl statics instr
364 -> Bag (Reg, Reg)
365
366 slurpReloadCoalesce live
367 = slurpCmm emptyBag live
368
369 where
370 slurpCmm :: Bag (Reg, Reg)
371 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
372 -> Bag (Reg, Reg)
373 slurpCmm cs CmmData{} = cs
374 slurpCmm cs (CmmProc _ _ sccs)
375 = slurpComp cs (flattenSCCs sccs)
376
377 slurpComp :: Bag (Reg, Reg)
378 -> [LiveBasicBlock instr]
379 -> Bag (Reg, Reg)
380 slurpComp cs blocks
381 = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM
382 in unionManyBags (cs : moveBags)
383
384 slurpCompM :: [LiveBasicBlock instr]
385 -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
386 slurpCompM blocks
387 = do -- run the analysis once to record the mapping across jumps.
388 mapM_ (slurpBlock False) blocks
389
390 -- run it a second time while using the information from the last pass.
391 -- We /could/ run this many more times to deal with graphical control
392 -- flow and propagating info across multiple jumps, but it's probably
393 -- not worth the trouble.
394 mapM (slurpBlock True) blocks
395
396 slurpBlock :: Bool -> LiveBasicBlock instr
397 -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
398 slurpBlock propagate (BasicBlock blockId instrs)
399 = do -- grab the slot map for entry to this block
400 slotMap <- if propagate
401 then getSlotMap blockId
402 else return emptyUFM
403
404 (_, mMoves) <- mapAccumLM slurpLI slotMap instrs
405 return $ listToBag $ catMaybes mMoves
406
407 slurpLI :: UniqFM Reg -- current slotMap
408 -> LiveInstr instr
409 -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
410 -- for tracking slotMaps across jumps
411
412 ( UniqFM Reg -- new slotMap
413 , Maybe (Reg, Reg)) -- maybe a new coalesce edge
414
415 slurpLI slotMap li
416
417 -- remember what reg was stored into the slot
418 | LiveInstr (SPILL reg slot) _ <- li
419 , slotMap' <- addToUFM slotMap slot reg
420 = return (slotMap', Nothing)
421
422 -- add an edge betwen the this reg and the last one stored into the slot
423 | LiveInstr (RELOAD slot reg) _ <- li
424 = case lookupUFM slotMap slot of
425 Just reg2
426 | reg /= reg2 -> return (slotMap, Just (reg, reg2))
427 | otherwise -> return (slotMap, Nothing)
428
429 Nothing -> return (slotMap, Nothing)
430
431 -- if we hit a jump, remember the current slotMap
432 | LiveInstr (Instr instr) _ <- li
433 , targets <- jumpDestsOfInstr instr
434 , not $ null targets
435 = do mapM_ (accSlotMap slotMap) targets
436 return (slotMap, Nothing)
437
438 | otherwise
439 = return (slotMap, Nothing)
440
441 -- record a slotmap for an in edge to this block
442 accSlotMap slotMap blockId
443 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
444
445 -- work out the slot map on entry to this block
446 -- if we have slot maps for multiple in-edges then we need to merge them.
447 getSlotMap blockId
448 = do map <- get
449 let slotMaps = fromMaybe [] (lookupUFM map blockId)
450 return $ foldr mergeSlotMaps emptyUFM slotMaps
451
452 mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
453 mergeSlotMaps map1 map2
454 = listToUFM
455 $ [ (k, r1) | (k, r1) <- ufmToList map1
456 , case lookupUFM map2 k of
457 Nothing -> False
458 Just r2 -> r1 == r2 ]
459
460
461 -- | Strip away liveness information, yielding NatCmmDecl
462 stripLive
463 :: (PlatformOutputable statics,
464 PlatformOutputable instr,
465 Instruction instr)
466 => Platform
467 -> LiveCmmDecl statics instr
468 -> NatCmmDecl statics instr
469
470 stripLive platform live
471 = stripCmm live
472
473 where stripCmm :: (PlatformOutputable statics,
474 PlatformOutputable instr,
475 Instruction instr)
476 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
477 stripCmm (CmmData sec ds) = CmmData sec ds
478 stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
479 = let final_blocks = flattenSCCs sccs
480
481 -- make sure the block that was first in the input list
482 -- stays at the front of the output. This is the entry point
483 -- of the proc, and it needs to come first.
484 ((first':_), rest')
485 = partition ((== first_id) . blockId) final_blocks
486
487 in CmmProc info label
488 (ListGraph $ map (stripLiveBlock platform) $ first' : rest')
489
490 -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
491 stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
492 = CmmProc info label (ListGraph [])
493
494 -- If the proc has blocks but we don't know what the first one was, then we're dead.
495 stripCmm proc
496 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc)
497
498 -- | Strip away liveness information from a basic block,
499 -- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
500
501 stripLiveBlock
502 :: Instruction instr
503 => Platform
504 -> LiveBasicBlock instr
505 -> NatBasicBlock instr
506
507 stripLiveBlock platform (BasicBlock i lis)
508 = BasicBlock i instrs'
509
510 where (instrs', _)
511 = runState (spillNat [] lis) 0
512
513 spillNat acc []
514 = return (reverse acc)
515
516 spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
517 = do delta <- get
518 spillNat (mkSpillInstr platform reg delta slot : acc) instrs
519
520 spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
521 = do delta <- get
522 spillNat (mkLoadInstr platform reg delta slot : acc) instrs
523
524 spillNat acc (LiveInstr (Instr instr) _ : instrs)
525 | Just i <- takeDeltaInstr instr
526 = do put i
527 spillNat acc instrs
528
529 spillNat acc (LiveInstr (Instr instr) _ : instrs)
530 = spillNat (instr : acc) instrs
531
532
533 -- | Erase Delta instructions.
534
535 eraseDeltasLive
536 :: Instruction instr
537 => LiveCmmDecl statics instr
538 -> LiveCmmDecl statics instr
539
540 eraseDeltasLive cmm
541 = mapBlockTop eraseBlock cmm
542 where
543 eraseBlock (BasicBlock id lis)
544 = BasicBlock id
545 $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
546 $ lis
547
548
549 -- | Patch the registers in this code according to this register mapping.
550 -- also erase reg -> reg moves when the reg is the same.
551 -- also erase reg -> reg moves when the destination dies in this instr.
552 patchEraseLive
553 :: Instruction instr
554 => (Reg -> Reg)
555 -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
556
557 patchEraseLive patchF cmm
558 = patchCmm cmm
559 where
560 patchCmm cmm@CmmData{} = cmm
561
562 patchCmm (CmmProc info label sccs)
563 | LiveInfo static id (Just blockMap) mLiveSlots <- info
564 = let
565 patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
566 blockMap' = mapMap patchRegSet blockMap
567
568 info' = LiveInfo static id (Just blockMap') mLiveSlots
569 in CmmProc info' label $ map patchSCC sccs
570
571 | otherwise
572 = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
573
574 patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b)
575 patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs)
576
577 patchBlock (BasicBlock id lis)
578 = BasicBlock id $ patchInstrs lis
579
580 patchInstrs [] = []
581 patchInstrs (li : lis)
582
583 | LiveInstr i (Just live) <- li'
584 , Just (r1, r2) <- takeRegRegMoveInstr i
585 , eatMe r1 r2 live
586 = patchInstrs lis
587
588 | otherwise
589 = li' : patchInstrs lis
590
591 where li' = patchRegsLiveInstr patchF li
592
593 eatMe r1 r2 live
594 -- source and destination regs are the same
595 | r1 == r2 = True
596
597 -- desination reg is never used
598 | elementOfUniqSet r2 (liveBorn live)
599 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
600 = True
601
602 | otherwise = False
603
604
605 -- | Patch registers in this LiveInstr, including the liveness information.
606 --
607 patchRegsLiveInstr
608 :: Instruction instr
609 => (Reg -> Reg)
610 -> LiveInstr instr -> LiveInstr instr
611
612 patchRegsLiveInstr patchF li
613 = case li of
614 LiveInstr instr Nothing
615 -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
616
617 LiveInstr instr (Just live)
618 -> LiveInstr
619 (patchRegsOfInstr instr patchF)
620 (Just live
621 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
622 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
623 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
624 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
625
626
627 --------------------------------------------------------------------------------
628 -- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information
629
630 natCmmTopToLive
631 :: Instruction instr
632 => NatCmmDecl statics instr
633 -> LiveCmmDecl statics instr
634
635 natCmmTopToLive (CmmData i d)
636 = CmmData i d
637
638 natCmmTopToLive (CmmProc info lbl (ListGraph []))
639 = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
640
641 natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
642 = let first_id = blockId first
643 sccs = sccBlocks blocks
644 sccsLive = map (fmap (\(BasicBlock l instrs) ->
645 BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
646 $ sccs
647
648 in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
649
650
651 sccBlocks
652 :: Instruction instr
653 => [NatBasicBlock instr]
654 -> [SCC (NatBasicBlock instr)]
655
656 sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
657 where
658 getOutEdges :: Instruction instr => [instr] -> [BlockId]
659 getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
660
661 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
662 | block@(BasicBlock id instrs) <- blocks ]
663
664
665 ---------------------------------------------------------------------------------
666 -- Annotate code with register liveness information
667 --
668 regLiveness
669 :: (PlatformOutputable instr, Instruction instr)
670 => Platform
671 -> LiveCmmDecl statics instr
672 -> UniqSM (LiveCmmDecl statics instr)
673
674 regLiveness _ (CmmData i d)
675 = returnUs $ CmmData i d
676
677 regLiveness _ (CmmProc info lbl [])
678 | LiveInfo static mFirst _ _ <- info
679 = returnUs $ CmmProc
680 (LiveInfo static mFirst (Just mapEmpty) Map.empty)
681 lbl []
682
683 regLiveness platform (CmmProc info lbl sccs)
684 | LiveInfo static mFirst _ liveSlotsOnEntry <- info
685 = let (ann_sccs, block_live) = computeLiveness platform sccs
686
687 in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
688 lbl ann_sccs
689
690
691 -- -----------------------------------------------------------------------------
692 -- | Check ordering of Blocks
693 -- The computeLiveness function requires SCCs to be in reverse dependent order.
694 -- If they're not the liveness information will be wrong, and we'll get a bad allocation.
695 -- Better to check for this precondition explicitly or some other poor sucker will
696 -- waste a day staring at bad assembly code..
697 --
698 checkIsReverseDependent
699 :: Instruction instr
700 => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on.
701 -> Maybe BlockId -- ^ BlockIds that fail the test (if any)
702
703 checkIsReverseDependent sccs'
704 = go emptyUniqSet sccs'
705
706 where go _ []
707 = Nothing
708
709 go blocksSeen (AcyclicSCC block : sccs)
710 = let dests = slurpJumpDestsOfBlock block
711 blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
712 badDests = dests `minusUniqSet` blocksSeen'
713 in case uniqSetToList badDests of
714 [] -> go blocksSeen' sccs
715 bad : _ -> Just bad
716
717 go blocksSeen (CyclicSCC blocks : sccs)
718 = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
719 blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
720 badDests = dests `minusUniqSet` blocksSeen'
721 in case uniqSetToList badDests of
722 [] -> go blocksSeen' sccs
723 bad : _ -> Just bad
724
725 slurpJumpDestsOfBlock (BasicBlock _ instrs)
726 = unionManyUniqSets
727 $ map (mkUniqSet . jumpDestsOfInstr)
728 [ i | LiveInstr i _ <- instrs]
729
730
731 -- | If we've compute liveness info for this code already we have to reverse
732 -- the SCCs in each top to get them back to the right order so we can do it again.
733 reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
734 reverseBlocksInTops top
735 = case top of
736 CmmData{} -> top
737 CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs)
738
739
740 -- | Computing liveness
741 --
742 -- On entry, the SCCs must be in "reverse" order: later blocks may transfer
743 -- control to earlier ones only, else `panic`.
744 --
745 -- The SCCs returned are in the *opposite* order, which is exactly what we
746 -- want for the next pass.
747 --
748 computeLiveness
749 :: (PlatformOutputable instr, Instruction instr)
750 => Platform
751 -> [SCC (LiveBasicBlock instr)]
752 -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers
753 -- which are "dead after this instruction".
754 BlockMap RegSet) -- blocks annontated with set of live registers
755 -- on entry to the block.
756
757 computeLiveness platform sccs
758 = case checkIsReverseDependent sccs of
759 Nothing -> livenessSCCs emptyBlockMap [] sccs
760 Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss"
761 (vcat [ text "SCCs aren't in reverse dependent order"
762 , text "bad blockId" <+> ppr bad
763 , pprPlatform platform sccs])
764
765 livenessSCCs
766 :: Instruction instr
767 => BlockMap RegSet
768 -> [SCC (LiveBasicBlock instr)] -- accum
769 -> [SCC (LiveBasicBlock instr)]
770 -> ( [SCC (LiveBasicBlock instr)]
771 , BlockMap RegSet)
772
773 livenessSCCs blockmap done []
774 = (done, blockmap)
775
776 livenessSCCs blockmap done (AcyclicSCC block : sccs)
777 = let (blockmap', block') = livenessBlock blockmap block
778 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
779
780 livenessSCCs blockmap done
781 (CyclicSCC blocks : sccs) =
782 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
783 where (blockmap', blocks')
784 = iterateUntilUnchanged linearLiveness equalBlockMaps
785 blockmap blocks
786
787 iterateUntilUnchanged
788 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
789 -> a -> b
790 -> (a,c)
791
792 iterateUntilUnchanged f eq a b
793 = head $
794 concatMap tail $
795 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
796 iterate (\(a, _) -> f a b) $
797 (a, panic "RegLiveness.livenessSCCs")
798
799
800 linearLiveness
801 :: Instruction instr
802 => BlockMap RegSet -> [LiveBasicBlock instr]
803 -> (BlockMap RegSet, [LiveBasicBlock instr])
804
805 linearLiveness = mapAccumL livenessBlock
806
807 -- probably the least efficient way to compare two
808 -- BlockMaps for equality.
809 equalBlockMaps a b
810 = a' == b'
811 where a' = map f $ mapToList a
812 b' = map f $ mapToList b
813 f (key,elt) = (key, uniqSetToList elt)
814
815
816
817 -- | Annotate a basic block with register liveness information.
818 --
819 livenessBlock
820 :: Instruction instr
821 => BlockMap RegSet
822 -> LiveBasicBlock instr
823 -> (BlockMap RegSet, LiveBasicBlock instr)
824
825 livenessBlock blockmap (BasicBlock block_id instrs)
826 = let
827 (regsLiveOnEntry, instrs1)
828 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
829 blockmap' = mapInsert block_id regsLiveOnEntry blockmap
830
831 instrs2 = livenessForward regsLiveOnEntry instrs1
832
833 output = BasicBlock block_id instrs2
834
835 in ( blockmap', output)
836
837 -- | Calculate liveness going forwards,
838 -- filling in when regs are born
839
840 livenessForward
841 :: Instruction instr
842 => RegSet -- regs live on this instr
843 -> [LiveInstr instr] -> [LiveInstr instr]
844
845 livenessForward _ [] = []
846 livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis)
847 | Nothing <- mLive
848 = li : livenessForward rsLiveEntry lis
849
850 | Just live <- mLive
851 , RU _ written <- regUsageOfInstr instr
852 = let
853 -- Regs that are written to but weren't live on entry to this instruction
854 -- are recorded as being born here.
855 rsBorn = mkUniqSet
856 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
857
858 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
859 `minusUniqSet` (liveDieRead live)
860 `minusUniqSet` (liveDieWrite live)
861
862 in LiveInstr instr (Just live { liveBorn = rsBorn })
863 : livenessForward rsLiveNext lis
864
865 livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
866
867
868 -- | Calculate liveness going backwards,
869 -- filling in when regs die, and what regs are live across each instruction
870
871 livenessBack
872 :: Instruction instr
873 => RegSet -- regs live on this instr
874 -> BlockMap RegSet -- regs live on entry to other BBs
875 -> [LiveInstr instr] -- instructions (accum)
876 -> [LiveInstr instr] -- instructions
877 -> (RegSet, [LiveInstr instr])
878
879 livenessBack liveregs _ done [] = (liveregs, done)
880
881 livenessBack liveregs blockmap acc (instr : instrs)
882 = let (liveregs', instr') = liveness1 liveregs blockmap instr
883 in livenessBack liveregs' blockmap (instr' : acc) instrs
884
885
886 -- don't bother tagging comments or deltas with liveness
887 liveness1
888 :: Instruction instr
889 => RegSet
890 -> BlockMap RegSet
891 -> LiveInstr instr
892 -> (RegSet, LiveInstr instr)
893
894 liveness1 liveregs _ (LiveInstr instr _)
895 | isMetaInstr instr
896 = (liveregs, LiveInstr instr Nothing)
897
898 liveness1 liveregs blockmap (LiveInstr instr _)
899
900 | not_a_branch
901 = (liveregs1, LiveInstr instr
902 (Just $ Liveness
903 { liveBorn = emptyUniqSet
904 , liveDieRead = mkUniqSet r_dying
905 , liveDieWrite = mkUniqSet w_dying }))
906
907 | otherwise
908 = (liveregs_br, LiveInstr instr
909 (Just $ Liveness
910 { liveBorn = emptyUniqSet
911 , liveDieRead = mkUniqSet r_dying_br
912 , liveDieWrite = mkUniqSet w_dying }))
913
914 where
915 RU read written = regUsageOfInstr instr
916
917 -- registers that were written here are dead going backwards.
918 -- registers that were read here are live going backwards.
919 liveregs1 = (liveregs `delListFromUniqSet` written)
920 `addListToUniqSet` read
921
922 -- registers that are not live beyond this point, are recorded
923 -- as dying here.
924 r_dying = [ reg | reg <- read, reg `notElem` written,
925 not (elementOfUniqSet reg liveregs) ]
926
927 w_dying = [ reg | reg <- written,
928 not (elementOfUniqSet reg liveregs) ]
929
930 -- union in the live regs from all the jump destinations of this
931 -- instruction.
932 targets = jumpDestsOfInstr instr -- where we go from here
933 not_a_branch = null targets
934
935 targetLiveRegs target
936 = case mapLookup target blockmap of
937 Just ra -> ra
938 Nothing -> emptyRegMap
939
940 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
941
942 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
943
944 -- registers that are live only in the branch targets should
945 -- be listed as dying here.
946 live_branch_only = live_from_branch `minusUniqSet` liveregs
947 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
948 live_branch_only)
949
950