    -- | 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 {k} (key :: k) 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