compiler/nativeGen/GraphColor.hs

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