module GHC.CmmToAsm.Reg.Graph.Coalesce (
regCoalesce,
slurpJoinMovs
) where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm
import GHC.Data.Bag
import GHC.Data.Graph.Directed
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
regCoalesce
:: Instruction instr
=> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
regCoalesce :: forall instr statics.
Instruction instr =>
[LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr]
regCoalesce [LiveCmmDecl statics instr]
code
= do
let joins :: Bag (Reg, Reg)
joins = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Bag a -> Bag a -> Bag a
unionBags forall a. Bag a
emptyBag
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpJoinMovs [LiveCmmDecl statics instr]
code
let alloc :: UniqFM Reg Reg
alloc = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
buildAlloc forall key elt. UniqFM key elt
emptyUFM
forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList Bag (Reg, Reg)
joins
let patched :: [LiveCmmDecl statics instr]
patched = forall a b. (a -> b) -> [a] -> [b]
map (forall instr statics.
Instruction instr =>
(Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchEraseLive (UniqFM Reg Reg -> Reg -> Reg
sinkReg UniqFM Reg Reg
alloc)) [LiveCmmDecl statics instr]
code
forall (m :: * -> *) a. Monad m => a -> m a
return [LiveCmmDecl statics instr]
patched
buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
buildAlloc UniqFM Reg Reg
fm (Reg
r1, Reg
r2)
= let rmin :: Reg
rmin = forall a. Ord a => a -> a -> a
min Reg
r1 Reg
r2
rmax :: Reg
rmax = forall a. Ord a => a -> a -> a
max Reg
r1 Reg
r2
in forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Reg Reg
fm Reg
rmax Reg
rmin
sinkReg :: UniqFM Reg Reg -> Reg -> Reg
sinkReg :: UniqFM Reg Reg -> Reg -> Reg
sinkReg UniqFM Reg Reg
fm Reg
r
= case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Reg Reg
fm Reg
r of
Maybe Reg
Nothing -> Reg
r
Just Reg
r' -> UniqFM Reg Reg -> Reg -> Reg
sinkReg UniqFM Reg Reg
fm Reg
r'
slurpJoinMovs
:: Instruction instr
=> LiveCmmDecl statics instr
-> Bag (Reg, Reg)
slurpJoinMovs :: forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpJoinMovs LiveCmmDecl statics instr
live
= forall {instr} {d} {h}.
Instruction instr =>
Bag (Reg, Reg)
-> GenCmmDecl d h [SCC (GenBasicBlock (LiveInstr instr))]
-> Bag (Reg, Reg)
slurpCmm forall a. Bag a
emptyBag LiveCmmDecl statics instr
live
where
slurpCmm :: Bag (Reg, Reg)
-> GenCmmDecl d h [SCC (GenBasicBlock (LiveInstr instr))]
-> Bag (Reg, Reg)
slurpCmm Bag (Reg, Reg)
rs CmmData{}
= Bag (Reg, Reg)
rs
slurpCmm Bag (Reg, Reg)
rs (CmmProc h
_ CLabel
_ [GlobalReg]
_ [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {instr}.
Instruction instr =>
Bag (Reg, Reg) -> GenBasicBlock (LiveInstr instr) -> Bag (Reg, Reg)
slurpBlock Bag (Reg, Reg)
rs (forall a. [SCC a] -> [a]
flattenSCCs [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
slurpBlock :: Bag (Reg, Reg) -> GenBasicBlock (LiveInstr instr) -> Bag (Reg, Reg)
slurpBlock Bag (Reg, Reg)
rs (BasicBlock BlockId
_ [LiveInstr instr]
instrs)
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {instr}.
Instruction instr =>
Bag (Reg, Reg) -> LiveInstr instr -> Bag (Reg, Reg)
slurpLI Bag (Reg, Reg)
rs [LiveInstr instr]
instrs
slurpLI :: Bag (Reg, Reg) -> LiveInstr instr -> Bag (Reg, Reg)
slurpLI Bag (Reg, Reg)
rs (LiveInstr InstrSR instr
_ Maybe Liveness
Nothing) = Bag (Reg, Reg)
rs
slurpLI Bag (Reg, Reg)
rs (LiveInstr InstrSR instr
instr (Just Liveness
live))
| Just (Reg
r1, Reg
r2) <- forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
instr
, forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r1 forall a b. (a -> b) -> a -> b
$ Liveness -> RegSet
liveDieRead Liveness
live
, forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r2 forall a b. (a -> b) -> a -> b
$ Liveness -> RegSet
liveBorn Liveness
live
, Reg -> Bool
isVirtualReg Reg
r1 Bool -> Bool -> Bool
&& Reg -> Bool
isVirtualReg Reg
r2
= forall a. a -> Bag a -> Bag a
consBag (Reg
r1, Reg
r2) Bag (Reg, Reg)
rs
| Bool
otherwise
= Bag (Reg, Reg)
rs