1 -----------------------------------------------------------------------------
3 -- The register liveness determinator
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
13 BlockMap, emptyBlockMap,
20 mapBlockTop, mapBlockTopM,
21 mapGenBlockTop, mapGenBlockTopM,
33 #include "HsVersions.h"
53 -----------------------------------------------------------------------------
54 type RegSet = UniqSet Reg
56 type RegMap a = UniqFM a
57 emptyRegMap = emptyUFM
59 type BlockMap a = UniqFM a
60 emptyBlockMap = emptyUFM
63 -- | A top level thing which carries liveness information.
68 (GenBasicBlock LiveInstr)
69 -- the "instructions" here are actually more blocks,
70 -- single blocks are acyclic
71 -- multiple blocks are taken to be cyclic.
73 -- | An instruction with liveness information.
75 = Instr Instr (Maybe Liveness)
77 -- | Liveness information.
78 -- The regs which die are ones which are no longer live in the *next* instruction
80 -- (NB. if the instruction is a jump, these registers might still be live
81 -- at the jump target(s) - you have to check the liveness at the destination
82 -- block to find out).
86 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
87 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
88 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
91 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
94 [CmmStatic] -- cmm static stuff
95 (Maybe BlockId) -- id of the first block
96 (BlockMap RegSet) -- argument locals live on entry to this block
98 -- | A basic block with liveness information.
100 = GenBasicBlock LiveInstr
103 instance Outputable LiveInstr where
104 ppr (Instr instr Nothing)
107 ppr (Instr instr (Just live))
111 [ pprRegs (ptext SLIT("# born: ")) (liveBorn live)
112 , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
113 , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
116 where pprRegs :: SDoc -> RegSet -> SDoc
118 | isEmptyUniqSet regs = empty
119 | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
122 instance Outputable LiveInfo where
123 ppr (LiveInfo static firstId liveOnEntry)
124 = (vcat $ map ppr static)
125 $$ text "# firstId = " <> ppr firstId
126 $$ text "# liveOnEntry = " <> ppr liveOnEntry
129 -- | map a function across all the basic blocks in this code
132 :: (LiveBasicBlock -> LiveBasicBlock)
133 -> LiveCmmTop -> LiveCmmTop
136 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
139 -- | map a function across all the basic blocks in this code (monadic version)
143 => (LiveBasicBlock -> m LiveBasicBlock)
144 -> LiveCmmTop -> m LiveCmmTop
146 mapBlockTopM f cmm@(CmmData{})
149 mapBlockTopM f (CmmProc header label params comps)
150 = do comps' <- mapM (mapBlockCompM f) comps
151 return $ CmmProc header label params comps'
153 mapBlockCompM f (BasicBlock i blocks)
154 = do blocks' <- mapM f blocks
155 return $ BasicBlock i blocks'
158 -- map a function across all the basic blocks in this code
160 :: (GenBasicBlock i -> GenBasicBlock i)
161 -> (GenCmmTop d h i -> GenCmmTop d h i)
164 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
167 -- | map a function across all the basic blocks in this code (monadic version)
170 => (GenBasicBlock i -> m (GenBasicBlock i))
171 -> (GenCmmTop d h i -> m (GenCmmTop d h i))
173 mapGenBlockTopM f cmm@(CmmData{})
176 mapGenBlockTopM f (CmmProc header label params blocks)
177 = do blocks' <- mapM f blocks
178 return $ CmmProc header label params blocks'
181 -- | Slurp out the list of register conflicts from this top level thing.
183 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
185 = slurpCmm emptyBag live
187 where slurpCmm rs CmmData{} = rs
188 slurpCmm rs (CmmProc info _ _ blocks)
189 = foldl' (slurpComp info) rs blocks
191 slurpComp info rs (BasicBlock i blocks)
192 = foldl' (slurpBlock info) rs blocks
194 slurpBlock info rs (BasicBlock blockId instrs)
195 | LiveInfo _ _ blockLive <- info
196 , Just rsLiveEntry <- lookupUFM blockLive blockId
197 = consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
199 slurpLIs rsLive rs [] = consBag rsLive rs
200 slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
202 slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
204 -- regs that die because they are read for the last time at the start of an instruction
205 -- are not live across it.
206 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
208 -- regs live on entry to the next instruction.
209 -- be careful of orphans, make sure to delete dying regs _after_ unioning
210 -- in the ones that are born here.
211 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
212 `minusUniqSet` (liveDieWrite live)
214 -- orphan vregs are the ones that die in the same instruction they are born in.
215 -- these are likely to be results that are never used, but we still
216 -- need to assign a hreg to them..
217 rsOrphans = intersectUniqSets
219 (unionUniqSets (liveDieWrite live) (liveDieRead live))
222 rsConflicts = unionUniqSets rsLiveNext rsOrphans
224 in slurpLIs rsLiveNext (consBag rsConflicts rs) lis
227 -- | Strip away liveness information, yielding NatCmmTop
229 stripLive :: LiveCmmTop -> NatCmmTop
233 where stripCmm (CmmData sec ds) = CmmData sec ds
234 stripCmm (CmmProc (LiveInfo info _ _) label params comps)
235 = CmmProc info label params (concatMap stripComp comps)
237 stripComp (BasicBlock i blocks) = map stripBlock blocks
238 stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
239 stripLI (Instr instr _) = instr
242 -- | Make real spill instructions out of SPILL, RELOAD pseudos
244 spillNatBlock :: NatBasicBlock -> NatBasicBlock
245 spillNatBlock (BasicBlock i instrs)
246 = BasicBlock i instrs'
248 = runState (spillNat [] instrs) 0
251 = return (reverse acc)
253 spillNat acc (instr@(DELTA i) : instrs)
257 spillNat acc (SPILL reg slot : instrs)
259 spillNat (mkSpillInstr reg delta slot : acc) instrs
261 spillNat acc (RELOAD slot reg : instrs)
263 spillNat (mkLoadInstr reg delta slot : acc) instrs
265 spillNat acc (instr : instrs)
266 = spillNat (instr : acc) instrs
269 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
273 -> UniqFM (Reg, Int) -- ^ reg -> (reg, count)
276 = countCmm emptyUFM cmm
278 countCmm fm CmmData{} = fm
279 countCmm fm (CmmProc info _ _ blocks)
280 = foldl' (countComp info) fm blocks
282 countComp info fm (BasicBlock i blocks)
283 = foldl' (countBlock info) fm blocks
285 countBlock info fm (BasicBlock blockId instrs)
286 | LiveInfo _ _ blockLive <- info
287 , Just rsLiveEntry <- lookupUFM blockLive blockId
288 = countLIs rsLiveEntry fm instrs
290 countLIs rsLive fm [] = fm
291 countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
293 countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
295 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
297 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
298 `minusUniqSet` (liveDieWrite live)
300 add r fm = addToUFM_C
301 (\(r1, l1) (_, l2) -> (r1, l1 + l2))
304 fm' = foldUniqSet add fm rsLiveEntry
305 in countLIs rsLiveNext fm' lis
308 -- | Erase Delta instructions.
310 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
312 = mapBlockTop eraseBlock cmm
314 isDelta (DELTA _) = True
317 eraseBlock (BasicBlock id lis)
319 $ filter (\(Instr i _) -> not $ isDelta i)
323 -- | Patch the registers in this code according to this register mapping.
324 -- also erase reg -> reg moves when the reg is the same.
325 -- also erase reg -> reg moves when the destination dies in this instr.
329 -> LiveCmmTop -> LiveCmmTop
331 patchEraseLive patchF cmm
334 patchCmm cmm@CmmData{} = cmm
336 patchCmm cmm@(CmmProc info label params comps)
337 | LiveInfo static id blockMap <- info
338 = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
339 blockMap' = mapUFM patchRegSet blockMap
341 info' = LiveInfo static id blockMap'
342 in CmmProc info' label params $ map patchComp comps
344 patchComp (BasicBlock id blocks)
345 = BasicBlock id $ map patchBlock blocks
347 patchBlock (BasicBlock id lis)
348 = BasicBlock id $ patchInstrs lis
351 patchInstrs (li : lis)
353 | Instr i (Just live) <- li'
354 , Just (r1, r2) <- isRegRegMove i
359 = li' : patchInstrs lis
361 where li' = patchRegsLiveInstr patchF li
364 -- source and destination regs are the same
367 -- desination reg is never used
368 | elementOfUniqSet r2 (liveBorn live)
369 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
375 -- | Patch registers in this LiveInstr, including the liveness information.
379 -> LiveInstr -> LiveInstr
381 patchRegsLiveInstr patchF li
384 -> Instr (patchRegs instr patchF) Nothing
386 Instr instr (Just live)
388 (patchRegs instr patchF)
390 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
391 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
392 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
393 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
396 ---------------------------------------------------------------------------------
397 -- Annotate code with register liveness information
403 regLiveness cmm@(CmmData sec d)
404 = returnUs $ CmmData sec d
406 regLiveness cmm@(CmmProc info lbl params [])
408 (LiveInfo info Nothing emptyUFM)
411 regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
412 = let first_id = blockId first
413 sccs = sccBlocks blocks
414 (ann_sccs, block_live) = computeLiveness sccs
417 = map (\scc -> case scc of
418 AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
419 CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
421 -> panic "RegLiveness.regLiveness: no blocks in scc list")
424 in returnUs $ CmmProc
425 (LiveInfo info (Just first_id) block_live)
426 lbl params liveBlocks
429 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
430 sccBlocks blocks = stronglyConnComp graph
432 getOutEdges :: [Instr] -> [BlockId]
433 getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
435 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
436 | block@(BasicBlock id instrs) <- blocks ]
439 -- -----------------------------------------------------------------------------
440 -- Computing liveness
443 :: [SCC NatBasicBlock]
444 -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
445 -- which are "dead after this instruction".
446 BlockMap RegSet) -- blocks annontated with set of live registers
447 -- on entry to the block.
449 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
450 -- control to earlier ones only. The SCCs returned are in the *opposite*
451 -- order, which is exactly what we want for the next pass.
454 = livenessSCCs emptyBlockMap [] sccs
459 -> [SCC LiveBasicBlock] -- accum
460 -> [SCC NatBasicBlock]
461 -> ([SCC LiveBasicBlock], BlockMap RegSet)
463 livenessSCCs blockmap done [] = (done, blockmap)
465 livenessSCCs blockmap done (AcyclicSCC block : sccs)
466 = let (blockmap', block') = livenessBlock blockmap block
467 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
469 livenessSCCs blockmap done
470 (CyclicSCC blocks : sccs) =
471 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
472 where (blockmap', blocks')
473 = iterateUntilUnchanged linearLiveness equalBlockMaps
476 iterateUntilUnchanged
477 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
481 iterateUntilUnchanged f eq a b
484 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
485 iterate (\(a, _) -> f a b) $
486 (a, error "RegisterAlloc.livenessSCCs")
489 linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
490 -> (BlockMap RegSet, [LiveBasicBlock])
491 linearLiveness = mapAccumL livenessBlock
493 -- probably the least efficient way to compare two
494 -- BlockMaps for equality.
497 where a' = map f $ ufmToList a
498 b' = map f $ ufmToList b
499 f (key,elt) = (key, uniqSetToList elt)
503 -- | Annotate a basic block with register liveness information.
508 -> (BlockMap RegSet, LiveBasicBlock)
510 livenessBlock blockmap block@(BasicBlock block_id instrs)
512 (regsLiveOnEntry, instrs1)
513 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
514 blockmap' = addToUFM blockmap block_id regsLiveOnEntry
516 instrs2 = livenessForward regsLiveOnEntry instrs1
518 output = BasicBlock block_id instrs2
520 in ( blockmap', output)
522 -- | Calculate liveness going forwards,
523 -- filling in when regs are born
526 :: RegSet -- regs live on this instr
527 -> [LiveInstr] -> [LiveInstr]
529 livenessForward rsLiveEntry [] = []
530 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
532 = li : livenessForward rsLiveEntry lis
535 , RU read written <- regUsage instr
537 -- Regs that are written to but weren't live on entry to this instruction
538 -- are recorded as being born here.
540 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
542 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
543 `minusUniqSet` (liveDieRead live)
544 `minusUniqSet` (liveDieWrite live)
546 in Instr instr (Just live { liveBorn = rsBorn })
547 : livenessForward rsLiveNext lis
550 -- | Calculate liveness going backwards,
551 -- filling in when regs die, and what regs are live across each instruction
554 :: RegSet -- regs live on this instr
555 -> BlockMap RegSet -- regs live on entry to other BBs
556 -> [LiveInstr] -- instructions (accum)
557 -> [Instr] -- instructions
558 -> (RegSet, [LiveInstr])
560 livenessBack liveregs blockmap done [] = (liveregs, done)
562 livenessBack liveregs blockmap acc (instr : instrs)
563 = let (liveregs', instr') = liveness1 liveregs blockmap instr
564 in livenessBack liveregs' blockmap (instr' : acc) instrs
566 -- don't bother tagging comments or deltas with liveness
567 liveness1 liveregs blockmap (instr@COMMENT{})
568 = (liveregs, Instr instr Nothing)
570 liveness1 liveregs blockmap (instr@DELTA{})
571 = (liveregs, Instr instr Nothing)
573 liveness1 liveregs blockmap instr
576 = (liveregs1, Instr instr
578 { liveBorn = emptyUniqSet
579 , liveDieRead = mkUniqSet r_dying
580 , liveDieWrite = mkUniqSet w_dying }))
583 = (liveregs_br, Instr instr
585 { liveBorn = emptyUniqSet
586 , liveDieRead = mkUniqSet r_dying_br
587 , liveDieWrite = mkUniqSet w_dying }))
590 RU read written = regUsage instr
592 -- registers that were written here are dead going backwards.
593 -- registers that were read here are live going backwards.
594 liveregs1 = (liveregs `delListFromUniqSet` written)
595 `addListToUniqSet` read
597 -- registers that are not live beyond this point, are recorded
599 r_dying = [ reg | reg <- read, reg `notElem` written,
600 not (elementOfUniqSet reg liveregs) ]
602 w_dying = [ reg | reg <- written,
603 not (elementOfUniqSet reg liveregs) ]
605 -- union in the live regs from all the jump destinations of this
607 targets = jumpDests instr [] -- where we go from here
608 not_a_branch = null targets
610 targetLiveRegs target
611 = case lookupUFM blockmap target of
613 Nothing -> emptyBlockMap
615 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
617 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
619 -- registers that are live only in the branch targets should
620 -- be listed as dying here.
621 live_branch_only = live_from_branch `minusUniqSet` liveregs
622 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`