-computeLiveness sccs
- = livenessSCCs emptyBlockMap [] sccs
- where
- livenessSCCs
- :: BlockMap RegSet
- -> [SCC AnnBasicBlock] -- accum
- -> [SCC NatBasicBlock]
- -> ([SCC AnnBasicBlock], BlockMap RegSet)
-
- livenessSCCs blockmap done [] = (done, blockmap)
- livenessSCCs blockmap done
- (AcyclicSCC (BasicBlock block_id instrs) : sccs) =
- {- pprTrace "live instrs" (ppr (getUnique block_id) $$
- vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $
- -}
- livenessSCCs blockmap'
- (AcyclicSCC (BasicBlock block_id instrs'):done) sccs
- where (live,instrs') = liveness emptyUniqSet blockmap []
- (reverse instrs)
- blockmap' = addToUFM blockmap block_id live
-
- livenessSCCs blockmap done
- (CyclicSCC blocks : sccs) =
- livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
- where (blockmap', blocks')
- = iterateUntilUnchanged linearLiveness equalBlockMaps
- blockmap blocks
-
- iterateUntilUnchanged
- :: (a -> b -> (a,c)) -> (a -> a -> Bool)
- -> a -> b
- -> (a,c)
-
- iterateUntilUnchanged f eq a b
- = head $
- concatMap tail $
- groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
- iterate (\(a, _) -> f a b) $
- (a, error "RegisterAlloc.livenessSCCs")
-
-
- linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
- -> (BlockMap RegSet, [AnnBasicBlock])
- linearLiveness = mapAccumL processBlock
-
- processBlock blockmap input@(BasicBlock block_id instrs)
- = (blockmap', BasicBlock block_id instrs')
- where (live,instrs') = liveness emptyUniqSet blockmap []
- (reverse instrs)
- blockmap' = addToUFM blockmap block_id live
-
- -- probably the least efficient way to compare two
- -- BlockMaps for equality.
- equalBlockMaps a b
- = a' == b'
- where a' = map f $ ufmToList a
- b' = map f $ ufmToList b
- f (key,elt) = (key, uniqSetToList elt)
-
- liveness :: RegSet -- live regs
- -> BlockMap RegSet -- live regs on entry to other BBs
- -> [(Instr,[Reg],[Reg])] -- instructions (accum)
- -> [Instr] -- instructions
- -> (RegSet, [(Instr,[Reg],[Reg])])
-
- liveness liveregs blockmap done [] = (liveregs, done)
- liveness liveregs blockmap done (instr:instrs)
- | not_a_branch = liveness liveregs1 blockmap
- ((instr,r_dying,w_dying):done) instrs
- | otherwise = liveness liveregs_br blockmap
- ((instr,r_dying_br,w_dying):done) instrs
- where
- RU read written = regUsage instr
-
- -- registers that were written here are dead going backwards.
- -- registers that were read here are live going backwards.
- liveregs1 = (liveregs `delListFromUniqSet` written)
- `addListToUniqSet` read
-
- -- registers that are not live beyond this point, are recorded
- -- as dying here.
- r_dying = [ reg | reg <- read, reg `notElem` written,
- not (elementOfUniqSet reg liveregs) ]
-
- w_dying = [ reg | reg <- written,
- not (elementOfUniqSet reg liveregs) ]
-
- -- union in the live regs from all the jump destinations of this
- -- instruction.
- targets = jumpDests instr [] -- where we go from here
- not_a_branch = null targets
-
- targetLiveRegs target = case lookupUFM blockmap target of
- Just ra -> ra
- Nothing -> emptyBlockMap
-
- live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
-
- liveregs_br = liveregs1 `unionUniqSets` live_from_branch
-
- -- registers that are live only in the branch targets should
- -- be listed as dying here.
- live_branch_only = live_from_branch `minusUniqSet` liveregs
- r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
- live_branch_only)