module RegAlloc.Graph.Spill (
regSpill,
SpillStats(..),
accSpillSL
) where
import GhcPrelude
import RegAlloc.Liveness
import Instruction
import Reg
import Cmm hiding (RegSet)
import BlockId
import Hoopl.Collections
import MonadUtils
import State
import Unique
import UniqFM
import UniqSet
import UniqSupply
import Outputable
import GHC.Platform
import Data.List
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
regSpill
:: Instruction instr
=> Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
([LiveCmmDecl statics instr]
, UniqSet Int
, Int
, SpillStats )
regSpill platform code slotsFree slotCount regs
| sizeUniqSet slotsFree < sizeUniqSet regs
=
let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512])
in regSpill platform code slotsFree' (slotCount+512) regs
| otherwise
= do
let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
let regSlotMap = listToUFM
$ zip (nonDetEltsUniqSet regs) slots
us <- getUniqueSupplyM
let (code', state') =
runState (mapM (regSpill_top platform regSlotMap) code)
(initSpillS us)
return ( code'
, minusUniqSet slotsFree (mkUniqSet slots)
, slotCount
, makeSpillStats state')
regSpill_top
:: Instruction instr
=> Platform
-> RegMap Int
-> LiveCmmDecl statics instr
-> SpillM (LiveCmmDecl statics instr)
regSpill_top platform regSlotMap cmm
= case cmm of
CmmData{}
-> return cmm
CmmProc info label live sccs
| LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info
-> do
let liveSlotsOnEntry' :: BlockMap IntSet
liveSlotsOnEntry'
= mapFoldlWithKey patchLiveSlot
liveSlotsOnEntry liveVRegsOnEntry
let info'
= LiveInfo static firstId
liveVRegsOnEntry
liveSlotsOnEntry'
sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs
return $ CmmProc info' label live sccs'
where
patchLiveSlot
:: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
patchLiveSlot slotMap blockId regsLive
= let
curSlotsLive = fromMaybe IntSet.empty
$ mapLookup blockId slotMap
moreSlotsLive = IntSet.fromList
$ catMaybes
$ map (lookupUFM regSlotMap)
$ nonDetEltsUniqSet regsLive
slotMap'
= mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
slotMap
in slotMap'
regSpill_block
:: Instruction instr
=> Platform
-> UniqFM Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
regSpill_block platform regSlotMap (BasicBlock i instrs)
= do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs
return $ BasicBlock i (concat instrss')
regSpill_instr
:: Instruction instr
=> Platform
-> UniqFM Int
-> LiveInstr instr
-> SpillM [LiveInstr instr]
regSpill_instr _ _ li@(LiveInstr _ Nothing)
= do return [li]
regSpill_instr platform regSlotMap
(LiveInstr instr (Just _))
= do
let RU rlRead rlWritten = regUsageOfInstr platform 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
:: Instruction instr
=> UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
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
:: Instruction instr
=> UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
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
:: Instruction instr
=> UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
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
type SpillM a
= State SpillS a
data SpillS
= SpillS
{
stateUS :: UniqSupply
, stateSpillSL :: UniqFM (Reg, Int, Int) }
initSpillS :: UniqSupply -> SpillS
initSpillS uniqueSupply
= SpillS
{ stateUS = uniqueSupply
, stateSpillSL = emptyUFM }
newUnique :: SpillM Unique
newUnique
= do us <- gets stateUS
case takeUniqFromSupply us of
(uniq, us')
-> do modify $ \s -> s { stateUS = us' }
return uniq
accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
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
= pprUFM (spillStoreLoad stats)
(vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l))