{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.CmmToAsm.Reg.Graph.SpillClean (
cleanSpills
) where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Utils.Monad.State
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Cmm.Dataflow.Collections
import Data.List (nub, foldl1', find)
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
type Slot = Int
cleanSpills
:: Instruction instr
=> Platform
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
cleanSpills :: forall instr statics.
Instruction instr =>
Platform -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
cleanSpills Platform
platform LiveCmmDecl statics instr
cmm
= forall s a. State s a -> s -> a
evalState (forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform Int
0 LiveCmmDecl statics instr
cmm) CleanS
initCleanS
cleanSpin
:: Instruction instr
=> Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin :: forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform Int
spinCount LiveCmmDecl statics instr
code
= do
forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
{ sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = Int
0
, sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = Int
0
, sReloadedBy :: UniqFM Store [BlockId]
sReloadedBy = forall key elt. UniqFM key elt
emptyUFM }
LiveCmmDecl statics instr
code_forward <- forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM (forall instr.
Instruction instr =>
Platform -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockForward Platform
platform) LiveCmmDecl statics instr
code
LiveCmmDecl statics instr
code_backward <- forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
cleanTopBackward LiveCmmDecl statics instr
code_forward
State CleanS ()
collateJoinPoints
Int
spills <- forall s a. (s -> a) -> State s a
gets CleanS -> Int
sCleanedSpillsAcc
Int
reloads <- forall s a. (s -> a) -> State s a
gets CleanS -> Int
sCleanedReloadsAcc
forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
{ sCleanedCount :: [(Int, Int)]
sCleanedCount = (Int
spills, Int
reloads) forall a. a -> [a] -> [a]
: CleanS -> [(Int, Int)]
sCleanedCount CleanS
s }
[(Int, Int)]
cleanedCount <- forall s a. (s -> a) -> State s a
gets CleanS -> [(Int, Int)]
sCleanedCount
if forall a. Int -> [a] -> [a]
take Int
2 [(Int, Int)]
cleanedCount forall a. Eq a => a -> a -> Bool
== [(Int
0, Int
0), (Int
0, Int
0)]
then forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
code
else forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform (Int
spinCount forall a. Num a => a -> a -> a
+ Int
1) LiveCmmDecl statics instr
code_backward
cleanBlockForward
:: Instruction instr
=> Platform
-> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockForward :: forall instr.
Instruction instr =>
Platform -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockForward Platform
platform (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
= do
UniqFM BlockId (Assoc Store)
jumpValid <- forall s a. (s -> a) -> State s a
gets CleanS -> UniqFM BlockId (Assoc Store)
sJumpValid
let assoc :: Assoc Store
assoc = case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM BlockId (Assoc Store)
jumpValid BlockId
blockId of
Just Assoc Store
assoc -> Assoc Store
assoc
Maybe (Assoc Store)
Nothing -> forall a. Assoc a
emptyAssoc
[LiveInstr instr]
instrs_reload <- forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [] [LiveInstr instr]
instrs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
blockId [LiveInstr instr]
instrs_reload
cleanForward
:: Instruction instr
=> Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward :: forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
_ BlockId
_ Assoc Store
_ [LiveInstr instr]
acc []
= forall (m :: * -> *) a. Monad m => a -> m a
return [LiveInstr instr]
acc
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc (LiveInstr instr
li1 : LiveInstr instr
li2 : [LiveInstr instr]
instrs)
| LiveInstr (SPILL Reg
reg1 Int
slot1) Maybe Liveness
_ <- LiveInstr instr
li1
, LiveInstr (RELOAD Int
slot2 Reg
reg2) Maybe Liveness
_ <- LiveInstr instr
li2
, Int
slot1 forall a. Eq a => a -> a -> Bool
== Int
slot2
= do
forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc
forall a b. (a -> b) -> a -> b
$ LiveInstr instr
li1 forall a. a -> [a] -> [a]
: forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
reg1 Reg
reg2) forall a. Maybe a
Nothing
forall a. a -> [a] -> [a]
: [LiveInstr instr]
instrs
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc (li :: LiveInstr instr
li@(LiveInstr InstrSR instr
i1 Maybe Liveness
_) : [LiveInstr instr]
instrs)
| Just (Reg
r1, Reg
r2) <- forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
i1
= if Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2
then forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc [LiveInstr instr]
instrs
else do let assoc' :: Assoc Store
assoc' = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
r1) (Reg -> Store
SReg Reg
r2)
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Reg -> Store
SReg Reg
r2)
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc (LiveInstr instr
li : [LiveInstr instr]
instrs)
| LiveInstr (SPILL Reg
reg Int
slot) Maybe Liveness
_ <- LiveInstr instr
li
= let assoc' :: Assoc Store
assoc' = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
reg) (Int -> Store
SSlot Int
slot)
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Int -> Store
SSlot Int
slot)
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
in forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr (RELOAD{}) Maybe Liveness
_ <- LiveInstr instr
li
= do (Assoc Store
assoc', Maybe (LiveInstr instr)
mli) <- forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload Platform
platform BlockId
blockId Assoc Store
assoc LiveInstr instr
li
case Maybe (LiveInstr instr)
mli of
Maybe (LiveInstr instr)
Nothing -> forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' [LiveInstr instr]
acc
[LiveInstr instr]
instrs
Just LiveInstr instr
li' -> forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li' forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc)
[LiveInstr instr]
instrs
| LiveInstr InstrSR instr
instr Maybe Liveness
_ <- LiveInstr instr
li
, [BlockId]
targets <- forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets
= do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Assoc Store -> BlockId -> State CleanS ()
accJumpValid Assoc Store
assoc) [BlockId]
targets
forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr InstrSR instr
instr Maybe Liveness
_ <- LiveInstr instr
li
, RU [Reg]
_ [Reg]
written <- forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
= let assoc' :: Assoc Store
assoc' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Store -> Assoc Store -> Assoc Store
delAssoc Assoc Store
assoc (forall a b. (a -> b) -> [a] -> [b]
map Reg -> Store
SReg forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Reg]
written)
in forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
cleanReload
:: Instruction instr
=> Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload :: forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload Platform
platform BlockId
blockId Assoc Store
assoc li :: LiveInstr instr
li@(LiveInstr (RELOAD Int
slot Reg
reg) Maybe Liveness
_)
| Store -> Store -> Assoc Store -> Bool
elemAssoc (Int -> Store
SSlot Int
slot) (Reg -> Store
SReg Reg
reg) Assoc Store
assoc
= do forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
forall (m :: * -> *) a. Monad m => a -> m a
return (Assoc Store
assoc, forall a. Maybe a
Nothing)
| Just Reg
reg2 <- Assoc Store -> Int -> Maybe Reg
findRegOfSlot Assoc Store
assoc Int
slot
= do forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
let assoc' :: Assoc Store
assoc' = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
reg) (Reg -> Store
SReg Reg
reg2)
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Reg -> Store
SReg Reg
reg)
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
forall (m :: * -> *) a. Monad m => a -> m a
return ( Assoc Store
assoc'
, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
reg2 Reg
reg) forall a. Maybe a
Nothing)
| Bool
otherwise
= do
let assoc' :: Assoc Store
assoc'
= Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
reg) (Int -> Store
SSlot Int
slot)
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Reg -> Store
SReg Reg
reg)
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
BlockId -> Int -> State CleanS ()
accBlockReloadsSlot BlockId
blockId Int
slot
forall (m :: * -> *) a. Monad m => a -> m a
return (Assoc Store
assoc', forall a. a -> Maybe a
Just LiveInstr instr
li)
cleanReload Platform
_ BlockId
_ Assoc Store
_ LiveInstr instr
_
= forall a. String -> a
panic String
"RegSpillClean.cleanReload: unhandled instr"
cleanTopBackward
:: Instruction instr
=> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanTopBackward :: forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
cleanTopBackward LiveCmmDecl statics instr
cmm
= case LiveCmmDecl statics instr
cmm of
CmmData{}
-> forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
cmm
CmmProc LiveInfo
info CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs
| LiveInfo LabelMap RawCmmStatics
_ [BlockId]
_ BlockMap RegSet
_ BlockMap IntSet
liveSlotsOnEntry <- LiveInfo
info
-> do [SCC (LiveBasicBlock instr)]
sccs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM (forall instr.
Instruction instr =>
BlockMap IntSet
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockBackward BlockMap IntSet
liveSlotsOnEntry)) [SCC (LiveBasicBlock instr)]
sccs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs'
cleanBlockBackward
:: Instruction instr
=> BlockMap IntSet
-> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockBackward :: forall instr.
Instruction instr =>
BlockMap IntSet
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockBackward BlockMap IntSet
liveSlotsOnEntry (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
= do [LiveInstr instr]
instrs_spill <- forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry forall a. UniqSet a
emptyUniqSet [] [LiveInstr instr]
instrs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
blockId [LiveInstr instr]
instrs_spill
cleanBackward
:: Instruction instr
=> BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward :: forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
lis
= do UniqFM Store [BlockId]
reloadedBy <- forall s a. (s -> a) -> State s a
gets CleanS -> UniqFM Store [BlockId]
sReloadedBy
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqFM Store [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' BlockMap IntSet
liveSlotsOnEntry UniqFM Store [BlockId]
reloadedBy UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
lis
cleanBackward'
:: Instruction instr
=> BlockMap IntSet
-> UniqFM Store [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' :: forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqFM Store [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' BlockMap IntSet
_ UniqFM Store [BlockId]
_ UniqSet Int
_ [LiveInstr instr]
acc []
= forall (m :: * -> *) a. Monad m => a -> m a
return [LiveInstr instr]
acc
cleanBackward' BlockMap IntSet
liveSlotsOnEntry UniqFM Store [BlockId]
reloadedBy UniqSet Int
noReloads [LiveInstr instr]
acc (LiveInstr instr
li : [LiveInstr instr]
instrs)
| LiveInstr (SPILL Reg
_ Int
slot) Maybe Liveness
_ <- LiveInstr instr
li
, Maybe [BlockId]
Nothing <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Store [BlockId]
reloadedBy (Int -> Store
SSlot Int
slot)
= do forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = CleanS -> Int
sCleanedSpillsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
instrs
| LiveInstr (SPILL Reg
_ Int
slot) Maybe Liveness
_ <- LiveInstr instr
li
= if forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Int
slot UniqSet Int
noReloads
then do
forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = CleanS -> Int
sCleanedSpillsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
instrs
else do
let noReloads' :: UniqSet Int
noReloads' = forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Int
noReloads Int
slot
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr (RELOAD Int
slot Reg
_) Maybe Liveness
_ <- LiveInstr instr
li
, UniqSet Int
noReloads' <- forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Int
noReloads Int
slot
= forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr InstrSR instr
instr Maybe Liveness
_ <- LiveInstr instr
li
, [BlockId]
targets <- forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
= do
let slotsReloadedByTargets :: IntSet
slotsReloadedByTargets
= forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions
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 (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockMap IntSet
liveSlotsOnEntry)
forall a b. (a -> b) -> a -> b
$ [BlockId]
targets
let noReloads' :: UniqSet Int
noReloads'
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Int
noReloads
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
slotsReloadedByTargets
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
#if __GLASGOW_HASKELL__ <= 810
| otherwise
= cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
#endif
collateJoinPoints :: CleanM ()
collateJoinPoints :: State CleanS ()
collateJoinPoints
= forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
{ sJumpValid :: UniqFM BlockId (Assoc Store)
sJumpValid = forall elt1 elt2 key.
(elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM [Assoc Store] -> Assoc Store
intersects (CleanS -> UniqFM BlockId [Assoc Store]
sJumpValidAcc CleanS
s)
, sJumpValidAcc :: UniqFM BlockId [Assoc Store]
sJumpValidAcc = forall key elt. UniqFM key elt
emptyUFM }
intersects :: [Assoc Store] -> Assoc Store
intersects :: [Assoc Store] -> Assoc Store
intersects [] = forall a. Assoc a
emptyAssoc
intersects [Assoc Store]
assocs = forall a. (a -> a -> a) -> [a] -> a
foldl1' Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc [Assoc Store]
assocs
findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
findRegOfSlot Assoc Store
assoc Int
slot
| UniqSet Store
close <- Store -> Assoc Store -> UniqSet Store
closeAssoc (Int -> Store
SSlot Int
slot) Assoc Store
assoc
, Just (SReg Reg
reg) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Store -> Bool
isStoreReg forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Store
close
= forall a. a -> Maybe a
Just Reg
reg
| Bool
otherwise
= forall a. Maybe a
Nothing
type CleanM
= State CleanS
data CleanS
= CleanS
{
CleanS -> UniqFM BlockId (Assoc Store)
sJumpValid :: UniqFM BlockId (Assoc Store)
, CleanS -> UniqFM BlockId [Assoc Store]
sJumpValidAcc :: UniqFM BlockId [Assoc Store]
, CleanS -> UniqFM Store [BlockId]
sReloadedBy :: UniqFM Store [BlockId]
, CleanS -> [(Int, Int)]
sCleanedCount :: [(Int, Int)]
, CleanS -> Int
sCleanedSpillsAcc :: Int
, CleanS -> Int
sCleanedReloadsAcc :: Int }
initCleanS :: CleanS
initCleanS :: CleanS
initCleanS
= CleanS
{ sJumpValid :: UniqFM BlockId (Assoc Store)
sJumpValid = forall key elt. UniqFM key elt
emptyUFM
, sJumpValidAcc :: UniqFM BlockId [Assoc Store]
sJumpValidAcc = forall key elt. UniqFM key elt
emptyUFM
, sReloadedBy :: UniqFM Store [BlockId]
sReloadedBy = forall key elt. UniqFM key elt
emptyUFM
, sCleanedCount :: [(Int, Int)]
sCleanedCount = []
, sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = Int
0
, sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = Int
0 }
accJumpValid :: Assoc Store -> BlockId -> CleanM ()
accJumpValid :: Assoc Store -> BlockId -> State CleanS ()
accJumpValid Assoc Store
assocs BlockId
target
= forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s {
sJumpValidAcc :: UniqFM BlockId [Assoc Store]
sJumpValidAcc = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. [a] -> [a] -> [a]
(++)
(CleanS -> UniqFM BlockId [Assoc Store]
sJumpValidAcc CleanS
s)
BlockId
target
[Assoc Store
assocs] }
accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
accBlockReloadsSlot :: BlockId -> Int -> State CleanS ()
accBlockReloadsSlot BlockId
blockId Int
slot
= forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s {
sReloadedBy :: UniqFM Store [BlockId]
sReloadedBy = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. [a] -> [a] -> [a]
(++)
(CleanS -> UniqFM Store [BlockId]
sReloadedBy CleanS
s)
(Int -> Store
SSlot Int
slot)
[BlockId
blockId] }
data Store
= SSlot Int
| SReg Reg
isStoreReg :: Store -> Bool
isStoreReg :: Store -> Bool
isStoreReg Store
ss
= case Store
ss of
SSlot Int
_ -> Bool
False
SReg Reg
_ -> Bool
True
instance Uniquable Store where
getUnique :: Store -> Unique
getUnique (SReg Reg
r)
| RegReal (RealRegSingle Int
i) <- Reg
r
= Int -> Unique
mkRegSingleUnique Int
i
| RegReal (RealRegPair Int
r1 Int
r2) <- Reg
r
= Int -> Unique
mkRegPairUnique (Int
r1 forall a. Num a => a -> a -> a
* Int
65535 forall a. Num a => a -> a -> a
+ Int
r2)
| Bool
otherwise
= forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"RegSpillClean.getUnique: found virtual reg during spill clean,"
forall a. [a] -> [a] -> [a]
++ String
"only real regs expected."
getUnique (SSlot Int
i) = Int -> Unique
mkRegSubUnique Int
i
instance Outputable Store where
ppr :: Store -> SDoc
ppr (SSlot Int
i) = String -> SDoc
text String
"slot" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
ppr (SReg Reg
r) = forall a. Outputable a => a -> SDoc
ppr Reg
r
type Assoc a = UniqFM a (UniqSet a)
emptyAssoc :: Assoc a
emptyAssoc :: forall a. Assoc a
emptyAssoc = forall key elt. UniqFM key elt
emptyUFM
addAssoc :: Store -> Store -> Assoc Store -> Assoc Store
addAssoc :: Store -> Store -> Assoc Store -> Assoc Store
addAssoc Store
a Store
b Assoc Store
m
= let m1 :: Assoc Store
m1 = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets Assoc Store
m Store
a (forall a. Uniquable a => a -> UniqSet a
unitUniqSet Store
b)
m2 :: Assoc Store
m2 = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets Assoc Store
m1 Store
b (forall a. Uniquable a => a -> UniqSet a
unitUniqSet Store
a)
in Assoc Store
m2
delAssoc :: Store -> Assoc Store -> Assoc Store
delAssoc :: Store -> Assoc Store -> Assoc Store
delAssoc Store
a Assoc Store
m
| Just UniqSet Store
aSet <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Assoc Store
m Store
a
, Assoc Store
m1 <- forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM Assoc Store
m Store
a
= forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet (\Store
x Assoc Store
m -> Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 Store
x Store
a Assoc Store
m) Assoc Store
m1 UniqSet Store
aSet
| Bool
otherwise = Assoc Store
m
delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 Store
a Store
b Assoc Store
m
| Just UniqSet Store
aSet <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Assoc Store
m Store
a
= forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM Assoc Store
m Store
a (forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Store
aSet Store
b)
| Bool
otherwise = Assoc Store
m
elemAssoc :: Store -> Store -> Assoc Store -> Bool
elemAssoc :: Store -> Store -> Assoc Store -> Bool
elemAssoc Store
a Store
b Assoc Store
m
= forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Store
b (Store -> Assoc Store -> UniqSet Store
closeAssoc Store
a Assoc Store
m)
closeAssoc :: Store -> Assoc Store -> UniqSet Store
closeAssoc :: Store -> Assoc Store -> UniqSet Store
closeAssoc Store
a Assoc Store
assoc
= forall {key}.
Uniquable key =>
UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' Assoc Store
assoc forall a. UniqSet a
emptyUniqSet (forall a. Uniquable a => a -> UniqSet a
unitUniqSet Store
a)
where
closeAssoc' :: UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' UniqFM key (UniqSet key)
assoc UniqSet key
visited UniqSet key
toVisit
= case forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet key
toVisit of
[] -> UniqSet key
visited
(key
x:[key]
_)
| forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet key
x UniqSet key
visited
-> UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' UniqFM key (UniqSet key)
assoc UniqSet key
visited (forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet key
toVisit key
x)
| Bool
otherwise
-> let neighbors :: UniqSet key
neighbors
= case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM key (UniqSet key)
assoc key
x of
Maybe (UniqSet key)
Nothing -> forall a. UniqSet a
emptyUniqSet
Just UniqSet key
set -> UniqSet key
set
in UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' UniqFM key (UniqSet key)
assoc
(forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet key
visited key
x)
(forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet key
toVisit UniqSet key
neighbors)
intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc Assoc Store
a Assoc Store
b
= forall elt1 elt2 elt3 key.
(elt1 -> elt2 -> elt3)
-> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt3
intersectUFM_C (forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets) Assoc Store
a Assoc Store
b