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
   7 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  12 -- for details
  13
  14 module GraphColor (
  15         module GraphBase,
  16         module GraphOps,
  17         module GraphPpr,
  18         colorGraph
  19 )
  20
  21 where
  22
  23 import GraphBase
  24 import GraphOps
  25 import GraphPpr
  26
  27 import Unique
  28 import UniqFM
  29 import UniqSet
  30 import Outputable
  31
  32 import Data.Maybe
  33 import Data.List
  34
  35
  36 -- | Try to color a graph with this set of colors.
  37 --      Uses Chaitin's algorithm to color the graph.
  38 --      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
  39 --      are pushed onto a stack and removed from the graph.
  40 --      Once this process is complete the graph can be colored by removing nodes from
  41 --      the stack (ie in reverse order) and assigning them colors different to their neighbors.
  42 --
  43 colorGraph
  44         :: ( Uniquable  k, Uniquable cls,  Uniquable  color
  45            , Eq color, Eq cls, Ord k
  46            , Outputable k, Outputable cls, Outputable color)
  47         => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
  48         -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
  49         -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
  50         -> Graph  k cls color           -- ^ the graph to color.
  51
  52         -> ( Graph k cls color          -- the colored graph.
  53            , UniqSet k                  -- the set of nodes that we couldn't find a color for.
  54            , UniqFM  k )                -- map of regs (r1 -> r2) that were coaleced
  55                                         --       r1 should be replaced by r2 in the source
  56
  57 colorGraph colors triv spill graph0
  58  = let
  59         -- do aggressive coalesing on the graph
  60         (graph_coalesced, rsCoalesce)
  61                 = coalesceGraph graph0
  62
  63         -- run the scanner to slurp out all the trivially colorable nodes
  64         (ksTriv, ksProblems)
  65                 = colorScan colors triv spill [] emptyUniqSet graph_coalesced
  66
  67         -- color the trivially colorable nodes
  68         (graph_triv, ksNoTriv)
  69                 = assignColors colors graph_coalesced ksTriv
  70
  71         -- try and color the problem nodes
  72         (graph_prob, ksNoColor) = assignColors colors graph_triv (uniqSetToList ksProblems)
  73
  74         -- if the trivially colorable nodes didn't color then something is wrong
  75         --      with the provided triv function.
  76    in   if not $ null ksNoTriv
  77          then   pprPanic "colorGraph: trivially colorable nodes didn't color!" empty
  78 {-                      (  empty
  79                         $$ text "ksTriv    = " <> ppr ksTriv
  80                         $$ text "ksNoTriv  = " <> ppr ksNoTriv
  81                         $$ empty
  82                         $$ dotGraph (\x -> text "white") triv graph1) -}
  83
  84          else   ( graph_prob
  85                 , mkUniqSet ksNoColor
  86                 , listToUFM rsCoalesce)
  87
  88 colorScan colors triv spill safe prob graph
  89
  90         -- empty graphs are easy to color.
  91         | isNullUFM $ graphMap graph
  92         = (safe, prob)
  93
  94         -- Try and find a trivially colorable node.
  95         | Just node     <- find (\node -> triv  (nodeClass node)
  96                                                 (nodeConflicts node)
  97                                                 (nodeExclusions node))
  98                                 $ eltsUFM $ graphMap graph
  99         , k             <- nodeId node
 100         = colorScan colors triv spill
 101                 (k : safe) prob (delNode k graph)
 102
 103         -- There was no trivially colorable node,
 104         --      Choose one to potentially leave uncolored. We /might/ be able to find
 105         --      a color for this later on, but no guarantees.
 106         | k             <- spill graph
 107         = colorScan colors triv spill
 108                 safe (addOneToUniqSet prob k) (delNode k graph)
 109
 110
 111 -- | Try to assign a color to all these nodes.
 112
 113 assignColors
 114         :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color )
 115         => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
 116         -> Graph k cls color            -- ^ the graph
 117         -> [k]                          -- ^ nodes to assign a color to.
 118         -> ( Graph k cls color          -- the colored graph
 119            , [k])                       -- the nodes that didn't color.
 120
 121 assignColors colors graph ks
 122         = assignColors' colors graph [] ks
 123
 124  where  assignColors' colors graph prob []
 125                 = (graph, prob)
 126
 127         assignColors' colors graph prob (k:ks)
 128          = case assignColor colors k graph of
 129
 130                 -- couldn't color this node
 131                 Nothing         -> assignColors' colors graph (k : prob) ks
 132
 133                 -- this node colored ok, so do the rest
 134                 Just graph'     -> assignColors' colors graph' prob ks
 135
 136
 137         assignColor colors u graph
 138                 | Just c        <- selectColor colors graph u
 139                 = Just (setColor u c graph)
 140
 141                 | otherwise
 142                 = Nothing
 143
 144
 145
 146 -- | Select a color for a certain node
 147 --      taking into account preferences, neighbors and exclusions.
 148 --      returns Nothing if no color can be assigned to this node.
 149 --
 150 --      TODO: avoid using the prefs of the neighbors, if at all possible.
 151 --
 152 selectColor
 153         :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color)
 154         => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
 155         -> Graph k cls color            -- ^ the graph
 156         -> k                            -- ^ key of the node to select a color for.
 157         -> Maybe color
 158
 159 selectColor colors graph u
 160  = let  -- lookup the node
 161         Just node       = lookupNode graph u
 162
 163         -- lookup the available colors for the class of this node.
 164         Just colors_avail
 165                         = lookupUFM colors (nodeClass node)
 166
 167         -- find colors we can't use because they're already being used
 168         --      by a node that conflicts with this one.
 169         Just nsConflicts
 170                         = sequence
 171                         $ map (lookupNode graph)
 172                         $ uniqSetToList
 173                         $ nodeConflicts node
 174
 175         colors_conflict = mkUniqSet
 176                         $ catMaybes
 177                         $ map nodeColor nsConflicts
 178
 179         -- colors that are still ok
 180         colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
 181         colors_ok       = minusUniqSet colors_ok_ex colors_conflict
 182
 183         -- the colors that we prefer, and are still ok
 184         colors_ok_pref  = intersectUniqSets
 185                                 (mkUniqSet $ nodePreference node) colors_ok
 186
 187         -- make the decision
 188         chooseColor
 189
 190                 -- we got one of our preferences, score!
 191                 | not $ isEmptyUniqSet colors_ok_pref
 192                 , c : rest      <- uniqSetToList colors_ok_pref
 193                 = Just c
 194
 195                 -- it wasn't a preference, but it was still ok
 196                 | not $ isEmptyUniqSet colors_ok
 197                 , c : rest      <- uniqSetToList colors_ok
 198                 = Just c
 199
 200                 -- leave this node uncolored
 201                 | otherwise
 202                 = Nothing
 203
 204    in   chooseColor
 205
 206
 207