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