{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}


-- | Graph coloring register allocator.
module GHC.CmmToAsm.Reg.Graph (
        regAlloc
) where
import GHC.Prelude

import qualified GHC.Data.Graph.Color as Color
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Graph.Spill
import GHC.CmmToAsm.Reg.Graph.SpillClean
import GHC.CmmToAsm.Reg.Graph.SpillCost
import GHC.CmmToAsm.Reg.Graph.Stats
import GHC.CmmToAsm.Reg.Graph.TrivColorable
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Types
import GHC.Platform.Reg.Class
import GHC.Platform.Reg

import GHC.Data.Bag
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSM
import GHC.Utils.Misc (seqList, HasDebugCallStack)
import GHC.CmmToAsm.CFG

import Data.Maybe
import Control.Monad


-- | The maximum number of build\/spill cycles we'll allow.
--
--   It should only take 3 or 4 cycles for the allocator to converge.
--   If it takes any longer than this it's probably in an infinite loop,
--   so it's better just to bail out and report a bug.
maxSpinCount    :: Int
maxSpinCount :: Int
maxSpinCount    = Int
10


-- | The top level of the graph coloring register allocator.
regAlloc
        :: (OutputableP Platform statics, Instruction instr)
        => NCGConfig
        -> UniqFM RegClass (UniqSet RealReg)     -- ^ registers we can use for allocation
        -> UniqSet Int                  -- ^ set of available spill slots.
        -> Int                          -- ^ current number of spill slots
        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.
        -> Maybe CFG                    -- ^ CFG of basic blocks if available
        -> UniqDSM ( [NatCmmDecl statics instr]
                   , Maybe Int, [RegAllocStats statics instr] )
           -- ^ code with registers allocated, additional stacks required
           -- and stats for each stage of allocation

regAlloc :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
NCGConfig
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqDSM
     ([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr])
regAlloc NCGConfig
config UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree Int
slotsCount [LiveCmmDecl statics instr]
code Maybe CFG
cfg
 = do
        let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
            triv :: Triv VirtualReg RegClass RealReg
triv = Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable Platform
platform
                        (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
                        (Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze Platform
platform)

        (code_final, debug_codeGraphs, slotsCount', _)
                <- NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqDSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
forall instr statics.
(Instruction instr, OutputableP Platform statics,
 HasDebugCallStack) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqDSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
regAlloc_spin NCGConfig
config Int
0
                        Triv VirtualReg RegClass RealReg
triv
                        UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree Int
slotsCount [] [LiveCmmDecl statics instr]
code Maybe CFG
cfg

        let needStack
                | Int
slotsCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
slotsCount'
                = Maybe Int
forall a. Maybe a
Nothing
                | Bool
otherwise
                = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
slotsCount'

        return  ( code_final
                , needStack
                , reverse debug_codeGraphs )


-- | Perform solver iterations for the graph coloring allocator.
--
--   We extract a register conflict graph from the provided cmm code,
--   and try to colour it. If that works then we use the solution rewrite
--   the code with real hregs. If coloring doesn't work we add spill code
--   and try to colour it again. After `maxSpinCount` iterations we give up.
--
regAlloc_spin
        :: forall instr statics.
           (Instruction instr,
            OutputableP Platform statics,
            HasDebugCallStack)
        => NCGConfig
        -> Int  -- ^ Number of solver iterations we've already performed.
        -> Color.Triv VirtualReg RegClass RealReg
                -- ^ Function for calculating whether a register is trivially
                --   colourable.
        -> UniqFM RegClass (UniqSet RealReg)      -- ^ Free registers that we can allocate.
        -> UniqSet Int                   -- ^ Free stack slots that we can use.
        -> Int                           -- ^ Number of spill slots in use
        -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
        -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.
        -> Maybe CFG
        -> UniqDSM ( [NatCmmDecl statics instr]
                  , [RegAllocStats statics instr]
                  , Int                  -- Slots in use
                  , Color.Graph VirtualReg RegClass RealReg)

regAlloc_spin :: forall instr statics.
(Instruction instr, OutputableP Platform statics,
 HasDebugCallStack) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqDSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
regAlloc_spin NCGConfig
config Int
spinCount Triv VirtualReg RegClass RealReg
triv UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree Int
slotsCount [RegAllocStats statics instr]
debug_codeGraphs [LiveCmmDecl statics instr]
code Maybe CFG
cfg
 = do
        let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

        -- If any of these dump flags are turned on we want to hang on to
        -- intermediate structures in the allocator - otherwise tell the
        -- allocator to ditch them early so we don't end up creating space leaks.
        let dump :: Bool
dump = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
                [ NCGConfig -> Bool
ncgDumpRegAllocStages NCGConfig
config
                , NCGConfig -> Bool
ncgDumpAsmStats       NCGConfig
config
                , NCGConfig -> Bool
ncgDumpAsmConflicts   NCGConfig
config
                ]

        -- Check that we're not running off down the garden path.
        Bool -> UniqDSM () -> UniqDSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
spinCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSpinCount)
         (UniqDSM () -> UniqDSM ()) -> UniqDSM () -> UniqDSM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> UniqDSM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"regAlloc_spin: max build/spill cycle count exceeded."
           (  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"It looks like the register allocator is stuck in an infinite loop."
           SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"max cycles  = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
maxSpinCount
           SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"regsFree    = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
space ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (RealReg -> SDoc) -> [RealReg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr
                                             ([RealReg] -> [SDoc]) -> [RealReg] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UniqSet RealReg -> [RealReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (UniqSet RealReg -> [RealReg]) -> UniqSet RealReg -> [RealReg]
forall a b. (a -> b) -> a -> b
$ [UniqSet RealReg] -> UniqSet RealReg
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                                             ([UniqSet RealReg] -> UniqSet RealReg)
-> [UniqSet RealReg] -> UniqSet RealReg
forall a b. (a -> b) -> a -> b
$ UniqFM RegClass (UniqSet RealReg) -> [UniqSet RealReg]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM RegClass (UniqSet RealReg)
regsFree)
              -- This is non-deterministic but we do not
              -- currently support deterministic code-generation.
              -- See Note [Unique Determinism and code generation]
           SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"slotsFree   = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UniqSet Int -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet Int
slotsFree))

        -- Build the register conflict graph from the cmm code.
        (graph  :: Color.Graph VirtualReg RegClass RealReg)
                <- {-# SCC "BuildGraph" #-} Platform
-> [LiveCmmDecl statics instr]
-> UniqDSM (Graph VirtualReg RegClass RealReg)
forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqDSM (Graph VirtualReg RegClass RealReg)
buildGraph Platform
platform [LiveCmmDecl statics instr]
code

        -- VERY IMPORTANT:
        --   We really do want the graph to be fully evaluated _before_ we
        --   start coloring. If we don't do this now then when the call to
        --   Color.colorGraph forces bits of it, the heap will be filled with
        --   half evaluated pieces of graph and zillions of apply thunks.
        seqGraph graph `seq` return ()

        -- Build a map of the cost of spilling each instruction.
        -- This is a lazy binding, so the map will only be computed if we
        -- actually have to spill to the stack.
        let spillCosts  = (SpillCostInfo -> SpillCostInfo -> SpillCostInfo)
-> SpillCostInfo -> [SpillCostInfo] -> SpillCostInfo
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
zeroSpillCostInfo
                        ([SpillCostInfo] -> SpillCostInfo)
-> [SpillCostInfo] -> SpillCostInfo
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr -> SpillCostInfo)
-> [LiveCmmDecl statics instr] -> [SpillCostInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Maybe CFG -> LiveCmmDecl statics instr -> SpillCostInfo
forall instr statics.
Instruction instr =>
Platform -> Maybe CFG -> LiveCmmDecl statics instr -> SpillCostInfo
slurpSpillCostInfo Platform
platform Maybe CFG
cfg) [LiveCmmDecl statics instr]
code

        -- The function to choose regs to leave uncolored.
        let spill       = SpillCostInfo -> Graph VirtualReg RegClass RealReg -> VirtualReg
chooseSpill SpillCostInfo
spillCosts

        -- Record startup state in our log.
        let stat1
             = if Int
spinCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                 then   RegAllocStats statics instr -> Maybe (RegAllocStats statics instr)
forall a. a -> Maybe a
Just (RegAllocStats statics instr
 -> Maybe (RegAllocStats statics instr))
-> RegAllocStats statics instr
-> Maybe (RegAllocStats statics instr)
forall a b. (a -> b) -> a -> b
$ RegAllocStatsStart
                        { raLiveCmm :: [LiveCmmDecl statics instr]
raLiveCmm     = [LiveCmmDecl statics instr]
code
                        , raGraph :: Graph VirtualReg RegClass RealReg
raGraph       = Graph VirtualReg RegClass RealReg
graph
                        , raSpillCosts :: SpillCostInfo
raSpillCosts  = SpillCostInfo
spillCosts
                        , raPlatform :: Platform
raPlatform    = Platform
platform
                        }
                 else   Maybe (RegAllocStats statics instr)
forall a. Maybe a
Nothing

        -- Try and color the graph.
        let (graph_colored, rsSpill, rmCoalesce)
                = {-# SCC "ColorGraph" #-}
                  Color.colorGraph
                       (ncgRegsIterative config)
                       spinCount
                       regsFree triv spill graph

        -- Rewrite registers in the code that have been coalesced.
        let patchF Reg
reg
                | RegVirtual VirtualReg
vr <- Reg
reg
                = case UniqFM VirtualReg VirtualReg -> VirtualReg -> Maybe VirtualReg
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM VirtualReg VirtualReg
rmCoalesce VirtualReg
vr of
                        Just VirtualReg
vr'        -> Reg -> Reg
patchF (VirtualReg -> Reg
RegVirtual VirtualReg
vr')
                        Maybe VirtualReg
Nothing         -> Reg
reg

                | Bool
otherwise
                = Reg
reg

        let (code_coalesced :: [LiveCmmDecl statics instr])
                = map (patchEraseLive platform patchF) code

        -- Check whether we've found a coloring.
        if isEmptyUniqSet rsSpill

         -- Coloring was successful because no registers needed to be spilled.
         then do
                -- if -fasm-lint is turned on then validate the graph.
                -- This checks for bugs in the graph allocator itself.
                let graph_colored_lint  =
                        if NCGConfig -> Bool
ncgAsmLinting NCGConfig
config
                                then SDoc
-> Bool
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k color cls.
(Uniquable k, Outputable k, Eq color) =>
SDoc -> Bool -> Graph k cls color -> Graph k cls color
Color.validateGraph (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"")
                                        Bool
True    -- Require all nodes to be colored.
                                        Graph VirtualReg RegClass RealReg
graph_colored
                                else Graph VirtualReg RegClass RealReg
graph_colored

                -- Rewrite the code to use real hregs, using the colored graph.
                let code_patched
                        = (LiveCmmDecl statics instr -> LiveCmmDecl statics instr)
-> [LiveCmmDecl statics instr] -> [LiveCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (Platform
-> Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform
-> Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
patchRegsFromGraph Platform
platform Graph VirtualReg RegClass RealReg
graph_colored_lint)
                              [LiveCmmDecl statics instr]
code_coalesced

                -- Clean out unneeded SPILL/RELOAD meta instructions.
                --   The spill code generator just spills the entire live range
                --   of a vreg, but it might not need to be on the stack for
                --   its entire lifetime.
                let code_spillclean
                        = (LiveCmmDecl statics instr -> LiveCmmDecl statics instr)
-> [LiveCmmDecl statics instr] -> [LiveCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
Instruction instr =>
NCGConfig -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
cleanSpills NCGConfig
config) [LiveCmmDecl statics instr]
code_patched

                -- Strip off liveness information from the allocated code.
                -- Also rewrite SPILL/RELOAD meta instructions into real machine
                -- instructions along the way
                let code_final
                        = (LiveCmmDecl statics instr -> NatCmmDecl statics instr)
-> [LiveCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr
forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripLive NCGConfig
config) [LiveCmmDecl statics instr]
code_spillclean

                -- Record what happened in this stage for debugging
                let stat
                     =  RegAllocStatsColored
                        { raCode :: [LiveCmmDecl statics instr]
raCode                = [LiveCmmDecl statics instr]
code
                        , raGraph :: Graph VirtualReg RegClass RealReg
raGraph               = Graph VirtualReg RegClass RealReg
graph
                        , raGraphColored :: Graph VirtualReg RegClass RealReg
raGraphColored        = Graph VirtualReg RegClass RealReg
graph_colored_lint
                        , raCoalesced :: UniqFM VirtualReg VirtualReg
raCoalesced           = UniqFM VirtualReg VirtualReg
rmCoalesce
                        , raCodeCoalesced :: [LiveCmmDecl statics instr]
raCodeCoalesced       = [LiveCmmDecl statics instr]
code_coalesced
                        , raPatched :: [LiveCmmDecl statics instr]
raPatched             = [LiveCmmDecl statics instr]
code_patched
                        , raSpillClean :: [LiveCmmDecl statics instr]
raSpillClean          = [LiveCmmDecl statics instr]
code_spillclean
                        , raFinal :: [NatCmmDecl statics instr]
raFinal               = [NatCmmDecl statics instr]
code_final
                        , raSRMs :: (Int, Int, Int)
raSRMs                = ((Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int))
-> (Int, Int, Int) -> [(Int, Int, Int)] -> (Int, Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (Int
0, Int
0, Int
0)
                                                ([(Int, Int, Int)] -> (Int, Int, Int))
-> [(Int, Int, Int)] -> (Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr -> (Int, Int, Int))
-> [LiveCmmDecl statics instr] -> [(Int, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> LiveCmmDecl statics instr -> (Int, Int, Int)
forall instr statics.
Instruction instr =>
Platform -> LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs Platform
platform) [LiveCmmDecl statics instr]
code_spillclean
                        , raPlatform :: Platform
raPlatform    = Platform
platform
                     }

                -- Bundle up all the register allocator statistics.
                --   .. but make sure to drop them on the floor if they're not
                --      needed, otherwise we'll get a space leak.
                let statList =
                        if Bool
dump then [RegAllocStats statics instr
stat] [RegAllocStats statics instr]
-> [RegAllocStats statics instr] -> [RegAllocStats statics instr]
forall a. [a] -> [a] -> [a]
++ Maybe (RegAllocStats statics instr)
-> [RegAllocStats statics instr]
forall a. Maybe a -> [a]
maybeToList Maybe (RegAllocStats statics instr)
stat1 [RegAllocStats statics instr]
-> [RegAllocStats statics instr] -> [RegAllocStats statics instr]
forall a. [a] -> [a] -> [a]
++ [RegAllocStats statics instr]
debug_codeGraphs
                                else []

                -- Ensure all the statistics are evaluated, to avoid space leaks.
                seqList statList (return ())

                return  ( code_final
                        , statList
                        , slotsCount
                        , graph_colored_lint)

         -- Coloring was unsuccessful. We need to spill some register to the
         -- stack, make a new graph, and try to color it again.
         else do
                -- if -fasm-lint is turned on then validate the graph
                let graph_colored_lint  =
                        if NCGConfig -> Bool
ncgAsmLinting NCGConfig
config
                                then SDoc
-> Bool
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k color cls.
(Uniquable k, Outputable k, Eq color) =>
SDoc -> Bool -> Graph k cls color -> Graph k cls color
Color.validateGraph (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"")
                                        Bool
False   -- don't require nodes to be colored
                                        Graph VirtualReg RegClass RealReg
graph_colored
                                else Graph VirtualReg RegClass RealReg
graph_colored

                -- Spill uncolored regs to the stack.
                (code_spilled, slotsFree', slotsCount', spillStats)
                        <- regSpill platform code_coalesced slotsFree slotsCount rsSpill

                -- Recalculate liveness information.
                -- NOTE: we have to reverse the SCCs here to get them back into
                --       the reverse-dependency order required by computeLiveness.
                --       If they're not in the correct order that function will panic.
                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops)
                                        code_spilled

                -- Record what happened in this stage for debugging.
                let stat        =
                        RegAllocStatsSpill
                        { raCode :: [LiveCmmDecl statics instr]
raCode        = [LiveCmmDecl statics instr]
code
                        , raGraph :: Graph VirtualReg RegClass RealReg
raGraph       = Graph VirtualReg RegClass RealReg
graph_colored_lint
                        , raCoalesced :: UniqFM VirtualReg VirtualReg
raCoalesced   = UniqFM VirtualReg VirtualReg
rmCoalesce
                        , raSpillStats :: SpillStats
raSpillStats  = SpillStats
spillStats
                        , raSpillCosts :: SpillCostInfo
raSpillCosts  = SpillCostInfo
spillCosts
                        , raSpilled :: [LiveCmmDecl statics instr]
raSpilled     = [LiveCmmDecl statics instr]
code_spilled
                        , raPlatform :: Platform
raPlatform    = Platform
platform }

                -- Bundle up all the register allocator statistics.
                --   .. but make sure to drop them on the floor if they're not
                --      needed, otherwise we'll get a space leak.
                let statList =
                        if Bool
dump
                                then [RegAllocStats statics instr
stat] [RegAllocStats statics instr]
-> [RegAllocStats statics instr] -> [RegAllocStats statics instr]
forall a. [a] -> [a] -> [a]
++ Maybe (RegAllocStats statics instr)
-> [RegAllocStats statics instr]
forall a. Maybe a -> [a]
maybeToList Maybe (RegAllocStats statics instr)
stat1 [RegAllocStats statics instr]
-> [RegAllocStats statics instr] -> [RegAllocStats statics instr]
forall a. [a] -> [a] -> [a]
++ [RegAllocStats statics instr]
debug_codeGraphs
                                else []

                -- Ensure all the statistics are evaluated, to avoid space leaks.
                seqList statList (return ())

                regAlloc_spin config (spinCount + 1) triv regsFree slotsFree'
                              slotsCount' statList code_relive cfg


-- | Build a graph from the liveness and coalesce information in this code.
buildGraph
        :: Instruction instr
        => Platform
        -> [LiveCmmDecl statics instr]
        -> UniqDSM (Color.Graph VirtualReg RegClass RealReg)

buildGraph :: forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqDSM (Graph VirtualReg RegClass RealReg)
buildGraph Platform
platform [LiveCmmDecl statics instr]
code
 = do
        -- Slurp out the conflicts and reg->reg moves from this code.
        let ([Bag (UniqSet RegWithFormat)]
conflictList, [Bag (Reg, Reg)]
moveList) =
                [(Bag (UniqSet RegWithFormat), Bag (Reg, Reg))]
-> ([Bag (UniqSet RegWithFormat)], [Bag (Reg, Reg)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Bag (UniqSet RegWithFormat), Bag (Reg, Reg))]
 -> ([Bag (UniqSet RegWithFormat)], [Bag (Reg, Reg)]))
-> [(Bag (UniqSet RegWithFormat), Bag (Reg, Reg))]
-> ([Bag (UniqSet RegWithFormat)], [Bag (Reg, Reg)])
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr
 -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)))
-> [LiveCmmDecl statics instr]
-> [(Bag (UniqSet RegWithFormat), Bag (Reg, Reg))]
forall a b. (a -> b) -> [a] -> [b]
map (Platform
-> LiveCmmDecl statics instr
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
forall instr statics.
Instruction instr =>
Platform
-> LiveCmmDecl statics instr
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpConflicts Platform
platform) [LiveCmmDecl statics instr]
code

        -- Slurp out the spill/reload coalesces.
        let moveList2 :: [Bag (Reg, Reg)]
moveList2           = (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 statics instr.
Instruction instr =>
LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpReloadCoalesce [LiveCmmDecl statics instr]
code

        -- Add the reg-reg conflicts to the graph.
        let conflictBag :: Bag (UniqSet RegWithFormat)
conflictBag         = [Bag (UniqSet RegWithFormat)] -> Bag (UniqSet RegWithFormat)
forall a. [Bag a] -> Bag a
unionManyBags [Bag (UniqSet RegWithFormat)]
conflictList
        let graph_conflict :: Graph VirtualReg RegClass RealReg
graph_conflict
                = (UniqSet RegWithFormat
 -> Graph VirtualReg RegClass RealReg
 -> Graph VirtualReg RegClass RealReg)
-> Graph VirtualReg RegClass RealReg
-> Bag (UniqSet RegWithFormat)
-> Graph VirtualReg RegClass RealReg
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Platform
-> UniqSet RegWithFormat
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddConflictSet Platform
platform) Graph VirtualReg RegClass RealReg
forall k cls color. Graph k cls color
Color.initGraph Bag (UniqSet RegWithFormat)
conflictBag

        -- Add the coalescences edges to the graph.
        let moveBag :: Bag (Reg, Reg)
moveBag
                = Bag (Reg, Reg) -> Bag (Reg, Reg) -> Bag (Reg, Reg)
forall a. Bag a -> Bag a -> Bag a
unionBags ([Bag (Reg, Reg)] -> Bag (Reg, Reg)
forall a. [Bag a] -> Bag a
unionManyBags [Bag (Reg, Reg)]
moveList2)
                            ([Bag (Reg, Reg)] -> Bag (Reg, Reg)
forall a. [Bag a] -> Bag a
unionManyBags [Bag (Reg, Reg)]
moveList)

        let graph_coalesce :: Graph VirtualReg RegClass RealReg
graph_coalesce
                = ((Reg, Reg)
 -> Graph VirtualReg RegClass RealReg
 -> Graph VirtualReg RegClass RealReg)
-> Graph VirtualReg RegClass RealReg
-> Bag (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Platform
-> (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddCoalesce Platform
platform) Graph VirtualReg RegClass RealReg
graph_conflict Bag (Reg, Reg)
moveBag

        Graph VirtualReg RegClass RealReg
-> UniqDSM (Graph VirtualReg RegClass RealReg)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return  Graph VirtualReg RegClass RealReg
graph_coalesce


-- | Add some conflict edges to the graph.
--   Conflicts between virtual and real regs are recorded as exclusions.
graphAddConflictSet
        :: Platform
        -> UniqSet RegWithFormat
        -> Color.Graph VirtualReg RegClass RealReg
        -> Color.Graph VirtualReg RegClass RealReg

graphAddConflictSet :: Platform
-> UniqSet RegWithFormat
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddConflictSet Platform
platform UniqSet RegWithFormat
regs Graph VirtualReg RegClass RealReg
graph
 = let  arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
        virtuals :: UniqSet VirtualReg
virtuals = UniqSet RegWithFormat -> UniqSet VirtualReg
takeVirtualRegs UniqSet RegWithFormat
regs
        reals :: UniqSet RealReg
reals    = UniqSet RegWithFormat -> UniqSet RealReg
takeRealRegs UniqSet RegWithFormat
regs

        graph1 :: Graph VirtualReg RegClass RealReg
graph1  = UniqSet VirtualReg
-> (VirtualReg -> RegClass)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k cls color.
Uniquable k =>
UniqSet k -> (k -> cls) -> Graph k cls color -> Graph k cls color
Color.addConflicts UniqSet VirtualReg
virtuals (Arch -> VirtualReg -> RegClass
classOfVirtualReg Arch
arch) Graph VirtualReg RegClass RealReg
graph
          -- NB: we could add "arch" as argument to functions such as "addConflicts"
          -- and "addExclusion" if it turns out that the partial application
          -- "classOfVirtualReg arch" affects performance.

        graph2 :: Graph VirtualReg RegClass RealReg
graph2  = ((VirtualReg, RealReg)
 -> Graph VirtualReg RegClass RealReg
 -> Graph VirtualReg RegClass RealReg)
-> Graph VirtualReg RegClass RealReg
-> [(VirtualReg, RealReg)]
-> Graph VirtualReg RegClass RealReg
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(VirtualReg
r1, RealReg
r2) -> VirtualReg
-> (VirtualReg -> RegClass)
-> RealReg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k color cls.
(Uniquable k, Uniquable color) =>
k -> (k -> cls) -> color -> Graph k cls color -> Graph k cls color
Color.addExclusion VirtualReg
r1 (Arch -> VirtualReg -> RegClass
classOfVirtualReg Arch
arch) RealReg
r2)
                        Graph VirtualReg RegClass RealReg
graph1
                        [ (VirtualReg
vr, RealReg
rr)
                        | VirtualReg
vr <- UniqSet VirtualReg -> [VirtualReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet VirtualReg
virtuals
                        , RealReg
rr <- UniqSet RealReg -> [RealReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet RealReg
reals ]
                          -- See Note [Unique Determinism and code generation]

   in   Graph VirtualReg RegClass RealReg
graph2


-- | Add some coalescence edges to the graph
--   Coalescences between virtual and real regs are recorded as preferences.
graphAddCoalesce
        :: Platform
        -> (Reg, Reg)
        -> Color.Graph VirtualReg RegClass RealReg
        -> Color.Graph VirtualReg RegClass RealReg

graphAddCoalesce :: Platform
-> (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddCoalesce Platform
platform (Reg
r1, Reg
r2) Graph VirtualReg RegClass RealReg
graph
        | RegReal RealReg
rr            <- Reg
r1
        , RegVirtual VirtualReg
vr         <- Reg
r2
        = (VirtualReg, RegClass)
-> RealReg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k cls color.
Uniquable k =>
(k, cls) -> color -> Graph k cls color -> Graph k cls color
Color.addPreference (VirtualReg
vr, Arch -> VirtualReg -> RegClass
classOfVirtualReg Arch
arch VirtualReg
vr) RealReg
rr Graph VirtualReg RegClass RealReg
graph

        | RegReal RealReg
rr            <- Reg
r2
        , RegVirtual VirtualReg
vr         <- Reg
r1
        = (VirtualReg, RegClass)
-> RealReg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k cls color.
Uniquable k =>
(k, cls) -> color -> Graph k cls color -> Graph k cls color
Color.addPreference (VirtualReg
vr, Arch -> VirtualReg -> RegClass
classOfVirtualReg Arch
arch VirtualReg
vr) RealReg
rr Graph VirtualReg RegClass RealReg
graph

        | RegVirtual VirtualReg
vr1        <- Reg
r1
        , RegVirtual VirtualReg
vr2        <- Reg
r2
        = (VirtualReg, RegClass)
-> (VirtualReg, RegClass)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k cls color.
Uniquable k =>
(k, cls) -> (k, cls) -> Graph k cls color -> Graph k cls color
Color.addCoalesce
                (VirtualReg
vr1, Arch -> VirtualReg -> RegClass
classOfVirtualReg Arch
arch VirtualReg
vr1)
                (VirtualReg
vr2, Arch -> VirtualReg -> RegClass
classOfVirtualReg Arch
arch VirtualReg
vr2)
                Graph VirtualReg RegClass RealReg
graph

        -- We can't coalesce two real regs, but there could well be existing
        --      hreg,hreg moves in the input code. We'll just ignore these
        --      for coalescing purposes.
        | RegReal RealReg
_             <- Reg
r1
        , RegReal RealReg
_             <- Reg
r2
        = Graph VirtualReg RegClass RealReg
graph
        where
          arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform


-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph
        :: (OutputableP Platform statics, Instruction instr)
        => Platform -> Color.Graph VirtualReg RegClass RealReg
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr

patchRegsFromGraph :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform
-> Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
patchRegsFromGraph Platform
platform Graph VirtualReg RegClass RealReg
graph LiveCmmDecl statics instr
code
 = Platform
-> (Reg -> Reg)
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
forall instr statics.
(Instruction instr, HasDebugCallStack) =>
Platform
-> (Reg -> Reg)
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
patchEraseLive Platform
platform Reg -> Reg
patchF LiveCmmDecl statics instr
code
 where
        -- Function to lookup the hardreg for a virtual reg from the graph.
        patchF :: Reg -> Reg
patchF Reg
reg
                -- leave real regs alone.
                | RegReal{}     <- Reg
reg
                = Reg
reg

                -- this virtual has a regular node in the graph.
                | RegVirtual VirtualReg
vr <- Reg
reg
                , Just Node VirtualReg RegClass RealReg
node     <- Graph VirtualReg RegClass RealReg
-> VirtualReg -> Maybe (Node VirtualReg RegClass RealReg)
forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
Color.lookupNode Graph VirtualReg RegClass RealReg
graph VirtualReg
vr
                = case Node VirtualReg RegClass RealReg -> Maybe RealReg
forall k cls color. Node k cls color -> Maybe color
Color.nodeColor Node VirtualReg RegClass RealReg
node of
                        Just RealReg
color      -> RealReg -> Reg
RegReal    RealReg
color
                        Maybe RealReg
Nothing         -> VirtualReg -> Reg
RegVirtual VirtualReg
vr

                -- no node in the graph for this virtual, bad news.
                | Bool
otherwise
                = String -> SDoc -> Reg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"patchRegsFromGraph: register mapping failed."
                        (  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"There is no node in the graph for register "
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg
                        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Platform -> LiveCmmDecl statics instr -> SDoc
forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform -> LiveCmmDecl statics instr -> SDoc
pprLiveCmmDecl Platform
platform LiveCmmDecl statics instr
code
                        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (RealReg -> SDoc)
-> Triv VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
-> SDoc
forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
Color.dotGraph
                                (\RealReg
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"white")
                                (Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable Platform
platform
                                        (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
                                        (Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze Platform
platform))
                                Graph VirtualReg RegClass RealReg
graph)


-----
-- for when laziness just isn't what you wanted...
--  We need to deepSeq the whole graph before trying to colour it to avoid
--  space leaks.
seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
seqGraph :: Graph VirtualReg RegClass RealReg -> ()
seqGraph Graph VirtualReg RegClass RealReg
graph          = [Node VirtualReg RegClass RealReg] -> ()
seqNodes (UniqFM VirtualReg (Node VirtualReg RegClass RealReg)
-> [Node VirtualReg RegClass RealReg]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM (Graph VirtualReg RegClass RealReg
-> UniqFM VirtualReg (Node VirtualReg RegClass RealReg)
forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
Color.graphMap Graph VirtualReg RegClass RealReg
graph))
   -- See Note [Unique Determinism and code generation]

seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
seqNodes :: [Node VirtualReg RegClass RealReg] -> ()
seqNodes [Node VirtualReg RegClass RealReg]
ns
 = case [Node VirtualReg RegClass RealReg]
ns of
        []              -> ()
        (Node VirtualReg RegClass RealReg
n : [Node VirtualReg RegClass RealReg]
ns)        -> Node VirtualReg RegClass RealReg -> ()
seqNode Node VirtualReg RegClass RealReg
n () -> () -> ()
forall a b. a -> b -> b
`seq` [Node VirtualReg RegClass RealReg] -> ()
seqNodes [Node VirtualReg RegClass RealReg]
ns

seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
seqNode :: Node VirtualReg RegClass RealReg -> ()
seqNode Node VirtualReg RegClass RealReg
node
        =     VirtualReg -> ()
seqVirtualReg     (Node VirtualReg RegClass RealReg -> VirtualReg
forall k cls color. Node k cls color -> k
Color.nodeId Node VirtualReg RegClass RealReg
node)
        () -> () -> ()
forall a b. a -> b -> b
`seq` RegClass -> ()
seqRegClass       (Node VirtualReg RegClass RealReg -> RegClass
forall k cls color. Node k cls color -> cls
Color.nodeClass Node VirtualReg RegClass RealReg
node)
        () -> () -> ()
forall a b. a -> b -> b
`seq` Maybe RealReg -> ()
seqMaybeRealReg   (Node VirtualReg RegClass RealReg -> Maybe RealReg
forall k cls color. Node k cls color -> Maybe color
Color.nodeColor Node VirtualReg RegClass RealReg
node)
        () -> () -> ()
forall a b. a -> b -> b
`seq` ([VirtualReg] -> ()
seqVirtualRegList (UniqSet VirtualReg -> [VirtualReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Node VirtualReg RegClass RealReg -> UniqSet VirtualReg
forall k cls color. Node k cls color -> UniqSet k
Color.nodeConflicts Node VirtualReg RegClass RealReg
node)))
        () -> () -> ()
forall a b. a -> b -> b
`seq` ([RealReg] -> ()
seqRealRegList    (UniqSet RealReg -> [RealReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Node VirtualReg RegClass RealReg -> UniqSet RealReg
forall k cls color. Node k cls color -> UniqSet color
Color.nodeExclusions Node VirtualReg RegClass RealReg
node)))
        () -> () -> ()
forall a b. a -> b -> b
`seq` ([RealReg] -> ()
seqRealRegList (Node VirtualReg RegClass RealReg -> [RealReg]
forall k cls color. Node k cls color -> [color]
Color.nodePreference Node VirtualReg RegClass RealReg
node))
        () -> () -> ()
forall a b. a -> b -> b
`seq` ([VirtualReg] -> ()
seqVirtualRegList (UniqSet VirtualReg -> [VirtualReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Node VirtualReg RegClass RealReg -> UniqSet VirtualReg
forall k cls color. Node k cls color -> UniqSet k
Color.nodeCoalesce Node VirtualReg RegClass RealReg
node)))
              -- It's OK to use nonDetEltsUniqSet for seq

seqVirtualReg :: VirtualReg -> ()
seqVirtualReg :: VirtualReg -> ()
seqVirtualReg VirtualReg
reg = VirtualReg
reg VirtualReg -> () -> ()
forall a b. a -> b -> b
`seq` ()

seqRealReg :: RealReg -> ()
seqRealReg :: RealReg -> ()
seqRealReg RealReg
reg = RealReg
reg RealReg -> () -> ()
forall a b. a -> b -> b
`seq` ()

seqRegClass :: RegClass -> ()
seqRegClass :: RegClass -> ()
seqRegClass RegClass
c = RegClass
c RegClass -> () -> ()
forall a b. a -> b -> b
`seq` ()

seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg Maybe RealReg
mr
 = case Maybe RealReg
mr of
        Maybe RealReg
Nothing         -> ()
        Just RealReg
r          -> RealReg -> ()
seqRealReg RealReg
r

seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList [VirtualReg]
rs
 = case [VirtualReg]
rs of
        []              -> ()
        (VirtualReg
r : [VirtualReg]
rs)        -> VirtualReg -> ()
seqVirtualReg VirtualReg
r () -> () -> ()
forall a b. a -> b -> b
`seq` [VirtualReg] -> ()
seqVirtualRegList [VirtualReg]
rs

seqRealRegList :: [RealReg] -> ()
seqRealRegList :: [RealReg] -> ()
seqRealRegList [RealReg]
rs
 = case [RealReg]
rs of
        []              -> ()
        (RealReg
r : [RealReg]
rs)        -> RealReg -> ()
seqRealReg RealReg
r () -> () -> ()
forall a b. a -> b -> b
`seq` [RealReg] -> ()
seqRealRegList [RealReg]
rs