1 -----------------------------------------------------------------------------
3 -- The register liveness determinator
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
19 BlockMap, emptyBlockMap,
26 mapBlockTop, mapBlockTopM,
27 mapGenBlockTop, mapGenBlockTopM,
39 #include "HsVersions.h"
59 -----------------------------------------------------------------------------
60 type RegSet = UniqSet Reg
62 type RegMap a = UniqFM a
63 emptyRegMap = emptyUFM
65 type BlockMap a = UniqFM a
66 emptyBlockMap = emptyUFM
69 -- | A top level thing which carries liveness information.
74 (GenBasicBlock LiveInstr)
75 -- the "instructions" here are actually more blocks,
76 -- single blocks are acyclic
77 -- multiple blocks are taken to be cyclic.
79 -- | An instruction with liveness information.
81 = Instr Instr (Maybe Liveness)
83 -- | Liveness information.
84 -- The regs which die are ones which are no longer live in the *next* instruction
86 -- (NB. if the instruction is a jump, these registers might still be live
87 -- at the jump target(s) - you have to check the liveness at the destination
88 -- block to find out).
92 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
93 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
94 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
97 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
100 [CmmStatic] -- cmm static stuff
101 (Maybe BlockId) -- id of the first block
102 (BlockMap RegSet) -- argument locals live on entry to this block
104 -- | A basic block with liveness information.
106 = GenBasicBlock LiveInstr
109 instance Outputable LiveInstr where
110 ppr (Instr instr Nothing)
113 ppr (Instr instr (Just live))
117 [ pprRegs (ptext SLIT("# born: ")) (liveBorn live)
118 , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
119 , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
122 where pprRegs :: SDoc -> RegSet -> SDoc
124 | isEmptyUniqSet regs = empty
125 | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
128 instance Outputable LiveInfo where
129 ppr (LiveInfo static firstId liveOnEntry)
130 = (vcat $ map ppr static)
131 $$ text "# firstId = " <> ppr firstId
132 $$ text "# liveOnEntry = " <> ppr liveOnEntry
135 -- | map a function across all the basic blocks in this code
138 :: (LiveBasicBlock -> LiveBasicBlock)
139 -> LiveCmmTop -> LiveCmmTop
142 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
145 -- | map a function across all the basic blocks in this code (monadic version)
149 => (LiveBasicBlock -> m LiveBasicBlock)
150 -> LiveCmmTop -> m LiveCmmTop
152 mapBlockTopM f cmm@(CmmData{})
155 mapBlockTopM f (CmmProc header label params comps)
156 = do comps' <- mapM (mapBlockCompM f) comps
157 return $ CmmProc header label params comps'
159 mapBlockCompM f (BasicBlock i blocks)
160 = do blocks' <- mapM f blocks
161 return $ BasicBlock i blocks'
164 -- map a function across all the basic blocks in this code
166 :: (GenBasicBlock i -> GenBasicBlock i)
167 -> (GenCmmTop d h i -> GenCmmTop d h i)
170 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
173 -- | map a function across all the basic blocks in this code (monadic version)
176 => (GenBasicBlock i -> m (GenBasicBlock i))
177 -> (GenCmmTop d h i -> m (GenCmmTop d h i))
179 mapGenBlockTopM f cmm@(CmmData{})
182 mapGenBlockTopM f (CmmProc header label params blocks)
183 = do blocks' <- mapM f blocks
184 return $ CmmProc header label params blocks'
187 -- | Slurp out the list of register conflicts from this top level thing.
189 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
191 = slurpCmm emptyBag live
193 where slurpCmm rs CmmData{} = rs
194 slurpCmm rs (CmmProc info _ _ blocks)
195 = foldl' (slurpComp info) rs blocks
197 slurpComp info rs (BasicBlock i blocks)
198 = foldl' (slurpBlock info) rs blocks
200 slurpBlock info rs (BasicBlock blockId instrs)
201 | LiveInfo _ _ blockLive <- info
202 , Just rsLiveEntry <- lookupUFM blockLive blockId
203 = consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
205 slurpLIs rsLive rs [] = consBag rsLive rs
206 slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
208 slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
210 -- regs that die because they are read for the last time at the start of an instruction
211 -- are not live across it.
212 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
214 -- regs live on entry to the next instruction.
215 -- be careful of orphans, make sure to delete dying regs _after_ unioning
216 -- in the ones that are born here.
217 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
218 `minusUniqSet` (liveDieWrite live)
220 -- orphan vregs are the ones that die in the same instruction they are born in.
221 -- these are likely to be results that are never used, but we still
222 -- need to assign a hreg to them..
223 rsOrphans = intersectUniqSets
225 (unionUniqSets (liveDieWrite live) (liveDieRead live))
228 rsConflicts = unionUniqSets rsLiveNext rsOrphans
230 in slurpLIs rsLiveNext (consBag rsConflicts rs) lis
233 -- | Strip away liveness information, yielding NatCmmTop
235 stripLive :: LiveCmmTop -> NatCmmTop
239 where stripCmm (CmmData sec ds) = CmmData sec ds
240 stripCmm (CmmProc (LiveInfo info _ _) label params comps)
241 = CmmProc info label params (concatMap stripComp comps)
243 stripComp (BasicBlock i blocks) = map stripBlock blocks
244 stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
245 stripLI (Instr instr _) = instr
248 -- | Make real spill instructions out of SPILL, RELOAD pseudos
250 spillNatBlock :: NatBasicBlock -> NatBasicBlock
251 spillNatBlock (BasicBlock i instrs)
252 = BasicBlock i instrs'
254 = runState (spillNat [] instrs) 0
257 = return (reverse acc)
259 spillNat acc (instr@(DELTA i) : instrs)
263 spillNat acc (SPILL reg slot : instrs)
265 spillNat (mkSpillInstr reg delta slot : acc) instrs
267 spillNat acc (RELOAD slot reg : instrs)
269 spillNat (mkLoadInstr reg delta slot : acc) instrs
271 spillNat acc (instr : instrs)
272 = spillNat (instr : acc) instrs
275 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
279 -> UniqFM (Reg, Int) -- ^ reg -> (reg, count)
282 = countCmm emptyUFM cmm
284 countCmm fm CmmData{} = fm
285 countCmm fm (CmmProc info _ _ blocks)
286 = foldl' (countComp info) fm blocks
288 countComp info fm (BasicBlock i blocks)
289 = foldl' (countBlock info) fm blocks
291 countBlock info fm (BasicBlock blockId instrs)
292 | LiveInfo _ _ blockLive <- info
293 , Just rsLiveEntry <- lookupUFM blockLive blockId
294 = countLIs rsLiveEntry fm instrs
296 countLIs rsLive fm [] = fm
297 countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
299 countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
301 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
303 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
304 `minusUniqSet` (liveDieWrite live)
306 add r fm = addToUFM_C
307 (\(r1, l1) (_, l2) -> (r1, l1 + l2))
310 fm' = foldUniqSet add fm rsLiveEntry
311 in countLIs rsLiveNext fm' lis
314 -- | Erase Delta instructions.
316 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
318 = mapBlockTop eraseBlock cmm
320 isDelta (DELTA _) = True
323 eraseBlock (BasicBlock id lis)
325 $ filter (\(Instr i _) -> not $ isDelta i)
329 -- | Patch the registers in this code according to this register mapping.
330 -- also erase reg -> reg moves when the reg is the same.
331 -- also erase reg -> reg moves when the destination dies in this instr.
335 -> LiveCmmTop -> LiveCmmTop
337 patchEraseLive patchF cmm
340 patchCmm cmm@CmmData{} = cmm
342 patchCmm cmm@(CmmProc info label params comps)
343 | LiveInfo static id blockMap <- info
344 = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
345 blockMap' = mapUFM patchRegSet blockMap
347 info' = LiveInfo static id blockMap'
348 in CmmProc info' label params $ map patchComp comps
350 patchComp (BasicBlock id blocks)
351 = BasicBlock id $ map patchBlock blocks
353 patchBlock (BasicBlock id lis)
354 = BasicBlock id $ patchInstrs lis
357 patchInstrs (li : lis)
359 | Instr i (Just live) <- li'
360 , Just (r1, r2) <- isRegRegMove i
365 = li' : patchInstrs lis
367 where li' = patchRegsLiveInstr patchF li
370 -- source and destination regs are the same
373 -- desination reg is never used
374 | elementOfUniqSet r2 (liveBorn live)
375 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
381 -- | Patch registers in this LiveInstr, including the liveness information.
385 -> LiveInstr -> LiveInstr
387 patchRegsLiveInstr patchF li
390 -> Instr (patchRegs instr patchF) Nothing
392 Instr instr (Just live)
394 (patchRegs instr patchF)
396 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
397 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
398 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
399 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
402 ---------------------------------------------------------------------------------
403 -- Annotate code with register liveness information
409 regLiveness cmm@(CmmData sec d)
410 = returnUs $ CmmData sec d
412 regLiveness cmm@(CmmProc info lbl params [])
414 (LiveInfo info Nothing emptyUFM)
417 regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
418 = let first_id = blockId first
419 sccs = sccBlocks blocks
420 (ann_sccs, block_live) = computeLiveness sccs
423 = map (\scc -> case scc of
424 AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
425 CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
427 -> panic "RegLiveness.regLiveness: no blocks in scc list")
430 in returnUs $ CmmProc
431 (LiveInfo info (Just first_id) block_live)
432 lbl params liveBlocks
435 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
436 sccBlocks blocks = stronglyConnComp graph
438 getOutEdges :: [Instr] -> [BlockId]
439 getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
441 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
442 | block@(BasicBlock id instrs) <- blocks ]
445 -- -----------------------------------------------------------------------------
446 -- Computing liveness
449 :: [SCC NatBasicBlock]
450 -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
451 -- which are "dead after this instruction".
452 BlockMap RegSet) -- blocks annontated with set of live registers
453 -- on entry to the block.
455 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
456 -- control to earlier ones only. The SCCs returned are in the *opposite*
457 -- order, which is exactly what we want for the next pass.
460 = livenessSCCs emptyBlockMap [] sccs
465 -> [SCC LiveBasicBlock] -- accum
466 -> [SCC NatBasicBlock]
467 -> ([SCC LiveBasicBlock], BlockMap RegSet)
469 livenessSCCs blockmap done [] = (done, blockmap)
471 livenessSCCs blockmap done (AcyclicSCC block : sccs)
472 = let (blockmap', block') = livenessBlock blockmap block
473 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
475 livenessSCCs blockmap done
476 (CyclicSCC blocks : sccs) =
477 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
478 where (blockmap', blocks')
479 = iterateUntilUnchanged linearLiveness equalBlockMaps
482 iterateUntilUnchanged
483 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
487 iterateUntilUnchanged f eq a b
490 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
491 iterate (\(a, _) -> f a b) $
492 (a, error "RegisterAlloc.livenessSCCs")
495 linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
496 -> (BlockMap RegSet, [LiveBasicBlock])
497 linearLiveness = mapAccumL livenessBlock
499 -- probably the least efficient way to compare two
500 -- BlockMaps for equality.
503 where a' = map f $ ufmToList a
504 b' = map f $ ufmToList b
505 f (key,elt) = (key, uniqSetToList elt)
509 -- | Annotate a basic block with register liveness information.
514 -> (BlockMap RegSet, LiveBasicBlock)
516 livenessBlock blockmap block@(BasicBlock block_id instrs)
518 (regsLiveOnEntry, instrs1)
519 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
520 blockmap' = addToUFM blockmap block_id regsLiveOnEntry
522 instrs2 = livenessForward regsLiveOnEntry instrs1
524 output = BasicBlock block_id instrs2
526 in ( blockmap', output)
528 -- | Calculate liveness going forwards,
529 -- filling in when regs are born
532 :: RegSet -- regs live on this instr
533 -> [LiveInstr] -> [LiveInstr]
535 livenessForward rsLiveEntry [] = []
536 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
538 = li : livenessForward rsLiveEntry lis
541 , RU read written <- regUsage instr
543 -- Regs that are written to but weren't live on entry to this instruction
544 -- are recorded as being born here.
546 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
548 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
549 `minusUniqSet` (liveDieRead live)
550 `minusUniqSet` (liveDieWrite live)
552 in Instr instr (Just live { liveBorn = rsBorn })
553 : livenessForward rsLiveNext lis
556 -- | Calculate liveness going backwards,
557 -- filling in when regs die, and what regs are live across each instruction
560 :: RegSet -- regs live on this instr
561 -> BlockMap RegSet -- regs live on entry to other BBs
562 -> [LiveInstr] -- instructions (accum)
563 -> [Instr] -- instructions
564 -> (RegSet, [LiveInstr])
566 livenessBack liveregs blockmap done [] = (liveregs, done)
568 livenessBack liveregs blockmap acc (instr : instrs)
569 = let (liveregs', instr') = liveness1 liveregs blockmap instr
570 in livenessBack liveregs' blockmap (instr' : acc) instrs
572 -- don't bother tagging comments or deltas with liveness
573 liveness1 liveregs blockmap (instr@COMMENT{})
574 = (liveregs, Instr instr Nothing)
576 liveness1 liveregs blockmap (instr@DELTA{})
577 = (liveregs, Instr instr Nothing)
579 liveness1 liveregs blockmap instr
582 = (liveregs1, Instr instr
584 { liveBorn = emptyUniqSet
585 , liveDieRead = mkUniqSet r_dying
586 , liveDieWrite = mkUniqSet w_dying }))
589 = (liveregs_br, Instr instr
591 { liveBorn = emptyUniqSet
592 , liveDieRead = mkUniqSet r_dying_br
593 , liveDieWrite = mkUniqSet w_dying }))
596 RU read written = regUsage instr
598 -- registers that were written here are dead going backwards.
599 -- registers that were read here are live going backwards.
600 liveregs1 = (liveregs `delListFromUniqSet` written)
601 `addListToUniqSet` read
603 -- registers that are not live beyond this point, are recorded
605 r_dying = [ reg | reg <- read, reg `notElem` written,
606 not (elementOfUniqSet reg liveregs) ]
608 w_dying = [ reg | reg <- written,
609 not (elementOfUniqSet reg liveregs) ]
611 -- union in the live regs from all the jump destinations of this
613 targets = jumpDests instr [] -- where we go from here
614 not_a_branch = null targets
616 targetLiveRegs target
617 = case lookupUFM blockmap target of
619 Nothing -> emptyBlockMap
621 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
623 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
625 -- registers that are live only in the branch targets should
626 -- be listed as dying here.
627 live_branch_only = live_from_branch `minusUniqSet` liveregs
628 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`