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