{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.CmmToAsm.Reg.Graph.SpillCost (
SpillCostRecord,
plusSpillCostRecord,
pprSpillCostRecord,
SpillCostInfo,
zeroSpillCostInfo,
plusSpillCostInfo,
slurpSpillCostInfo,
chooseSpill,
lifeMapFromSpillCostInfo
) where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.Data.Graph.Base
import GHC.Cmm.Dataflow.Collections (mapLookup)
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Data.Graph.Directed (flattenSCCs)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Utils.Monad.State
import GHC.CmmToAsm.CFG
import Data.List (nub, minimumBy)
import Data.Maybe
import Control.Monad (join)
type SpillCostRecord
= ( VirtualReg
, Int
, Int
, Int)
type SpillCostInfo
= UniqFM VirtualReg SpillCostRecord
type SpillCostState = State SpillCostInfo ()
zeroSpillCostInfo :: SpillCostInfo
zeroSpillCostInfo :: SpillCostInfo
zeroSpillCostInfo = forall key elt. UniqFM key elt
emptyUFM
plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
sc1 SpillCostInfo
sc2
= forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord SpillCostInfo
sc1 SpillCostInfo
sc2
plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord (VirtualReg
r1, Int
a1, Int
b1, Int
c1) (VirtualReg
r2, Int
a2, Int
b2, Int
c2)
| VirtualReg
r1 forall a. Eq a => a -> a -> Bool
== VirtualReg
r2 = (VirtualReg
r1, Int
a1 forall a. Num a => a -> a -> a
+ Int
a2, Int
b1 forall a. Num a => a -> a -> a
+ Int
b2, Int
c1 forall a. Num a => a -> a -> a
+ Int
c2)
| Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"RegSpillCost.plusRegInt: regs don't match"
slurpSpillCostInfo :: forall instr statics. Instruction instr
=> Platform
-> Maybe CFG
-> LiveCmmDecl statics instr
-> SpillCostInfo
slurpSpillCostInfo :: forall instr statics.
Instruction instr =>
Platform -> Maybe CFG -> LiveCmmDecl statics instr -> SpillCostInfo
slurpSpillCostInfo Platform
platform Maybe CFG
cfg LiveCmmDecl statics instr
cmm
= forall s a. State s a -> s -> s
execState (LiveCmmDecl statics instr -> State SpillCostInfo ()
countCmm LiveCmmDecl statics instr
cmm) SpillCostInfo
zeroSpillCostInfo
where
countCmm :: LiveCmmDecl statics instr -> State SpillCostInfo ()
countCmm CmmData{} = forall (m :: * -> *) a. Monad m => a -> m a
return ()
countCmm (CmmProc LiveInfo
info CLabel
_ [GlobalReg]
_ [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LiveInfo
-> Maybe (LabelMap Double)
-> GenBasicBlock (LiveInstr instr)
-> State SpillCostInfo ()
countBlock LiveInfo
info Maybe (LabelMap Double)
freqMap)
forall a b. (a -> b) -> a -> b
$ forall a. [SCC a] -> [a]
flattenSCCs [SCC (GenBasicBlock (LiveInstr instr))]
sccs
where
LiveInfo LabelMap RawCmmStatics
_ [BlockId]
entries BlockMap RegSet
_ BlockMap IntSet
_ = LiveInfo
info
freqMap :: Maybe (LabelMap Double)
freqMap = (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack =>
BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
mkGlobalWeights (forall a. [a] -> a
head [BlockId]
entries)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CFG
cfg
countBlock :: LiveInfo
-> Maybe (LabelMap Double)
-> GenBasicBlock (LiveInstr instr)
-> State SpillCostInfo ()
countBlock LiveInfo
info Maybe (LabelMap Double)
freqMap (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
| LiveInfo LabelMap RawCmmStatics
_ [BlockId]
_ BlockMap RegSet
blockLive BlockMap IntSet
_ <- LiveInfo
info
, Just RegSet
rsLiveEntry <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
blockId BlockMap RegSet
blockLive
, UniqSet VirtualReg
rsLiveEntry_virt <- RegSet -> UniqSet VirtualReg
takeVirtuals RegSet
rsLiveEntry
= Int
-> UniqSet VirtualReg
-> [LiveInstr instr]
-> State SpillCostInfo ()
countLIs (forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ Maybe (LabelMap Double) -> BlockId -> Double
blockFreq Maybe (LabelMap Double)
freqMap BlockId
blockId) UniqSet VirtualReg
rsLiveEntry_virt [LiveInstr instr]
instrs
| Bool
otherwise
= forall a. HasCallStack => [Char] -> a
error [Char]
"RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs :: Int
-> UniqSet VirtualReg
-> [LiveInstr instr]
-> State SpillCostInfo ()
countLIs Int
_ UniqSet VirtualReg
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
countLIs Int
scale UniqSet VirtualReg
rsLive (LiveInstr InstrSR instr
instr Maybe Liveness
Nothing : [LiveInstr instr]
lis)
| forall instr. Instruction instr => instr -> Bool
isMetaInstr InstrSR instr
instr
= Int
-> UniqSet VirtualReg
-> [LiveInstr instr]
-> State SpillCostInfo ()
countLIs Int
scale UniqSet VirtualReg
rsLive [LiveInstr instr]
lis
| Bool
otherwise
= forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RegSpillCost.slurpSpillCostInfo"
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"no liveness information on instruction " SDoc -> SDoc -> SDoc
<> forall instr. Instruction instr => Platform -> instr -> SDoc
pprInstr Platform
platform InstrSR instr
instr
countLIs Int
scale UniqSet VirtualReg
rsLiveEntry (LiveInstr InstrSR instr
instr (Just Liveness
live) : [LiveInstr instr]
lis)
= do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VirtualReg -> State SpillCostInfo ()
incLifetime forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet VirtualReg
rsLiveEntry
let (RU [Reg]
read [Reg]
written) = forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> VirtualReg -> State SpillCostInfo ()
incUses Int
scale) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Reg -> Maybe VirtualReg
takeVirtualReg forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Reg]
read
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> VirtualReg -> State SpillCostInfo ()
incDefs Int
scale) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Reg -> Maybe VirtualReg
takeVirtualReg forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Reg]
written
let liveDieRead_virt :: UniqSet VirtualReg
liveDieRead_virt = RegSet -> UniqSet VirtualReg
takeVirtuals (Liveness -> RegSet
liveDieRead Liveness
live)
let liveDieWrite_virt :: UniqSet VirtualReg
liveDieWrite_virt = RegSet -> UniqSet VirtualReg
takeVirtuals (Liveness -> RegSet
liveDieWrite Liveness
live)
let liveBorn_virt :: UniqSet VirtualReg
liveBorn_virt = RegSet -> UniqSet VirtualReg
takeVirtuals (Liveness -> RegSet
liveBorn Liveness
live)
let rsLiveAcross :: UniqSet VirtualReg
rsLiveAcross
= UniqSet VirtualReg
rsLiveEntry forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet VirtualReg
liveDieRead_virt
let rsLiveNext :: UniqSet VirtualReg
rsLiveNext
= (UniqSet VirtualReg
rsLiveAcross forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` UniqSet VirtualReg
liveBorn_virt)
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet VirtualReg
liveDieWrite_virt
Int
-> UniqSet VirtualReg
-> [LiveInstr instr]
-> State SpillCostInfo ()
countLIs Int
scale UniqSet VirtualReg
rsLiveNext [LiveInstr instr]
lis
incDefs :: Int -> VirtualReg -> State SpillCostInfo ()
incDefs Int
count VirtualReg
reg = forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \SpillCostInfo
s -> forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord SpillCostInfo
s VirtualReg
reg (VirtualReg
reg, Int
count, Int
0, Int
0)
incUses :: Int -> VirtualReg -> State SpillCostInfo ()
incUses Int
count VirtualReg
reg = forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \SpillCostInfo
s -> forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord SpillCostInfo
s VirtualReg
reg (VirtualReg
reg, Int
0, Int
count, Int
0)
incLifetime :: VirtualReg -> State SpillCostInfo ()
incLifetime VirtualReg
reg = forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \SpillCostInfo
s -> forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C SpillCostRecord -> SpillCostRecord -> SpillCostRecord
plusSpillCostRecord SpillCostInfo
s VirtualReg
reg (VirtualReg
reg, Int
0, Int
0, Int
1)
blockFreq :: Maybe (LabelMap Double) -> Label -> Double
blockFreq :: Maybe (LabelMap Double) -> BlockId -> Double
blockFreq Maybe (LabelMap Double)
freqs BlockId
bid
| Just Double
freq <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
bid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LabelMap Double)
freqs)
= forall a. Ord a => a -> a -> a
max Double
1.0 (Double
10000 forall a. Num a => a -> a -> a
* Double
freq)
| Bool
otherwise
= Double
1.0
takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
takeVirtuals :: RegSet -> UniqSet VirtualReg
takeVirtuals RegSet
set = forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
[ VirtualReg
vr | RegVirtual VirtualReg
vr <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet RegSet
set ]
chooseSpill
:: SpillCostInfo
-> Graph VirtualReg RegClass RealReg
-> VirtualReg
chooseSpill :: SpillCostInfo -> Graph VirtualReg RegClass RealReg -> VirtualReg
chooseSpill SpillCostInfo
info Graph VirtualReg RegClass RealReg
graph
= let cost :: VirtualReg -> Float
cost = SpillCostInfo
-> Graph VirtualReg RegClass RealReg -> VirtualReg -> Float
spillCost_length SpillCostInfo
info Graph VirtualReg RegClass RealReg
graph
node :: Node VirtualReg RegClass RealReg
node = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (\Node VirtualReg RegClass RealReg
n1 Node VirtualReg RegClass RealReg
n2 -> forall a. Ord a => a -> a -> Ordering
compare (VirtualReg -> Float
cost forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> k
nodeId Node VirtualReg RegClass RealReg
n1) (VirtualReg -> Float
cost forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> k
nodeId Node VirtualReg RegClass RealReg
n2))
forall a b. (a -> b) -> a -> b
$ forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM forall a b. (a -> b) -> a -> b
$ forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph VirtualReg RegClass RealReg
graph
in forall k cls color. Node k cls color -> k
nodeId Node VirtualReg RegClass RealReg
node
spillCost_length
:: SpillCostInfo
-> Graph VirtualReg RegClass RealReg
-> VirtualReg
-> Float
spillCost_length :: SpillCostInfo
-> Graph VirtualReg RegClass RealReg -> VirtualReg -> Float
spillCost_length SpillCostInfo
info Graph VirtualReg RegClass RealReg
_ VirtualReg
reg
| Int
lifetime forall a. Ord a => a -> a -> Bool
<= Int
1 = Float
1forall a. Fractional a => a -> a -> a
/Float
0
| Bool
otherwise = Float
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lifetime
where (VirtualReg
_, Int
_, Int
_, Int
lifetime)
= forall a. a -> Maybe a -> a
fromMaybe (VirtualReg
reg, Int
0, Int
0, Int
0)
forall a b. (a -> b) -> a -> b
$ forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM SpillCostInfo
info VirtualReg
reg
lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
lifeMapFromSpillCostInfo SpillCostInfo
info
= forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(VirtualReg
r, Int
_, Int
_, Int
life) -> (VirtualReg
r, (VirtualReg
r, Int
life)))
forall a b. (a -> b) -> a -> b
$ forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM SpillCostInfo
info
nodeDegree
:: (VirtualReg -> RegClass)
-> Graph VirtualReg RegClass RealReg
-> VirtualReg
-> Int
nodeDegree :: (VirtualReg -> RegClass)
-> Graph VirtualReg RegClass RealReg -> VirtualReg -> Int
nodeDegree VirtualReg -> RegClass
classOfVirtualReg Graph VirtualReg RegClass RealReg
graph VirtualReg
reg
| Just Node VirtualReg RegClass RealReg
node <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph VirtualReg RegClass RealReg
graph) VirtualReg
reg
, Int
virtConflicts
<- forall (t :: * -> *) a. Foldable t => t a -> Int
length
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\VirtualReg
r -> VirtualReg -> RegClass
classOfVirtualReg VirtualReg
r forall a. Eq a => a -> a -> Bool
== VirtualReg -> RegClass
classOfVirtualReg VirtualReg
reg)
forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node VirtualReg RegClass RealReg
node
= Int
virtConflicts forall a. Num a => a -> a -> a
+ forall a. UniqSet a -> Int
sizeUniqSet (forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node VirtualReg RegClass RealReg
node)
| Bool
otherwise
= Int
0
pprSpillCostRecord
:: (VirtualReg -> RegClass)
-> (Reg -> SDoc)
-> Graph VirtualReg RegClass RealReg
-> SpillCostRecord
-> SDoc
pprSpillCostRecord :: (VirtualReg -> RegClass)
-> (Reg -> SDoc)
-> Graph VirtualReg RegClass RealReg
-> SpillCostRecord
-> SDoc
pprSpillCostRecord VirtualReg -> RegClass
regClass Reg -> SDoc
pprReg Graph VirtualReg RegClass RealReg
graph (VirtualReg
reg, Int
uses, Int
defs, Int
life)
= [SDoc] -> SDoc
hsep
[ Reg -> SDoc
pprReg (VirtualReg -> Reg
RegVirtual VirtualReg
reg)
, forall a. Outputable a => a -> SDoc
ppr Int
uses
, forall a. Outputable a => a -> SDoc
ppr Int
defs
, forall a. Outputable a => a -> SDoc
ppr Int
life
, forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ (VirtualReg -> RegClass)
-> Graph VirtualReg RegClass RealReg -> VirtualReg -> Int
nodeDegree VirtualReg -> RegClass
regClass Graph VirtualReg RegClass RealReg
graph VirtualReg
reg
, [Char] -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
uses forall a. Num a => a -> a -> a
+ Int
defs)
forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral ((VirtualReg -> RegClass)
-> Graph VirtualReg RegClass RealReg -> VirtualReg -> Int
nodeDegree VirtualReg -> RegClass
regClass Graph VirtualReg RegClass RealReg
graph VirtualReg
reg) :: Float) ]