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 Data.List
import Data.Maybe
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
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 <- cleanTopBackward 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
cleanForward
:: Instruction instr
=> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward _ _ acc []
= return acc
cleanForward blockId assoc acc (li1 : li2 : instrs)
| LiveInstr (SPILL reg1 slot1) _ <- li1
, LiveInstr (RELOAD slot2 reg2) _ <- li2
, slot1 == slot2
= do
modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
cleanForward blockId assoc acc
(li1 : LiveInstr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
cleanForward blockId assoc acc (li@(LiveInstr 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)
| LiveInstr (SPILL reg slot) _ <- li
= let assoc' = addAssoc (SReg reg) (SSlot slot)
$ delAssoc (SSlot slot)
$ assoc
in cleanForward blockId assoc' (li : acc) instrs
| LiveInstr (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
| LiveInstr instr _ <- li
, targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accJumpValid assoc) targets
cleanForward blockId assoc (li : acc) instrs
| LiveInstr instr _ <- li
, RU _ written <- regUsageOfInstr instr
= let assoc' = foldr delAssoc assoc (map SReg $ nub written)
in cleanForward blockId assoc' (li : acc) instrs
cleanReload
:: Instruction instr
=> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload blockId assoc li@(LiveInstr (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 $ LiveInstr (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"
cleanTopBackward
:: Instruction instr
=> LiveCmmTop instr
-> CleanM (LiveCmmTop instr)
cleanTopBackward cmm
= case cmm of
CmmData{}
-> return cmm
CmmProc info label params sccs
| LiveInfo _ _ _ liveSlotsOnEntry <- info
-> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
return $ CmmProc info label params sccs'
cleanBlockBackward
:: Instruction instr
=> Map BlockId (Set Int)
-> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)
= do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs
return $ BasicBlock blockId instrs_spill
cleanBackward
:: Instruction instr
=> Map BlockId (Set Int)
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward liveSlotsOnEntry noReloads acc lis
= do reloadedBy <- gets sReloadedBy
cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis
cleanBackward' _ _ _ acc []
= return acc
cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
| LiveInstr (SPILL _ slot) _ <- li
, Nothing <- lookupUFM reloadedBy (SSlot slot)
= do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
cleanBackward liveSlotsOnEntry noReloads acc instrs
| LiveInstr (SPILL _ slot) _ <- li
= if elementOfUniqSet slot noReloads
then do
modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
cleanBackward liveSlotsOnEntry noReloads acc instrs
else do
let noReloads' = addOneToUniqSet noReloads slot
cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
| LiveInstr (RELOAD slot _) _ <- li
, noReloads' <- delOneFromUniqSet noReloads slot
= cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
| LiveInstr instr _ <- li
, targets <- jumpDestsOfInstr instr
= do
let slotsReloadedByTargets
= Set.unions
$ catMaybes
$ map (flip Map.lookup liveSlotsOnEntry)
$ targets
let noReloads' = foldl' delOneFromUniqSet noReloads
$ Set.toList slotsReloadedByTargets
cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
| otherwise
= cleanBackward liveSlotsOnEntry 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
= mkRegSingleUnique i
| RegReal (RealRegPair r1 r2) <- r
= mkRegPairUnique (r1 * 65535 + r2)
| otherwise
= error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
getUnique (SSlot i) = mkRegSubUnique 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