Use Chaitin's formula for calculation of spill costs.
Cost to spill some vreg = (num writes + num reads) / degree of node
With 2 extra provisos:
1) Don't spill vregs that live for only 1 instruction.
2) Always prefer to spill vregs that live for a number of instructions
more than 10 times the number of vregs in that class.
Proviso 2 is there to help deal with basic blocks containing very long
live ranges - SHA1 has live ranges > 1700 instructions. We don't ever
try to keep these long lived ranges in regs at the expense of others.
Because stack slots are allocated from a global pool, and there is no
slot coalescing yet, without this condition the allocation of SHA1 dosn't
converge fast enough and eventually runs out of stack slots.
Prior to this patch we were just choosing to spill the range with the
longest lifetime, so we didn't bump into this particular problem.
-- * Machine-dependent register-related stuff
allocatableRegs, argRegs, allArgRegs, callClobberedRegs,
+ allocatableRegsInClass,
freeReg,
spRel,
import RegLiveness
import RegSpill
import RegSpillClean
+import RegSpillCost
import RegAllocStats
-- import RegCoalesce
import MachRegs
let code_coalesced1 = code
-
-- build a conflict graph from the code.
graph <- {-# SCC "BuildGraph" #-} buildGraph code_coalesced1
seqGraph graph `seq` return ()
- -- build a map of how many instructions each reg lives for.
- -- this is lazy, it won't be computed unless we need to spill
+ -- build a map of the cost of spilling each instruction
+ -- this will only actually be computed if we have to spill something.
+ let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo
+ $ map slurpSpillCostInfo code_coalesced1
- let fmLife = {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
- $ map lifetimeCount code_coalesced1
+ -- the function to choose regs to leave uncolored
+ let spill = chooseSpill spillCosts
-- record startup state
let stat1 =
then Just $ RegAllocStatsStart
{ raLiveCmm = code
, raGraph = graph
- , raLifetimes = fmLife }
+ , raSpillCosts = spillCosts }
else Nothing
-
-
- -- the function to choose regs to leave uncolored
- let spill = chooseSpill_maxLife fmLife
-- try and color the graph
let (graph_colored, rsSpill, rmCoalesce)
, statList
, graph_colored)
+ -- we couldn't find a coloring, time to spill something
else do
-- spill the uncolored regs
(code_spilled, slotsFree', spillStats)
{ raGraph = graph_colored
, raCoalesced = rmCoalesce
, raSpillStats = spillStats
- , raLifetimes = fmLife
+ , raSpillCosts = spillCosts
, raSpilled = code_spilled }
let statList =
statList
code_relive
-
------
--- Simple maxconflicts isn't always good, because we
--- can naievely end up spilling vregs that only live for one or two instrs.
---
-{-
-chooseSpill_maxConflicts
- :: Color.Graph Reg RegClass Reg
- -> Reg
-
-chooseSpill_maxConflicts graph
- = let node = maximumBy
- (\n1 n2 -> compare
- (sizeUniqSet $ Color.nodeConflicts n1)
- (sizeUniqSet $ Color.nodeConflicts n2))
- $ eltsUFM $ Color.graphMap graph
-
- in Color.nodeId node
--}
-
------
-chooseSpill_maxLife
- :: UniqFM (Reg, Int)
- -> Color.Graph Reg RegClass Reg
- -> Reg
-
-chooseSpill_maxLife life graph
- = let node = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
- $ eltsUFM $ Color.graphMap graph
- -- Orphan vregs die in the same instruction they are born in.
- -- They will be in the graph, but not in the liveness map.
- -- Their liveness is 0.
- getLife n
- = case lookupUFM life (Color.nodeId n) of
- Just (_, l) -> l
- Nothing -> 0
-
- in Color.nodeId node
-
-- | Build a graph from the liveness and coalesce information in this code.
in patchEraseLive patchF code
-plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
-plusUFMs_C f maps
- = foldl' (plusUFM_C f) emptyUFM maps
-
-
-----
-- for when laziness just isn't what you wanted...
--
import RegLiveness
import RegAllocInfo
import RegSpill
+import RegSpillCost
import MachRegs
import MachInstrs
import Cmm
-- initial graph
= RegAllocStatsStart
{ raLiveCmm :: [LiveCmmTop] -- ^ initial code, with liveness
- , raGraph :: Color.Graph Reg RegClass Reg -- ^ the initial, uncolored graph
- , raLifetimes :: UniqFM (Reg, Int) } -- ^ number of instrs each reg lives for
+ , raGraph :: Color.Graph Reg RegClass Reg -- ^ the initial, uncolored graph
+ , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill
-- a spill stage
| RegAllocStatsSpill
{ raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
, raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced
, raSpillStats :: SpillStats -- ^ spiller stats
- , raLifetimes :: UniqFM (Reg, Int) -- ^ number of instrs each reg lives for
+ , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
, raSpilled :: [LiveCmmTop] } -- ^ code with spill instructions added
-- a successful coloring
$$ text ""
else empty)
+ $$ text "# Spill costs. reg uses defs lifetime degree cost"
+ $$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
+ $$ text ""
+
$$ text "# Spills inserted."
$$ ppr (raSpillStats s)
$$ text ""
:: [RegAllocStats] -> SDoc
pprStatsLifetimes stats
- = let lifeMap = foldl' plusUFM emptyUFM
- [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
- lifeBins = binLifetimeCount lifeMap
+ = let info = foldl' plusSpillCostInfo zeroSpillCostInfo
+ [ raSpillCosts s
+ | s@RegAllocStatsStart{} <- stats ]
+
+ lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info
in ( text "-- vreg-population-lifetimes"
$$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)"
-> SDoc
pprStatsLifeConflict stats graph
- = let lifeMap = foldl' plusUFM emptyUFM
- [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
+ = let lifeMap = lifeMapFromSpillCostInfo
+ $ foldl' plusSpillCostInfo zeroSpillCostInfo
+ $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of
Just (_, l) -> l
spillNatBlock,
slurpConflicts,
slurpReloadCoalesce,
- lifetimeCount,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
= spillNat (instr : acc) instrs
--- | Slurp out a map of how many times each register was live upon entry to an instruction.
-
-lifetimeCount
- :: LiveCmmTop
- -> UniqFM (Reg, Int) -- ^ reg -> (reg, count)
-
-lifetimeCount cmm
- = countCmm emptyUFM cmm
- where
- countCmm fm CmmData{} = fm
- countCmm fm (CmmProc info _ _ (ListGraph blocks))
- = foldl' (countComp info) fm blocks
-
- countComp info fm (BasicBlock _ blocks)
- = foldl' (countBlock info) fm blocks
-
- countBlock info fm (BasicBlock blockId instrs)
- | LiveInfo _ _ blockLive <- info
- , Just rsLiveEntry <- lookupUFM blockLive blockId
- = countLIs rsLiveEntry fm instrs
-
- | otherwise
- = error "RegLiveness.countBlock: bad block"
-
- countLIs _ fm [] = fm
- countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
-
- countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
- = let
- rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
-
- rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
- `minusUniqSet` (liveDieWrite live)
-
- add r fm = addToUFM_C
- (\(r1, l1) (_, l2) -> (r1, l1 + l2))
- fm r (r, 1)
-
- fm' = foldUniqSet add fm rsLiveEntry
- in countLIs rsLiveNext fm' lis
-
-
-- | Erase Delta instructions.
eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
--- /dev/null
+
+module RegSpillCost (
+ SpillCostRecord,
+ plusSpillCostRecord,
+ pprSpillCostRecord,
+
+ SpillCostInfo,
+ zeroSpillCostInfo,
+ plusSpillCostInfo,
+
+ slurpSpillCostInfo,
+ chooseSpill,
+
+ lifeMapFromSpillCostInfo
+)
+
+where
+
+import GraphBase
+import RegLiveness
+import RegAllocInfo
+import MachInstrs
+import MachRegs
+import Cmm
+
+import UniqFM
+import UniqSet
+import Outputable
+import State
+
+import Data.List (nub, minimumBy)
+import Data.Maybe
+import Control.Monad
+
+type SpillCostRecord
+ = ( Reg -- register name
+ , Int -- number of writes to this reg
+ , Int -- number of reads from this reg
+ , Int) -- number of instrs this reg was live on entry to
+
+type SpillCostInfo
+ = UniqFM SpillCostRecord
+
+
+zeroSpillCostInfo :: SpillCostInfo
+zeroSpillCostInfo = emptyUFM
+
+-- | Add two spillCostInfos
+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"
+
+
+-- | Slurp out information used for determining spill costs
+-- for each vreg, the number of times it was written to, read from,
+-- and the number of instructions it was live on entry to (lifetime)
+--
+slurpSpillCostInfo
+ :: LiveCmmTop
+ -> 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
+
+ -- lookup the regs that are live on entry to this block in
+ -- the info table from the CmmProc
+ countBlock info (BasicBlock blockId instrs)
+ | LiveInfo _ _ blockLive <- info
+ , Just rsLiveEntry <- lookupUFM blockLive blockId
+ = countLIs rsLiveEntry instrs
+
+ | otherwise
+ = error "RegLiveness.slurpSpillCostInfo: bad block"
+
+ countLIs _ []
+ = return ()
+
+ -- skip over comment and delta pseudo instrs
+ countLIs rsLive (Instr instr Nothing : lis)
+ | COMMENT{} <- instr
+ = countLIs rsLive lis
+
+ | DELTA{} <- instr
+ = countLIs rsLive lis
+
+ | otherwise
+ = pprPanic "RegSpillCost.slurpSpillCostInfo"
+ (text "no liveness information on instruction " <> ppr instr)
+
+ countLIs rsLiveEntry (Instr instr (Just live) : lis)
+ = do
+ -- increment the lifetime counts for regs live on entry to this instr
+ mapM_ incLifetime $ uniqSetToList rsLiveEntry
+
+ -- increment counts for what regs were read/written from
+ let (RU read written) = regUsage instr
+ mapM_ incUses $ filter (not . isRealReg) $ nub read
+ mapM_ incDefs $ filter (not . isRealReg) $ nub written
+
+ -- compute liveness for entry to next instruction.
+ let rsLiveAcross
+ = rsLiveEntry `minusUniqSet` (liveDieRead live)
+
+ let rsLiveNext
+ = (rsLiveAcross `unionUniqSets` (liveBorn live))
+ `minusUniqSet` (liveDieWrite live)
+
+ 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)
+
+
+-- | Choose a node to spill from this graph
+
+chooseSpill
+ :: SpillCostInfo
+ -> Graph Reg RegClass Reg
+ -> Reg
+
+chooseSpill info graph
+ = let cost = spillCost info graph
+ node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))
+ $ eltsUFM $ graphMap graph
+
+ in nodeId node
+
+
+
+-- | Chaitins spill cost function is:
+--
+-- cost = sum loadCost * freq (u) + sum storeCost * freq (d)
+-- u <- uses (v) d <- defs (v)
+--
+-- There are no loops in our code at the momemnt, so we can set the freq's to 1
+-- We divide this by the degree if t
+--
+--
+-- If we don't have live range splitting then Chaitins function performs badly if we have
+-- lots of nested live ranges and very few registers.
+--
+-- v1 v2 v3
+-- def v1 .
+-- use v1 .
+-- def v2 . .
+-- def v3 . . .
+-- use v1 . . .
+-- use v3 . . .
+-- use v2 . .
+-- use v1 .
+--
+--
+-- defs uses degree cost
+-- v1: 1 3 3 1.5
+-- v2: 1 2 3 1.0
+-- v3: 1 1 3 0.666
+--
+-- v3 has the lowest cost, but if we only have 2 hardregs and we insert spill code for v3
+-- then this isn't going to improve the colorability of the graph.
+--
+-- When compiling SHA1, which as very long basic blocks and some vregs with very long live ranges
+-- the allocator seems to try and spill from the inside out and eventually run out of stack slots.
+--
+-- Without live range splitting, its's better to spill from the outside in so set the cost of very
+-- long live ranges to zero
+--
+
+spillCost
+ :: SpillCostInfo
+ -> Graph Reg RegClass Reg
+ -> Reg
+ -> Float
+
+spillCost info graph reg
+ -- Spilling a live range that only lives for 1 instruction isn't going to help
+ -- us at all - and we definately want to avoid trying to re-spill previously
+ -- inserted spill code.
+ | lifetime <= 1 = 1/0
+
+ -- It's unlikely that we'll find a reg for a live range this long
+ -- better to spill it straight up and not risk trying to keep it around
+ -- and have to go through the build/color cycle again.
+ | lifetime > allocatableRegsInClass (regClass reg) * 10
+ = 0
+
+ -- otherwise revert to chaitin's regular cost function.
+ | otherwise = fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg)
+ where (_, defs, uses, lifetime)
+ = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
+
+
+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (Reg, Int)
+lifeMapFromSpillCostInfo info
+ = listToUFM
+ $ map (\(r, _, _, life) -> (r, (r, life)))
+ $ eltsUFM info
+
+
+-- | Work out the degree (number of neighbors) of this node which have the same class.
+nodeDegree :: Graph Reg RegClass Reg -> Reg -> Int
+nodeDegree graph reg
+ | Just node <- lookupUFM (graphMap graph) reg
+ , virtConflicts <- length $ filter (\r -> regClass r == regClass reg)
+ $ uniqSetToList $ nodeConflicts node
+ = virtConflicts + sizeUniqSet (nodeExclusions node)
+
+ | otherwise
+ = 0
+
+
+-- | Show a spill cost record, including the degree from the graph and final calulated spill cos
+pprSpillCostRecord :: Graph Reg RegClass Reg -> SpillCostRecord -> SDoc
+pprSpillCostRecord graph (reg, uses, defs, life)
+ = hsep
+ [ ppr reg
+ , ppr uses
+ , ppr defs
+ , ppr life
+ , ppr $ nodeDegree graph reg
+ , text $ show $ (fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg) :: Float) ]
projects / ghc-hetmet.git / commitdiff