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,
37 import Cmm hiding (RegSet)
52 -----------------------------------------------------------------------------
53 type RegSet = UniqSet Reg
55 type RegMap a = UniqFM a
57 emptyRegMap :: UniqFM a
58 emptyRegMap = emptyUFM
60 type BlockMap a = UniqFM a
62 emptyBlockMap :: UniqFM a
63 emptyBlockMap = emptyUFM
66 -- | A top level thing which carries liveness information.
71 (ListGraph (GenBasicBlock LiveInstr))
72 -- the "instructions" here are actually more blocks,
73 -- single blocks are acyclic
74 -- multiple blocks are taken to be cyclic.
76 -- | An instruction with liveness information.
78 = Instr Instr (Maybe Liveness)
80 -- | Liveness information.
81 -- The regs which die are ones which are no longer live in the *next* instruction
83 -- (NB. if the instruction is a jump, these registers might still be live
84 -- at the jump target(s) - you have to check the liveness at the destination
85 -- block to find out).
89 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
90 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
91 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
94 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
97 [CmmStatic] -- cmm static stuff
98 (Maybe BlockId) -- id of the first block
99 (BlockMap RegSet) -- argument locals live on entry to this block
101 -- | A basic block with liveness information.
103 = GenBasicBlock LiveInstr
106 instance Outputable LiveInstr where
107 ppr (Instr instr Nothing)
110 ppr (Instr instr (Just live))
114 [ pprRegs (ptext (sLit "# born: ")) (liveBorn live)
115 , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
116 , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
119 where pprRegs :: SDoc -> RegSet -> SDoc
121 | isEmptyUniqSet regs = empty
122 | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
125 instance Outputable LiveInfo where
126 ppr (LiveInfo static firstId liveOnEntry)
127 = (vcat $ map ppr static)
128 $$ text "# firstId = " <> ppr firstId
129 $$ text "# liveOnEntry = " <> ppr liveOnEntry
132 -- | map a function across all the basic blocks in this code
135 :: (LiveBasicBlock -> LiveBasicBlock)
136 -> LiveCmmTop -> LiveCmmTop
139 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
142 -- | map a function across all the basic blocks in this code (monadic version)
146 => (LiveBasicBlock -> m LiveBasicBlock)
147 -> LiveCmmTop -> m LiveCmmTop
149 mapBlockTopM _ cmm@(CmmData{})
152 mapBlockTopM f (CmmProc header label params (ListGraph comps))
153 = do comps' <- mapM (mapBlockCompM f) comps
154 return $ CmmProc header label params (ListGraph comps')
156 mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
157 mapBlockCompM f (BasicBlock i blocks)
158 = do blocks' <- mapM f blocks
159 return $ BasicBlock i blocks'
162 -- map a function across all the basic blocks in this code
164 :: (GenBasicBlock i -> GenBasicBlock i)
165 -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
168 = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
171 -- | map a function across all the basic blocks in this code (monadic version)
174 => (GenBasicBlock i -> m (GenBasicBlock i))
175 -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
177 mapGenBlockTopM _ cmm@(CmmData{})
180 mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
181 = do blocks' <- mapM f blocks
182 return $ CmmProc header label params (ListGraph blocks')
185 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
186 -- Slurping of conflicts and moves is wrapped up together so we don't have
187 -- to make two passes over the same code when we want to build the graph.
189 slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg))
191 = slurpCmm (emptyBag, emptyBag) live
193 where slurpCmm rs CmmData{} = rs
194 slurpCmm rs (CmmProc info _ _ (ListGraph blocks))
195 = foldl' (slurpComp info) rs blocks
197 slurpComp info rs (BasicBlock _ 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 , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
204 = (consBag rsLiveEntry conflicts, moves)
207 = panic "RegLiveness.slurpBlock: bad block"
209 slurpLIs rsLive (conflicts, moves) []
210 = (consBag rsLive conflicts, moves)
212 slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
214 slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
216 -- regs that die because they are read for the last time at the start of an instruction
217 -- are not live across it.
218 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
220 -- regs live on entry to the next instruction.
221 -- be careful of orphans, make sure to delete dying regs _after_ unioning
222 -- in the ones that are born here.
223 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
224 `minusUniqSet` (liveDieWrite live)
226 -- orphan vregs are the ones that die in the same instruction they are born in.
227 -- these are likely to be results that are never used, but we still
228 -- need to assign a hreg to them..
229 rsOrphans = intersectUniqSets
231 (unionUniqSets (liveDieWrite live) (liveDieRead live))
234 rsConflicts = unionUniqSets rsLiveNext rsOrphans
236 in case isRegRegMove instr of
237 Just rr -> slurpLIs rsLiveNext
238 ( consBag rsConflicts conflicts
239 , consBag rr moves) lis
241 Nothing -> slurpLIs rsLiveNext
242 ( consBag rsConflicts conflicts
246 -- | For spill/reloads
252 -- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
253 -- the spill/reload instrs can be cleaned and replaced by a nop reg-reg move.
256 slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
257 slurpReloadCoalesce live
258 = slurpCmm emptyBag live
260 where slurpCmm cs CmmData{} = cs
261 slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
262 = foldl' slurpComp cs blocks
265 = let (moveBags, _) = runState (slurpCompM comp) emptyUFM
266 in unionManyBags (cs : moveBags)
268 slurpCompM (BasicBlock _ blocks)
269 = do -- run the analysis once to record the mapping across jumps.
270 mapM_ (slurpBlock False) blocks
272 -- run it a second time while using the information from the last pass.
273 -- We /could/ run this many more times to deal with graphical control
274 -- flow and propagating info across multiple jumps, but it's probably
275 -- not worth the trouble.
276 mapM (slurpBlock True) blocks
278 slurpBlock propagate (BasicBlock blockId instrs)
279 = do -- grab the slot map for entry to this block
280 slotMap <- if propagate
281 then getSlotMap blockId
284 (_, mMoves) <- mapAccumLM slurpLI slotMap instrs
285 return $ listToBag $ catMaybes mMoves
287 slurpLI :: UniqFM Reg -- current slotMap
289 -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
290 -- for tracking slotMaps across jumps
292 ( UniqFM Reg -- new slotMap
293 , Maybe (Reg, Reg)) -- maybe a new coalesce edge
295 slurpLI slotMap (Instr instr _)
297 -- remember what reg was stored into the slot
298 | SPILL reg slot <- instr
299 , slotMap' <- addToUFM slotMap slot reg
300 = return (slotMap', Nothing)
302 -- add an edge betwen the this reg and the last one stored into the slot
303 | RELOAD slot reg <- instr
304 = case lookupUFM slotMap slot of
306 | reg /= reg2 -> return (slotMap, Just (reg, reg2))
307 | otherwise -> return (slotMap, Nothing)
309 Nothing -> return (slotMap, Nothing)
311 -- if we hit a jump, remember the current slotMap
312 | targets <- jumpDests instr []
314 = do mapM_ (accSlotMap slotMap) targets
315 return (slotMap, Nothing)
318 = return (slotMap, Nothing)
320 -- record a slotmap for an in edge to this block
321 accSlotMap slotMap blockId
322 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
324 -- work out the slot map on entry to this block
325 -- if we have slot maps for multiple in-edges then we need to merge them.
328 let slotMaps = fromMaybe [] (lookupUFM map blockId)
329 return $ foldr mergeSlotMaps emptyUFM slotMaps
331 mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
332 mergeSlotMaps map1 map2
334 $ [ (k, r1) | (k, r1) <- ufmToList map1
335 , case lookupUFM map2 k of
337 Just r2 -> r1 == r2 ]
340 -- | Strip away liveness information, yielding NatCmmTop
342 stripLive :: LiveCmmTop -> NatCmmTop
346 where stripCmm (CmmData sec ds) = CmmData sec ds
347 stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
348 = CmmProc info label params (ListGraph $ concatMap stripComp comps)
350 stripComp (BasicBlock _ blocks) = map stripBlock blocks
351 stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
352 stripLI (Instr instr _) = instr
355 -- | Make real spill instructions out of SPILL, RELOAD pseudos
357 spillNatBlock :: NatBasicBlock -> NatBasicBlock
358 spillNatBlock (BasicBlock i is)
359 = BasicBlock i instrs'
361 = runState (spillNat [] is) 0
364 = return (reverse acc)
366 spillNat acc (DELTA i : instrs)
370 spillNat acc (SPILL reg slot : instrs)
372 spillNat (mkSpillInstr reg delta slot : acc) instrs
374 spillNat acc (RELOAD slot reg : instrs)
376 spillNat (mkLoadInstr reg delta slot : acc) instrs
378 spillNat acc (instr : instrs)
379 = spillNat (instr : acc) instrs
382 -- | Erase Delta instructions.
384 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
386 = mapBlockTop eraseBlock cmm
388 isDelta (DELTA _) = True
391 eraseBlock (BasicBlock id lis)
393 $ filter (\(Instr i _) -> not $ isDelta i)
397 -- | Patch the registers in this code according to this register mapping.
398 -- also erase reg -> reg moves when the reg is the same.
399 -- also erase reg -> reg moves when the destination dies in this instr.
403 -> LiveCmmTop -> LiveCmmTop
405 patchEraseLive patchF cmm
408 patchCmm cmm@CmmData{} = cmm
410 patchCmm (CmmProc info label params (ListGraph comps))
411 | LiveInfo static id blockMap <- info
412 = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
413 blockMap' = mapUFM patchRegSet blockMap
415 info' = LiveInfo static id blockMap'
416 in CmmProc info' label params $ ListGraph $ map patchComp comps
418 patchComp (BasicBlock id blocks)
419 = BasicBlock id $ map patchBlock blocks
421 patchBlock (BasicBlock id lis)
422 = BasicBlock id $ patchInstrs lis
425 patchInstrs (li : lis)
427 | Instr i (Just live) <- li'
428 , Just (r1, r2) <- isRegRegMove i
433 = li' : patchInstrs lis
435 where li' = patchRegsLiveInstr patchF li
438 -- source and destination regs are the same
441 -- desination reg is never used
442 | elementOfUniqSet r2 (liveBorn live)
443 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
449 -- | Patch registers in this LiveInstr, including the liveness information.
453 -> LiveInstr -> LiveInstr
455 patchRegsLiveInstr patchF li
458 -> Instr (patchRegs instr patchF) Nothing
460 Instr instr (Just live)
462 (patchRegs instr patchF)
464 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
465 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
466 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
467 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
470 ---------------------------------------------------------------------------------
471 -- Annotate code with register liveness information
477 regLiveness (CmmData i d)
478 = returnUs $ CmmData i d
480 regLiveness (CmmProc info lbl params (ListGraph []))
482 (LiveInfo info Nothing emptyUFM)
483 lbl params (ListGraph [])
485 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
486 = let first_id = blockId first
487 sccs = sccBlocks blocks
488 (ann_sccs, block_live) = computeLiveness sccs
491 = map (\scc -> case scc of
492 AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
493 CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
495 -> panic "RegLiveness.regLiveness: no blocks in scc list")
498 in returnUs $ CmmProc
499 (LiveInfo info (Just first_id) block_live)
500 lbl params (ListGraph liveBlocks)
503 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
504 sccBlocks blocks = stronglyConnComp graph
506 getOutEdges :: [Instr] -> [BlockId]
507 getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
509 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
510 | block@(BasicBlock id instrs) <- blocks ]
513 -- -----------------------------------------------------------------------------
514 -- Computing liveness
517 :: [SCC NatBasicBlock]
518 -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
519 -- which are "dead after this instruction".
520 BlockMap RegSet) -- blocks annontated with set of live registers
521 -- on entry to the block.
523 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
524 -- control to earlier ones only. The SCCs returned are in the *opposite*
525 -- order, which is exactly what we want for the next pass.
528 = livenessSCCs emptyBlockMap [] sccs
533 -> [SCC LiveBasicBlock] -- accum
534 -> [SCC NatBasicBlock]
535 -> ([SCC LiveBasicBlock], BlockMap RegSet)
537 livenessSCCs blockmap done [] = (done, blockmap)
539 livenessSCCs blockmap done (AcyclicSCC block : sccs)
540 = let (blockmap', block') = livenessBlock blockmap block
541 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
543 livenessSCCs blockmap done
544 (CyclicSCC blocks : sccs) =
545 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
546 where (blockmap', blocks')
547 = iterateUntilUnchanged linearLiveness equalBlockMaps
550 iterateUntilUnchanged
551 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
555 iterateUntilUnchanged f eq a b
558 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
559 iterate (\(a, _) -> f a b) $
560 (a, panic "RegLiveness.livenessSCCs")
563 linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
564 -> (BlockMap RegSet, [LiveBasicBlock])
565 linearLiveness = mapAccumL livenessBlock
567 -- probably the least efficient way to compare two
568 -- BlockMaps for equality.
571 where a' = map f $ ufmToList a
572 b' = map f $ ufmToList b
573 f (key,elt) = (key, uniqSetToList elt)
577 -- | Annotate a basic block with register liveness information.
582 -> (BlockMap RegSet, LiveBasicBlock)
584 livenessBlock blockmap (BasicBlock block_id instrs)
586 (regsLiveOnEntry, instrs1)
587 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
588 blockmap' = addToUFM blockmap block_id regsLiveOnEntry
590 instrs2 = livenessForward regsLiveOnEntry instrs1
592 output = BasicBlock block_id instrs2
594 in ( blockmap', output)
596 -- | Calculate liveness going forwards,
597 -- filling in when regs are born
600 :: RegSet -- regs live on this instr
601 -> [LiveInstr] -> [LiveInstr]
603 livenessForward _ [] = []
604 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
606 = li : livenessForward rsLiveEntry lis
609 , RU _ written <- regUsage instr
611 -- Regs that are written to but weren't live on entry to this instruction
612 -- are recorded as being born here.
614 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
616 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
617 `minusUniqSet` (liveDieRead live)
618 `minusUniqSet` (liveDieWrite live)
620 in Instr instr (Just live { liveBorn = rsBorn })
621 : livenessForward rsLiveNext lis
623 livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
626 -- | Calculate liveness going backwards,
627 -- filling in when regs die, and what regs are live across each instruction
630 :: RegSet -- regs live on this instr
631 -> BlockMap RegSet -- regs live on entry to other BBs
632 -> [LiveInstr] -- instructions (accum)
633 -> [Instr] -- instructions
634 -> (RegSet, [LiveInstr])
636 livenessBack liveregs _ done [] = (liveregs, done)
638 livenessBack liveregs blockmap acc (instr : instrs)
639 = let (liveregs', instr') = liveness1 liveregs blockmap instr
640 in livenessBack liveregs' blockmap (instr' : acc) instrs
642 -- don't bother tagging comments or deltas with liveness
643 liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
644 liveness1 liveregs _ (instr@COMMENT{})
645 = (liveregs, Instr instr Nothing)
647 liveness1 liveregs _ (instr@DELTA{})
648 = (liveregs, Instr instr Nothing)
650 liveness1 liveregs blockmap instr
653 = (liveregs1, Instr instr
655 { liveBorn = emptyUniqSet
656 , liveDieRead = mkUniqSet r_dying
657 , liveDieWrite = mkUniqSet w_dying }))
660 = (liveregs_br, Instr instr
662 { liveBorn = emptyUniqSet
663 , liveDieRead = mkUniqSet r_dying_br
664 , liveDieWrite = mkUniqSet w_dying }))
667 RU read written = regUsage instr
669 -- registers that were written here are dead going backwards.
670 -- registers that were read here are live going backwards.
671 liveregs1 = (liveregs `delListFromUniqSet` written)
672 `addListToUniqSet` read
674 -- registers that are not live beyond this point, are recorded
676 r_dying = [ reg | reg <- read, reg `notElem` written,
677 not (elementOfUniqSet reg liveregs) ]
679 w_dying = [ reg | reg <- written,
680 not (elementOfUniqSet reg liveregs) ]
682 -- union in the live regs from all the jump destinations of this
684 targets = jumpDests instr [] -- where we go from here
685 not_a_branch = null targets
687 targetLiveRegs target
688 = case lookupUFM blockmap target of
690 Nothing -> emptyBlockMap
692 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
694 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
696 -- registers that are live only in the branch targets should
697 -- be listed as dying here.
698 live_branch_only = live_from_branch `minusUniqSet` liveregs
699 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`