{-# 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.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.Supply
import GHC.Utils.Misc (seqList)
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
        -> UniqSM ( [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
-> UniqSM
     ([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)

        ([NatCmmDecl statics instr]
code_final, [RegAllocStats statics instr]
debug_codeGraphs, Int
slotsCount', Graph VirtualReg RegClass RealReg
_)
                <- NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
forall instr statics.
(Instruction instr, OutputableP Platform statics) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([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 :: Maybe Int
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'

        ([NatCmmDecl statics instr], Maybe Int,
 [RegAllocStats statics instr])
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr])
forall (m :: * -> *) a. Monad m => a -> m a
return  ( [NatCmmDecl statics instr]
code_final
                , Maybe Int
needStack
                , [RegAllocStats statics instr] -> [RegAllocStats statics instr]
forall a. [a] -> [a]
reverse [RegAllocStats statics instr]
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)
        => 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
        -> UniqSM ( [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) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([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 -> UniqSM () -> UniqSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
spinCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSpinCount)
         (UniqSM () -> UniqSM ()) -> UniqSM () -> UniqSM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> UniqSM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"regAlloc_spin: max build/spill cycle count exceeded."
           (  String -> SDoc
text String
"It looks like the register allocator is stuck in an infinite loop."
           SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"max cycles  = " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
maxSpinCount
           SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"regsFree    = " SDoc -> SDoc -> SDoc
<> ([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
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 key 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
$$ String -> SDoc
text String
"slotsFree   = " SDoc -> SDoc -> SDoc
<> 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 VirtualReg RegClass RealReg
graph  :: Color.Graph VirtualReg RegClass RealReg)
                <- {-# SCC "BuildGraph" #-} [LiveCmmDecl statics instr]
-> UniqSM (Graph VirtualReg RegClass RealReg)
forall instr statics.
Instruction instr =>
[LiveCmmDecl statics instr]
-> UniqSM (Graph VirtualReg RegClass RealReg)
buildGraph [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.
        Graph VirtualReg RegClass RealReg -> ()
seqGraph Graph VirtualReg RegClass RealReg
graph () -> UniqSM () -> UniqSM ()
`seq` () -> UniqSM ()
forall (m :: * -> *) a. Monad m => a -> m a
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
spillCosts  = (SpillCostInfo -> SpillCostInfo -> SpillCostInfo)
-> SpillCostInfo -> [SpillCostInfo] -> SpillCostInfo
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 :: Graph VirtualReg RegClass RealReg -> VirtualReg
spill       = SpillCostInfo -> Graph VirtualReg RegClass RealReg -> VirtualReg
chooseSpill SpillCostInfo
spillCosts

        -- Record startup state in our log.
        let stat1 :: Maybe (RegAllocStats statics instr)
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 VirtualReg RegClass RealReg
graph_colored, UniqSet VirtualReg
rsSpill, UniqFM VirtualReg VirtualReg
rmCoalesce)
                = {-# SCC "ColorGraph" #-}
                  Bool
-> Int
-> UniqFM RegClass (UniqSet RealReg)
-> Triv VirtualReg RegClass RealReg
-> (Graph VirtualReg RegClass RealReg -> VirtualReg)
-> Graph VirtualReg RegClass RealReg
-> (Graph VirtualReg RegClass RealReg, UniqSet VirtualReg,
    UniqFM VirtualReg VirtualReg)
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Eq cls, Ord k,
 Outputable k, Outputable cls, Outputable color) =>
Bool
-> Int
-> UniqFM cls (UniqSet color)
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> (Graph k cls color, UniqSet k, UniqFM k k)
Color.colorGraph
                       (NCGConfig -> Bool
ncgRegsIterative NCGConfig
config)
                       Int
spinCount
                       UniqFM RegClass (UniqSet RealReg)
regsFree Triv VirtualReg RegClass RealReg
triv Graph VirtualReg RegClass RealReg -> VirtualReg
spill Graph VirtualReg RegClass RealReg
graph

        -- Rewrite registers in the code that have been coalesced.
        let patchF :: Reg -> Reg
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 ([LiveCmmDecl statics instr]
code_coalesced :: [LiveCmmDecl statics instr])
                = (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 Reg -> Reg
patchF) [LiveCmmDecl statics instr]
code

        -- Check whether we've found a coloring.
        if UniqSet VirtualReg -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet VirtualReg
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 :: Graph VirtualReg RegClass RealReg
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
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]
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]
code_spillclean
                        = (LiveCmmDecl statics instr -> LiveCmmDecl statics instr)
-> [LiveCmmDecl statics instr] -> [LiveCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
Instruction instr =>
Platform -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
cleanSpills Platform
platform) [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 :: [NatCmmDecl statics instr]
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 :: RegAllocStats statics instr
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 (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 LiveCmmDecl statics instr -> (Int, Int, Int)
forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs [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 :: [RegAllocStats statics instr]
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.
                [RegAllocStats statics instr] -> UniqSM () -> UniqSM ()
forall a b. [a] -> b -> b
seqList [RegAllocStats statics instr]
statList (() -> UniqSM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

                ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
 Graph VirtualReg RegClass RealReg)
-> UniqSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
forall (m :: * -> *) a. Monad m => a -> m a
return  ( [NatCmmDecl statics instr]
code_final
                        , [RegAllocStats statics instr]
statList
                        , Int
slotsCount
                        , Graph VirtualReg RegClass RealReg
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 :: Graph VirtualReg RegClass RealReg
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
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.
                ([LiveCmmDecl statics instr]
code_spilled, UniqSet Int
slotsFree', Int
slotsCount', SpillStats
spillStats)
                        <- Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
     ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
     ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
regSpill Platform
platform [LiveCmmDecl statics instr]
code_coalesced UniqSet Int
slotsFree Int
slotsCount UniqSet VirtualReg
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.
                [LiveCmmDecl statics instr]
code_relive     <- (LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Platform
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall instr statics.
Instruction instr =>
Platform
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
regLiveness Platform
platform (LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> (LiveCmmDecl statics instr -> LiveCmmDecl statics instr)
-> LiveCmmDecl statics instr
-> UniqSM (LiveCmmDecl statics instr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LiveCmmDecl statics instr -> LiveCmmDecl statics instr
forall statics instr.
LiveCmmDecl statics instr -> LiveCmmDecl statics instr
reverseBlocksInTops)
                                        [LiveCmmDecl statics instr]
code_spilled

                -- Record what happened in this stage for debugging.
                let stat :: RegAllocStats statics instr
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 :: [RegAllocStats statics instr]
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.
                [RegAllocStats statics instr] -> UniqSM () -> UniqSM ()
forall a b. [a] -> b -> b
seqList [RegAllocStats statics instr]
statList (() -> UniqSM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

                NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
forall instr statics.
(Instruction instr, OutputableP Platform statics) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
      Graph VirtualReg RegClass RealReg)
regAlloc_spin NCGConfig
config (Int
spinCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Triv VirtualReg RegClass RealReg
triv UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree'
                              Int
slotsCount' [RegAllocStats statics instr]
statList [LiveCmmDecl statics instr]
code_relive Maybe CFG
cfg


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

buildGraph :: forall instr statics.
Instruction instr =>
[LiveCmmDecl statics instr]
-> UniqSM (Graph VirtualReg RegClass RealReg)
buildGraph [LiveCmmDecl statics instr]
code
 = do
        -- Slurp out the conflicts and reg->reg moves from this code.
        let ([Bag (UniqSet Reg)]
conflictList, [Bag (Reg, Reg)]
moveList) =
                [(Bag (UniqSet Reg), Bag (Reg, Reg))]
-> ([Bag (UniqSet Reg)], [Bag (Reg, Reg)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Bag (UniqSet Reg), Bag (Reg, Reg))]
 -> ([Bag (UniqSet Reg)], [Bag (Reg, Reg)]))
-> [(Bag (UniqSet Reg), Bag (Reg, Reg))]
-> ([Bag (UniqSet Reg)], [Bag (Reg, Reg)])
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr -> (Bag (UniqSet Reg), Bag (Reg, Reg)))
-> [LiveCmmDecl statics instr]
-> [(Bag (UniqSet Reg), Bag (Reg, Reg))]
forall a b. (a -> b) -> [a] -> [b]
map LiveCmmDecl statics instr -> (Bag (UniqSet Reg), Bag (Reg, Reg))
forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> (Bag (UniqSet Reg), Bag (Reg, Reg))
slurpConflicts [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 Reg)
conflictBag         = [Bag (UniqSet Reg)] -> Bag (UniqSet Reg)
forall a. [Bag a] -> Bag a
unionManyBags [Bag (UniqSet Reg)]
conflictList
        let graph_conflict :: Graph VirtualReg RegClass RealReg
graph_conflict
                = (UniqSet Reg
 -> Graph VirtualReg RegClass RealReg
 -> Graph VirtualReg RegClass RealReg)
-> Graph VirtualReg RegClass RealReg
-> Bag (UniqSet Reg)
-> Graph VirtualReg RegClass RealReg
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UniqSet Reg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddConflictSet Graph VirtualReg RegClass RealReg
forall k cls color. Graph k cls color
Color.initGraph Bag (UniqSet Reg)
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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddCoalesce Graph VirtualReg RegClass RealReg
graph_conflict Bag (Reg, Reg)
moveBag

        Graph VirtualReg RegClass RealReg
-> UniqSM (Graph VirtualReg RegClass RealReg)
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
        :: UniqSet Reg
        -> Color.Graph VirtualReg RegClass RealReg
        -> Color.Graph VirtualReg RegClass RealReg

graphAddConflictSet :: UniqSet Reg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddConflictSet UniqSet Reg
set Graph VirtualReg RegClass RealReg
graph
 = let  virtuals :: UniqSet VirtualReg
virtuals        = [VirtualReg] -> UniqSet VirtualReg
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
                        [ VirtualReg
vr | RegVirtual VirtualReg
vr <- UniqSet Reg -> [Reg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
set ]

        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 VirtualReg -> RegClass
classOfVirtualReg Graph VirtualReg RegClass RealReg
graph

        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 (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 VirtualReg -> RegClass
classOfVirtualReg RealReg
r2)
                        Graph VirtualReg RegClass RealReg
graph1
                        [ (VirtualReg
vr, RealReg
rr)
                                | RegVirtual VirtualReg
vr <- UniqSet Reg -> [Reg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
set
                                , RegReal    RealReg
rr <- UniqSet Reg -> [Reg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
set]
                          -- See Note [Unique Determinism and code generation]

   in   Graph VirtualReg RegClass RealReg
graph2


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

graphAddCoalesce :: (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddCoalesce (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, VirtualReg -> RegClass
classOfVirtualReg 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, VirtualReg -> RegClass
classOfVirtualReg 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, VirtualReg -> RegClass
classOfVirtualReg VirtualReg
vr1)
                (VirtualReg
vr2, VirtualReg -> RegClass
classOfVirtualReg 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

#if __GLASGOW_HASKELL__ <= 810
        | otherwise
        = panic "graphAddCoalesce"
#endif


-- | 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
 = (Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
Instruction instr =>
(Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchEraseLive 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
text String
"There is no node in the graph for register "
                                SDoc -> SDoc -> SDoc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg
                        SDoc -> SDoc -> SDoc
$$ 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
$$ (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
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 key 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 () -> () -> ()
`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)
        () -> () -> ()
`seq` RegClass -> ()
seqRegClass       (Node VirtualReg RegClass RealReg -> RegClass
forall k cls color. Node k cls color -> cls
Color.nodeClass Node VirtualReg RegClass RealReg
node)
        () -> () -> ()
`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)
        () -> () -> ()
`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)))
        () -> () -> ()
`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)))
        () -> () -> ()
`seq` ([RealReg] -> ()
seqRealRegList (Node VirtualReg RegClass RealReg -> [RealReg]
forall k cls color. Node k cls color -> [color]
Color.nodePreference Node VirtualReg RegClass RealReg
node))
        () -> () -> ()
`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 -> () -> ()
`seq` ()

seqRealReg :: RealReg -> ()
seqRealReg :: RealReg -> ()
seqRealReg RealReg
reg = RealReg
reg RealReg -> () -> ()
`seq` ()

seqRegClass :: RegClass -> ()
seqRegClass :: RegClass -> ()
seqRegClass RegClass
c = RegClass
c RegClass -> () -> ()
`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 () -> () -> ()
`seq` [VirtualReg] -> ()
seqVirtualRegList [VirtualReg]
rs

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