never executed always true always false
    1 -- | Graph Coloring.
    2 --      This is a generic graph coloring library, abstracted over the type of
    3 --      the node keys, nodes and colors.
    4 --
    5 
    6 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    7 {-# LANGUAGE ScopedTypeVariables #-}
    8 
    9 module GHC.Data.Graph.Color (
   10         module GHC.Data.Graph.Base,
   11         module GHC.Data.Graph.Ops,
   12         module GHC.Data.Graph.Ppr,
   13         colorGraph
   14 )
   15 
   16 where
   17 
   18 import GHC.Prelude
   19 
   20 import GHC.Data.Graph.Base
   21 import GHC.Data.Graph.Ops
   22 import GHC.Data.Graph.Ppr
   23 
   24 import GHC.Types.Unique
   25 import GHC.Types.Unique.FM
   26 import GHC.Types.Unique.Set
   27 import GHC.Utils.Outputable
   28 import GHC.Utils.Panic
   29 
   30 import Data.Maybe
   31 import Data.List (mapAccumL)
   32 
   33 
   34 -- | Try to color a graph with this set of colors.
   35 --      Uses Chaitin's algorithm to color the graph.
   36 --      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
   37 --      are pushed onto a stack and removed from the graph.
   38 --      Once this process is complete the graph can be colored by removing nodes from
   39 --      the stack (ie in reverse order) and assigning them colors different to their neighbors.
   40 --
   41 colorGraph
   42         :: forall k cls color.
   43            ( Uniquable  k, Uniquable cls,  Uniquable  color
   44            , Eq cls, Ord k
   45            , Outputable k, Outputable cls, Outputable color)
   46         => Bool                         -- ^ whether to do iterative coalescing
   47         -> Int                          -- ^ how many times we've tried to color this graph so far.
   48         -> UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
   49         -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
   50         -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
   51         -> Graph  k cls color           -- ^ the graph to color.
   52 
   53         -> ( Graph k cls color          -- the colored graph.
   54            , UniqSet k                  -- the set of nodes that we couldn't find a color for.
   55            , UniqFM k k )                -- map of regs (r1 -> r2) that were coalesced
   56                                         --       r1 should be replaced by r2 in the source
   57 
   58 colorGraph iterative spinCount colors triv spill graph0
   59  = let
   60         -- If we're not doing iterative coalescing then do an aggressive coalescing first time
   61         --      around and then conservative coalescing for subsequent passes.
   62         --
   63         --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
   64         --      there is a lot of register pressure and we do it on every round then it can make the
   65         --      graph less colorable and prevent the algorithm from converging in a sensible number
   66         --      of cycles.
   67         --
   68         (graph_coalesced, kksCoalesce1)
   69          = if iterative
   70                 then (graph0, [])
   71                 else if spinCount == 0
   72                         then coalesceGraph True  triv graph0
   73                         else coalesceGraph False triv graph0
   74 
   75         -- run the scanner to slurp out all the trivially colorable nodes
   76         --      (and do coalescing if iterative coalescing is enabled)
   77         (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)])
   78                 = colorScan iterative triv spill graph_coalesced
   79 
   80         -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
   81         --      We need to apply all the coalescences found by the scanner to the original
   82         --      graph before doing assignColors.
   83         --
   84         --      Because we've got the whole, non-pruned graph here we turn on aggressive coalescing
   85         --      to force all the (conservative) coalescences found during scanning.
   86         --
   87         (graph_scan_coalesced, _)
   88                 = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
   89 
   90         -- color the trivially colorable nodes
   91         --      during scanning, keys of triv nodes were added to the front of the list as they were found
   92         --      this colors them in the reverse order, as required by the algorithm.
   93         (graph_triv, ksNoTriv)
   94                 = assignColors colors graph_scan_coalesced ksTriv
   95 
   96         -- try and color the problem nodes
   97         --      problem nodes are the ones that were left uncolored because they weren't triv.
   98         --      theres a change we can color them here anyway.
   99         (graph_prob, ksNoColor)
  100                 = assignColors colors graph_triv ksProblems
  101 
  102         -- if the trivially colorable nodes didn't color then something is probably wrong
  103         --      with the provided triv function.
  104         --
  105    in   if not $ null ksNoTriv
  106          then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
  107                         (  empty
  108                         $$ text "ksTriv    = " <> ppr ksTriv
  109                         $$ text "ksNoTriv  = " <> ppr ksNoTriv
  110                         $$ text "colors    = " <> ppr colors
  111                         $$ empty
  112                         $$ dotGraph (\_ -> text "white") triv graph_triv)
  113 
  114          else   ( graph_prob
  115                 , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)
  116                 , if iterative
  117                         then (listToUFM kksCoalesce2)
  118                         else (listToUFM kksCoalesce1))
  119 
  120 
  121 -- | Scan through the conflict graph separating out trivially colorable and
  122 --      potentially uncolorable (problem) nodes.
  123 --
  124 --      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
  125 --      so after a triv node is found and removed from the graph it's no good to return to the 'start'
  126 --      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
  127 --
  128 --      To ward against this, during each pass through the graph we collect up a list of triv nodes
  129 --      that were found, and only remove them once we've finished the pass. The more nodes we can delete
  130 --      at once the more likely it is that nodes we've already checked will become trivially colorable
  131 --      for the next pass.
  132 --
  133 --      TODO:   add work lists to finding triv nodes is easier.
  134 --              If we've just scanned the graph, and removed triv nodes, then the only
  135 --              nodes that we need to rescan are the ones we've removed edges from.
  136 
  137 colorScan
  138         :: ( Uniquable k, Uniquable cls, Uniquable color
  139            , Ord k,       Eq cls
  140            , Outputable k, Outputable cls)
  141         => Bool                         -- ^ whether to do iterative coalescing
  142         -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
  143         -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
  144         -> Graph k cls color            -- ^ the graph to scan
  145 
  146         -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce
  147 
  148 colorScan iterative triv spill graph
  149         = colorScan_spin iterative triv spill graph [] [] []
  150 
  151 colorScan_spin
  152         :: ( Uniquable k, Uniquable cls, Uniquable color
  153            , Ord k,       Eq cls
  154            , Outputable k, Outputable cls)
  155         => Bool
  156         -> Triv k cls color
  157         -> (Graph k cls color -> k)
  158         -> Graph k cls color
  159         -> [k]
  160         -> [k]
  161         -> [(k, k)]
  162         -> ([k], [k], [(k, k)])
  163 
  164 colorScan_spin iterative triv spill graph
  165         ksTriv ksSpill kksCoalesce
  166 
  167         -- if the graph is empty then we're done
  168         | isNullUFM $ graphMap graph
  169         = (ksTriv, ksSpill, reverse kksCoalesce)
  170 
  171         -- Simplify:
  172         --      Look for trivially colorable nodes.
  173         --      If we can find some then remove them from the graph and go back for more.
  174         --
  175         | nsTrivFound@(_:_)
  176                 <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)
  177 
  178                                   -- for iterative coalescing we only want non-move related
  179                                   --    nodes here
  180                                   && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
  181                         $ graph
  182 
  183         , ksTrivFound   <- map nodeId nsTrivFound
  184         , graph2        <- foldr (\k g -> let Just g' = delNode k g
  185                                           in  g')
  186                                 graph ksTrivFound
  187 
  188         = colorScan_spin iterative triv spill graph2
  189                 (ksTrivFound ++ ksTriv)
  190                 ksSpill
  191                 kksCoalesce
  192 
  193         -- Coalesce:
  194         --      If we're doing iterative coalescing and no triv nodes are available
  195         --      then it's time for a coalescing pass.
  196         | iterative
  197         = case coalesceGraph False triv graph of
  198 
  199                 -- we were able to coalesce something
  200                 --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
  201                 (graph2, kksCoalesceFound@(_:_))
  202                  -> colorScan_spin iterative triv spill graph2
  203                         ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
  204 
  205                 -- Freeze:
  206                 -- nothing could be coalesced (or was triv),
  207                 --      time to choose a node to freeze and give up on ever coalescing it.
  208                 (graph2, [])
  209                  -> case freezeOneInGraph graph2 of
  210 
  211                         -- we were able to freeze something
  212                         --      hopefully this will free up something for Simplify
  213                         (graph3, True)
  214                          -> colorScan_spin iterative triv spill graph3
  215                                 ksTriv ksSpill kksCoalesce
  216 
  217                         -- we couldn't find something to freeze either
  218                         --      time for a spill
  219                         (graph3, False)
  220                          -> colorScan_spill iterative triv spill graph3
  221                                 ksTriv ksSpill kksCoalesce
  222 
  223         -- spill time
  224         | otherwise
  225         = colorScan_spill iterative triv spill graph
  226                 ksTriv ksSpill kksCoalesce
  227 
  228 
  229 -- Select:
  230 -- we couldn't find any triv nodes or things to freeze or coalesce,
  231 --      and the graph isn't empty yet.. We'll have to choose a spill
  232 --      candidate and leave it uncolored.
  233 --
  234 colorScan_spill
  235         :: ( Uniquable k, Uniquable cls, Uniquable color
  236            , Ord k,       Eq cls
  237            , Outputable k, Outputable cls)
  238         => Bool
  239         -> Triv k cls color
  240         -> (Graph k cls color -> k)
  241         -> Graph k cls color
  242         -> [k]
  243         -> [k]
  244         -> [(k, k)]
  245         -> ([k], [k], [(k, k)])
  246 
  247 colorScan_spill iterative triv spill graph
  248         ksTriv ksSpill kksCoalesce
  249 
  250  = let  kSpill          = spill graph
  251         Just graph'     = delNode kSpill graph
  252    in   colorScan_spin iterative triv spill graph'
  253                 ksTriv (kSpill : ksSpill) kksCoalesce
  254 
  255 
  256 -- | Try to assign a color to all these nodes.
  257 
  258 assignColors
  259         :: forall k cls color.
  260            ( Uniquable k, Uniquable cls, Uniquable color
  261            , Outputable cls)
  262         => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
  263         -> Graph k cls color            -- ^ the graph
  264         -> [k]                          -- ^ nodes to assign a color to.
  265         -> ( Graph k cls color          -- the colored graph
  266            , [k])                       -- the nodes that didn't color.
  267 
  268 assignColors colors graph ks
  269         = assignColors' colors graph [] ks
  270 
  271  where  assignColors' :: UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
  272                         -> Graph k cls color            -- ^ the graph
  273                         -> [k]                          -- ^ nodes to assign a color to.
  274                         -> [k]
  275                         -> ( Graph k cls color          -- the colored graph
  276                         , [k])
  277         assignColors' _ graph prob []
  278                 = (graph, prob)
  279 
  280         assignColors' colors graph prob (k:ks)
  281          = case assignColor colors k graph of
  282 
  283                 -- couldn't color this node
  284                 Nothing         -> assignColors' colors graph (k : prob) ks
  285 
  286                 -- this node colored ok, so do the rest
  287                 Just graph'     -> assignColors' colors graph' prob ks
  288 
  289 
  290         assignColor colors u graph
  291                 | Just c        <- selectColor colors graph u
  292                 = Just (setColor u c graph)
  293 
  294                 | otherwise
  295                 = Nothing
  296 
  297 
  298 
  299 -- | Select a color for a certain node
  300 --      taking into account preferences, neighbors and exclusions.
  301 --      returns Nothing if no color can be assigned to this node.
  302 --
  303 selectColor
  304         :: ( Uniquable k, Uniquable cls, Uniquable color
  305            , Outputable cls)
  306         => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
  307         -> Graph k cls color            -- ^ the graph
  308         -> k                            -- ^ key of the node to select a color for.
  309         -> Maybe color
  310 
  311 selectColor colors graph u
  312  = let  -- lookup the node
  313         Just node       = lookupNode graph u
  314 
  315         -- lookup the available colors for the class of this node.
  316         colors_avail
  317          = case lookupUFM colors (nodeClass node) of
  318                 Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
  319                 Just cs -> cs
  320 
  321         -- find colors we can't use because they're already being used
  322         --      by a node that conflicts with this one.
  323         Just nsConflicts
  324                         = sequence
  325                         $ map (lookupNode graph)
  326                         $ nonDetEltsUniqSet
  327                         $ nodeConflicts node
  328                         -- See Note [Unique Determinism and code generation]
  329 
  330         colors_conflict = mkUniqSet
  331                         $ catMaybes
  332                         $ map nodeColor nsConflicts
  333 
  334         -- the prefs of our neighbors
  335         colors_neighbor_prefs
  336                         = mkUniqSet
  337                         $ concatMap nodePreference nsConflicts
  338 
  339         -- colors that are still valid for us
  340         colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
  341         colors_ok       = minusUniqSet colors_ok_ex colors_conflict
  342 
  343         -- the colors that we prefer, and are still ok
  344         colors_ok_pref  = intersectUniqSets
  345                                 (mkUniqSet $ nodePreference node) colors_ok
  346 
  347         -- the colors that we could choose while being nice to our neighbors
  348         colors_ok_nice  = minusUniqSet
  349                                 colors_ok colors_neighbor_prefs
  350 
  351         -- the best of all possible worlds..
  352         colors_ok_pref_nice
  353                         = intersectUniqSets
  354                                 colors_ok_nice colors_ok_pref
  355 
  356         -- make the decision
  357         chooseColor
  358 
  359                 -- everyone is happy, yay!
  360                 | not $ isEmptyUniqSet colors_ok_pref_nice
  361                 , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
  362                                         (nodePreference node)
  363                 = Just c
  364 
  365                 -- we've got one of our preferences
  366                 | not $ isEmptyUniqSet colors_ok_pref
  367                 , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)
  368                                         (nodePreference node)
  369                 = Just c
  370 
  371                 -- it wasn't a preference, but it was still ok
  372                 | not $ isEmptyUniqSet colors_ok
  373                 , c : _         <- nonDetEltsUniqSet colors_ok
  374                 -- See Note [Unique Determinism and code generation]
  375                 = Just c
  376 
  377                 -- no colors were available for us this time.
  378                 --      looks like we're going around the loop again..
  379                 | otherwise
  380                 = Nothing
  381 
  382    in   chooseColor
  383 
  384 
  385