compiler/utils/GraphColor.hs

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