module RegAlloc.Graph.SpillClean (
cleanSpills
)
where
import RegAlloc.Liveness
import Instruction
import Reg
import BlockId
import Cmm
import UniqSet
import UniqFM
import Unique
import State
import Outputable
import Util
import Data.List ( find, nub )
type Slot = Int
cleanSpills
:: Instruction instr
=> LiveCmmTop instr -> LiveCmmTop instr
cleanSpills cmm
= evalState (cleanSpin 0 cmm) initCleanS
cleanSpin
:: Instruction instr
=> Int
-> LiveCmmTop instr
-> CleanM (LiveCmmTop instr)
cleanSpin spinCount code
= do
modify $ \s -> s
{ sCleanedSpillsAcc = 0
, sCleanedReloadsAcc = 0
, sReloadedBy = emptyUFM }
code_forward <- mapBlockTopM cleanBlockForward code
code_backward <- mapBlockTopM cleanBlockBackward code_forward
collateJoinPoints
spills <- gets sCleanedSpillsAcc
reloads <- gets sCleanedReloadsAcc
modify $ \s -> s
{ sCleanedCount = (spills, reloads) : sCleanedCount s }
cleanedCount <- gets sCleanedCount
if take 2 cleanedCount == [(0, 0), (0, 0)]
then return code
else cleanSpin (spinCount + 1) code_backward
cleanBlockForward
:: Instruction instr
=> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockForward (BasicBlock blockId instrs)
= do
jumpValid <- gets sJumpValid
let assoc = case lookupUFM jumpValid blockId of
Just assoc -> assoc
Nothing -> emptyAssoc
instrs_reload <- cleanForward blockId assoc [] instrs
return $ BasicBlock blockId instrs_reload
cleanBlockBackward
:: Instruction instr
=> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockBackward (BasicBlock blockId instrs)
= do instrs_spill <- cleanBackward emptyUniqSet [] instrs
return $ BasicBlock blockId instrs_spill
cleanForward
:: Instruction instr
=> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward _ _ acc []
= return acc
cleanForward blockId assoc acc (li1 : li2 : instrs)
| SPILL reg1 slot1 <- li1
, RELOAD slot2 reg2 <- li2
, slot1 == slot2
= do
modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
cleanForward blockId assoc acc
(li1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
| Just (r1, r2) <- takeRegRegMoveInstr i1
= if r1 == r2
then cleanForward blockId assoc acc instrs
else do let assoc' = addAssoc (SReg r1) (SReg r2)
$ delAssoc (SReg r2)
$ assoc
cleanForward blockId assoc' (li : acc) instrs
cleanForward blockId assoc acc (li : instrs)
| SPILL reg slot <- li
= let assoc' = addAssoc (SReg reg) (SSlot slot)
$ delAssoc (SSlot slot)
$ assoc
in cleanForward blockId assoc' (li : acc) instrs
| RELOAD{} <- li
= do (assoc', mli) <- cleanReload blockId assoc li
case mli of
Nothing -> cleanForward blockId assoc' acc instrs
Just li' -> cleanForward blockId assoc' (li' : acc) instrs
| Instr instr _ <- li
, targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accJumpValid assoc) targets
cleanForward blockId assoc (li : acc) instrs
| Instr instr _ <- li
, RU _ written <- regUsageOfInstr instr
= let assoc' = foldr delAssoc assoc (map SReg $ nub written)
in cleanForward blockId assoc' (li : acc) instrs
cleanForward _ _ _ _
= panic "RegAlloc.Graph.SpillClean.cleanForward: no match"
cleanReload
:: Instruction instr
=> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload blockId assoc li@(RELOAD slot reg)
| elemAssoc (SSlot slot) (SReg reg) assoc
= do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
return (assoc, Nothing)
| Just reg2 <- findRegOfSlot assoc slot
= do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
let assoc' = addAssoc (SReg reg) (SReg reg2)
$ delAssoc (SReg reg)
$ assoc
return (assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing)
| otherwise
= do
let assoc' = addAssoc (SReg reg) (SSlot slot)
$ delAssoc (SReg reg)
$ assoc
accBlockReloadsSlot blockId slot
return (assoc', Just li)
cleanReload _ _ _
= panic "RegSpillClean.cleanReload: unhandled instr"
cleanBackward
:: UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward noReloads acc lis
= do reloadedBy <- gets sReloadedBy
cleanBackward' reloadedBy noReloads acc lis
cleanBackward' _ _ acc []
= return acc
cleanBackward' reloadedBy noReloads acc (li : instrs)
| SPILL _ slot <- li
, Nothing <- lookupUFM reloadedBy (SSlot slot)
= do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
cleanBackward noReloads acc instrs
| SPILL _ slot <- li
= if elementOfUniqSet slot noReloads
then do
modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
cleanBackward noReloads acc instrs
else do
let noReloads' = addOneToUniqSet noReloads slot
cleanBackward noReloads' (li : acc) instrs
| RELOAD slot _ <- li
, noReloads' <- delOneFromUniqSet noReloads slot
= cleanBackward noReloads' (li : acc) instrs
| otherwise
= cleanBackward noReloads (li : acc) instrs
collateJoinPoints :: CleanM ()
collateJoinPoints
= modify $ \s -> s
{ sJumpValid = mapUFM intersects (sJumpValidAcc s)
, sJumpValidAcc = emptyUFM }
intersects :: [Assoc Store] -> Assoc Store
intersects [] = emptyAssoc
intersects assocs = foldl1' intersectAssoc assocs
findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
findRegOfSlot assoc slot
| close <- closeAssoc (SSlot slot) assoc
, Just (SReg reg) <- find isStoreReg $ uniqSetToList close
= Just reg
| otherwise
= Nothing
type CleanM = State CleanS
data CleanS
= CleanS
{
sJumpValid :: UniqFM (Assoc Store)
, sJumpValidAcc :: UniqFM [Assoc Store]
, sReloadedBy :: UniqFM [BlockId]
, sCleanedCount :: [(Int, Int)]
, sCleanedSpillsAcc :: Int
, sCleanedReloadsAcc :: Int }
initCleanS :: CleanS
initCleanS
= CleanS
{ sJumpValid = emptyUFM
, sJumpValidAcc = emptyUFM
, sReloadedBy = emptyUFM
, sCleanedCount = []
, sCleanedSpillsAcc = 0
, sCleanedReloadsAcc = 0 }
accJumpValid :: Assoc Store -> BlockId -> CleanM ()
accJumpValid assocs target
= modify $ \s -> s {
sJumpValidAcc = addToUFM_C (++)
(sJumpValidAcc s)
target
[assocs] }
accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
accBlockReloadsSlot blockId slot
= modify $ \s -> s {
sReloadedBy = addToUFM_C (++)
(sReloadedBy s)
(SSlot slot)
[blockId] }
data Store
= SSlot Int
| SReg Reg
isStoreReg :: Store -> Bool
isStoreReg ss
= case ss of
SSlot _ -> False
SReg _ -> True
instance Uniquable Store where
getUnique (SReg r)
| RegReal (RealRegSingle i) <- r
= mkUnique 'R' i
| RegReal (RealRegPair r1 r2) <- r
= mkUnique 'P' (r1 * 65535 + r2)
| otherwise
= error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
getUnique (SSlot i) = mkUnique 'S' i
instance Outputable Store where
ppr (SSlot i) = text "slot" <> int i
ppr (SReg r) = ppr r
type Assoc a = UniqFM (UniqSet a)
emptyAssoc :: Assoc a
emptyAssoc = emptyUFM
addAssoc :: Uniquable a
=> a -> a -> Assoc a -> Assoc a
addAssoc a b m
= let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b)
m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
in m2
delAssoc :: (Outputable a, Uniquable a)
=> a -> Assoc a -> Assoc a
delAssoc a m
| Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a
= foldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
| otherwise = m
delAssoc1 :: Uniquable a
=> a -> a -> Assoc a -> Assoc a
delAssoc1 a b m
| Just aSet <- lookupUFM m a
= addToUFM m a (delOneFromUniqSet aSet b)
| otherwise = m
elemAssoc :: (Outputable a, Uniquable a)
=> a -> a -> Assoc a -> Bool
elemAssoc a b m
= elementOfUniqSet b (closeAssoc a m)
closeAssoc :: (Outputable a, Uniquable a)
=> a -> Assoc a -> UniqSet a
closeAssoc a assoc
= closeAssoc' assoc emptyUniqSet (unitUniqSet a)
where
closeAssoc' assoc visited toVisit
= case uniqSetToList toVisit of
[] -> visited
(x:_)
| elementOfUniqSet x visited
-> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
| otherwise
-> let neighbors
= case lookupUFM assoc x of
Nothing -> emptyUniqSet
Just set -> set
in closeAssoc' assoc
(addOneToUniqSet visited x)
(unionUniqSets toVisit neighbors)
intersectAssoc
:: Uniquable a
=> Assoc a -> Assoc a -> Assoc a
intersectAssoc a b
= intersectUFM_C (intersectUniqSets) a b