-- | Register coalescing.
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


-- | Do register coalescing on this top level thing
--
--   For Reg -> Reg moves, if the first reg dies at the same time the
--   second reg is born then the mov only serves to join live ranges.
--   The two regs can be renamed to be the same and the move instruction
--   safely erased.
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       = (Bag (Reg, Reg) -> Bag (Reg, Reg) -> Bag (Reg, Reg))
-> Bag (Reg, Reg) -> [Bag (Reg, Reg)] -> Bag (Reg, Reg)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Bag (Reg, Reg) -> Bag (Reg, Reg) -> Bag (Reg, Reg)
forall a. Bag a -> Bag a -> Bag a
unionBags Bag (Reg, Reg)
forall a. Bag a
emptyBag
                        ([Bag (Reg, Reg)] -> Bag (Reg, Reg))
-> [Bag (Reg, Reg)] -> Bag (Reg, Reg)
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr -> Bag (Reg, Reg))
-> [LiveCmmDecl statics instr] -> [Bag (Reg, Reg)]
forall a b. (a -> b) -> [a] -> [b]
map LiveCmmDecl statics instr -> Bag (Reg, Reg)
forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpJoinMovs [LiveCmmDecl statics instr]
code

        let alloc :: UniqFM Reg Reg
alloc       = (UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg)
-> UniqFM Reg Reg -> [(Reg, Reg)] -> UniqFM Reg Reg
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
buildAlloc UniqFM Reg Reg
forall key elt. UniqFM key elt
emptyUFM
                        ([(Reg, Reg)] -> UniqFM Reg Reg) -> [(Reg, Reg)] -> UniqFM Reg Reg
forall a b. (a -> b) -> a -> b
$ Bag (Reg, Reg) -> [(Reg, Reg)]
forall a. Bag a -> [a]
bagToList Bag (Reg, Reg)
joins

        let patched :: [LiveCmmDecl statics instr]
patched     = (LiveCmmDecl statics instr -> LiveCmmDecl statics instr)
-> [LiveCmmDecl statics instr] -> [LiveCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map ((Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
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

        [LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [LiveCmmDecl statics instr]
patched


-- | Add a v1 = v2 register renaming to the map.
--   The register with the lowest lexical name is set as the
--   canonical version.
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    = Reg -> Reg -> Reg
forall a. Ord a => a -> a -> a
min Reg
r1 Reg
r2
        rmax :: Reg
rmax    = Reg -> Reg -> Reg
forall a. Ord a => a -> a -> a
max Reg
r1 Reg
r2
   in   UniqFM Reg Reg -> Reg -> Reg -> UniqFM Reg Reg
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Reg Reg
fm Reg
rmax Reg
rmin


-- | Determine the canonical name for a register by following
--   v1 = v2 renamings in this map.
sinkReg :: UniqFM Reg Reg -> Reg -> Reg
sinkReg :: UniqFM Reg Reg -> Reg -> Reg
sinkReg UniqFM Reg Reg
fm Reg
r
 = case UniqFM Reg Reg -> Reg -> Maybe Reg
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'


-- | Slurp out mov instructions that only serve to join live ranges.
--
--   During a mov, if the source reg dies and the destination reg is
--   born then we can rename the two regs to the same thing and
--   eliminate the move.
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
        = Bag (Reg, Reg) -> LiveCmmDecl statics instr -> Bag (Reg, Reg)
forall {instr} {d} {h}.
Instruction instr =>
Bag (Reg, Reg)
-> GenCmmDecl d h [SCC (GenBasicBlock (LiveInstr instr))]
-> Bag (Reg, Reg)
slurpCmm Bag (Reg, Reg)
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)
         = (Bag (Reg, Reg)
 -> GenBasicBlock (LiveInstr instr) -> Bag (Reg, Reg))
-> Bag (Reg, Reg)
-> [GenBasicBlock (LiveInstr instr)]
-> Bag (Reg, Reg)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Bag (Reg, Reg) -> GenBasicBlock (LiveInstr instr) -> Bag (Reg, Reg)
forall {instr}.
Instruction instr =>
Bag (Reg, Reg) -> GenBasicBlock (LiveInstr instr) -> Bag (Reg, Reg)
slurpBlock Bag (Reg, Reg)
rs ([SCC (GenBasicBlock (LiveInstr instr))]
-> [GenBasicBlock (LiveInstr instr)]
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)
         = (Bag (Reg, Reg) -> LiveInstr instr -> Bag (Reg, Reg))
-> Bag (Reg, Reg) -> [LiveInstr instr] -> Bag (Reg, Reg)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Bag (Reg, Reg) -> LiveInstr instr -> Bag (Reg, Reg)
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) <- InstrSR instr -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
instr
                , Reg -> UniqSet Reg -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r1 (UniqSet Reg -> Bool) -> UniqSet Reg -> Bool
forall a b. (a -> b) -> a -> b
$ Liveness -> UniqSet Reg
liveDieRead Liveness
live
                , Reg -> UniqSet Reg -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r2 (UniqSet Reg -> Bool) -> UniqSet Reg -> Bool
forall a b. (a -> b) -> a -> b
$ Liveness -> UniqSet Reg
liveBorn Liveness
live

                -- only coalesce movs between two virtuals for now,
                -- else we end up with allocatable regs in the live
                -- regs list..
                , Reg -> Bool
isVirtualReg Reg
r1 Bool -> Bool -> Bool
&& Reg -> Bool
isVirtualReg Reg
r2
                = (Reg, Reg) -> Bag (Reg, Reg) -> Bag (Reg, Reg)
forall a. a -> Bag a -> Bag a
consBag (Reg
r1, Reg
r2) Bag (Reg, Reg)
rs

                | Bool
otherwise
                = Bag (Reg, Reg)
rs