module RegAlloc.Liveness (
RegSet,
RegMap, emptyRegMap,
BlockMap, emptyBlockMap,
LiveCmmTop,
LiveInstr (..),
Liveness (..),
LiveInfo (..),
LiveBasicBlock,
mapBlockTop, mapBlockTopM,
mapGenBlockTop, mapGenBlockTopM,
stripLive,
stripLiveBlock,
slurpConflicts,
slurpReloadCoalesce,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
regLiveness
) where
import Reg
import Instruction
import BlockId
import Cmm hiding (RegSet)
import PprCmm()
import Digraph
import Outputable
import Unique
import UniqSet
import UniqFM
import UniqSupply
import Bag
import State
import FastString
import Data.List
import Data.Maybe
type RegSet = UniqSet Reg
type RegMap a = UniqFM a
emptyRegMap :: UniqFM a
emptyRegMap = emptyUFM
type BlockMap a = BlockEnv a
emptyBlockMap :: BlockEnv a
emptyBlockMap = emptyBlockEnv
type LiveCmmTop instr
= GenCmmTop
CmmStatic
LiveInfo
(ListGraph (GenBasicBlock (LiveInstr instr)))
data LiveInstr instr
= Instr instr (Maybe Liveness)
| SPILL Reg Int
| RELOAD Int Reg
data Liveness
= Liveness
{ liveBorn :: RegSet
, liveDieRead :: RegSet
, liveDieWrite :: RegSet }
data LiveInfo
= LiveInfo
[CmmStatic]
(Maybe BlockId)
(BlockMap RegSet)
type LiveBasicBlock instr
= GenBasicBlock (LiveInstr instr)
instance Outputable instr
=> Outputable (LiveInstr instr) where
ppr (SPILL reg slot)
= hcat [
ptext (sLit "\tSPILL"),
char ' ',
ppr reg,
comma,
ptext (sLit "SLOT") <> parens (int slot)]
ppr (RELOAD slot reg)
= hcat [
ptext (sLit "\tRELOAD"),
char ' ',
ptext (sLit "SLOT") <> parens (int slot),
comma,
ppr reg]
ppr (Instr instr Nothing)
= ppr instr
ppr (Instr instr (Just live))
= ppr instr
$$ (nest 8
$ vcat
[ pprRegs (ptext (sLit "# born: ")) (liveBorn live)
, pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
, pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
$+$ space)
where pprRegs :: SDoc -> RegSet -> SDoc
pprRegs name regs
| isEmptyUniqSet regs = empty
| otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
instance Outputable LiveInfo where
ppr (LiveInfo static firstId liveOnEntry)
= (vcat $ map ppr static)
$$ text "# firstId = " <> ppr firstId
$$ text "# liveOnEntry = " <> ppr liveOnEntry
mapBlockTop
:: (LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmTop instr -> LiveCmmTop instr
mapBlockTop f cmm
= evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
mapBlockTopM
:: Monad m
=> (LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmTop instr -> m (LiveCmmTop instr)
mapBlockTopM _ cmm@(CmmData{})
= return cmm
mapBlockTopM f (CmmProc header label params (ListGraph comps))
= do comps' <- mapM (mapBlockCompM f) comps
return $ CmmProc header label params (ListGraph comps')
mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
mapBlockCompM f (BasicBlock i blocks)
= do blocks' <- mapM f blocks
return $ BasicBlock i blocks'
mapGenBlockTop
:: (GenBasicBlock i -> GenBasicBlock i)
-> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
mapGenBlockTop f cmm
= evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
mapGenBlockTopM
:: Monad m
=> (GenBasicBlock i -> m (GenBasicBlock i))
-> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
mapGenBlockTopM _ cmm@(CmmData{})
= return cmm
mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
= do blocks' <- mapM f blocks
return $ CmmProc header label params (ListGraph blocks')
slurpConflicts
:: Instruction instr
=> LiveCmmTop instr
-> (Bag (UniqSet Reg), Bag (Reg, Reg))
slurpConflicts live
= slurpCmm (emptyBag, emptyBag) live
where slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc info _ _ (ListGraph blocks))
= foldl' (slurpComp info) rs blocks
slurpComp info rs (BasicBlock _ blocks)
= foldl' (slurpBlock info) rs blocks
slurpBlock info rs (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive <- info
, Just rsLiveEntry <- lookupBlockEnv blockLive blockId
, (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
| otherwise
= panic "Liveness.slurpConflicts: bad block"
slurpLIs rsLive (conflicts, moves) []
= (consBag rsLive conflicts, moves)
slurpLIs rsLive rs (Instr _ Nothing : lis)
= slurpLIs rsLive rs lis
slurpLIs _ _ (SPILL _ _ : _)
= panic "Liveness.slurpConflicts: unexpected SPILL"
slurpLIs _ _ (RELOAD _ _ : _)
= panic "Liveness.slurpConflicts: unexpected RELOAD"
slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
= let
rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
`minusUniqSet` (liveDieWrite live)
rsOrphans = intersectUniqSets
(liveBorn live)
(unionUniqSets (liveDieWrite live) (liveDieRead live))
rsConflicts = unionUniqSets rsLiveNext rsOrphans
in case takeRegRegMoveInstr instr of
Just rr -> slurpLIs rsLiveNext
( consBag rsConflicts conflicts
, consBag rr moves) lis
Nothing -> slurpLIs rsLiveNext
( consBag rsConflicts conflicts
, moves) lis
slurpReloadCoalesce
:: Instruction instr
=> LiveCmmTop instr
-> Bag (Reg, Reg)
slurpReloadCoalesce live
= slurpCmm emptyBag live
where slurpCmm cs CmmData{} = cs
slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
= foldl' slurpComp cs blocks
slurpComp cs comp
= let (moveBags, _) = runState (slurpCompM comp) emptyUFM
in unionManyBags (cs : moveBags)
slurpCompM (BasicBlock _ blocks)
= do
mapM_ (slurpBlock False) blocks
mapM (slurpBlock True) blocks
slurpBlock propagate (BasicBlock blockId instrs)
= do
slotMap <- if propagate
then getSlotMap blockId
else return emptyUFM
(_, mMoves) <- mapAccumLM slurpLI slotMap instrs
return $ listToBag $ catMaybes mMoves
slurpLI :: Instruction instr
=> UniqFM Reg
-> LiveInstr instr
-> State (UniqFM [UniqFM Reg])
( UniqFM Reg
, Maybe (Reg, Reg))
slurpLI slotMap li
| SPILL reg slot <- li
, slotMap' <- addToUFM slotMap slot reg
= return (slotMap', Nothing)
| RELOAD slot reg <- li
= case lookupUFM slotMap slot of
Just reg2
| reg /= reg2 -> return (slotMap, Just (reg, reg2))
| otherwise -> return (slotMap, Nothing)
Nothing -> return (slotMap, Nothing)
| Instr instr _ <- li
, targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accSlotMap slotMap) targets
return (slotMap, Nothing)
| otherwise
= return (slotMap, Nothing)
accSlotMap slotMap blockId
= modify (\s -> addToUFM_C (++) s blockId [slotMap])
getSlotMap blockId
= do map <- get
let slotMaps = fromMaybe [] (lookupUFM map blockId)
return $ foldr mergeSlotMaps emptyUFM slotMaps
mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
mergeSlotMaps map1 map2
= listToUFM
$ [ (k, r1) | (k, r1) <- ufmToList map1
, case lookupUFM map2 k of
Nothing -> False
Just r2 -> r1 == r2 ]
stripLive
:: Instruction instr
=> LiveCmmTop instr
-> NatCmmTop instr
stripLive live
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
= CmmProc info label params
(ListGraph $ concatMap stripComp comps)
stripComp (BasicBlock _ blocks) = map stripLiveBlock blocks
stripLiveBlock
:: Instruction instr
=> LiveBasicBlock instr
-> NatBasicBlock instr
stripLiveBlock (BasicBlock i lis)
= BasicBlock i instrs'
where (instrs', _)
= runState (spillNat [] lis) 0
spillNat acc []
= return (reverse acc)
spillNat acc (SPILL reg slot : instrs)
= do delta <- get
spillNat (mkSpillInstr reg delta slot : acc) instrs
spillNat acc (RELOAD slot reg : instrs)
= do delta <- get
spillNat (mkLoadInstr reg delta slot : acc) instrs
spillNat acc (Instr instr _ : instrs)
| Just i <- takeDeltaInstr instr
= do put i
spillNat acc instrs
spillNat acc (Instr instr _ : instrs)
= spillNat (instr : acc) instrs
eraseDeltasLive
:: Instruction instr
=> LiveCmmTop instr
-> LiveCmmTop instr
eraseDeltasLive cmm
= mapBlockTop eraseBlock cmm
where
eraseBlock (BasicBlock id lis)
= BasicBlock id
$ filter (\(Instr i _) -> not $ isJust $ takeDeltaInstr i)
$ lis
patchEraseLive
:: Instruction instr
=> (Reg -> Reg)
-> LiveCmmTop instr -> LiveCmmTop instr
patchEraseLive patchF cmm
= patchCmm cmm
where
patchCmm cmm@CmmData{} = cmm
patchCmm (CmmProc info label params (ListGraph comps))
| LiveInfo static id blockMap <- info
= let
patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
blockMap' = mapBlockEnv patchRegSet blockMap
info' = LiveInfo static id blockMap'
in CmmProc info' label params $ ListGraph $ map patchComp comps
patchComp (BasicBlock id blocks)
= BasicBlock id $ map patchBlock blocks
patchBlock (BasicBlock id lis)
= BasicBlock id $ patchInstrs lis
patchInstrs [] = []
patchInstrs (li : lis)
| Instr i (Just live) <- li'
, Just (r1, r2) <- takeRegRegMoveInstr i
, eatMe r1 r2 live
= patchInstrs lis
| otherwise
= li' : patchInstrs lis
where li' = patchRegsLiveInstr patchF li
eatMe r1 r2 live
| r1 == r2 = True
| elementOfUniqSet r2 (liveBorn live)
, elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
= True
| otherwise = False
patchRegsLiveInstr
:: Instruction instr
=> (Reg -> Reg)
-> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr patchF li
= case li of
Instr instr Nothing
-> Instr (patchRegsOfInstr instr patchF) Nothing
Instr instr (Just live)
-> Instr
(patchRegsOfInstr instr patchF)
(Just live
{
liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
, liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
, liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
SPILL reg slot
-> SPILL (patchF reg) slot
RELOAD slot reg
-> RELOAD slot (patchF reg)
regLiveness
:: Instruction instr
=> NatCmmTop instr
-> UniqSM (LiveCmmTop instr)
regLiveness (CmmData i d)
= returnUs $ CmmData i d
regLiveness (CmmProc info lbl params (ListGraph []))
= returnUs $ CmmProc
(LiveInfo info Nothing emptyBlockEnv)
lbl params (ListGraph [])
regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
= let first_id = blockId first
sccs = sccBlocks blocks
(ann_sccs, block_live) = computeLiveness sccs
liveBlocks
= map (\scc -> case scc of
AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
CyclicSCC []
-> panic "RegLiveness.regLiveness: no blocks in scc list")
$ ann_sccs
in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
lbl params (ListGraph liveBlocks)
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [SCC (NatBasicBlock instr)]
sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
where
getOutEdges :: Instruction instr => [instr] -> [BlockId]
getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
| block@(BasicBlock id instrs) <- blocks ]
computeLiveness
:: Instruction instr
=> [SCC (NatBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)],
BlockMap RegSet)
computeLiveness sccs
= livenessSCCs emptyBlockMap [] sccs
livenessSCCs
:: Instruction instr
=> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (NatBasicBlock instr)]
-> ( [SCC (LiveBasicBlock instr)]
, BlockMap RegSet)
livenessSCCs blockmap done [] = (done, blockmap)
livenessSCCs blockmap done (AcyclicSCC block : sccs)
= let (blockmap', block') = livenessBlock blockmap block
in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
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, panic "RegLiveness.livenessSCCs")
linearLiveness
:: Instruction instr
=> BlockMap RegSet -> [NatBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
linearLiveness = mapAccumL livenessBlock
equalBlockMaps a b
= a' == b'
where a' = map f $ blockEnvToList a
b' = map f $ blockEnvToList b
f (key,elt) = (key, uniqSetToList elt)
livenessBlock
:: Instruction instr
=> BlockMap RegSet
-> NatBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
livenessBlock blockmap (BasicBlock block_id instrs)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
instrs2 = livenessForward regsLiveOnEntry instrs1
output = BasicBlock block_id instrs2
in ( blockmap', output)
livenessForward
:: Instruction instr
=> RegSet
-> [LiveInstr instr] -> [LiveInstr instr]
livenessForward _ [] = []
livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
| Nothing <- mLive
= li : livenessForward rsLiveEntry lis
| Just live <- mLive
, RU _ written <- regUsageOfInstr instr
= let
rsBorn = mkUniqSet
$ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
`minusUniqSet` (liveDieRead live)
`minusUniqSet` (liveDieWrite live)
in Instr instr (Just live { liveBorn = rsBorn })
: livenessForward rsLiveNext lis
livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
livenessBack
:: Instruction instr
=> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [instr]
-> (RegSet, [LiveInstr instr])
livenessBack liveregs _ done [] = (liveregs, done)
livenessBack liveregs blockmap acc (instr : instrs)
= let (liveregs', instr') = liveness1 liveregs blockmap instr
in livenessBack liveregs' blockmap (instr' : acc) instrs
liveness1
:: Instruction instr
=> RegSet
-> BlockMap RegSet
-> instr
-> (RegSet, LiveInstr instr)
liveness1 liveregs _ instr
| isMetaInstr instr
= (liveregs, Instr instr Nothing)
liveness1 liveregs blockmap instr
| not_a_branch
= (liveregs1, Instr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying
, liveDieWrite = mkUniqSet w_dying }))
| otherwise
= (liveregs_br, Instr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying_br
, liveDieWrite = mkUniqSet w_dying }))
where
RU read written = regUsageOfInstr instr
liveregs1 = (liveregs `delListFromUniqSet` written)
`addListToUniqSet` read
r_dying = [ reg | reg <- read, reg `notElem` written,
not (elementOfUniqSet reg liveregs) ]
w_dying = [ reg | reg <- written,
not (elementOfUniqSet reg liveregs) ]
targets = jumpDestsOfInstr instr
not_a_branch = null targets
targetLiveRegs target
= case lookupBlockEnv blockmap target of
Just ra -> ra
Nothing -> emptyRegMap
live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
liveregs_br = liveregs1 `unionUniqSets` live_from_branch
live_branch_only = live_from_branch `minusUniqSet` liveregs
r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
live_branch_only)