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         => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
  42         -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
  43         -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
  44         -> Graph  k cls color           -- ^ the graph to color.
  45
  46         -> ( Graph k cls color          -- the colored graph.
  47            , UniqSet k                  -- the set of nodes that we couldn't find a color for.
  48            , UniqFM  k )                -- map of regs (r1 -> r2) that were coaleced
  49                                         --       r1 should be replaced by r2 in the source
  50
  51 colorGraph colors triv spill graph0
  52  = let
  53         -- do aggressive coalesing on the graph
  54         (graph_coalesced, rsCoalesce)
  55                 = coalesceGraph triv graph0
  56
  57         -- run the scanner to slurp out all the trivially colorable nodes
  58         (ksTriv, ksProblems)
  59                 = colorScan triv spill graph_coalesced
  60
  61         -- color the trivially colorable nodes
  62         --      as the keys were added to the front of the list while they were scanned,
  63         --      this colors them in the reverse order they were found, as required by the algorithm.
  64         (graph_triv, ksNoTriv)
  65                 = assignColors colors graph_coalesced ksTriv
  66
  67         -- try and color the problem nodes
  68         (graph_prob, ksNoColor) = assignColors colors graph_triv ksProblems
  69
  70         -- if the trivially colorable nodes didn't color then something is wrong
  71         --      with the provided triv function.
  72    in   if not $ null ksNoTriv
  73          then   pprPanic "colorGraph: trivially colorable nodes didn't color!" empty
  74 {-                      (  empty
  75                         $$ text "ksTriv    = " <> ppr ksTriv
  76                         $$ text "ksNoTriv  = " <> ppr ksNoTriv
  77                         $$ empty
  78                         $$ dotGraph (\x -> text "white") triv graph1) -}
  79
  80          else   ( graph_prob
  81                 , mkUniqSet ksNoColor
  82                 , listToUFM rsCoalesce)
  83
  84
  85 -- | Scan through the conflict graph separating out trivially colorable and
  86 --      potentially uncolorable (problem) nodes.
  87 --
  88 --      Checking whether a node is trivially colorable or not is a resonably expensive operation,
  89 --      so after a triv node is found and removed from the graph it's no good to return to the 'start'
  90 --      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
  91 --
  92 --      To ward against this, during each pass through the graph we collect up a list of triv nodes
  93 --      that were found, and only remove them once we've finished the pass. The more nodes we can delete
  94 --      at once the more likely it is that nodes we've already checked will become trivially colorable
  95 --      for the next pass.
  96 --
  97 colorScan
  98         :: ( Uniquable k, Uniquable cls, Uniquable color)
  99         => Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
 100         -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
 101         -> Graph k cls color            -- ^ the graph to scan
 102         -> ([k], [k])                   --  triv colorable, problem nodes
 103
 104
 105 colorScan triv spill graph
 106         = colorScan' triv spill graph
 107                 []      []
 108                 []
 109                 (eltsUFM $ graphMap graph)
 110
 111 -- we've reached the end of the candidates list
 112 colorScan' triv spill graph
 113         ksTriv  ksTrivFound
 114         ksSpill
 115         []
 116
 117         -- if the graph is empty then we're done
 118         | isNullUFM $ graphMap graph
 119         = (ksTrivFound ++ ksTriv, ksSpill)
 120
 121         -- if we haven't found a trivially colorable node then we'll have to
 122         --      choose a spill candidate and leave it uncolored
 123         | []            <- ksTrivFound
 124         , kSpill        <- spill graph                  -- choose a spill candiate
 125         , graph'        <- delNode kSpill graph         -- remove it from the graph
 126         , nsRest'       <- eltsUFM $ graphMap graph'    -- graph has changed, so get new node list
 127
 128         = colorScan' triv spill graph'
 129                 ksTriv ksTrivFound
 130                 (kSpill : ksSpill)
 131                 nsRest'
 132
 133         -- we're at the end of the candidates list but we've found some triv nodes
 134         --      along the way. We can delete them from the graph and go back for more.
 135         | graph'        <- foldr delNode graph ksTrivFound
 136         , nsRest'       <- eltsUFM $ graphMap graph'
 137
 138         = colorScan' triv spill graph'
 139                 (ksTrivFound ++ ksTriv) []
 140                 ksSpill
 141                 nsRest'
 142
 143 -- check if the current node is triv colorable
 144 colorScan' triv spill graph
 145         ksTriv  ksTrivFound
 146         ksSpill
 147         (node : nsRest)
 148
 149         -- node is trivially colorable
 150         --      add it to the found nodes list and carry on.
 151         | k     <- nodeId node
 152         , triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
 153
 154         = colorScan' triv spill graph
 155                 ksTriv  (k : ksTrivFound)
 156                 ksSpill
 157                 nsRest
 158
 159         -- node wasn't trivially colorable, skip over it and look in the rest of the list
 160         | otherwise
 161         = colorScan' triv spill graph
 162                 ksTriv ksTrivFound
 163                 ksSpill
 164                 nsRest
 165
 166 {- -- This is cute and easy to understand, but too slow.. BL 2007/09
 167
 168 colorScan colors triv spill safe prob graph
 169
 170         -- empty graphs are easy to color.
 171         | isNullUFM $ graphMap graph
 172         = (safe, prob)
 173
 174         -- Try and find a trivially colorable node.
 175         | Just node     <- find (\node -> triv  (nodeClass node)
 176                                                 (nodeConflicts node)
 177                                                 (nodeExclusions node))
 178                                 $ eltsUFM $ graphMap graph
 179         , k             <- nodeId node
 180         = colorScan colors triv spill
 181                 (k : safe) prob (delNode k graph)
 182
 183         -- There was no trivially colorable node,
 184         --      Choose one to potentially leave uncolored. We /might/ be able to find
 185         --      a color for this later on, but no guarantees.
 186         | k             <- spill graph
 187         = colorScan colors triv spill
 188                 safe (addOneToUniqSet prob k) (delNode k graph)
 189 -}
 190
 191
 192 -- | Try to assign a color to all these nodes.
 193
 194 assignColors
 195         :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color )
 196         => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
 197         -> Graph k cls color            -- ^ the graph
 198         -> [k]                          -- ^ nodes to assign a color to.
 199         -> ( Graph k cls color          -- the colored graph
 200            , [k])                       -- the nodes that didn't color.
 201
 202 assignColors colors graph ks
 203         = assignColors' colors graph [] ks
 204
 205  where  assignColors' _ graph prob []
 206                 = (graph, prob)
 207
 208         assignColors' colors graph prob (k:ks)
 209          = case assignColor colors k graph of
 210
 211                 -- couldn't color this node
 212                 Nothing         -> assignColors' colors graph (k : prob) ks
 213
 214                 -- this node colored ok, so do the rest
 215                 Just graph'     -> assignColors' colors graph' prob ks
 216
 217
 218         assignColor colors u graph
 219                 | Just c        <- selectColor colors graph u
 220                 = Just (setColor u c graph)
 221
 222                 | otherwise
 223                 = Nothing
 224
 225
 226
 227 -- | Select a color for a certain node
 228 --      taking into account preferences, neighbors and exclusions.
 229 --      returns Nothing if no color can be assigned to this node.
 230 --
 231 selectColor
 232         :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color)
 233         => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
 234         -> Graph k cls color            -- ^ the graph
 235         -> k                            -- ^ key of the node to select a color for.
 236         -> Maybe color
 237
 238 selectColor colors graph u
 239  = let  -- lookup the node
 240         Just node       = lookupNode graph u
 241
 242         -- lookup the available colors for the class of this node.
 243         Just colors_avail
 244                         = lookupUFM colors (nodeClass node)
 245
 246         -- find colors we can't use because they're already being used
 247         --      by a node that conflicts with this one.
 248         Just nsConflicts
 249                         = sequence
 250                         $ map (lookupNode graph)
 251                         $ uniqSetToList
 252                         $ nodeConflicts node
 253
 254         colors_conflict = mkUniqSet
 255                         $ catMaybes
 256                         $ map nodeColor nsConflicts
 257
 258         -- the prefs of our neighbors
 259         colors_neighbor_prefs
 260                         = mkUniqSet
 261                         $ concat $ map nodePreference nsConflicts
 262
 263         -- colors that are still valid for us
 264         colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
 265         colors_ok       = minusUniqSet colors_ok_ex colors_conflict
 266
 267         -- the colors that we prefer, and are still ok
 268         colors_ok_pref  = intersectUniqSets
 269                                 (mkUniqSet $ nodePreference node) colors_ok
 270
 271         -- the colors that we could choose while being nice to our neighbors
 272         colors_ok_nice  = minusUniqSet
 273                                 colors_ok colors_neighbor_prefs
 274
 275         -- the best of all possible worlds..
 276         colors_ok_pref_nice
 277                         = intersectUniqSets
 278                                 colors_ok_nice colors_ok_pref
 279
 280         -- make the decision
 281         chooseColor
 282
 283                 -- everyone is happy, yay!
 284                 | not $ isEmptyUniqSet colors_ok_pref_nice
 285                 , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
 286                                         (nodePreference node)
 287                 = Just c
 288
 289                 -- we've got one of our preferences
 290                 | not $ isEmptyUniqSet colors_ok_pref
 291                 , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)
 292                                         (nodePreference node)
 293                 = Just c
 294
 295                 -- it wasn't a preference, but it was still ok
 296                 | not $ isEmptyUniqSet colors_ok
 297                 , c : _         <- uniqSetToList colors_ok
 298                 = Just c
 299
 300                 -- no colors were available for us this time.
 301                 --      looks like we're going around the loop again..
 302                 | otherwise
 303                 = Nothing
 304
 305    in   chooseColor
 306
 307
 308