1 -----------------------------------------------------------------------------
3 -- The register liveness determinator
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
8 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
10 module RegAlloc.Liveness (
13 BlockMap, emptyBlockMap,
21 mapBlockTop, mapBlockTopM,
22 mapGenBlockTop, mapGenBlockTopM,
39 import Cmm hiding (RegSet)
55 -----------------------------------------------------------------------------
56 type RegSet = UniqSet Reg
58 type RegMap a = UniqFM a
60 emptyRegMap :: UniqFM a
61 emptyRegMap = emptyUFM
63 type BlockMap a = BlockEnv a
65 emptyBlockMap :: BlockEnv a
66 emptyBlockMap = emptyBlockEnv
69 -- | A top level thing which carries liveness information.
74 [SCC (LiveBasicBlock instr)]
77 -- | The register allocator also wants to use SPILL/RELOAD meta instructions,
78 -- so we'll keep those here.
80 -- | A real machine instruction
83 -- | spill this reg to a stack slot
86 -- | reload this reg from a stack slot
89 instance Instruction instr => Instruction (InstrSR instr) where
92 Instr instr -> regUsageOfInstr instr
93 SPILL reg _ -> RU [reg] []
94 RELOAD _ reg -> RU [] [reg]
98 Instr instr -> Instr (patchRegsOfInstr instr f)
99 SPILL reg slot -> SPILL (f reg) slot
100 RELOAD slot reg -> RELOAD slot (f reg)
104 Instr instr -> isJumpishInstr instr
109 Instr instr -> jumpDestsOfInstr instr
114 Instr instr -> Instr (patchJumpInstr instr f)
117 mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
118 mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
122 Instr instr -> takeDeltaInstr instr
127 Instr instr -> isMetaInstr instr
130 mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2)
132 takeRegRegMoveInstr i
134 Instr instr -> takeRegRegMoveInstr instr
137 mkJumpInstr target = map Instr (mkJumpInstr target)
141 -- | An instruction with liveness information.
143 = LiveInstr (InstrSR instr) (Maybe Liveness)
147 -- | Liveness information.
148 -- The regs which die are ones which are no longer live in the *next* instruction
150 -- (NB. if the instruction is a jump, these registers might still be live
151 -- at the jump target(s) - you have to check the liveness at the destination
152 -- block to find out).
156 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
157 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
158 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
161 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
164 [CmmStatic] -- cmm static stuff
165 (Maybe BlockId) -- id of the first block
166 (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block
168 -- | A basic block with liveness information.
169 type LiveBasicBlock instr
170 = GenBasicBlock (LiveInstr instr)
173 instance Outputable instr
174 => Outputable (InstrSR instr) where
176 ppr (Instr realInstr)
181 ptext (sLit "\tSPILL"),
185 ptext (sLit "SLOT") <> parens (int slot)]
187 ppr (RELOAD slot reg)
189 ptext (sLit "\tRELOAD"),
191 ptext (sLit "SLOT") <> parens (int slot),
195 instance Outputable instr
196 => Outputable (LiveInstr instr) where
198 ppr (LiveInstr instr Nothing)
201 ppr (LiveInstr instr (Just live))
205 [ pprRegs (ptext (sLit "# born: ")) (liveBorn live)
206 , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
207 , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
210 where pprRegs :: SDoc -> RegSet -> SDoc
212 | isEmptyUniqSet regs = empty
213 | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
215 instance Outputable LiveInfo where
216 ppr (LiveInfo static firstId liveOnEntry)
217 = (vcat $ map ppr static)
218 $$ text "# firstId = " <> ppr firstId
219 $$ text "# liveOnEntry = " <> ppr liveOnEntry
223 -- | map a function across all the basic blocks in this code
226 :: (LiveBasicBlock instr -> LiveBasicBlock instr)
227 -> LiveCmmTop instr -> LiveCmmTop instr
230 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
233 -- | map a function across all the basic blocks in this code (monadic version)
237 => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
238 -> LiveCmmTop instr -> m (LiveCmmTop instr)
240 mapBlockTopM _ cmm@(CmmData{})
243 mapBlockTopM f (CmmProc header label params sccs)
244 = do sccs' <- mapM (mapSCCM f) sccs
245 return $ CmmProc header label params sccs'
247 mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
248 mapSCCM f (AcyclicSCC x)
250 return $ AcyclicSCC x'
252 mapSCCM f (CyclicSCC xs)
253 = do xs' <- mapM f xs
254 return $ CyclicSCC xs'
257 -- map a function across all the basic blocks in this code
259 :: (GenBasicBlock i -> GenBasicBlock i)
260 -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
263 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
266 -- | map a function across all the basic blocks in this code (monadic version)
269 => (GenBasicBlock i -> m (GenBasicBlock i))
270 -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
272 mapGenBlockTopM _ cmm@(CmmData{})
275 mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
276 = do blocks' <- mapM f blocks
277 return $ CmmProc header label params (ListGraph blocks')
280 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
281 -- Slurping of conflicts and moves is wrapped up together so we don't have
282 -- to make two passes over the same code when we want to build the graph.
287 -> (Bag (UniqSet Reg), Bag (Reg, Reg))
290 = slurpCmm (emptyBag, emptyBag) live
292 where slurpCmm rs CmmData{} = rs
293 slurpCmm rs (CmmProc info _ _ sccs)
294 = foldl' (slurpSCC info) rs sccs
296 slurpSCC info rs (AcyclicSCC b)
297 = slurpBlock info rs b
299 slurpSCC info rs (CyclicSCC bs)
300 = foldl' (slurpBlock info) rs bs
302 slurpBlock info rs (BasicBlock blockId instrs)
303 | LiveInfo _ _ (Just blockLive) <- info
304 , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
305 , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
306 = (consBag rsLiveEntry conflicts, moves)
309 = panic "Liveness.slurpConflicts: bad block"
311 slurpLIs rsLive (conflicts, moves) []
312 = (consBag rsLive conflicts, moves)
314 slurpLIs rsLive rs (LiveInstr _ Nothing : lis)
315 = slurpLIs rsLive rs lis
317 slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
319 -- regs that die because they are read for the last time at the start of an instruction
320 -- are not live across it.
321 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
323 -- regs live on entry to the next instruction.
324 -- be careful of orphans, make sure to delete dying regs _after_ unioning
325 -- in the ones that are born here.
326 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
327 `minusUniqSet` (liveDieWrite live)
329 -- orphan vregs are the ones that die in the same instruction they are born in.
330 -- these are likely to be results that are never used, but we still
331 -- need to assign a hreg to them..
332 rsOrphans = intersectUniqSets
334 (unionUniqSets (liveDieWrite live) (liveDieRead live))
337 rsConflicts = unionUniqSets rsLiveNext rsOrphans
339 in case takeRegRegMoveInstr instr of
340 Just rr -> slurpLIs rsLiveNext
341 ( consBag rsConflicts conflicts
342 , consBag rr moves) lis
344 Nothing -> slurpLIs rsLiveNext
345 ( consBag rsConflicts conflicts
349 -- | For spill\/reloads
355 -- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
356 -- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
364 slurpReloadCoalesce live
365 = slurpCmm emptyBag live
367 where slurpCmm cs CmmData{} = cs
368 slurpCmm cs (CmmProc _ _ _ sccs)
369 = slurpComp cs (flattenSCCs sccs)
372 = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM
373 in unionManyBags (cs : moveBags)
376 = do -- run the analysis once to record the mapping across jumps.
377 mapM_ (slurpBlock False) blocks
379 -- run it a second time while using the information from the last pass.
380 -- We /could/ run this many more times to deal with graphical control
381 -- flow and propagating info across multiple jumps, but it's probably
382 -- not worth the trouble.
383 mapM (slurpBlock True) blocks
385 slurpBlock propagate (BasicBlock blockId instrs)
386 = do -- grab the slot map for entry to this block
387 slotMap <- if propagate
388 then getSlotMap blockId
391 (_, mMoves) <- mapAccumLM slurpLI slotMap instrs
392 return $ listToBag $ catMaybes mMoves
394 slurpLI :: Instruction instr
395 => UniqFM Reg -- current slotMap
397 -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
398 -- for tracking slotMaps across jumps
400 ( UniqFM Reg -- new slotMap
401 , Maybe (Reg, Reg)) -- maybe a new coalesce edge
405 -- remember what reg was stored into the slot
406 | LiveInstr (SPILL reg slot) _ <- li
407 , slotMap' <- addToUFM slotMap slot reg
408 = return (slotMap', Nothing)
410 -- add an edge betwen the this reg and the last one stored into the slot
411 | LiveInstr (RELOAD slot reg) _ <- li
412 = case lookupUFM slotMap slot of
414 | reg /= reg2 -> return (slotMap, Just (reg, reg2))
415 | otherwise -> return (slotMap, Nothing)
417 Nothing -> return (slotMap, Nothing)
419 -- if we hit a jump, remember the current slotMap
420 | LiveInstr (Instr instr) _ <- li
421 , targets <- jumpDestsOfInstr instr
423 = do mapM_ (accSlotMap slotMap) targets
424 return (slotMap, Nothing)
427 = return (slotMap, Nothing)
429 -- record a slotmap for an in edge to this block
430 accSlotMap slotMap blockId
431 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
433 -- work out the slot map on entry to this block
434 -- if we have slot maps for multiple in-edges then we need to merge them.
437 let slotMaps = fromMaybe [] (lookupUFM map blockId)
438 return $ foldr mergeSlotMaps emptyUFM slotMaps
440 mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
441 mergeSlotMaps map1 map2
443 $ [ (k, r1) | (k, r1) <- ufmToList map1
444 , case lookupUFM map2 k of
446 Just r2 -> r1 == r2 ]
449 -- | Strip away liveness information, yielding NatCmmTop
459 where stripCmm (CmmData sec ds) = CmmData sec ds
460 stripCmm (CmmProc (LiveInfo info _ _) label params sccs)
461 = CmmProc info label params
462 (ListGraph $ map stripLiveBlock $ flattenSCCs sccs)
465 -- | Strip away liveness information from a basic block,
466 -- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
470 => LiveBasicBlock instr
471 -> NatBasicBlock instr
473 stripLiveBlock (BasicBlock i lis)
474 = BasicBlock i instrs'
477 = runState (spillNat [] lis) 0
480 = return (reverse acc)
482 spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
484 spillNat (mkSpillInstr reg delta slot : acc) instrs
486 spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
488 spillNat (mkLoadInstr reg delta slot : acc) instrs
490 spillNat acc (LiveInstr (Instr instr) _ : instrs)
491 | Just i <- takeDeltaInstr instr
495 spillNat acc (LiveInstr (Instr instr) _ : instrs)
496 = spillNat (instr : acc) instrs
499 -- | Erase Delta instructions.
507 = mapBlockTop eraseBlock cmm
509 eraseBlock (BasicBlock id lis)
511 $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
515 -- | Patch the registers in this code according to this register mapping.
516 -- also erase reg -> reg moves when the reg is the same.
517 -- also erase reg -> reg moves when the destination dies in this instr.
522 -> LiveCmmTop instr -> LiveCmmTop instr
524 patchEraseLive patchF cmm
527 patchCmm cmm@CmmData{} = cmm
529 patchCmm (CmmProc info label params sccs)
530 | LiveInfo static id (Just blockMap) <- info
532 patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
533 blockMap' = mapBlockEnv patchRegSet blockMap
535 info' = LiveInfo static id (Just blockMap')
536 in CmmProc info' label params $ map patchSCC sccs
539 = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
541 patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b)
542 patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs)
544 patchBlock (BasicBlock id lis)
545 = BasicBlock id $ patchInstrs lis
548 patchInstrs (li : lis)
550 | LiveInstr i (Just live) <- li'
551 , Just (r1, r2) <- takeRegRegMoveInstr i
556 = li' : patchInstrs lis
558 where li' = patchRegsLiveInstr patchF li
561 -- source and destination regs are the same
564 -- desination reg is never used
565 | elementOfUniqSet r2 (liveBorn live)
566 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
572 -- | Patch registers in this LiveInstr, including the liveness information.
577 -> LiveInstr instr -> LiveInstr instr
579 patchRegsLiveInstr patchF li
581 LiveInstr instr Nothing
582 -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
584 LiveInstr instr (Just live)
586 (patchRegsOfInstr instr patchF)
588 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
589 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
590 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
591 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
594 --------------------------------------------------------------------------------
595 -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
602 natCmmTopToLive (CmmData i d)
605 natCmmTopToLive (CmmProc info lbl params (ListGraph []))
606 = CmmProc (LiveInfo info Nothing Nothing)
609 natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _)))
610 = let first_id = blockId first
611 sccs = sccBlocks blocks
612 sccsLive = map (fmap (\(BasicBlock l instrs) ->
613 BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
616 in CmmProc (LiveInfo info (Just first_id) Nothing)
622 => [NatBasicBlock instr]
623 -> [SCC (NatBasicBlock instr)]
625 sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
627 getOutEdges :: Instruction instr => [instr] -> [BlockId]
628 getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
630 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
631 | block@(BasicBlock id instrs) <- blocks ]
634 ---------------------------------------------------------------------------------
635 -- Annotate code with register liveness information
640 -> UniqSM (LiveCmmTop instr)
642 regLiveness (CmmData i d)
643 = returnUs $ CmmData i d
645 regLiveness (CmmProc info lbl params [])
646 | LiveInfo static mFirst _ <- info
648 (LiveInfo static mFirst (Just emptyBlockEnv))
651 regLiveness (CmmProc info lbl params sccs)
652 | LiveInfo static mFirst _ <- info
653 = let (ann_sccs, block_live) = computeLiveness sccs
655 in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live))
660 -- -----------------------------------------------------------------------------
661 -- Computing liveness
665 => [SCC (LiveBasicBlock instr)]
666 -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers
667 -- which are "dead after this instruction".
668 BlockMap RegSet) -- blocks annontated with set of live registers
669 -- on entry to the block.
671 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
672 -- control to earlier ones only. The SCCs returned are in the *opposite*
673 -- order, which is exactly what we want for the next pass.
676 = livenessSCCs emptyBlockMap [] sccs
682 -> [SCC (LiveBasicBlock instr)] -- accum
683 -> [SCC (LiveBasicBlock instr)]
684 -> ( [SCC (LiveBasicBlock instr)]
687 livenessSCCs blockmap done []
690 livenessSCCs blockmap done (AcyclicSCC block : sccs)
691 = let (blockmap', block') = livenessBlock blockmap block
692 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
694 livenessSCCs blockmap done
695 (CyclicSCC blocks : sccs) =
696 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
697 where (blockmap', blocks')
698 = iterateUntilUnchanged linearLiveness equalBlockMaps
701 iterateUntilUnchanged
702 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
706 iterateUntilUnchanged f eq a b
709 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
710 iterate (\(a, _) -> f a b) $
711 (a, panic "RegLiveness.livenessSCCs")
716 => BlockMap RegSet -> [LiveBasicBlock instr]
717 -> (BlockMap RegSet, [LiveBasicBlock instr])
719 linearLiveness = mapAccumL livenessBlock
721 -- probably the least efficient way to compare two
722 -- BlockMaps for equality.
725 where a' = map f $ blockEnvToList a
726 b' = map f $ blockEnvToList b
727 f (key,elt) = (key, uniqSetToList elt)
731 -- | Annotate a basic block with register liveness information.
736 -> LiveBasicBlock instr
737 -> (BlockMap RegSet, LiveBasicBlock instr)
739 livenessBlock blockmap (BasicBlock block_id instrs)
741 (regsLiveOnEntry, instrs1)
742 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
743 blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
745 instrs2 = livenessForward regsLiveOnEntry instrs1
747 output = BasicBlock block_id instrs2
749 in ( blockmap', output)
751 -- | Calculate liveness going forwards,
752 -- filling in when regs are born
756 => RegSet -- regs live on this instr
757 -> [LiveInstr instr] -> [LiveInstr instr]
759 livenessForward _ [] = []
760 livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis)
762 = li : livenessForward rsLiveEntry lis
765 , RU _ written <- regUsageOfInstr instr
767 -- Regs that are written to but weren't live on entry to this instruction
768 -- are recorded as being born here.
770 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
772 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
773 `minusUniqSet` (liveDieRead live)
774 `minusUniqSet` (liveDieWrite live)
776 in LiveInstr instr (Just live { liveBorn = rsBorn })
777 : livenessForward rsLiveNext lis
779 livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
782 -- | Calculate liveness going backwards,
783 -- filling in when regs die, and what regs are live across each instruction
787 => RegSet -- regs live on this instr
788 -> BlockMap RegSet -- regs live on entry to other BBs
789 -> [LiveInstr instr] -- instructions (accum)
790 -> [LiveInstr instr] -- instructions
791 -> (RegSet, [LiveInstr instr])
793 livenessBack liveregs _ done [] = (liveregs, done)
795 livenessBack liveregs blockmap acc (instr : instrs)
796 = let (liveregs', instr') = liveness1 liveregs blockmap instr
797 in livenessBack liveregs' blockmap (instr' : acc) instrs
800 -- don't bother tagging comments or deltas with liveness
806 -> (RegSet, LiveInstr instr)
808 liveness1 liveregs _ (LiveInstr instr _)
810 = (liveregs, LiveInstr instr Nothing)
812 liveness1 liveregs blockmap (LiveInstr instr _)
815 = (liveregs1, LiveInstr instr
817 { liveBorn = emptyUniqSet
818 , liveDieRead = mkUniqSet r_dying
819 , liveDieWrite = mkUniqSet w_dying }))
822 = (liveregs_br, LiveInstr instr
824 { liveBorn = emptyUniqSet
825 , liveDieRead = mkUniqSet r_dying_br
826 , liveDieWrite = mkUniqSet w_dying }))
829 RU read written = regUsageOfInstr instr
831 -- registers that were written here are dead going backwards.
832 -- registers that were read here are live going backwards.
833 liveregs1 = (liveregs `delListFromUniqSet` written)
834 `addListToUniqSet` read
836 -- registers that are not live beyond this point, are recorded
838 r_dying = [ reg | reg <- read, reg `notElem` written,
839 not (elementOfUniqSet reg liveregs) ]
841 w_dying = [ reg | reg <- written,
842 not (elementOfUniqSet reg liveregs) ]
844 -- union in the live regs from all the jump destinations of this
846 targets = jumpDestsOfInstr instr -- where we go from here
847 not_a_branch = null targets
849 targetLiveRegs target
850 = case lookupBlockEnv blockmap target of
852 Nothing -> emptyRegMap
854 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
856 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
858 -- registers that are live only in the branch targets should
859 -- be listed as dying here.
860 live_branch_only = live_from_branch `minusUniqSet` liveregs
861 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`