1 -----------------------------------------------------------------------------
3 -- The register liveness determinator
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
8 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
13 BlockMap, emptyBlockMap,
20 mapBlockTop, mapBlockTopM,
21 mapGenBlockTop, mapGenBlockTopM,
33 #include "HsVersions.h"
39 import Cmm hiding (RegSet)
53 -----------------------------------------------------------------------------
54 type RegSet = UniqSet Reg
56 type RegMap a = UniqFM a
58 emptyRegMap :: UniqFM a
59 emptyRegMap = emptyUFM
61 type BlockMap a = UniqFM a
63 emptyBlockMap :: UniqFM a
64 emptyBlockMap = emptyUFM
67 -- | A top level thing which carries liveness information.
72 (ListGraph (GenBasicBlock LiveInstr))
73 -- the "instructions" here are actually more blocks,
74 -- single blocks are acyclic
75 -- multiple blocks are taken to be cyclic.
77 -- | An instruction with liveness information.
79 = Instr Instr (Maybe Liveness)
81 -- | Liveness information.
82 -- The regs which die are ones which are no longer live in the *next* instruction
84 -- (NB. if the instruction is a jump, these registers might still be live
85 -- at the jump target(s) - you have to check the liveness at the destination
86 -- block to find out).
90 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
91 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
92 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
95 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
98 [CmmStatic] -- cmm static stuff
99 (Maybe BlockId) -- id of the first block
100 (BlockMap RegSet) -- argument locals live on entry to this block
102 -- | A basic block with liveness information.
104 = GenBasicBlock LiveInstr
107 instance Outputable LiveInstr where
108 ppr (Instr instr Nothing)
111 ppr (Instr instr (Just live))
115 [ pprRegs (ptext SLIT("# born: ")) (liveBorn live)
116 , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
117 , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
120 where pprRegs :: SDoc -> RegSet -> SDoc
122 | isEmptyUniqSet regs = empty
123 | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
126 instance Outputable LiveInfo where
127 ppr (LiveInfo static firstId liveOnEntry)
128 = (vcat $ map ppr static)
129 $$ text "# firstId = " <> ppr firstId
130 $$ text "# liveOnEntry = " <> ppr liveOnEntry
133 -- | map a function across all the basic blocks in this code
136 :: (LiveBasicBlock -> LiveBasicBlock)
137 -> LiveCmmTop -> LiveCmmTop
140 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
143 -- | map a function across all the basic blocks in this code (monadic version)
147 => (LiveBasicBlock -> m LiveBasicBlock)
148 -> LiveCmmTop -> m LiveCmmTop
150 mapBlockTopM _ cmm@(CmmData{})
153 mapBlockTopM f (CmmProc header label params (ListGraph comps))
154 = do comps' <- mapM (mapBlockCompM f) comps
155 return $ CmmProc header label params (ListGraph comps')
157 mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
158 mapBlockCompM f (BasicBlock i blocks)
159 = do blocks' <- mapM f blocks
160 return $ BasicBlock i blocks'
163 -- map a function across all the basic blocks in this code
165 :: (GenBasicBlock i -> GenBasicBlock i)
166 -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
169 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
172 -- | map a function across all the basic blocks in this code (monadic version)
175 => (GenBasicBlock i -> m (GenBasicBlock i))
176 -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
178 mapGenBlockTopM _ cmm@(CmmData{})
181 mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
182 = do blocks' <- mapM f blocks
183 return $ CmmProc header label params (ListGraph blocks')
186 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
187 -- Slurping of conflicts and moves is wrapped up together so we don't have
188 -- to make two passes over the same code when we want to build the graph.
190 slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg))
192 = slurpCmm (emptyBag, emptyBag) live
194 where slurpCmm rs CmmData{} = rs
195 slurpCmm rs (CmmProc info _ _ (ListGraph blocks))
196 = foldl' (slurpComp info) rs blocks
198 slurpComp info rs (BasicBlock _ blocks)
199 = foldl' (slurpBlock info) rs blocks
201 slurpBlock info rs (BasicBlock blockId instrs)
202 | LiveInfo _ _ blockLive <- info
203 , Just rsLiveEntry <- lookupUFM blockLive blockId
204 , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
205 = (consBag rsLiveEntry conflicts, moves)
208 = error "RegLiveness.slurpBlock: bad block"
210 slurpLIs rsLive (conflicts, moves) []
211 = (consBag rsLive conflicts, moves)
213 slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
215 slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
217 -- regs that die because they are read for the last time at the start of an instruction
218 -- are not live across it.
219 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
221 -- regs live on entry to the next instruction.
222 -- be careful of orphans, make sure to delete dying regs _after_ unioning
223 -- in the ones that are born here.
224 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
225 `minusUniqSet` (liveDieWrite live)
227 -- orphan vregs are the ones that die in the same instruction they are born in.
228 -- these are likely to be results that are never used, but we still
229 -- need to assign a hreg to them..
230 rsOrphans = intersectUniqSets
232 (unionUniqSets (liveDieWrite live) (liveDieRead live))
235 rsConflicts = unionUniqSets rsLiveNext rsOrphans
237 in case isRegRegMove instr of
238 Just rr -> slurpLIs rsLiveNext
239 ( consBag rsConflicts conflicts
240 , consBag rr moves) lis
242 Nothing -> slurpLIs rsLiveNext
243 ( consBag rsConflicts conflicts
247 -- | Strip away liveness information, yielding NatCmmTop
249 stripLive :: LiveCmmTop -> NatCmmTop
253 where stripCmm (CmmData sec ds) = CmmData sec ds
254 stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
255 = CmmProc info label params (ListGraph $ concatMap stripComp comps)
257 stripComp (BasicBlock _ blocks) = map stripBlock blocks
258 stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
259 stripLI (Instr instr _) = instr
262 -- | Make real spill instructions out of SPILL, RELOAD pseudos
264 spillNatBlock :: NatBasicBlock -> NatBasicBlock
265 spillNatBlock (BasicBlock i is)
266 = BasicBlock i instrs'
268 = runState (spillNat [] is) 0
271 = return (reverse acc)
273 spillNat acc (DELTA i : instrs)
277 spillNat acc (SPILL reg slot : instrs)
279 spillNat (mkSpillInstr reg delta slot : acc) instrs
281 spillNat acc (RELOAD slot reg : instrs)
283 spillNat (mkLoadInstr reg delta slot : acc) instrs
285 spillNat acc (instr : instrs)
286 = spillNat (instr : acc) instrs
289 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
293 -> UniqFM (Reg, Int) -- ^ reg -> (reg, count)
296 = countCmm emptyUFM cmm
298 countCmm fm CmmData{} = fm
299 countCmm fm (CmmProc info _ _ (ListGraph blocks))
300 = foldl' (countComp info) fm blocks
302 countComp info fm (BasicBlock _ blocks)
303 = foldl' (countBlock info) fm blocks
305 countBlock info fm (BasicBlock blockId instrs)
306 | LiveInfo _ _ blockLive <- info
307 , Just rsLiveEntry <- lookupUFM blockLive blockId
308 = countLIs rsLiveEntry fm instrs
311 = error "RegLiveness.countBlock: bad block"
313 countLIs _ fm [] = fm
314 countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
316 countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
318 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
320 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
321 `minusUniqSet` (liveDieWrite live)
323 add r fm = addToUFM_C
324 (\(r1, l1) (_, l2) -> (r1, l1 + l2))
327 fm' = foldUniqSet add fm rsLiveEntry
328 in countLIs rsLiveNext fm' lis
331 -- | Erase Delta instructions.
333 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
335 = mapBlockTop eraseBlock cmm
337 isDelta (DELTA _) = True
340 eraseBlock (BasicBlock id lis)
342 $ filter (\(Instr i _) -> not $ isDelta i)
346 -- | Patch the registers in this code according to this register mapping.
347 -- also erase reg -> reg moves when the reg is the same.
348 -- also erase reg -> reg moves when the destination dies in this instr.
352 -> LiveCmmTop -> LiveCmmTop
354 patchEraseLive patchF cmm
357 patchCmm cmm@CmmData{} = cmm
359 patchCmm (CmmProc info label params (ListGraph comps))
360 | LiveInfo static id blockMap <- info
361 = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
362 blockMap' = mapUFM patchRegSet blockMap
364 info' = LiveInfo static id blockMap'
365 in CmmProc info' label params $ ListGraph $ map patchComp comps
367 patchComp (BasicBlock id blocks)
368 = BasicBlock id $ map patchBlock blocks
370 patchBlock (BasicBlock id lis)
371 = BasicBlock id $ patchInstrs lis
374 patchInstrs (li : lis)
376 | Instr i (Just live) <- li'
377 , Just (r1, r2) <- isRegRegMove i
382 = li' : patchInstrs lis
384 where li' = patchRegsLiveInstr patchF li
387 -- source and destination regs are the same
390 -- desination reg is never used
391 | elementOfUniqSet r2 (liveBorn live)
392 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
398 -- | Patch registers in this LiveInstr, including the liveness information.
402 -> LiveInstr -> LiveInstr
404 patchRegsLiveInstr patchF li
407 -> Instr (patchRegs instr patchF) Nothing
409 Instr instr (Just live)
411 (patchRegs instr patchF)
413 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
414 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
415 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
416 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
419 ---------------------------------------------------------------------------------
420 -- Annotate code with register liveness information
426 regLiveness (CmmData i d)
427 = returnUs $ CmmData i d
429 regLiveness (CmmProc info lbl params (ListGraph []))
431 (LiveInfo info Nothing emptyUFM)
432 lbl params (ListGraph [])
434 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
435 = let first_id = blockId first
436 sccs = sccBlocks blocks
437 (ann_sccs, block_live) = computeLiveness sccs
440 = map (\scc -> case scc of
441 AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
442 CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
444 -> panic "RegLiveness.regLiveness: no blocks in scc list")
447 in returnUs $ CmmProc
448 (LiveInfo info (Just first_id) block_live)
449 lbl params (ListGraph liveBlocks)
452 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
453 sccBlocks blocks = stronglyConnComp graph
455 getOutEdges :: [Instr] -> [BlockId]
456 getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
458 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
459 | block@(BasicBlock id instrs) <- blocks ]
462 -- -----------------------------------------------------------------------------
463 -- Computing liveness
466 :: [SCC NatBasicBlock]
467 -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
468 -- which are "dead after this instruction".
469 BlockMap RegSet) -- blocks annontated with set of live registers
470 -- on entry to the block.
472 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
473 -- control to earlier ones only. The SCCs returned are in the *opposite*
474 -- order, which is exactly what we want for the next pass.
477 = livenessSCCs emptyBlockMap [] sccs
482 -> [SCC LiveBasicBlock] -- accum
483 -> [SCC NatBasicBlock]
484 -> ([SCC LiveBasicBlock], BlockMap RegSet)
486 livenessSCCs blockmap done [] = (done, blockmap)
488 livenessSCCs blockmap done (AcyclicSCC block : sccs)
489 = let (blockmap', block') = livenessBlock blockmap block
490 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
492 livenessSCCs blockmap done
493 (CyclicSCC blocks : sccs) =
494 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
495 where (blockmap', blocks')
496 = iterateUntilUnchanged linearLiveness equalBlockMaps
499 iterateUntilUnchanged
500 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
504 iterateUntilUnchanged f eq a b
507 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
508 iterate (\(a, _) -> f a b) $
509 (a, error "RegisterAlloc.livenessSCCs")
512 linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
513 -> (BlockMap RegSet, [LiveBasicBlock])
514 linearLiveness = mapAccumL livenessBlock
516 -- probably the least efficient way to compare two
517 -- BlockMaps for equality.
520 where a' = map f $ ufmToList a
521 b' = map f $ ufmToList b
522 f (key,elt) = (key, uniqSetToList elt)
526 -- | Annotate a basic block with register liveness information.
531 -> (BlockMap RegSet, LiveBasicBlock)
533 livenessBlock blockmap (BasicBlock block_id instrs)
535 (regsLiveOnEntry, instrs1)
536 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
537 blockmap' = addToUFM blockmap block_id regsLiveOnEntry
539 instrs2 = livenessForward regsLiveOnEntry instrs1
541 output = BasicBlock block_id instrs2
543 in ( blockmap', output)
545 -- | Calculate liveness going forwards,
546 -- filling in when regs are born
549 :: RegSet -- regs live on this instr
550 -> [LiveInstr] -> [LiveInstr]
552 livenessForward _ [] = []
553 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
555 = li : livenessForward rsLiveEntry lis
558 , RU _ written <- regUsage instr
560 -- Regs that are written to but weren't live on entry to this instruction
561 -- are recorded as being born here.
563 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
565 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
566 `minusUniqSet` (liveDieRead live)
567 `minusUniqSet` (liveDieWrite live)
569 in Instr instr (Just live { liveBorn = rsBorn })
570 : livenessForward rsLiveNext lis
572 livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
575 -- | Calculate liveness going backwards,
576 -- filling in when regs die, and what regs are live across each instruction
579 :: RegSet -- regs live on this instr
580 -> BlockMap RegSet -- regs live on entry to other BBs
581 -> [LiveInstr] -- instructions (accum)
582 -> [Instr] -- instructions
583 -> (RegSet, [LiveInstr])
585 livenessBack liveregs _ done [] = (liveregs, done)
587 livenessBack liveregs blockmap acc (instr : instrs)
588 = let (liveregs', instr') = liveness1 liveregs blockmap instr
589 in livenessBack liveregs' blockmap (instr' : acc) instrs
591 -- don't bother tagging comments or deltas with liveness
592 liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
593 liveness1 liveregs _ (instr@COMMENT{})
594 = (liveregs, Instr instr Nothing)
596 liveness1 liveregs _ (instr@DELTA{})
597 = (liveregs, Instr instr Nothing)
599 liveness1 liveregs blockmap instr
602 = (liveregs1, Instr instr
604 { liveBorn = emptyUniqSet
605 , liveDieRead = mkUniqSet r_dying
606 , liveDieWrite = mkUniqSet w_dying }))
609 = (liveregs_br, Instr instr
611 { liveBorn = emptyUniqSet
612 , liveDieRead = mkUniqSet r_dying_br
613 , liveDieWrite = mkUniqSet w_dying }))
616 RU read written = regUsage instr
618 -- registers that were written here are dead going backwards.
619 -- registers that were read here are live going backwards.
620 liveregs1 = (liveregs `delListFromUniqSet` written)
621 `addListToUniqSet` read
623 -- registers that are not live beyond this point, are recorded
625 r_dying = [ reg | reg <- read, reg `notElem` written,
626 not (elementOfUniqSet reg liveregs) ]
628 w_dying = [ reg | reg <- written,
629 not (elementOfUniqSet reg liveregs) ]
631 -- union in the live regs from all the jump destinations of this
633 targets = jumpDests instr [] -- where we go from here
634 not_a_branch = null targets
636 targetLiveRegs target
637 = case lookupUFM blockmap target of
639 Nothing -> emptyBlockMap
641 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
643 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
645 -- registers that are live only in the branch targets should
646 -- be listed as dying here.
647 live_branch_only = live_from_branch `minusUniqSet` liveregs
648 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`