1 -----------------------------------------------------------------------------
3 -- The register liveness determinator
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
13 BlockMap, emptyBlockMap,
31 #include "HsVersions.h"
51 -----------------------------------------------------------------------------
52 type RegSet = UniqSet Reg
54 type RegMap a = UniqFM a
55 emptyRegMap = emptyUFM
57 type BlockMap a = UniqFM a
58 emptyBlockMap = emptyUFM
61 -- | A top level thing which carries liveness information.
66 (GenBasicBlock LiveInstr)
67 -- the "instructions" here are actually more blocks,
68 -- single blocks are acyclic
69 -- multiple blocks are taken to be cyclic.
71 -- | An instruction with liveness information.
73 = Instr Instr (Maybe Liveness)
75 -- | Liveness information.
76 -- The regs which die are ones which are no longer live in the *next* instruction
78 -- (NB. if the instruction is a jump, these registers might still be live
79 -- at the jump target(s) - you have to check the liveness at the destination
80 -- block to find out).
84 { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
85 , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
86 , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
89 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
92 [CmmStatic] -- cmm static stuff
93 (Maybe BlockId) -- id of the first block
94 (BlockMap RegSet) -- argument locals live on entry to this block
96 -- | A basic block with liveness information.
98 = GenBasicBlock LiveInstr
101 instance Outputable LiveInstr where
102 ppr (Instr instr Nothing)
105 ppr (Instr instr (Just live))
109 [ pprRegs (ptext SLIT("# born: ")) (liveBorn live)
110 , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
111 , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
114 where pprRegs :: SDoc -> RegSet -> SDoc
116 | isEmptyUniqSet regs = empty
117 | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
120 instance Outputable LiveInfo where
121 ppr (LiveInfo static firstId liveOnEntry)
122 = (vcat $ map ppr static)
123 $$ text "# firstId = " <> ppr firstId
124 $$ text "# liveOnEntry = " <> ppr liveOnEntry
127 -- | map a function across all the basic blocks in this code
130 :: (LiveBasicBlock -> LiveBasicBlock)
131 -> LiveCmmTop -> LiveCmmTop
134 = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
137 -- | map a function across all the basic blocks in this code (monadic version)
141 => (LiveBasicBlock -> m LiveBasicBlock)
142 -> LiveCmmTop -> m LiveCmmTop
144 mapBlockTopM f cmm@(CmmData{})
147 mapBlockTopM f (CmmProc header label params comps)
148 = do comps' <- mapM (mapBlockCompM f) comps
149 return $ CmmProc header label params comps'
151 mapBlockCompM f (BasicBlock i blocks)
152 = do blocks' <- mapM f blocks
153 return $ BasicBlock i blocks'
156 -- | Slurp out the list of register conflicts from this top level thing.
158 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
160 = slurpCmm emptyBag live
162 where slurpCmm rs CmmData{} = rs
163 slurpCmm rs (CmmProc info _ _ blocks)
164 = foldl' (slurpComp info) rs blocks
166 slurpComp info rs (BasicBlock i blocks)
167 = foldl' (slurpBlock info) rs blocks
169 slurpBlock info rs (BasicBlock blockId instrs)
170 | LiveInfo _ _ blockLive <- info
171 , Just rsLiveEntry <- lookupUFM blockLive blockId
172 = consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
174 slurpLIs rsLive rs [] = consBag rsLive rs
175 slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
177 slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
179 -- regs that die because they are read for the last time at the start of an instruction
180 -- are not live across it.
181 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
183 -- regs live on entry to the next instruction.
184 -- be careful of orphans, make sure to delete dying regs _after_ unioning
185 -- in the ones that are born here.
186 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
187 `minusUniqSet` (liveDieWrite live)
189 -- orphan vregs are the ones that die in the same instruction they are born in.
190 -- these are likely to be results that are never used, but we still
191 -- need to assign a hreg to them..
192 rsOrphans = intersectUniqSets
194 (unionUniqSets (liveDieWrite live) (liveDieRead live))
197 rsConflicts = unionUniqSets rsLiveNext rsOrphans
199 in slurpLIs rsLiveNext (consBag rsConflicts rs) lis
202 -- | Strip away liveness information, yielding NatCmmTop
204 stripLive :: LiveCmmTop -> NatCmmTop
208 where stripCmm (CmmData sec ds) = CmmData sec ds
209 stripCmm (CmmProc (LiveInfo info _ _) label params comps)
210 = CmmProc info label params (concatMap stripComp comps)
212 stripComp (BasicBlock i blocks) = map stripBlock blocks
213 stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
214 stripLI (Instr instr _) = instr
217 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
221 -> UniqFM (Reg, Int) -- ^ reg -> (reg, count)
224 = countCmm emptyUFM cmm
226 countCmm fm CmmData{} = fm
227 countCmm fm (CmmProc info _ _ blocks)
228 = foldl' (countComp info) fm blocks
230 countComp info fm (BasicBlock i blocks)
231 = foldl' (countBlock info) fm blocks
233 countBlock info fm (BasicBlock blockId instrs)
234 | LiveInfo _ _ blockLive <- info
235 , Just rsLiveEntry <- lookupUFM blockLive blockId
236 = countLIs rsLiveEntry fm instrs
238 countLIs rsLive fm [] = fm
239 countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
241 countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
243 rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
245 rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
246 `minusUniqSet` (liveDieWrite live)
248 add r fm = addToUFM_C
249 (\(r1, l1) (_, l2) -> (r1, l1 + l2))
252 fm' = foldUniqSet add fm rsLiveEntry
253 in countLIs rsLiveNext fm' lis
256 -- | Erase Delta instructions.
258 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
260 = mapBlockTop eraseBlock cmm
262 isDelta (DELTA _) = True
265 eraseBlock (BasicBlock id lis)
267 $ filter (\(Instr i _) -> not $ isDelta i)
271 -- | Patch the registers in this code according to this register mapping.
272 -- also erase reg -> reg moves when the reg is the same.
273 -- also erase reg -> reg moves when the destination dies in this instr.
277 -> LiveCmmTop -> LiveCmmTop
279 patchEraseLive patchF cmm
282 patchCmm cmm@CmmData{} = cmm
284 patchCmm cmm@(CmmProc info label params comps)
285 | LiveInfo static id blockMap <- info
286 = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
287 blockMap' = mapUFM patchRegSet blockMap
289 info' = LiveInfo static id blockMap'
290 in CmmProc info' label params $ map patchComp comps
292 patchComp (BasicBlock id blocks)
293 = BasicBlock id $ map patchBlock blocks
295 patchBlock (BasicBlock id lis)
296 = BasicBlock id $ patchInstrs lis
299 patchInstrs (li : lis)
301 | Instr i (Just live) <- li'
302 , Just (r1, r2) <- isRegRegMove i
307 = li' : patchInstrs lis
309 where li' = patchRegsLiveInstr patchF li
312 -- source and destination regs are the same
315 -- desination reg is never used
316 | elementOfUniqSet r2 (liveBorn live)
317 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
323 -- | Patch registers in this LiveInstr, including the liveness information.
327 -> LiveInstr -> LiveInstr
329 patchRegsLiveInstr patchF li
332 -> Instr (patchRegs instr patchF) Nothing
334 Instr instr (Just live)
336 (patchRegs instr patchF)
338 { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
339 liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
340 , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
341 , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
344 ---------------------------------------------------------------------------------
345 -- Annotate code with register liveness information
351 regLiveness cmm@(CmmData sec d)
352 = returnUs $ CmmData sec d
354 regLiveness cmm@(CmmProc info lbl params [])
356 (LiveInfo info Nothing emptyUFM)
359 regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
360 = let first_id = blockId first
361 sccs = sccBlocks blocks
362 (ann_sccs, block_live) = computeLiveness sccs
365 = map (\scc -> case scc of
366 AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
367 CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
369 -> panic "RegLiveness.regLiveness: no blocks in scc list")
372 in returnUs $ CmmProc
373 (LiveInfo info (Just first_id) block_live)
374 lbl params liveBlocks
377 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
378 sccBlocks blocks = stronglyConnComp graph
380 getOutEdges :: [Instr] -> [BlockId]
381 getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
383 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
384 | block@(BasicBlock id instrs) <- blocks ]
387 -- -----------------------------------------------------------------------------
388 -- Computing liveness
391 :: [SCC NatBasicBlock]
392 -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
393 -- which are "dead after this instruction".
394 BlockMap RegSet) -- blocks annontated with set of live registers
395 -- on entry to the block.
397 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
398 -- control to earlier ones only. The SCCs returned are in the *opposite*
399 -- order, which is exactly what we want for the next pass.
402 = livenessSCCs emptyBlockMap [] sccs
407 -> [SCC LiveBasicBlock] -- accum
408 -> [SCC NatBasicBlock]
409 -> ([SCC LiveBasicBlock], BlockMap RegSet)
411 livenessSCCs blockmap done [] = (done, blockmap)
413 livenessSCCs blockmap done (AcyclicSCC block : sccs)
414 = let (blockmap', block') = livenessBlock blockmap block
415 in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
417 livenessSCCs blockmap done
418 (CyclicSCC blocks : sccs) =
419 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
420 where (blockmap', blocks')
421 = iterateUntilUnchanged linearLiveness equalBlockMaps
424 iterateUntilUnchanged
425 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
429 iterateUntilUnchanged f eq a b
432 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
433 iterate (\(a, _) -> f a b) $
434 (a, error "RegisterAlloc.livenessSCCs")
437 linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
438 -> (BlockMap RegSet, [LiveBasicBlock])
439 linearLiveness = mapAccumL livenessBlock
441 -- probably the least efficient way to compare two
442 -- BlockMaps for equality.
445 where a' = map f $ ufmToList a
446 b' = map f $ ufmToList b
447 f (key,elt) = (key, uniqSetToList elt)
451 -- | Annotate a basic block with register liveness information.
456 -> (BlockMap RegSet, LiveBasicBlock)
458 livenessBlock blockmap block@(BasicBlock block_id instrs)
460 (regsLiveOnEntry, instrs1)
461 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
462 blockmap' = addToUFM blockmap block_id regsLiveOnEntry
464 instrs2 = livenessForward regsLiveOnEntry instrs1
466 output = BasicBlock block_id instrs2
468 in ( blockmap', output)
470 -- | Calculate liveness going forwards,
471 -- filling in when regs are born
474 :: RegSet -- regs live on this instr
475 -> [LiveInstr] -> [LiveInstr]
477 livenessForward rsLiveEntry [] = []
478 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
480 = li : livenessForward rsLiveEntry lis
483 , RU read written <- regUsage instr
485 -- Regs that are written to but weren't live on entry to this instruction
486 -- are recorded as being born here.
488 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
490 rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
491 `minusUniqSet` (liveDieRead live)
492 `minusUniqSet` (liveDieWrite live)
494 in Instr instr (Just live { liveBorn = rsBorn })
495 : livenessForward rsLiveNext lis
498 -- | Calculate liveness going backwards,
499 -- filling in when regs die, and what regs are live across each instruction
502 :: RegSet -- regs live on this instr
503 -> BlockMap RegSet -- regs live on entry to other BBs
504 -> [LiveInstr] -- instructions (accum)
505 -> [Instr] -- instructions
506 -> (RegSet, [LiveInstr])
508 livenessBack liveregs blockmap done [] = (liveregs, done)
510 livenessBack liveregs blockmap acc (instr : instrs)
511 = let (liveregs', instr') = liveness1 liveregs blockmap instr
512 in livenessBack liveregs' blockmap (instr' : acc) instrs
514 -- don't bother tagging comments or deltas with liveness
515 liveness1 liveregs blockmap (instr@COMMENT{})
516 = (liveregs, Instr instr Nothing)
518 liveness1 liveregs blockmap (instr@DELTA{})
519 = (liveregs, Instr instr Nothing)
521 liveness1 liveregs blockmap instr
524 = (liveregs1, Instr instr
526 { liveBorn = emptyUniqSet
527 , liveDieRead = mkUniqSet r_dying
528 , liveDieWrite = mkUniqSet w_dying }))
531 = (liveregs_br, Instr instr
533 { liveBorn = emptyUniqSet
534 , liveDieRead = mkUniqSet r_dying_br
535 , liveDieWrite = mkUniqSet w_dying }))
538 RU read written = regUsage instr
540 -- registers that were written here are dead going backwards.
541 -- registers that were read here are live going backwards.
542 liveregs1 = (liveregs `delListFromUniqSet` written)
543 `addListToUniqSet` read
545 -- registers that are not live beyond this point, are recorded
547 r_dying = [ reg | reg <- read, reg `notElem` written,
548 not (elementOfUniqSet reg liveregs) ]
550 w_dying = [ reg | reg <- written,
551 not (elementOfUniqSet reg liveregs) ]
553 -- union in the live regs from all the jump destinations of this
555 targets = jumpDests instr [] -- where we go from here
556 not_a_branch = null targets
558 targetLiveRegs target
559 = case lookupUFM blockmap target of
561 Nothing -> emptyBlockMap
563 live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
565 liveregs_br = liveregs1 `unionUniqSets` live_from_branch
567 -- registers that are live only in the branch targets should
568 -- be listed as dying here.
569 live_branch_only = live_from_branch `minusUniqSet` liveregs
570 r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`