-- | Register coalescing.
module RegAlloc.Graph.Coalesce (
        regCoalesce,
        slurpJoinMovs
) where
import GhcPrelude

import RegAlloc.Liveness
import Instruction
import Reg

import Cmm
import Bag
import Digraph
import UniqFM
import UniqSet
import UniqSupply


-- | 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 :: [LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr]
regCoalesce code :: [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 (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
alloc       = (UniqFM Reg -> (Reg, Reg) -> UniqFM Reg)
-> UniqFM Reg -> [(Reg, Reg)] -> UniqFM Reg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
buildAlloc UniqFM Reg
forall elt. UniqFM elt
emptyUFM
                        ([(Reg, Reg)] -> UniqFM Reg) -> [(Reg, Reg)] -> UniqFM 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
sinkReg UniqFM Reg
alloc)) [LiveCmmDecl statics instr]
code

        [LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr]
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) -> UniqFM Reg
buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
buildAlloc fm :: UniqFM Reg
fm (r1 :: Reg
r1, r2 :: 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 -> UniqFM Reg
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM 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
sinkReg :: UniqFM Reg -> Reg -> Reg
sinkReg fm :: UniqFM Reg
fm r :: Reg
r
 = case UniqFM Reg -> Reg -> Maybe Reg
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM Reg
fm Reg
r of
        Nothing -> Reg
r
        Just r' :: Reg
r' -> UniqFM Reg -> Reg -> Reg
sinkReg UniqFM 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 :: LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpJoinMovs live :: 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   rs :: Bag (Reg, Reg)
rs  CmmData{}
         = Bag (Reg, Reg)
rs

        slurpCmm   rs :: Bag (Reg, Reg)
rs (CmmProc _ _ _ sccs :: [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
         = (Bag (Reg, Reg)
 -> GenBasicBlock (LiveInstr instr) -> Bag (Reg, Reg))
-> Bag (Reg, Reg)
-> [GenBasicBlock (LiveInstr instr)]
-> Bag (Reg, Reg)
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 rs :: Bag (Reg, Reg)
rs (BasicBlock _ instrs :: [LiveInstr instr]
instrs)
         = (Bag (Reg, Reg) -> LiveInstr instr -> Bag (Reg, Reg))
-> Bag (Reg, Reg) -> [LiveInstr instr] -> Bag (Reg, Reg)
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    rs :: Bag (Reg, Reg)
rs (LiveInstr _      Nothing)    = Bag (Reg, Reg)
rs
        slurpLI    rs :: Bag (Reg, Reg)
rs (LiveInstr instr :: InstrSR instr
instr (Just live :: Liveness
live))
                | Just (r1 :: Reg
r1, r2 :: 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