-- | Graph Coloring.
--      This is a generic graph coloring library, abstracted over the type of
--      the node keys, nodes and colors.
--

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module GHC.Data.Graph.Color (
        module GHC.Data.Graph.Base,
        module GHC.Data.Graph.Ops,
        module GHC.Data.Graph.Ppr,
        colorGraph
)

where

import GHC.Prelude

import GHC.Data.Graph.Base
import GHC.Data.Graph.Ops
import GHC.Data.Graph.Ppr

import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic

import Data.Maybe
import Data.List (mapAccumL)


-- | Try to color a graph with this set of colors.
--      Uses Chaitin's algorithm to color the graph.
--      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
--      are pushed onto a stack and removed from the graph.
--      Once this process is complete the graph can be colored by removing nodes from
--      the stack (ie in reverse order) and assigning them colors different to their neighbors.
--
colorGraph
        :: forall k cls color.
           ( Uniquable  k, Uniquable cls,  Uniquable  color
           , Eq cls, Ord k
           , Outputable k, Outputable cls, Outputable color)
        => Bool                         -- ^ whether to do iterative coalescing
        -> Int                          -- ^ how many times we've tried to color this graph so far.
        -> UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
        -> Graph  k cls color           -- ^ the graph to color.

        -> ( Graph k cls color          -- the colored graph.
           , UniqSet k                  -- the set of nodes that we couldn't find a color for.
           , UniqFM k k )                -- map of regs (r1 -> r2) that were coalesced
                                        --       r1 should be replaced by r2 in the source

colorGraph :: 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)
colorGraph Bool
iterative Int
spinCount UniqFM cls (UniqSet color)
colors Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph0
 = let
        -- If we're not doing iterative coalescing then do an aggressive coalescing first time
        --      around and then conservative coalescing for subsequent passes.
        --
        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
        --      there is a lot of register pressure and we do it on every round then it can make the
        --      graph less colorable and prevent the algorithm from converging in a sensible number
        --      of cycles.
        --
        (Graph k cls color
graph_coalesced, [(k, k)]
kksCoalesce1)
         = if Bool
iterative
                then (Graph k cls color
graph0, [])
                else if Int
spinCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                        then Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
coalesceGraph Bool
True  Triv k cls color
triv Graph k cls color
graph0
                        else Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
coalesceGraph Bool
False Triv k cls color
triv Graph k cls color
graph0

        -- run the scanner to slurp out all the trivially colorable nodes
        --      (and do coalescing if iterative coalescing is enabled)
        ([k]
ksTriv, [k]
ksProblems, [(k, k)]
kksCoalesce2 :: [(k,k)])
                = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> ([k], [k], [(k, k)])
colorScan Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph_coalesced

        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
        --      We need to apply all the coalescences found by the scanner to the original
        --      graph before doing assignColors.
        --
        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalescing
        --      to force all the (conservative) coalescences found during scanning.
        --
        (Graph k cls color
graph_scan_coalesced, [Maybe (k, k)]
_)
                = (Graph k cls color -> (k, k) -> (Graph k cls color, Maybe (k, k)))
-> Graph k cls color
-> [(k, k)]
-> (Graph k cls color, [Maybe (k, k)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Bool
-> Triv k cls color
-> Graph k cls color
-> (k, k)
-> (Graph k cls color, Maybe (k, k))
forall k cls color.
(Uniquable k, Ord k, Eq cls) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (k, k)
-> (Graph k cls color, Maybe (k, k))
coalesceNodes Bool
True Triv k cls color
triv) Graph k cls color
graph_coalesced [(k, k)]
kksCoalesce2

        -- color the trivially colorable nodes
        --      during scanning, keys of triv nodes were added to the front of the list as they were found
        --      this colors them in the reverse order, as required by the algorithm.
        (Graph k cls color
graph_triv, [k]
ksNoTriv)
                = UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
assignColors UniqFM cls (UniqSet color)
colors Graph k cls color
graph_scan_coalesced [k]
ksTriv

        -- try and color the problem nodes
        --      problem nodes are the ones that were left uncolored because they weren't triv.
        --      theres a change we can color them here anyway.
        (Graph k cls color
graph_prob, [k]
ksNoColor)
                = UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
assignColors UniqFM cls (UniqSet color)
colors Graph k cls color
graph_triv [k]
ksProblems

        -- if the trivially colorable nodes didn't color then something is probably wrong
        --      with the provided triv function.
        --
   in   if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [k] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
ksNoTriv
         then   String -> SDoc -> (Graph k cls color, UniqSet k, UniqFM k k)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"colorGraph: trivially colorable nodes didn't color!" -- empty
                        (  SDoc
empty
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"ksTriv    = " SDoc -> SDoc -> SDoc
<> [k] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [k]
ksTriv
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"ksNoTriv  = " SDoc -> SDoc -> SDoc
<> [k] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [k]
ksNoTriv
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"colors    = " SDoc -> SDoc -> SDoc
<> UniqFM cls (UniqSet color) -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM cls (UniqSet color)
colors
                        SDoc -> SDoc -> SDoc
$$ SDoc
empty
                        SDoc -> SDoc -> SDoc
$$ (color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
dotGraph (\color
_ -> String -> SDoc
text String
"white") Triv k cls color
triv Graph k cls color
graph_triv)

         else   ( Graph k cls color
graph_prob
                , [k] -> UniqSet k
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [k]
ksNoColor   -- the nodes that didn't color (spills)
                , if Bool
iterative
                        then ([(k, k)] -> UniqFM k k
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(k, k)]
kksCoalesce2)
                        else ([(k, k)] -> UniqFM k k
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(k, k)]
kksCoalesce1))


-- | Scan through the conflict graph separating out trivially colorable and
--      potentially uncolorable (problem) nodes.
--
--      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
--      so after a triv node is found and removed from the graph it's no good to return to the 'start'
--      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
--
--      To ward against this, during each pass through the graph we collect up a list of triv nodes
--      that were found, and only remove them once we've finished the pass. The more nodes we can delete
--      at once the more likely it is that nodes we've already checked will become trivially colorable
--      for the next pass.
--
--      TODO:   add work lists to finding triv nodes is easier.
--              If we've just scanned the graph, and removed triv nodes, then the only
--              nodes that we need to rescan are the ones we've removed edges from.

colorScan
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Ord k,       Eq cls
           , Outputable k, Outputable cls)
        => Bool                         -- ^ whether to do iterative coalescing
        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
        -> Graph k cls color            -- ^ the graph to scan

        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce

colorScan :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> ([k], [k], [(k, k)])
colorScan Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
        = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph [] [] []

colorScan_spin
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Ord k,       Eq cls
           , Outputable k, Outputable cls)
        => Bool
        -> Triv k cls color
        -> (Graph k cls color -> k)
        -> Graph k cls color
        -> [k]
        -> [k]
        -> [(k, k)]
        -> ([k], [k], [(k, k)])

colorScan_spin :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
        [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce

        -- if the graph is empty then we're done
        | UniqFM k (Node k cls color) -> Bool
forall key elt. UniqFM key elt -> Bool
isNullUFM (UniqFM k (Node k cls color) -> Bool)
-> UniqFM k (Node k cls color) -> Bool
forall a b. (a -> b) -> a -> b
$ Graph k cls color -> UniqFM k (Node k cls color)
forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph k cls color
graph
        = ([k]
ksTriv, [k]
ksSpill, [(k, k)] -> [(k, k)]
forall a. [a] -> [a]
reverse [(k, k)]
kksCoalesce)

        -- Simplify:
        --      Look for trivially colorable nodes.
        --      If we can find some then remove them from the graph and go back for more.
        --
        | nsTrivFound :: [Node k cls color]
nsTrivFound@(Node k cls color
_:[Node k cls color]
_)
                <-  (Node k cls color -> Bool)
-> Graph k cls color -> [Node k cls color]
forall k cls color.
(Node k cls color -> Bool)
-> Graph k cls color -> [Node k cls color]
scanGraph   (\Node k cls color
node -> Triv k cls color
triv  (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)

                                  -- for iterative coalescing we only want non-move related
                                  --    nodes here
                                  Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
iterative Bool -> Bool -> Bool
|| UniqSet k -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)))
                        (Graph k cls color -> [Node k cls color])
-> Graph k cls color -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ Graph k cls color
graph

        , [k]
ksTrivFound   <- (Node k cls color -> k) -> [Node k cls color] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId [Node k cls color]
nsTrivFound
        , Graph k cls color
graph2        <- (k -> Graph k cls color -> Graph k cls color)
-> Graph k cls color -> [k] -> Graph k cls color
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\k
k Graph k cls color
g -> let Just Graph k cls color
g' = k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Maybe (Graph k cls color)
delNode k
k Graph k cls color
g
                                          in  Graph k cls color
g')
                                Graph k cls color
graph [k]
ksTrivFound

        = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph2
                ([k]
ksTrivFound [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
++ [k]
ksTriv)
                [k]
ksSpill
                [(k, k)]
kksCoalesce

        -- Coalesce:
        --      If we're doing iterative coalescing and no triv nodes are available
        --      then it's time for a coalescing pass.
        | Bool
iterative
        = case Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
coalesceGraph Bool
False Triv k cls color
triv Graph k cls color
graph of

                -- we were able to coalesce something
                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
                (Graph k cls color
graph2, kksCoalesceFound :: [(k, k)]
kksCoalesceFound@((k, k)
_:[(k, k)]
_))
                 -> Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph2
                        [k]
ksTriv [k]
ksSpill ([(k, k)] -> [(k, k)]
forall a. [a] -> [a]
reverse [(k, k)]
kksCoalesceFound [(k, k)] -> [(k, k)] -> [(k, k)]
forall a. [a] -> [a] -> [a]
++ [(k, k)]
kksCoalesce)

                -- Freeze:
                -- nothing could be coalesced (or was triv),
                --      time to choose a node to freeze and give up on ever coalescing it.
                (Graph k cls color
graph2, [])
                 -> case Graph k cls color -> (Graph k cls color, Bool)
forall k cls color.
Uniquable k =>
Graph k cls color -> (Graph k cls color, Bool)
freezeOneInGraph Graph k cls color
graph2 of

                        -- we were able to freeze something
                        --      hopefully this will free up something for Simplify
                        (Graph k cls color
graph3, Bool
True)
                         -> Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph3
                                [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce

                        -- we couldn't find something to freeze either
                        --      time for a spill
                        (Graph k cls color
graph3, Bool
False)
                         -> Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spill Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph3
                                [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce

        -- spill time
        | Bool
otherwise
        = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spill Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
                [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce


-- Select:
-- we couldn't find any triv nodes or things to freeze or coalesce,
--      and the graph isn't empty yet.. We'll have to choose a spill
--      candidate and leave it uncolored.
--
colorScan_spill
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Ord k,       Eq cls
           , Outputable k, Outputable cls)
        => Bool
        -> Triv k cls color
        -> (Graph k cls color -> k)
        -> Graph k cls color
        -> [k]
        -> [k]
        -> [(k, k)]
        -> ([k], [k], [(k, k)])

colorScan_spill :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spill Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
        [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce

 = let  kSpill :: k
kSpill          = Graph k cls color -> k
spill Graph k cls color
graph
        Just Graph k cls color
graph'     = k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Maybe (Graph k cls color)
delNode k
kSpill Graph k cls color
graph
   in   Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph'
                [k]
ksTriv (k
kSpill k -> [k] -> [k]
forall a. a -> [a] -> [a]
: [k]
ksSpill) [(k, k)]
kksCoalesce


-- | Try to assign a color to all these nodes.

assignColors
        :: forall k cls color.
           ( Uniquable k, Uniquable cls, Uniquable color
           , Outputable cls)
        => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
        -> Graph k cls color            -- ^ the graph
        -> [k]                          -- ^ nodes to assign a color to.
        -> ( Graph k cls color          -- the colored graph
           , [k])                       -- the nodes that didn't color.

assignColors :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
assignColors UniqFM cls (UniqSet color)
colors Graph k cls color
graph [k]
ks
        = UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph [] [k]
ks

 where  assignColors' :: UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
                        -> Graph k cls color            -- ^ the graph
                        -> [k]                          -- ^ nodes to assign a color to.
                        -> [k]
                        -> ( Graph k cls color          -- the colored graph
                        , [k])
        assignColors' :: UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
_ Graph k cls color
graph [k]
prob []
                = (Graph k cls color
graph, [k]
prob)

        assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph [k]
prob (k
k:[k]
ks)
         = case UniqFM cls (UniqSet color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
forall {k} {cls} {color}.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
assignColor UniqFM cls (UniqSet color)
colors k
k Graph k cls color
graph of

                -- couldn't color this node
                Maybe (Graph k cls color)
Nothing         -> UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph (k
k k -> [k] -> [k]
forall a. a -> [a] -> [a]
: [k]
prob) [k]
ks

                -- this node colored ok, so do the rest
                Just Graph k cls color
graph'     -> UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph' [k]
prob [k]
ks


        assignColor :: UniqFM cls (UniqSet color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
assignColor UniqFM cls (UniqSet color)
colors k
u Graph k cls color
graph
                | Just color
c        <- UniqFM cls (UniqSet color) -> Graph k cls color -> k -> Maybe color
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color) -> Graph k cls color -> k -> Maybe color
selectColor UniqFM cls (UniqSet color)
colors Graph k cls color
graph k
u
                = Graph k cls color -> Maybe (Graph k cls color)
forall a. a -> Maybe a
Just (k -> color -> Graph k cls color -> Graph k cls color
forall k color cls.
Uniquable k =>
k -> color -> Graph k cls color -> Graph k cls color
setColor k
u color
c Graph k cls color
graph)

                | Bool
otherwise
                = Maybe (Graph k cls color)
forall a. Maybe a
Nothing



-- | Select a color for a certain node
--      taking into account preferences, neighbors and exclusions.
--      returns Nothing if no color can be assigned to this node.
--
selectColor
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Outputable cls)
        => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
        -> Graph k cls color            -- ^ the graph
        -> k                            -- ^ key of the node to select a color for.
        -> Maybe color

selectColor :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color) -> Graph k cls color -> k -> Maybe color
selectColor UniqFM cls (UniqSet color)
colors Graph k cls color
graph k
u
 = let  -- lookup the node
        Just Node k cls color
node       = Graph k cls color -> k -> Maybe (Node k cls color)
forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
lookupNode Graph k cls color
graph k
u

        -- lookup the available colors for the class of this node.
        colors_avail :: UniqSet color
colors_avail
         = case UniqFM cls (UniqSet color) -> cls -> Maybe (UniqSet color)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM cls (UniqSet color)
colors (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) of
                Maybe (UniqSet color)
Nothing -> String -> SDoc -> UniqSet color
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"selectColor: no colors available for class " (cls -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node))
                Just UniqSet color
cs -> UniqSet color
cs

        -- find colors we can't use because they're already being used
        --      by a node that conflicts with this one.
        Just [Node k cls color]
nsConflicts
                        = [Maybe (Node k cls color)] -> Maybe [Node k cls color]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                        ([Maybe (Node k cls color)] -> Maybe [Node k cls color])
-> [Maybe (Node k cls color)] -> Maybe [Node k cls color]
forall a b. (a -> b) -> a -> b
$ (k -> Maybe (Node k cls color))
-> [k] -> [Maybe (Node k cls color)]
forall a b. (a -> b) -> [a] -> [b]
map (Graph k cls color -> k -> Maybe (Node k cls color)
forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
lookupNode Graph k cls color
graph)
                        ([k] -> [Maybe (Node k cls color)])
-> [k] -> [Maybe (Node k cls color)]
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
                        (UniqSet k -> [k]) -> UniqSet k -> [k]
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node
                        -- See Note [Unique Determinism and code generation]

        colors_conflict :: UniqSet color
colors_conflict = [color] -> UniqSet color
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
                        ([color] -> UniqSet color) -> [color] -> UniqSet color
forall a b. (a -> b) -> a -> b
$ [Maybe color] -> [color]
forall a. [Maybe a] -> [a]
catMaybes
                        ([Maybe color] -> [color]) -> [Maybe color] -> [color]
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> Maybe color)
-> [Node k cls color] -> [Maybe color]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor [Node k cls color]
nsConflicts

        -- the prefs of our neighbors
        colors_neighbor_prefs :: UniqSet color
colors_neighbor_prefs
                        = [color] -> UniqSet color
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
                        ([color] -> UniqSet color) -> [color] -> UniqSet color
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> [color]) -> [Node k cls color] -> [color]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference [Node k cls color]
nsConflicts

        -- colors that are still valid for us
        colors_ok_ex :: UniqSet color
colors_ok_ex    = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet color
colors_avail (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)
        colors_ok :: UniqSet color
colors_ok       = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet color
colors_ok_ex UniqSet color
colors_conflict

        -- the colors that we prefer, and are still ok
        colors_ok_pref :: UniqSet color
colors_ok_pref  = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
                                ([color] -> UniqSet color
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([color] -> UniqSet color) -> [color] -> UniqSet color
forall a b. (a -> b) -> a -> b
$ Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node) UniqSet color
colors_ok

        -- the colors that we could choose while being nice to our neighbors
        colors_ok_nice :: UniqSet color
colors_ok_nice  = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet
                                UniqSet color
colors_ok UniqSet color
colors_neighbor_prefs

        -- the best of all possible worlds..
        colors_ok_pref_nice :: UniqSet color
colors_ok_pref_nice
                        = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
                                UniqSet color
colors_ok_nice UniqSet color
colors_ok_pref

        -- make the decision
        chooseColor :: Maybe color
chooseColor

                -- everyone is happy, yay!
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok_pref_nice
                , color
c : [color]
_         <- (color -> Bool) -> [color] -> [color]
forall a. (a -> Bool) -> [a] -> [a]
filter (\color
x -> color -> UniqSet color -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet color
x UniqSet color
colors_ok_pref_nice)
                                        (Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)
                = color -> Maybe color
forall a. a -> Maybe a
Just color
c

                -- we've got one of our preferences
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok_pref
                , color
c : [color]
_         <- (color -> Bool) -> [color] -> [color]
forall a. (a -> Bool) -> [a] -> [a]
filter (\color
x -> color -> UniqSet color -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet color
x UniqSet color
colors_ok_pref)
                                        (Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)
                = color -> Maybe color
forall a. a -> Maybe a
Just color
c

                -- it wasn't a preference, but it was still ok
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok
                , color
c : [color]
_         <- UniqSet color -> [color]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet color
colors_ok
                -- See Note [Unique Determinism and code generation]
                = color -> Maybe color
forall a. a -> Maybe a
Just color
c

                -- no colors were available for us this time.
                --      looks like we're going around the loop again..
                | Bool
otherwise
                = Maybe color
forall a. Maybe a
Nothing

   in   Maybe color
chooseColor