compiler/nativeGen/GraphOps.hs

   1
   2 -- | Basic operations on graphs.
   3 --
   4
   5 {-# OPTIONS_GHC -w #-}
   6 -- The above warning supression flag is a temporary kludge.
   7 -- While working on this module you are encouraged to remove it and fix
   8 -- any warnings in the module. See
   9 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  10 -- for details
  11
  12 module GraphOps (
  13         addNode,        delNode,        getNode,        lookupNode,     modNode,
  14         size,
  15         union,
  16         addConflict,    delConflict,    addConflicts,
  17         addCoalesce,    delCoalesce,
  18         addExclusion,
  19         addPreference,
  20         setColor,
  21         verify,
  22         slurpNodeConflictCount
  23 )
  24 where
  25
  26 import GraphBase
  27
  28 import Outputable
  29 import Unique
  30 import UniqSet
  31 import UniqFM
  32
  33 import Data.List        hiding (union)
  34 import Data.Maybe
  35
  36
  37 -- | Lookup a node from the graph.
  38 lookupNode
  39         :: Uniquable k
  40         => Graph k cls color
  41         -> k -> Maybe (Node  k cls color)
  42
  43 lookupNode graph k
  44         = lookupUFM (graphMap graph) k
  45
  46
  47 -- | Get a node from the graph, throwing an error if it's not there
  48 getNode
  49         :: Uniquable k
  50         => Graph k cls color
  51         -> k -> Node k cls color
  52
  53 getNode graph k
  54  = case lookupUFM (graphMap graph) k of
  55         Just node       -> node
  56         Nothing         -> panic "ColorOps.getNode: not found"
  57
  58
  59 -- | Add a node to the graph, linking up its edges
  60 addNode :: Uniquable k
  61         => k -> Node k cls color
  62         -> Graph k cls color -> Graph k cls color
  63
  64 addNode k node graph
  65  = let
  66         -- add back conflict edges from other nodes to this one
  67         map_conflict
  68                 = foldUniqSet
  69                         (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
  70                         (graphMap graph)
  71                         (nodeConflicts node)
  72
  73         -- add back coalesce edges from other nodes to this one
  74         map_coalesce
  75                 = foldUniqSet
  76                         (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
  77                         map_conflict
  78                         (nodeCoalesce node)
  79
  80   in    graph
  81         { graphMap      = addToUFM map_coalesce k node}
  82
  83
  84
  85 -- | Delete a node and all its edges from the graph.
  86 --      Throws an error if it's not there.
  87 delNode :: Uniquable k
  88         => k -> Graph k cls color -> Graph k cls color
  89
  90 delNode k graph
  91  = let  Just node       = lookupNode graph k
  92
  93         -- delete conflict edges from other nodes to this one.
  94         graph1          = foldl' (\g k1 -> delConflict k1 k g) graph
  95                         $ uniqSetToList (nodeConflicts node)
  96
  97         -- delete coalesce edge from other nodes to this one.
  98         graph2          = foldl' (\g k1 -> delCoalesce k1 k g) graph1
  99                         $ uniqSetToList (nodeCoalesce node)
 100
 101         -- delete the node
 102         graph3          = graphMapModify (\fm -> delFromUFM fm k) graph2
 103
 104   in    graph3
 105
 106
 107 -- | Modify a node in the graph
 108 modNode :: Uniquable k
 109         => (Node k cls color -> Node k cls color)
 110         -> k -> Graph k cls color -> Graph k cls color
 111
 112 modNode f k graph
 113  = case getNode graph k of
 114         Node{} -> graphMapModify
 115                  (\fm   -> let  Just node       = lookupUFM fm k
 116                                 node'           = f node
 117                            in   addToUFM fm k node')
 118                 graph
 119
 120
 121 -- | Get the size of the graph, O(n)
 122 size    :: Uniquable k
 123         => Graph k cls color -> Int
 124
 125 size graph
 126         = sizeUFM $ graphMap graph
 127
 128
 129 -- | Union two graphs together.
 130 union   :: Uniquable k
 131         => Graph k cls color -> Graph k cls color -> Graph k cls color
 132
 133 union   graph1 graph2
 134         = Graph
 135         { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
 136
 137
 138
 139
 140 -- | Add a conflict between nodes to the graph, creating the nodes required.
 141 --      Conflicts are virtual regs which need to be colored differently.
 142 addConflict
 143         :: Uniquable k
 144         => (k, cls) -> (k, cls)
 145         -> Graph k cls color -> Graph k cls color
 146
 147 addConflict (u1, c1) (u2, c2)
 148  = let  addNeighbor u c u'
 149                 = adjustWithDefaultUFM
 150                         (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
 151                         (newNode u c)  { nodeConflicts = unitUniqSet u' }
 152                         u
 153
 154    in   graphMapModify
 155         ( addNeighbor u1 c1 u2
 156         . addNeighbor u2 c2 u1)
 157
 158
 159 -- | Delete a conflict edge. k1 -> k2
 160 delConflict
 161         :: Uniquable k
 162         => k -> k
 163         -> Graph k cls color -> Graph k cls color
 164
 165 delConflict k1 k2
 166         = modNode
 167                 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
 168                 k1
 169
 170
 171 -- | Add some conflicts to the graph, creating nodes if required.
 172 --      All the nodes in the set are taken to conflict with each other.
 173 addConflicts
 174         :: Uniquable k
 175         => UniqSet k -> (k -> cls)
 176         -> Graph k cls color -> Graph k cls color
 177
 178 addConflicts conflicts getClass
 179
 180         -- just a single node, but no conflicts, create the node anyway.
 181         | (u : [])      <- uniqSetToList conflicts
 182         = graphMapModify
 183         $ adjustWithDefaultUFM
 184                 id
 185                 (newNode u (getClass u))
 186                 u
 187
 188         | otherwise
 189         = graphMapModify
 190         $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
 191                 $ uniqSetToList conflicts)
 192
 193
 194 addConflictSet1 u getClass set
 195  = let  set'    = delOneFromUniqSet set u
 196    in   adjustWithDefaultUFM
 197                 (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
 198                 (newNode u (getClass u))        { nodeConflicts = set' }
 199                 u
 200
 201
 202 -- | Add an exclusion to the graph, creating nodes if required.
 203 --      These are extra colors that the node cannot use.
 204 addExclusion
 205         :: (Uniquable k, Uniquable color)
 206         => k -> (k -> cls) -> color
 207         -> Graph k cls color -> Graph k cls color
 208
 209 addExclusion u getClass color
 210         = graphMapModify
 211         $ adjustWithDefaultUFM
 212                 (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
 213                 (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
 214                 u
 215
 216
 217 -- | Add a coalescence edge to the graph, creating nodes if requried.
 218 --      It is considered adventageous to assign the same color to nodes in a coalesence.
 219 addCoalesce
 220         :: Uniquable k
 221         => (k, cls) -> (k, cls)
 222         -> Graph k cls color -> Graph k cls color
 223
 224 addCoalesce (u1, c1) (u2, c2)
 225  = let  addCoalesce u c u'
 226          =      adjustWithDefaultUFM
 227                         (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
 228                         (newNode u c)  { nodeCoalesce = unitUniqSet u' }
 229                         u
 230
 231    in   graphMapModify
 232         ( addCoalesce u1 c1 u2
 233         . addCoalesce u2 c2 u1)
 234
 235
 236 -- | Delete a coalescence edge (k1 -> k2) from the graph.
 237 delCoalesce
 238         :: Uniquable k
 239         => k -> k
 240         -> Graph k cls color    -> Graph k cls color
 241
 242 delCoalesce k1 k2
 243         = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
 244                 k1
 245
 246
 247 -- | Add a color preference to the graph, creating nodes if required.
 248 --      The most recently added preference is the most prefered.
 249 --      The algorithm tries to assign a node it's prefered color if possible.
 250 --
 251 addPreference
 252         :: Uniquable k
 253         => (k, cls) -> color
 254         -> Graph k cls color -> Graph k cls color
 255
 256 addPreference (u, c) color
 257         = graphMapModify
 258         $ adjustWithDefaultUFM
 259                 (\node -> node { nodePreference = color : (nodePreference node) })
 260                 (newNode u c)  { nodePreference = [color] }
 261                 u
 262
 263
 264 -- | Verify the internal structure of a graph
 265 --      all its edges should point to valid nodes
 266 --
 267 verify  :: Uniquable k
 268         => Graph k cls color
 269         -> Bool
 270
 271 verify graph
 272  = let  edges   = unionUniqSets
 273                         (unionManyUniqSets
 274                                 (map nodeConflicts $ eltsUFM $ graphMap graph))
 275                         (unionManyUniqSets
 276                                 (map nodeCoalesce  $ eltsUFM $ graphMap graph))
 277
 278         nodes   = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 279
 280         badEdges = minusUniqSet edges nodes
 281
 282   in    if isEmptyUniqSet badEdges
 283          then   True
 284          else   False
 285
 286
 287 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
 288
 289 slurpNodeConflictCount
 290         :: Uniquable k
 291         => Graph k cls color
 292         -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
 293
 294 slurpNodeConflictCount graph
 295         = addListToUFM_C
 296                 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
 297                 emptyUFM
 298         $ map   (\node
 299                   -> let count  = sizeUniqSet $ nodeConflicts node
 300                      in  (count, (count, 1)))
 301         $ eltsUFM
 302         $ graphMap graph
 303
 304
 305 -- | Set the color of a certain node
 306 setColor
 307         :: Uniquable k
 308         => k -> color
 309         -> Graph k cls color -> Graph k cls color
 310
 311 setColor u color
 312         = graphMapModify
 313         $ adjustUFM
 314                 (\n -> n { nodeColor = Just color })
 315                 u
 316
 317
 318 adjustWithDefaultUFM
 319         :: Uniquable k
 320         => (a -> a) -> a -> k
 321         -> UniqFM a -> UniqFM a
 322
 323 adjustWithDefaultUFM f def k map
 324         = addToUFM_C
 325                 (\old new -> f old)
 326                 map
 327                 k def
 328
 329
 330 adjustUFM
 331         :: Uniquable k
 332         => (a -> a)
 333         -> k -> UniqFM a -> UniqFM a
 334
 335 adjustUFM f k map
 336  = case lookupUFM map k of
 337         Nothing -> map
 338         Just a  -> addToUFM map k (f a)
 339
 340