module RegAlloc.Liveness (
RegSet,
RegMap, emptyRegMap,
BlockMap, emptyBlockMap,
LiveCmmTop,
InstrSR (..),
LiveInstr (..),
Liveness (..),
LiveInfo (..),
LiveBasicBlock,
mapBlockTop, mapBlockTopM, mapSCCM,
mapGenBlockTop, mapGenBlockTopM,
stripLive,
stripLiveBlock,
slurpConflicts,
slurpReloadCoalesce,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
reverseBlocksInTops,
regLiveness,
natCmmTopToLive
) 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
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as Map
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
[SCC (LiveBasicBlock instr)]
data InstrSR instr
= Instr instr
| SPILL Reg Int
| RELOAD Int Reg
instance Instruction instr => Instruction (InstrSR instr) where
regUsageOfInstr i
= case i of
Instr instr -> regUsageOfInstr instr
SPILL reg _ -> RU [reg] []
RELOAD _ reg -> RU [] [reg]
patchRegsOfInstr i f
= case i of
Instr instr -> Instr (patchRegsOfInstr instr f)
SPILL reg slot -> SPILL (f reg) slot
RELOAD slot reg -> RELOAD slot (f reg)
isJumpishInstr i
= case i of
Instr instr -> isJumpishInstr instr
_ -> False
jumpDestsOfInstr i
= case i of
Instr instr -> jumpDestsOfInstr instr
_ -> []
patchJumpInstr i f
= case i of
Instr instr -> Instr (patchJumpInstr instr f)
_ -> i
mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
takeDeltaInstr i
= case i of
Instr instr -> takeDeltaInstr instr
_ -> Nothing
isMetaInstr i
= case i of
Instr instr -> isMetaInstr instr
_ -> False
mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2)
takeRegRegMoveInstr i
= case i of
Instr instr -> takeRegRegMoveInstr instr
_ -> Nothing
mkJumpInstr target = map Instr (mkJumpInstr target)
data LiveInstr instr
= LiveInstr (InstrSR instr) (Maybe Liveness)
data Liveness
= Liveness
{ liveBorn :: RegSet
, liveDieRead :: RegSet
, liveDieWrite :: RegSet }
data LiveInfo
= LiveInfo
[CmmStatic]
(Maybe BlockId)
(Maybe (BlockMap RegSet))
(Map BlockId (Set Int))
type LiveBasicBlock instr
= GenBasicBlock (LiveInstr instr)
instance Outputable instr
=> Outputable (InstrSR instr) where
ppr (Instr realInstr)
= ppr realInstr
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]
instance Outputable instr
=> Outputable (LiveInstr instr) where
ppr (LiveInstr instr Nothing)
= ppr instr
ppr (LiveInstr 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 liveVRegsOnEntry liveSlotsOnEntry)
= (vcat $ map ppr static)
$$ text "# firstId = " <> ppr firstId
$$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
$$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
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 sccs)
= do sccs' <- mapM (mapSCCM f) sccs
return $ CmmProc header label params sccs'
mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
mapSCCM f (AcyclicSCC x)
= do x' <- f x
return $ AcyclicSCC x'
mapSCCM f (CyclicSCC xs)
= do xs' <- mapM f xs
return $ CyclicSCC xs'
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 _ _ sccs)
= foldl' (slurpSCC info) rs sccs
slurpSCC info rs (AcyclicSCC b)
= slurpBlock info rs b
slurpSCC info rs (CyclicSCC bs)
= foldl' (slurpBlock info) rs bs
slurpBlock info rs (BasicBlock blockId instrs)
| LiveInfo _ _ (Just 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 (LiveInstr _ Nothing : lis)
= slurpLIs rsLive rs lis
slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr 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
:: forall instr. Instruction instr
=> LiveCmmTop instr
-> Bag (Reg, Reg)
slurpReloadCoalesce live
= slurpCmm emptyBag live
where
slurpCmm :: Bag (Reg, Reg)
-> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
-> Bag (Reg, Reg)
slurpCmm cs CmmData{} = cs
slurpCmm cs (CmmProc _ _ _ sccs)
= slurpComp cs (flattenSCCs sccs)
slurpComp :: Bag (Reg, Reg)
-> [LiveBasicBlock instr]
-> Bag (Reg, Reg)
slurpComp cs blocks
= let (moveBags, _) = runState (slurpCompM blocks) emptyUFM
in unionManyBags (cs : moveBags)
slurpCompM :: [LiveBasicBlock instr]
-> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
slurpCompM blocks
= do
mapM_ (slurpBlock False) blocks
mapM (slurpBlock True) blocks
slurpBlock :: Bool -> LiveBasicBlock instr
-> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
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 :: UniqFM Reg
-> LiveInstr instr
-> State (UniqFM [UniqFM Reg])
( UniqFM Reg
, Maybe (Reg, Reg))
slurpLI slotMap li
| LiveInstr (SPILL reg slot) _ <- li
, slotMap' <- addToUFM slotMap slot reg
= return (slotMap', Nothing)
| LiveInstr (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)
| LiveInstr (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
:: (Outputable instr, Instruction instr)
=> LiveCmmTop instr
-> NatCmmTop instr
stripLive live
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label params sccs)
= let final_blocks = flattenSCCs sccs
((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
in CmmProc info label params
(ListGraph $ map stripLiveBlock $ first' : rest')
stripCmm (CmmProc (LiveInfo info Nothing _ _) label params [])
= CmmProc info label params (ListGraph [])
stripCmm proc
= pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
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 (LiveInstr (SPILL reg slot) _ : instrs)
= do delta <- get
spillNat (mkSpillInstr reg delta slot : acc) instrs
spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
= do delta <- get
spillNat (mkLoadInstr reg delta slot : acc) instrs
spillNat acc (LiveInstr (Instr instr) _ : instrs)
| Just i <- takeDeltaInstr instr
= do put i
spillNat acc instrs
spillNat acc (LiveInstr (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 (\(LiveInstr 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 sccs)
| LiveInfo static id (Just blockMap) mLiveSlots <- info
= let
patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
blockMap' = mapBlockEnv patchRegSet blockMap
info' = LiveInfo static id (Just blockMap') mLiveSlots
in CmmProc info' label params $ map patchSCC sccs
| otherwise
= panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b)
patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs)
patchBlock (BasicBlock id lis)
= BasicBlock id $ patchInstrs lis
patchInstrs [] = []
patchInstrs (li : lis)
| LiveInstr 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
LiveInstr instr Nothing
-> LiveInstr (patchRegsOfInstr instr patchF) Nothing
LiveInstr instr (Just live)
-> LiveInstr
(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 })
natCmmTopToLive
:: Instruction instr
=> NatCmmTop instr
-> LiveCmmTop instr
natCmmTopToLive (CmmData i d)
= CmmData i d
natCmmTopToLive (CmmProc info lbl params (ListGraph []))
= CmmProc (LiveInfo info Nothing Nothing Map.empty)
lbl params []
natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _)))
= let first_id = blockId first
sccs = sccBlocks blocks
sccsLive = map (fmap (\(BasicBlock l instrs) ->
BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
$ sccs
in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty)
lbl params sccsLive
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 ]
regLiveness
:: (Outputable instr, Instruction instr)
=> LiveCmmTop instr
-> UniqSM (LiveCmmTop instr)
regLiveness (CmmData i d)
= returnUs $ CmmData i d
regLiveness (CmmProc info lbl params [])
| LiveInfo static mFirst _ _ <- info
= returnUs $ CmmProc
(LiveInfo static mFirst (Just emptyBlockEnv) Map.empty)
lbl params []
regLiveness (CmmProc info lbl params sccs)
| LiveInfo static mFirst _ liveSlotsOnEntry <- info
= let (ann_sccs, block_live) = computeLiveness sccs
in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
lbl params ann_sccs
checkIsReverseDependent
:: Instruction instr
=> [SCC (LiveBasicBlock instr)]
-> Maybe BlockId
checkIsReverseDependent sccs'
= go emptyUniqSet sccs'
where go _ []
= Nothing
go blocksSeen (AcyclicSCC block : sccs)
= let dests = slurpJumpDestsOfBlock block
blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
badDests = dests `minusUniqSet` blocksSeen'
in case uniqSetToList badDests of
[] -> go blocksSeen' sccs
bad : _ -> Just bad
go blocksSeen (CyclicSCC blocks : sccs)
= let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
badDests = dests `minusUniqSet` blocksSeen'
in case uniqSetToList badDests of
[] -> go blocksSeen' sccs
bad : _ -> Just bad
slurpJumpDestsOfBlock (BasicBlock _ instrs)
= unionManyUniqSets
$ map (mkUniqSet . jumpDestsOfInstr)
[ i | LiveInstr i _ <- instrs]
reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
reverseBlocksInTops top
= case top of
CmmData{} -> top
CmmProc info lbl params sccs -> CmmProc info lbl params (reverse sccs)
computeLiveness
:: (Outputable instr, Instruction instr)
=> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)],
BlockMap RegSet)
computeLiveness sccs
= case checkIsReverseDependent sccs of
Nothing -> livenessSCCs emptyBlockMap [] sccs
Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss"
(vcat [ text "SCCs aren't in reverse dependent order"
, text "bad blockId" <+> ppr bad
, ppr sccs])
livenessSCCs
:: Instruction instr
=> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock 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 -> [LiveBasicBlock 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
-> LiveBasicBlock 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@(LiveInstr 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 LiveInstr instr (Just live { liveBorn = rsBorn })
: livenessForward rsLiveNext lis
livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
livenessBack
:: Instruction instr
=> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [LiveInstr 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
-> LiveInstr instr
-> (RegSet, LiveInstr instr)
liveness1 liveregs _ (LiveInstr instr _)
| isMetaInstr instr
= (liveregs, LiveInstr instr Nothing)
liveness1 liveregs blockmap (LiveInstr instr _)
| not_a_branch
= (liveregs1, LiveInstr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying
, liveDieWrite = mkUniqSet w_dying }))
| otherwise
= (liveregs_br, LiveInstr 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)