module GHC.CmmToAsm.Reg.Graph.Spill (
regSpill,
SpillStats(..),
accSpillSL
) where
import GHC.Prelude
import GHC.CmmToAsm.Format ( RegWithFormat(..) )
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Utils
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Label
import GHC.Utils.Monad
import GHC.Utils.Monad.State.Strict
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSM
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import Data.Function ( on )
import Data.List (intersectBy, nubBy)
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
-> UniqDSM
([LiveCmmDecl statics instr]
, UniqSet Int
, Int
, SpillStats )
regSpill :: forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqDSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
regSpill Platform
platform [LiveCmmDecl statics instr]
code UniqSet Int
slotsFree Int
slotCount UniqSet VirtualReg
regs
| UniqSet Int -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet Int
slotsFree Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< UniqSet VirtualReg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet VirtualReg
regs
=
let slotsFree' :: UniqSet Int
slotsFree' = (UniqSet Int -> [Int] -> UniqSet Int
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet Int
slotsFree [Int
slotCountInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 .. Int
slotCountInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
512])
in Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqDSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqDSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
regSpill Platform
platform [LiveCmmDecl statics instr]
code UniqSet Int
slotsFree' (Int
slotCountInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
512) UniqSet VirtualReg
regs
| Bool
otherwise
= do
let slots :: [Int]
slots = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (UniqSet VirtualReg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet VirtualReg
regs) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ UniqSet Int -> [Int]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Int
slotsFree
let
regSlotMap :: UniqFM Reg Int
regSlotMap = UniqFM VirtualReg Int -> UniqFM Reg Int
forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
toRegMap
(UniqFM VirtualReg Int -> UniqFM Reg Int)
-> UniqFM VirtualReg Int -> UniqFM Reg Int
forall a b. (a -> b) -> a -> b
$ [(VirtualReg, Int)] -> UniqFM VirtualReg Int
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM
([(VirtualReg, Int)] -> UniqFM VirtualReg Int)
-> [(VirtualReg, Int)] -> UniqFM VirtualReg Int
forall a b. (a -> b) -> a -> b
$ [VirtualReg] -> [Int] -> [(VirtualReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (UniqSet VirtualReg -> [VirtualReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet VirtualReg
regs) [Int]
slots :: UniqFM Reg Int
(DUniqSupply
-> DUniqResult
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats))
-> UniqDSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall a. (DUniqSupply -> DUniqResult a) -> UniqDSM a
UDSM ((DUniqSupply
-> DUniqResult
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats))
-> UniqDSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats))
-> (DUniqSupply
-> DUniqResult
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats))
-> UniqDSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall a b. (a -> b) -> a -> b
$ \DUniqSupply
us ->
let ([LiveCmmDecl statics instr]
code', SpillS
state') =
State SpillS [LiveCmmDecl statics instr]
-> SpillS -> ([LiveCmmDecl statics instr], SpillS)
forall s a. State s a -> s -> (a, s)
runState ((LiveCmmDecl statics instr
-> State SpillS (LiveCmmDecl statics instr))
-> [LiveCmmDecl statics instr]
-> State SpillS [LiveCmmDecl statics instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Platform
-> UniqFM Reg Int
-> LiveCmmDecl statics instr
-> State SpillS (LiveCmmDecl statics instr)
forall instr statics.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> LiveCmmDecl statics instr
-> SpillM (LiveCmmDecl statics instr)
regSpill_top Platform
platform UniqFM Reg Int
regSlotMap) [LiveCmmDecl statics instr]
code)
(DUniqSupply -> SpillS
initSpillS DUniqSupply
us)
in ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
-> DUniqSupply
-> DUniqResult
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall a. a -> DUniqSupply -> (# a, DUniqSupply #)
DUniqResult
( [LiveCmmDecl statics instr]
code'
, UniqSet Int -> UniqSet Int -> UniqSet Int
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet Int
slotsFree ([Int] -> UniqSet Int
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Int]
slots)
, Int
slotCount
, SpillS -> SpillStats
makeSpillStats SpillS
state')
( SpillS -> DUniqSupply
stateUS SpillS
state' )
regSpill_top
:: Instruction instr
=> Platform
-> RegMap Int
-> LiveCmmDecl statics instr
-> SpillM (LiveCmmDecl statics instr)
regSpill_top :: forall instr statics.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> LiveCmmDecl statics instr
-> SpillM (LiveCmmDecl statics instr)
regSpill_top Platform
platform UniqFM Reg Int
regSlotMap LiveCmmDecl statics instr
cmm
= case LiveCmmDecl statics instr
cmm of
CmmData{}
-> LiveCmmDecl statics instr -> SpillM (LiveCmmDecl statics instr)
forall a. a -> State SpillS a
forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
cmm
CmmProc LiveInfo
info CLabel
label [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccs
| LiveInfo LabelMap RawCmmStatics
static [BlockId]
firstId BlockMap (UniqSet RegWithFormat)
liveVRegsOnEntry BlockMap IntSet
liveSlotsOnEntry <- LiveInfo
info
-> do
let liveSlotsOnEntry' :: BlockMap IntSet
liveSlotsOnEntry' :: BlockMap IntSet
liveSlotsOnEntry'
= (BlockMap IntSet
-> BlockId -> UniqSet RegWithFormat -> BlockMap IntSet)
-> BlockMap IntSet
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
forall t b. (t -> BlockId -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey BlockMap IntSet
-> BlockId -> UniqSet RegWithFormat -> BlockMap IntSet
patchLiveSlot
BlockMap IntSet
liveSlotsOnEntry BlockMap (UniqSet RegWithFormat)
liveVRegsOnEntry
let info' :: LiveInfo
info'
= LabelMap RawCmmStatics
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap RawCmmStatics
static [BlockId]
firstId
BlockMap (UniqSet RegWithFormat)
liveVRegsOnEntry
BlockMap IntSet
liveSlotsOnEntry'
sccs' <- (SCC (LiveBasicBlock instr)
-> State SpillS (SCC (LiveBasicBlock instr)))
-> [SCC (LiveBasicBlock instr)]
-> State SpillS [SCC (LiveBasicBlock instr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((LiveBasicBlock instr -> State SpillS (LiveBasicBlock instr))
-> SCC (LiveBasicBlock instr)
-> State SpillS (SCC (LiveBasicBlock instr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM (Platform
-> UniqFM Reg Int
-> LiveBasicBlock instr
-> State SpillS (LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
regSpill_block Platform
platform UniqFM Reg Int
regSlotMap)) [SCC (LiveBasicBlock instr)]
sccs
return $ CmmProc info' label live sccs'
where
patchLiveSlot
:: BlockMap IntSet -> BlockId -> UniqSet RegWithFormat-> BlockMap IntSet
patchLiveSlot :: BlockMap IntSet
-> BlockId -> UniqSet RegWithFormat -> BlockMap IntSet
patchLiveSlot BlockMap IntSet
slotMap BlockId
blockId UniqSet RegWithFormat
regsLive
= let
curSlotsLive :: IntSet
curSlotsLive = IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
IntSet.empty
(Maybe IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ BlockId -> BlockMap IntSet -> Maybe IntSet
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
blockId BlockMap IntSet
slotMap
moreSlotsLive :: IntSet
moreSlotsLive = [Int] -> IntSet
IntSet.fromList
([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (RegWithFormat -> Maybe Int) -> [RegWithFormat] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (UniqFM Reg Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Reg Int
regSlotMap (Reg -> Maybe Int)
-> (RegWithFormat -> Reg) -> RegWithFormat -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegWithFormat -> Reg
regWithFormat_reg)
([RegWithFormat] -> [Int]) -> [RegWithFormat] -> [Int]
forall a b. (a -> b) -> a -> b
$ UniqSet RegWithFormat -> [RegWithFormat]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet RegWithFormat
regsLive
slotMap' :: BlockMap IntSet
slotMap'
= BlockId -> IntSet -> BlockMap IntSet -> BlockMap IntSet
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
blockId (IntSet -> IntSet -> IntSet
IntSet.union IntSet
curSlotsLive IntSet
moreSlotsLive)
BlockMap IntSet
slotMap
in BlockMap IntSet
slotMap'
regSpill_block
:: Instruction instr
=> Platform
-> UniqFM Reg Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
regSpill_block :: forall instr.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
regSpill_block Platform
platform UniqFM Reg Int
regSlotMap (BasicBlock BlockId
i [LiveInstr instr]
instrs)
= do instrss' <- (LiveInstr instr -> State SpillS [LiveInstr instr])
-> [LiveInstr instr] -> State SpillS [[LiveInstr instr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Platform
-> UniqFM Reg Int
-> LiveInstr instr
-> State SpillS [LiveInstr instr]
forall instr.
Instruction instr =>
Platform
-> UniqFM Reg Int -> LiveInstr instr -> SpillM [LiveInstr instr]
regSpill_instr Platform
platform UniqFM Reg Int
regSlotMap) [LiveInstr instr]
instrs
return $ BasicBlock i (concat instrss')
regSpill_instr
:: Instruction instr
=> Platform
-> UniqFM Reg Int
-> LiveInstr instr
-> SpillM [LiveInstr instr]
regSpill_instr :: forall instr.
Instruction instr =>
Platform
-> UniqFM Reg Int -> LiveInstr instr -> SpillM [LiveInstr instr]
regSpill_instr Platform
_ UniqFM Reg Int
_ li :: LiveInstr instr
li@(LiveInstr InstrSR instr
_ Maybe Liveness
Nothing) = [LiveInstr instr] -> State SpillS [LiveInstr instr]
forall a. a -> State SpillS a
forall (m :: * -> *) a. Monad m => a -> m a
return [LiveInstr instr
li]
regSpill_instr Platform
platform UniqFM Reg Int
regSlotMap (LiveInstr InstrSR instr
instr (Just Liveness
_)) = do
let RU [RegWithFormat]
rlRead [RegWithFormat]
rlWritten = Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
let rsRead_ :: [RegWithFormat]
rsRead_ = (RegWithFormat -> RegWithFormat -> Bool)
-> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Unique -> Unique -> Bool)
-> (RegWithFormat -> Unique)
-> RegWithFormat
-> RegWithFormat
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RegWithFormat -> Unique
forall a. Uniquable a => a -> Unique
getUnique) [RegWithFormat]
rlRead
rsWritten_ :: [RegWithFormat]
rsWritten_ = (RegWithFormat -> RegWithFormat -> Bool)
-> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Unique -> Unique -> Bool)
-> (RegWithFormat -> Unique)
-> RegWithFormat
-> RegWithFormat
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RegWithFormat -> Unique
forall a. Uniquable a => a -> Unique
getUnique) [RegWithFormat]
rlWritten
let rsModify :: [RegWithFormat]
rsModify = (RegWithFormat -> RegWithFormat -> Bool)
-> [RegWithFormat] -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
intersectBy (Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Unique -> Unique -> Bool)
-> (RegWithFormat -> Unique)
-> RegWithFormat
-> RegWithFormat
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RegWithFormat -> Unique
forall a. Uniquable a => a -> Unique
getUnique) [RegWithFormat]
rsRead_ [RegWithFormat]
rsWritten_
modified :: UniqSet RegWithFormat
modified = [RegWithFormat] -> UniqSet RegWithFormat
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [RegWithFormat]
rsModify
rsRead :: [RegWithFormat]
rsRead = (RegWithFormat -> Bool) -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ RegWithFormat
r -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RegWithFormat -> UniqSet RegWithFormat -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet RegWithFormat
r UniqSet RegWithFormat
modified) [RegWithFormat]
rsRead_
rsWritten :: [RegWithFormat]
rsWritten = (RegWithFormat -> Bool) -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ RegWithFormat
r -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RegWithFormat -> UniqSet RegWithFormat -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet RegWithFormat
r UniqSet RegWithFormat
modified) [RegWithFormat]
rsWritten_
let rsSpillRead :: [RegWithFormat]
rsSpillRead = (RegWithFormat -> Bool) -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> Bool) -> [a] -> [a]
filter (\RegWithFormat
r -> Reg -> UniqFM Reg Int -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM (RegWithFormat -> Reg
regWithFormat_reg RegWithFormat
r) UniqFM Reg Int
regSlotMap) [RegWithFormat]
rsRead
let rsSpillWritten :: [RegWithFormat]
rsSpillWritten = (RegWithFormat -> Bool) -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> Bool) -> [a] -> [a]
filter (\RegWithFormat
r -> Reg -> UniqFM Reg Int -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM (RegWithFormat -> Reg
regWithFormat_reg RegWithFormat
r) UniqFM Reg Int
regSlotMap) [RegWithFormat]
rsWritten
let rsSpillModify :: [RegWithFormat]
rsSpillModify = (RegWithFormat -> Bool) -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> Bool) -> [a] -> [a]
filter (\RegWithFormat
r -> Reg -> UniqFM Reg Int -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM (RegWithFormat -> Reg
regWithFormat_reg RegWithFormat
r) UniqFM Reg Int
regSlotMap) [RegWithFormat]
rsModify
(instr1, prepost1) <- (InstrSR instr
-> RegWithFormat
-> State
SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr])))
-> InstrSR instr
-> [RegWithFormat]
-> State
SpillS (InstrSR instr, [([LiveInstr instr], [LiveInstr instr])])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (Platform
-> UniqFM Reg Int
-> InstrSR instr
-> RegWithFormat
-> State
SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr]))
forall instr instr'.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillRead Platform
platform UniqFM Reg Int
regSlotMap) InstrSR instr
instr [RegWithFormat]
rsSpillRead
(instr2, prepost2) <- mapAccumLM (spillWrite platform regSlotMap) instr1 rsSpillWritten
(instr3, prepost3) <- mapAccumLM (spillModify platform regSlotMap) instr2 rsSpillModify
let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
let prefixes = [[LiveInstr instr]] -> [LiveInstr instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LiveInstr instr]]
mPrefixes
let postfixes = [[LiveInstr instr]] -> [LiveInstr instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LiveInstr instr]]
mPostfixes
let instrs' = [LiveInstr instr]
prefixes
[LiveInstr instr] -> [LiveInstr instr] -> [LiveInstr instr]
forall a. [a] -> [a] -> [a]
++ [InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr3 Maybe Liveness
forall a. Maybe a
Nothing]
[LiveInstr instr] -> [LiveInstr instr] -> [LiveInstr instr]
forall a. [a] -> [a] -> [a]
++ [LiveInstr instr]
postfixes
return instrs'
spillRead
:: Instruction instr
=> Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillRead :: forall instr instr'.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillRead Platform
platform UniqFM Reg Int
regSlotMap instr
instr (RegWithFormat Reg
reg Format
fmt)
| Just Int
slot <- UniqFM Reg Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Reg Int
regSlotMap Reg
reg
= do (instr', nReg) <- Platform -> Reg -> instr -> SpillM (instr, Reg)
forall instr.
Instruction instr =>
Platform -> Reg -> instr -> SpillM (instr, Reg)
patchInstr Platform
platform Reg
reg instr
instr
modify $ \SpillS
s -> SpillS
s
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
return ( instr'
, ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]
, []) )
| Bool
otherwise = String
-> State SpillS (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall a. HasCallStack => String -> a
panic String
"RegSpill.spillRead: no slot defined for spilled reg"
spillWrite
:: Instruction instr
=> Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillWrite :: forall instr instr'.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillWrite Platform
platform UniqFM Reg Int
regSlotMap instr
instr (RegWithFormat Reg
reg Format
fmt)
| Just Int
slot <- UniqFM Reg Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Reg Int
regSlotMap Reg
reg
= do (instr', nReg) <- Platform -> Reg -> instr -> SpillM (instr, Reg)
forall instr.
Instruction instr =>
Platform -> Reg -> instr -> SpillM (instr, Reg)
patchInstr Platform
platform Reg
reg instr
instr
modify $ \SpillS
s -> SpillS
s
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
return ( instr'
, ( []
, [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing]))
| Bool
otherwise = String
-> State SpillS (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall a. HasCallStack => String -> a
panic String
"RegSpill.spillWrite: no slot defined for spilled reg"
spillModify
:: Instruction instr
=> Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillModify :: forall instr instr'.
Instruction instr =>
Platform
-> UniqFM Reg Int
-> instr
-> RegWithFormat
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillModify Platform
platform UniqFM Reg Int
regSlotMap instr
instr (RegWithFormat Reg
reg Format
fmt)
| Just Int
slot <- UniqFM Reg Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Reg Int
regSlotMap Reg
reg
= do (instr', nReg) <- Platform -> Reg -> instr -> SpillM (instr, Reg)
forall instr.
Instruction instr =>
Platform -> Reg -> instr -> SpillM (instr, Reg)
patchInstr Platform
platform Reg
reg instr
instr
modify $ \SpillS
s -> SpillS
s
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
return ( instr'
, ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]
, [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing]))
| Bool
otherwise = String
-> State SpillS (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall a. HasCallStack => String -> a
panic String
"RegSpill.spillModify: no slot defined for spilled reg"
patchInstr
:: Instruction instr
=> Platform -> Reg -> instr -> SpillM (instr, Reg)
patchInstr :: forall instr.
Instruction instr =>
Platform -> Reg -> instr -> SpillM (instr, Reg)
patchInstr Platform
platform Reg
reg instr
instr
= do nUnique <- SpillM Unique
newUnique
let nReg
= case Reg
reg of
RegVirtual VirtualReg
vr
-> VirtualReg -> Reg
RegVirtual (Unique -> VirtualReg -> VirtualReg
renameVirtualReg Unique
nUnique VirtualReg
vr)
RegReal{}
-> String -> Reg
forall a. HasCallStack => String -> a
panic String
"RegAlloc.Graph.Spill.patchIntr: not patching real reg"
let instr' = Platform -> Reg -> Reg -> instr -> instr
forall instr.
Instruction instr =>
Platform -> Reg -> Reg -> instr -> instr
patchReg1 Platform
platform Reg
reg Reg
nReg instr
instr
return (instr', nReg)
patchReg1
:: Instruction instr
=> Platform -> Reg -> Reg -> instr -> instr
patchReg1 :: forall instr.
Instruction instr =>
Platform -> Reg -> Reg -> instr -> instr
patchReg1 Platform
platform Reg
old Reg
new instr
instr
= let patchF :: Reg -> Reg
patchF Reg
r
| Reg
r Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
old = Reg
new
| Bool
otherwise = Reg
r
in Platform -> instr -> (Reg -> Reg) -> instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> instr -> (Reg -> Reg) -> instr
patchRegsOfInstr Platform
platform instr
instr Reg -> Reg
patchF
type SpillM = State SpillS
data SpillS
= SpillS
{
SpillS -> DUniqSupply
stateUS :: DUniqSupply
, SpillS -> UniqFM Reg (Reg, Int, Int)
stateSpillSL :: UniqFM Reg (Reg, Int, Int) }
instance MonadGetUnique SpillM where
getUniqueM :: SpillM Unique
getUniqueM = do
us <- (SpillS -> DUniqSupply) -> State SpillS DUniqSupply
forall s a. (s -> a) -> State s a
gets SpillS -> DUniqSupply
stateUS
case takeUniqueFromDSupply us of
(Unique
uniq, DUniqSupply
us')
-> do (SpillS -> SpillS) -> State SpillS ()
forall s. (s -> s) -> State s ()
modify ((SpillS -> SpillS) -> State SpillS ())
-> (SpillS -> SpillS) -> State SpillS ()
forall a b. (a -> b) -> a -> b
$ \SpillS
s -> SpillS
s { stateUS = us' }
Unique -> SpillM Unique
forall a. a -> State SpillS a
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
uniq
initSpillS :: DUniqSupply -> SpillS
initSpillS :: DUniqSupply -> SpillS
initSpillS DUniqSupply
uniqueSupply
= SpillS
{ stateUS :: DUniqSupply
stateUS = DUniqSupply
uniqueSupply
, stateSpillSL :: UniqFM Reg (Reg, Int, Int)
stateSpillSL = UniqFM Reg (Reg, Int, Int)
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM }
newUnique :: SpillM Unique
newUnique :: SpillM Unique
newUnique = SpillM Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM
accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL (Reg
r1, Int
s1, Int
l1) (Reg
_, Int
s2, Int
l2)
= (Reg
r1, Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s2, Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2)
data SpillStats
= SpillStats
{ SpillStats -> UniqFM Reg (Reg, Int, Int)
spillStoreLoad :: UniqFM Reg (Reg, Int, Int) }
makeSpillStats :: SpillS -> SpillStats
makeSpillStats :: SpillS -> SpillStats
makeSpillStats SpillS
s
= SpillStats
{ spillStoreLoad :: UniqFM Reg (Reg, Int, Int)
spillStoreLoad = SpillS -> UniqFM Reg (Reg, Int, Int)
stateSpillSL SpillS
s }
instance Outputable SpillStats where
ppr :: SpillStats -> SDoc
ppr SpillStats
stats
= UniqFM Reg (Reg, Int, Int) -> ([(Reg, Int, Int)] -> SDoc) -> SDoc
forall {k} (key :: k) a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM (SpillStats -> UniqFM Reg (Reg, Int, Int)
spillStoreLoad SpillStats
stats)
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc)
-> ([(Reg, Int, Int)] -> [SDoc]) -> [(Reg, Int, Int)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Reg, Int, Int) -> SDoc) -> [(Reg, Int, Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Reg
r, Int
s, Int
l) -> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
s SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
l))