module RegAlloc.Graph.Spill (
regSpill,
SpillStats(..),
accSpillSL
)
where
import RegAlloc.Liveness
import Instruction
import Reg
import Cmm hiding (RegSet)
import BlockId
import State
import Unique
import UniqFM
import UniqSet
import UniqSupply
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
regSpill
:: Instruction instr
=> [LiveCmmTop instr]
-> UniqSet Int
-> UniqSet VirtualReg
-> UniqSM
([LiveCmmTop instr]
, UniqSet Int
, SpillStats )
regSpill code slotsFree regs
| sizeUniqSet slotsFree < sizeUniqSet regs
= pprPanic "regSpill: out of spill slots!"
( text " regs to spill = " <> ppr (sizeUniqSet regs)
$$ text " slots left = " <> ppr (sizeUniqSet slotsFree))
| otherwise
= do
let slots = take (sizeUniqSet regs) $ uniqSetToList slotsFree
let regSlotMap = listToUFM
$ zip (uniqSetToList regs) slots
us <- getUs
let (code', state') =
runState (mapM (regSpill_top regSlotMap) code)
(initSpillS us)
return ( code'
, minusUniqSet slotsFree (mkUniqSet slots)
, makeSpillStats state')
regSpill_top
:: Instruction instr
=> RegMap Int
-> LiveCmmTop instr
-> SpillM (LiveCmmTop instr)
regSpill_top regSlotMap cmm
= case cmm of
CmmData{}
-> return cmm
CmmProc info label params sccs
| LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
-> do
let liveVRegsOnEntry = fromMaybe emptyBlockEnv mLiveVRegsOnEntry
let liveSlotsOnEntry' :: Map BlockId (Set Int)
liveSlotsOnEntry'
= foldBlockEnv patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
let info'
= LiveInfo static firstId
(Just liveVRegsOnEntry)
liveSlotsOnEntry'
sccs' <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs
return $ CmmProc info' label params sccs'
where
patchLiveSlot :: BlockId -> RegSet -> Map BlockId (Set Int) -> Map BlockId (Set Int)
patchLiveSlot blockId regsLive slotMap
= let curSlotsLive = fromMaybe Set.empty
$ Map.lookup blockId slotMap
moreSlotsLive = Set.fromList
$ catMaybes
$ map (lookupUFM regSlotMap)
$ uniqSetToList regsLive
slotMap' = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) slotMap
in slotMap'
regSpill_block
:: Instruction instr
=> UniqFM Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
regSpill_block regSlotMap (BasicBlock i instrs)
= do instrss' <- mapM (regSpill_instr regSlotMap) instrs
return $ BasicBlock i (concat instrss')
regSpill_instr
:: Instruction instr
=> UniqFM Int
-> LiveInstr instr
-> SpillM [LiveInstr instr]
regSpill_instr _ li@(LiveInstr _ Nothing)
= do return [li]
regSpill_instr regSlotMap
(LiveInstr instr (Just _))
= do
let RU rlRead rlWritten = regUsageOfInstr instr
let rsRead_ = nub rlRead
let rsWritten_ = nub rlWritten
let rsRead = rsRead_ \\ rsWritten_
let rsWritten = rsWritten_ \\ rsRead_
let rsModify = intersect rsRead_ rsWritten_
let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead
let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten
let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify
(instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead
(instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten
(instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
let prefixes = concat mPrefixes
let postfixes = concat mPostfixes
let instrs' = prefixes
++ [LiveInstr instr3 Nothing]
++ postfixes
return
$ instrs'
spillRead regSlotMap instr reg
| Just slot <- lookupUFM regSlotMap reg
= do (instr', nReg) <- patchInstr reg instr
modify $ \s -> s
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
return ( instr'
, ( [LiveInstr (RELOAD slot nReg) Nothing]
, []) )
| otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg"
spillWrite regSlotMap instr reg
| Just slot <- lookupUFM regSlotMap reg
= do (instr', nReg) <- patchInstr reg instr
modify $ \s -> s
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
return ( instr'
, ( []
, [LiveInstr (SPILL nReg slot) Nothing]))
| otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg"
spillModify regSlotMap instr reg
| Just slot <- lookupUFM regSlotMap reg
= do (instr', nReg) <- patchInstr reg instr
modify $ \s -> s
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
return ( instr'
, ( [LiveInstr (RELOAD slot nReg) Nothing]
, [LiveInstr (SPILL nReg slot) Nothing]))
| otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg"
patchInstr
:: Instruction instr
=> Reg -> instr -> SpillM (instr, Reg)
patchInstr reg instr
= do nUnique <- newUnique
let nReg = case reg of
RegVirtual vr -> RegVirtual (renameVirtualReg nUnique vr)
RegReal{} -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
let instr' = patchReg1 reg nReg instr
return (instr', nReg)
patchReg1
:: Instruction instr
=> Reg -> Reg -> instr -> instr
patchReg1 old new instr
= let patchF r
| r == old = new
| otherwise = r
in patchRegsOfInstr instr patchF
data SpillS
= SpillS
{
stateUS :: UniqSupply
, stateSpillSL :: UniqFM (Reg, Int, Int) }
initSpillS uniqueSupply
= SpillS
{ stateUS = uniqueSupply
, stateSpillSL = emptyUFM }
type SpillM a = State SpillS a
newUnique :: SpillM Unique
newUnique
= do us <- gets stateUS
case splitUniqSupply us of
(us1, us2)
-> do let uniq = uniqFromSupply us1
modify $ \s -> s { stateUS = us2 }
return uniq
accSpillSL (r1, s1, l1) (_, s2, l2)
= (r1, s1 + s2, l1 + l2)
data SpillStats
= SpillStats
{ spillStoreLoad :: UniqFM (Reg, Int, Int) }
makeSpillStats :: SpillS -> SpillStats
makeSpillStats s
= SpillStats
{ spillStoreLoad = stateSpillSL s }
instance Outputable SpillStats where
ppr stats
= (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
$ eltsUFM (spillStoreLoad stats))