module RegAlloc.Graph.SpillCost (
SpillCostRecord,
plusSpillCostRecord,
pprSpillCostRecord,
SpillCostInfo,
zeroSpillCostInfo,
plusSpillCostInfo,
slurpSpillCostInfo,
chooseSpill,
lifeMapFromSpillCostInfo
)
where
import RegAlloc.Liveness
import Instruction
import RegClass
import Reg
import GraphBase
import BlockId
import Cmm
import UniqFM
import UniqSet
import Outputable
import State
import Data.List (nub, minimumBy)
import Data.Maybe
type SpillCostRecord
= ( VirtualReg
, Int
, Int
, Int)
type SpillCostInfo
= UniqFM SpillCostRecord
zeroSpillCostInfo :: SpillCostInfo
zeroSpillCostInfo = emptyUFM
plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo sc1 sc2
= plusUFM_C plusSpillCostRecord sc1 sc2
plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
| r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2)
| otherwise = error "RegSpillCost.plusRegInt: regs don't match"
slurpSpillCostInfo
:: (Outputable instr, Instruction instr)
=> LiveCmmTop instr
-> SpillCostInfo
slurpSpillCostInfo cmm
= execState (countCmm cmm) zeroSpillCostInfo
where
countCmm CmmData{} = return ()
countCmm (CmmProc info _ _ (ListGraph blocks))
= mapM_ (countComp info) blocks
countComp info (BasicBlock _ blocks)
= mapM_ (countBlock info) blocks
countBlock info (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive <- info
, Just rsLiveEntry <- lookupBlockEnv blockLive blockId
, rsLiveEntry_virt <- mapUniqSet (\(RegVirtual vr) -> vr)
$ filterUniqSet isVirtualReg rsLiveEntry
= countLIs rsLiveEntry_virt instrs
| otherwise
= error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
countLIs _ []
= return ()
countLIs rsLive (SPILL{} : lis)
= countLIs rsLive lis
countLIs rsLive (RELOAD{} : lis)
= countLIs rsLive lis
countLIs rsLive (Instr instr Nothing : lis)
| isMetaInstr instr
= countLIs rsLive lis
| otherwise
= pprPanic "RegSpillCost.slurpSpillCostInfo"
(text "no liveness information on instruction " <> ppr instr)
countLIs rsLiveEntry (Instr instr (Just live) : lis)
= do
mapM_ incLifetime $ uniqSetToList rsLiveEntry
let (RU read written) = regUsageOfInstr instr
mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read
mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written
let takeVirtuals set
= mapUniqSet (\(RegVirtual vr) -> vr)
$ filterUniqSet isVirtualReg set
let liveDieRead_virt = takeVirtuals (liveDieRead live)
let liveDieWrite_virt = takeVirtuals (liveDieWrite live)
let liveBorn_virt = takeVirtuals (liveBorn live)
let rsLiveAcross
= rsLiveEntry `minusUniqSet` liveDieRead_virt
let rsLiveNext
= (rsLiveAcross `unionUniqSets` liveBorn_virt)
`minusUniqSet` liveDieWrite_virt
countLIs rsLiveNext lis
incDefs reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 1, 0, 0)
incUses reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 1, 0)
incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
chooseSpill
:: SpillCostInfo
-> Graph VirtualReg RegClass RealReg
-> VirtualReg
chooseSpill info graph
= let cost = spillCost_length info graph
node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))
$ eltsUFM $ graphMap graph
in nodeId node
spillCost_length
:: SpillCostInfo
-> Graph VirtualReg RegClass RealReg
-> VirtualReg
-> Float
spillCost_length info _ reg
| lifetime <= 1 = 1/0
| otherwise = 1 / fromIntegral lifetime
where (_, _, _, lifetime)
= fromMaybe (reg, 0, 0, 0)
$ lookupUFM info reg
lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)
lifeMapFromSpillCostInfo info
= listToUFM
$ map (\(r, _, _, life) -> (r, (r, life)))
$ eltsUFM info
nodeDegree
:: (VirtualReg -> RegClass)
-> Graph VirtualReg RegClass RealReg
-> VirtualReg
-> Int
nodeDegree classOfVirtualReg graph reg
| Just node <- lookupUFM (graphMap graph) reg
, virtConflicts <- length
$ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
$ uniqSetToList
$ nodeConflicts node
= virtConflicts + sizeUniqSet (nodeExclusions node)
| otherwise
= 0
pprSpillCostRecord
:: (VirtualReg -> RegClass)
-> (Reg -> SDoc)
-> Graph VirtualReg RegClass RealReg
-> SpillCostRecord
-> SDoc
pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
= hsep
[ pprReg (RegVirtual reg)
, ppr uses
, ppr defs
, ppr life
, ppr $ nodeDegree regClass graph reg
, text $ show $ (fromIntegral (uses + defs)
/ fromIntegral (nodeDegree regClass graph reg) :: Float) ]