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,
20 mapBlockTop, mapBlockTopM,
21 mapGenBlockTop, mapGenBlockTopM,
38 import Cmm hiding (RegSet)
54 -----------------------------------------------------------------------------
55 type RegSet = UniqSet Reg
57 type RegMap a = UniqFM a
59 emptyRegMap :: UniqFM a
60 emptyRegMap = emptyUFM
62 type BlockMap a = BlockEnv a
64 emptyBlockMap :: BlockEnv a
65 emptyBlockMap = emptyBlockEnv
68 -- | A top level thing which carries liveness information.
73 (ListGraph (GenBasicBlock (LiveInstr instr)))
74 -- the "instructions" here are actually more blocks,
75 -- single blocks are acyclic
76 -- multiple blocks are taken to be cyclic.
78 -- | An instruction with liveness information.
80 = Instr instr (Maybe Liveness)
82 -- | spill this reg to a stack slot
85 -- | reload this reg from a stack slot
89 -- | Liveness information.
90 -- The regs which die are ones which are no longer live in the *next* instruction
92 -- (NB. if the instruction is a jump, these registers might still be live
93 -- at the jump target(s) - you have to check the liveness at the destination
94 -- block to find out).
98 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
99 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
100 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
103 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
106 [CmmStatic] -- cmm static stuff
107 (Maybe BlockId) -- id of the first block
108 (BlockMap RegSet) -- argument locals live on entry to this block
110 -- | A basic block with liveness information.
111 type LiveBasicBlock instr
112 = GenBasicBlock (LiveInstr instr)
115 instance Outputable instr
116 => Outputable (LiveInstr instr) where
119 ptext (sLit "\tSPILL"),
123 ptext (sLit "SLOT") <> parens (int slot)]
125 ppr (RELOAD slot reg)
127 ptext (sLit "\tRELOAD"),
129 ptext (sLit "SLOT") <> parens (int slot),
133 ppr (Instr instr Nothing)
136 ppr (Instr instr (Just live))
140 [ pprRegs (ptext (sLit "# born: ")) (liveBorn live)
141 , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
142 , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
145 where pprRegs :: SDoc -> RegSet -> SDoc
147 | isEmptyUniqSet regs = empty
148 | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
150 instance Outputable LiveInfo where
151 ppr (LiveInfo static firstId liveOnEntry)
152 = (vcat $ map ppr static)
153 $$ text "# firstId = " <> ppr firstId
154 $$ text "# liveOnEntry = " <> ppr liveOnEntry
158 -- | map a function across all the basic blocks in this code
161 :: (LiveBasicBlock instr -> LiveBasicBlock instr)
162 -> LiveCmmTop instr -> LiveCmmTop instr
165 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
168 -- | map a function across all the basic blocks in this code (monadic version)
172 => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
173 -> LiveCmmTop instr -> m (LiveCmmTop instr)
175 mapBlockTopM _ cmm@(CmmData{})
178 mapBlockTopM f (CmmProc header label params (ListGraph comps))
179 = do comps' <- mapM (mapBlockCompM f) comps
180 return $ CmmProc header label params (ListGraph comps')
182 mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
183 mapBlockCompM f (BasicBlock i blocks)
184 = do blocks' <- mapM f blocks
185 return $ BasicBlock i blocks'
188 -- map a function across all the basic blocks in this code
190 :: (GenBasicBlock i -> GenBasicBlock i)
191 -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
194 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
197 -- | map a function across all the basic blocks in this code (monadic version)
200 => (GenBasicBlock i -> m (GenBasicBlock i))
201 -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
203 mapGenBlockTopM _ cmm@(CmmData{})
206 mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
207 = do blocks' <- mapM f blocks
208 return $ CmmProc header label params (ListGraph blocks')
211 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
212 -- Slurping of conflicts and moves is wrapped up together so we don't have
213 -- to make two passes over the same code when we want to build the graph.
218 -> (Bag (UniqSet Reg), Bag (Reg, Reg))
221 = slurpCmm (emptyBag, emptyBag) live
223 where slurpCmm rs CmmData{} = rs
224 slurpCmm rs (CmmProc info _ _ (ListGraph blocks))
225 = foldl' (slurpComp info) rs blocks
227 slurpComp info rs (BasicBlock _ blocks)
228 = foldl' (slurpBlock info) rs blocks
230 slurpBlock info rs (BasicBlock blockId instrs)
231 | LiveInfo _ _ blockLive <- info
232 , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
233 , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
234 = (consBag rsLiveEntry conflicts, moves)
237 = panic "Liveness.slurpConflicts: bad block"
239 slurpLIs rsLive (conflicts, moves) []
240 = (consBag rsLive conflicts, moves)
242 slurpLIs rsLive rs (Instr _ Nothing : lis)
243 = slurpLIs rsLive rs lis
245 -- we're not expecting to be slurping conflicts from spilled code
246 slurpLIs _ _ (SPILL _ _ : _)
247 = panic "Liveness.slurpConflicts: unexpected SPILL"
249 slurpLIs _ _ (RELOAD _ _ : _)
250 = panic "Liveness.slurpConflicts: unexpected RELOAD"
252 slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
254 -- regs that die because they are read for the last time at the start of an instruction
255 -- are not live across it.
256 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
258 -- regs live on entry to the next instruction.
259 -- be careful of orphans, make sure to delete dying regs _after_ unioning
260 -- in the ones that are born here.
261 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
262 `minusUniqSet` (liveDieWrite live)
264 -- orphan vregs are the ones that die in the same instruction they are born in.
265 -- these are likely to be results that are never used, but we still
266 -- need to assign a hreg to them..
267 rsOrphans = intersectUniqSets
269 (unionUniqSets (liveDieWrite live) (liveDieRead live))
272 rsConflicts = unionUniqSets rsLiveNext rsOrphans
274 in case takeRegRegMoveInstr instr of
275 Just rr -> slurpLIs rsLiveNext
276 ( consBag rsConflicts conflicts
277 , consBag rr moves) lis
279 Nothing -> slurpLIs rsLiveNext
280 ( consBag rsConflicts conflicts
284 -- | For spill\/reloads
290 -- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
291 -- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
299 slurpReloadCoalesce live
300 = slurpCmm emptyBag live
302 where slurpCmm cs CmmData{} = cs
303 slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
304 = foldl' slurpComp cs blocks
307 = let (moveBags, _) = runState (slurpCompM comp) emptyUFM
308 in unionManyBags (cs : moveBags)
310 slurpCompM (BasicBlock _ blocks)
311 = do -- run the analysis once to record the mapping across jumps.
312 mapM_ (slurpBlock False) blocks
314 -- run it a second time while using the information from the last pass.
315 -- We /could/ run this many more times to deal with graphical control
316 -- flow and propagating info across multiple jumps, but it's probably
317 -- not worth the trouble.
318 mapM (slurpBlock True) blocks
320 slurpBlock propagate (BasicBlock blockId instrs)
321 = do -- grab the slot map for entry to this block
322 slotMap <- if propagate
323 then getSlotMap blockId
326 (_, mMoves) <- mapAccumLM slurpLI slotMap instrs
327 return $ listToBag $ catMaybes mMoves
329 slurpLI :: Instruction instr
330 => UniqFM Reg -- current slotMap
332 -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
333 -- for tracking slotMaps across jumps
335 ( UniqFM Reg -- new slotMap
336 , Maybe (Reg, Reg)) -- maybe a new coalesce edge
340 -- remember what reg was stored into the slot
341 | SPILL reg slot <- li
342 , slotMap' <- addToUFM slotMap slot reg
343 = return (slotMap', Nothing)
345 -- add an edge betwen the this reg and the last one stored into the slot
346 | RELOAD slot reg <- li
347 = case lookupUFM slotMap slot of
349 | reg /= reg2 -> return (slotMap, Just (reg, reg2))
350 | otherwise -> return (slotMap, Nothing)
352 Nothing -> return (slotMap, Nothing)
354 -- if we hit a jump, remember the current slotMap
355 | Instr instr _ <- li
356 , targets <- jumpDestsOfInstr instr
358 = do mapM_ (accSlotMap slotMap) targets
359 return (slotMap, Nothing)
362 = return (slotMap, Nothing)
364 -- record a slotmap for an in edge to this block
365 accSlotMap slotMap blockId
366 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
368 -- work out the slot map on entry to this block
369 -- if we have slot maps for multiple in-edges then we need to merge them.
372 let slotMaps = fromMaybe [] (lookupUFM map blockId)
373 return $ foldr mergeSlotMaps emptyUFM slotMaps
375 mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
376 mergeSlotMaps map1 map2
378 $ [ (k, r1) | (k, r1) <- ufmToList map1
379 , case lookupUFM map2 k of
381 Just r2 -> r1 == r2 ]
384 -- | Strip away liveness information, yielding NatCmmTop
394 where stripCmm (CmmData sec ds) = CmmData sec ds
395 stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
396 = CmmProc info label params
397 (ListGraph $ concatMap stripComp comps)
399 stripComp (BasicBlock _ blocks) = map stripLiveBlock blocks
402 -- | Strip away liveness information from a basic block,
403 -- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
407 => LiveBasicBlock instr
408 -> NatBasicBlock instr
410 stripLiveBlock (BasicBlock i lis)
411 = BasicBlock i instrs'
414 = runState (spillNat [] lis) 0
417 = return (reverse acc)
419 spillNat acc (SPILL reg slot : instrs)
421 spillNat (mkSpillInstr reg delta slot : acc) instrs
423 spillNat acc (RELOAD slot reg : instrs)
425 spillNat (mkLoadInstr reg delta slot : acc) instrs
427 spillNat acc (Instr instr _ : instrs)
428 | Just i <- takeDeltaInstr instr
432 spillNat acc (Instr instr _ : instrs)
433 = spillNat (instr : acc) instrs
436 -- | Erase Delta instructions.
444 = mapBlockTop eraseBlock cmm
446 eraseBlock (BasicBlock id lis)
448 $ filter (\(Instr i _) -> not $ isJust $ takeDeltaInstr i)
452 -- | Patch the registers in this code according to this register mapping.
453 -- also erase reg -> reg moves when the reg is the same.
454 -- also erase reg -> reg moves when the destination dies in this instr.
459 -> LiveCmmTop instr -> LiveCmmTop instr
461 patchEraseLive patchF cmm
464 patchCmm cmm@CmmData{} = cmm
466 patchCmm (CmmProc info label params (ListGraph comps))
467 | LiveInfo static id blockMap <- info
469 patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
470 blockMap' = mapBlockEnv patchRegSet blockMap
472 info' = LiveInfo static id blockMap'
473 in CmmProc info' label params $ ListGraph $ map patchComp comps
475 patchComp (BasicBlock id blocks)
476 = BasicBlock id $ map patchBlock blocks
478 patchBlock (BasicBlock id lis)
479 = BasicBlock id $ patchInstrs lis
482 patchInstrs (li : lis)
484 | Instr i (Just live) <- li'
485 , Just (r1, r2) <- takeRegRegMoveInstr i
490 = li' : patchInstrs lis
492 where li' = patchRegsLiveInstr patchF li
495 -- source and destination regs are the same
498 -- desination reg is never used
499 | elementOfUniqSet r2 (liveBorn live)
500 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
506 -- | Patch registers in this LiveInstr, including the liveness information.
511 -> LiveInstr instr -> LiveInstr instr
513 patchRegsLiveInstr patchF li
516 -> Instr (patchRegsOfInstr instr patchF) Nothing
518 Instr instr (Just live)
520 (patchRegsOfInstr instr patchF)
522 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
523 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
524 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
525 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
528 -> SPILL (patchF reg) slot
531 -> RELOAD slot (patchF reg)
534 ---------------------------------------------------------------------------------
535 -- Annotate code with register liveness information
540 -> UniqSM (LiveCmmTop instr)
542 regLiveness (CmmData i d)
543 = returnUs $ CmmData i d
545 regLiveness (CmmProc info lbl params (ListGraph []))
547 (LiveInfo info Nothing emptyBlockEnv)
548 lbl params (ListGraph [])
550 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
551 = let first_id = blockId first
552 sccs = sccBlocks blocks
553 (ann_sccs, block_live) = computeLiveness sccs
556 = map (\scc -> case scc of
557 AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
558 CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
560 -> panic "RegLiveness.regLiveness: no blocks in scc list")
563 in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
564 lbl params (ListGraph liveBlocks)
569 => [NatBasicBlock instr]
570 -> [SCC (NatBasicBlock instr)]
572 sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
574 getOutEdges :: Instruction instr => [instr] -> [BlockId]
575 getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
577 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
578 | block@(BasicBlock id instrs) <- blocks ]
581 -- -----------------------------------------------------------------------------
582 -- Computing liveness
586 => [SCC (NatBasicBlock instr)]
587 -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers
588 -- which are "dead after this instruction".
589 BlockMap RegSet) -- blocks annontated with set of live registers
590 -- on entry to the block.
592 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
593 -- control to earlier ones only. The SCCs returned are in the *opposite*
594 -- order, which is exactly what we want for the next pass.
597 = livenessSCCs emptyBlockMap [] sccs
603 -> [SCC (LiveBasicBlock instr)] -- accum
604 -> [SCC (NatBasicBlock instr)]
605 -> ( [SCC (LiveBasicBlock instr)]
608 livenessSCCs blockmap done [] = (done, blockmap)
610 livenessSCCs blockmap done (AcyclicSCC block : sccs)
611 = let (blockmap', block') = livenessBlock blockmap block
612 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
614 livenessSCCs blockmap done
615 (CyclicSCC blocks : sccs) =
616 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
617 where (blockmap', blocks')
618 = iterateUntilUnchanged linearLiveness equalBlockMaps
621 iterateUntilUnchanged
622 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
626 iterateUntilUnchanged f eq a b
629 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
630 iterate (\(a, _) -> f a b) $
631 (a, panic "RegLiveness.livenessSCCs")
636 => BlockMap RegSet -> [NatBasicBlock instr]
637 -> (BlockMap RegSet, [LiveBasicBlock instr])
639 linearLiveness = mapAccumL livenessBlock
641 -- probably the least efficient way to compare two
642 -- BlockMaps for equality.
645 where a' = map f $ blockEnvToList a
646 b' = map f $ blockEnvToList b
647 f (key,elt) = (key, uniqSetToList elt)
651 -- | Annotate a basic block with register liveness information.
656 -> NatBasicBlock instr
657 -> (BlockMap RegSet, LiveBasicBlock instr)
659 livenessBlock blockmap (BasicBlock block_id instrs)
661 (regsLiveOnEntry, instrs1)
662 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
663 blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
665 instrs2 = livenessForward regsLiveOnEntry instrs1
667 output = BasicBlock block_id instrs2
669 in ( blockmap', output)
671 -- | Calculate liveness going forwards,
672 -- filling in when regs are born
676 => RegSet -- regs live on this instr
677 -> [LiveInstr instr] -> [LiveInstr instr]
679 livenessForward _ [] = []
680 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
682 = li : livenessForward rsLiveEntry lis
685 , RU _ written <- regUsageOfInstr instr
687 -- Regs that are written to but weren't live on entry to this instruction
688 -- are recorded as being born here.
690 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
692 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
693 `minusUniqSet` (liveDieRead live)
694 `minusUniqSet` (liveDieWrite live)
696 in Instr instr (Just live { liveBorn = rsBorn })
697 : livenessForward rsLiveNext lis
699 livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
702 -- | Calculate liveness going backwards,
703 -- filling in when regs die, and what regs are live across each instruction
707 => RegSet -- regs live on this instr
708 -> BlockMap RegSet -- regs live on entry to other BBs
709 -> [LiveInstr instr] -- instructions (accum)
710 -> [instr] -- instructions
711 -> (RegSet, [LiveInstr instr])
713 livenessBack liveregs _ done [] = (liveregs, done)
715 livenessBack liveregs blockmap acc (instr : instrs)
716 = let (liveregs', instr') = liveness1 liveregs blockmap instr
717 in livenessBack liveregs' blockmap (instr' : acc) instrs
720 -- don't bother tagging comments or deltas with liveness
726 -> (RegSet, LiveInstr instr)
728 liveness1 liveregs _ instr
730 = (liveregs, Instr instr Nothing)
732 liveness1 liveregs blockmap instr
735 = (liveregs1, Instr instr
737 { liveBorn = emptyUniqSet
738 , liveDieRead = mkUniqSet r_dying
739 , liveDieWrite = mkUniqSet w_dying }))
742 = (liveregs_br, Instr instr
744 { liveBorn = emptyUniqSet
745 , liveDieRead = mkUniqSet r_dying_br
746 , liveDieWrite = mkUniqSet w_dying }))
749 RU read written = regUsageOfInstr instr
751 -- registers that were written here are dead going backwards.
752 -- registers that were read here are live going backwards.
753 liveregs1 = (liveregs `delListFromUniqSet` written)
754 `addListToUniqSet` read
756 -- registers that are not live beyond this point, are recorded
758 r_dying = [ reg | reg <- read, reg `notElem` written,
759 not (elementOfUniqSet reg liveregs) ]
761 w_dying = [ reg | reg <- written,
762 not (elementOfUniqSet reg liveregs) ]
764 -- union in the live regs from all the jump destinations of this
766 targets = jumpDestsOfInstr instr -- where we go from here
767 not_a_branch = null targets
769 targetLiveRegs target
770 = case lookupBlockEnv blockmap target of
772 Nothing -> emptyRegMap
774 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
776 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
778 -- registers that are live only in the branch targets should
779 -- be listed as dying here.
780 live_branch_only = live_from_branch `minusUniqSet` liveregs
781 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`