compiler/nativeGen/GraphOps.hs

   1
   2 -- | Basic operations on graphs.
   3 --
   4
   5 {-# OPTIONS -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/Commentary/CodingStyle#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         coalesceGraph,
  21         coalesceNodes,
  22         setColor,
  23         validateGraph,
  24         slurpNodeConflictCount
  25 )
  26 where
  27
  28 import GraphBase
  29
  30 import Outputable
  31 import Unique
  32 import UniqSet
  33 import UniqFM
  34
  35 import Data.List        hiding (union)
  36 import Data.Maybe
  37
  38
  39 -- | Lookup a node from the graph.
  40 lookupNode
  41         :: Uniquable k
  42         => Graph k cls color
  43         -> k -> Maybe (Node  k cls color)
  44
  45 lookupNode graph k
  46         = lookupUFM (graphMap graph) k
  47
  48
  49 -- | Get a node from the graph, throwing an error if it's not there
  50 getNode
  51         :: Uniquable k
  52         => Graph k cls color
  53         -> k -> Node k cls color
  54
  55 getNode graph k
  56  = case lookupUFM (graphMap graph) k of
  57         Just node       -> node
  58         Nothing         -> panic "ColorOps.getNode: not found"
  59
  60
  61 -- | Add a node to the graph, linking up its edges
  62 addNode :: Uniquable k
  63         => k -> Node k cls color
  64         -> Graph k cls color -> Graph k cls color
  65
  66 addNode k node graph
  67  = let
  68         -- add back conflict edges from other nodes to this one
  69         map_conflict
  70                 = foldUniqSet
  71                         (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
  72                         (graphMap graph)
  73                         (nodeConflicts node)
  74
  75         -- add back coalesce edges from other nodes to this one
  76         map_coalesce
  77                 = foldUniqSet
  78                         (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
  79                         map_conflict
  80                         (nodeCoalesce node)
  81
  82   in    graph
  83         { graphMap      = addToUFM map_coalesce k node}
  84
  85
  86
  87 -- | Delete a node and all its edges from the graph.
  88 --      Throws an error if it's not there.
  89 delNode :: Uniquable k
  90         => k -> Graph k cls color -> Graph k cls color
  91
  92 delNode k graph
  93  = let  Just node       = lookupNode graph k
  94
  95         -- delete conflict edges from other nodes to this one.
  96         graph1          = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
  97                         $ uniqSetToList (nodeConflicts node)
  98
  99         -- delete coalesce edge from other nodes to this one.
 100         graph2          = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
 101                         $ uniqSetToList (nodeCoalesce node)
 102
 103         -- delete the node
 104         graph3          = graphMapModify (\fm -> delFromUFM fm k) graph2
 105
 106   in    graph3
 107
 108
 109 -- | Modify a node in the graph.
 110 --      returns Nothing if the node isn't present.
 111 --
 112 modNode :: Uniquable k
 113         => (Node k cls color -> Node k cls color)
 114         -> k -> Graph k cls color -> Maybe (Graph k cls color)
 115
 116 modNode f k graph
 117  = case lookupNode graph k of
 118         Just Node{}
 119          -> Just
 120          $  graphMapModify
 121                  (\fm   -> let  Just node       = lookupUFM fm k
 122                                 node'           = f node
 123                            in   addToUFM fm k node')
 124                 graph
 125
 126         Nothing -> Nothing
 127
 128 -- | Get the size of the graph, O(n)
 129 size    :: Uniquable k
 130         => Graph k cls color -> Int
 131
 132 size graph
 133         = sizeUFM $ graphMap graph
 134
 135
 136 -- | Union two graphs together.
 137 union   :: Uniquable k
 138         => Graph k cls color -> Graph k cls color -> Graph k cls color
 139
 140 union   graph1 graph2
 141         = Graph
 142         { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
 143
 144
 145
 146
 147 -- | Add a conflict between nodes to the graph, creating the nodes required.
 148 --      Conflicts are virtual regs which need to be colored differently.
 149 addConflict
 150         :: Uniquable k
 151         => (k, cls) -> (k, cls)
 152         -> Graph k cls color -> Graph k cls color
 153
 154 addConflict (u1, c1) (u2, c2)
 155  = let  addNeighbor u c u'
 156                 = adjustWithDefaultUFM
 157                         (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
 158                         (newNode u c)  { nodeConflicts = unitUniqSet u' }
 159                         u
 160
 161    in   graphMapModify
 162         ( addNeighbor u1 c1 u2
 163         . addNeighbor u2 c2 u1)
 164
 165
 166 -- | Delete a conflict edge. k1 -> k2
 167 --      returns Nothing if the node isn't in the graph
 168 delConflict
 169         :: Uniquable k
 170         => k -> k
 171         -> Graph k cls color -> Maybe (Graph k cls color)
 172
 173 delConflict k1 k2
 174         = modNode
 175                 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
 176                 k1
 177
 178
 179 -- | Add some conflicts to the graph, creating nodes if required.
 180 --      All the nodes in the set are taken to conflict with each other.
 181 addConflicts
 182         :: Uniquable k
 183         => UniqSet k -> (k -> cls)
 184         -> Graph k cls color -> Graph k cls color
 185
 186 addConflicts conflicts getClass
 187
 188         -- just a single node, but no conflicts, create the node anyway.
 189         | (u : [])      <- uniqSetToList conflicts
 190         = graphMapModify
 191         $ adjustWithDefaultUFM
 192                 id
 193                 (newNode u (getClass u))
 194                 u
 195
 196         | otherwise
 197         = graphMapModify
 198         $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
 199                 $ uniqSetToList conflicts)
 200
 201
 202 addConflictSet1 u getClass set
 203  = let  set'    = delOneFromUniqSet set u
 204    in   adjustWithDefaultUFM
 205                 (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
 206                 (newNode u (getClass u))        { nodeConflicts = set' }
 207                 u
 208
 209
 210 -- | Add an exclusion to the graph, creating nodes if required.
 211 --      These are extra colors that the node cannot use.
 212 addExclusion
 213         :: (Uniquable k, Uniquable color)
 214         => k -> (k -> cls) -> color
 215         -> Graph k cls color -> Graph k cls color
 216
 217 addExclusion u getClass color
 218         = graphMapModify
 219         $ adjustWithDefaultUFM
 220                 (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
 221                 (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
 222                 u
 223
 224
 225 -- | Add a coalescence edge to the graph, creating nodes if requried.
 226 --      It is considered adventageous to assign the same color to nodes in a coalesence.
 227 addCoalesce
 228         :: Uniquable k
 229         => (k, cls) -> (k, cls)
 230         -> Graph k cls color -> Graph k cls color
 231
 232 addCoalesce (u1, c1) (u2, c2)
 233  = let  addCoalesce u c u'
 234          =      adjustWithDefaultUFM
 235                         (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
 236                         (newNode u c)  { nodeCoalesce = unitUniqSet u' }
 237                         u
 238
 239    in   graphMapModify
 240         ( addCoalesce u1 c1 u2
 241         . addCoalesce u2 c2 u1)
 242
 243
 244 -- | Delete a coalescence edge (k1 -> k2) from the graph.
 245 delCoalesce
 246         :: Uniquable k
 247         => k -> k
 248         -> Graph k cls color    -> Maybe (Graph k cls color)
 249
 250 delCoalesce k1 k2
 251         = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
 252                 k1
 253
 254
 255 -- | Add a color preference to the graph, creating nodes if required.
 256 --      The most recently added preference is the most prefered.
 257 --      The algorithm tries to assign a node it's prefered color if possible.
 258 --
 259 addPreference
 260         :: Uniquable k
 261         => (k, cls) -> color
 262         -> Graph k cls color -> Graph k cls color
 263
 264 addPreference (u, c) color
 265         = graphMapModify
 266         $ adjustWithDefaultUFM
 267                 (\node -> node { nodePreference = color : (nodePreference node) })
 268                 (newNode u c)  { nodePreference = [color] }
 269                 u
 270
 271
 272 -- | Do agressive coalescing on this graph.
 273 --      returns the new graph and the list of pairs of nodes that got coaleced together.
 274 --      for each pair, the resulting node will have the least key and be second in the pair.
 275 --
 276 coalesceGraph
 277         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 278         => Triv k cls color
 279         -> Graph k cls color
 280         -> (Graph k cls color, [(k, k)])
 281
 282 coalesceGraph triv graph
 283  = let
 284         -- find all the nodes that have coalescence edges
 285         cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
 286                 $ eltsUFM $ graphMap graph
 287
 288         -- build a list of pairs of keys for node's we'll try and coalesce
 289         --      every pair of nodes will appear twice in this list
 290         --      ie [(k1, k2), (k2, k1) ... ]
 291         --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
 292         --      build a list of what nodes get coalesced together for later on.
 293         --
 294         cList   = [ (nodeId node1, k2)
 295                         | node1 <- cNodes
 296                         , k2    <- uniqSetToList $ nodeCoalesce node1 ]
 297
 298         -- do the coalescing, returning the new graph and a list of pairs of keys
 299         --      that got coalesced together.
 300         (graph', mPairs)
 301                 = mapAccumL (coalesceNodes False triv) graph cList
 302
 303    in   (graph', catMaybes mPairs)
 304
 305
 306 -- | Coalesce this pair of nodes unconditionally / agressively.
 307 --      The resulting node is the one with the least key.
 308 --
 309 --      returns: Just    the pair of keys if the nodes were coalesced
 310 --                       the second element of the pair being the least one
 311 --
 312 --               Nothing if either of the nodes weren't in the graph
 313
 314 coalesceNodes
 315         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 316         => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
 317                                 --      less colorable (aggressive coalescing)
 318         -> Triv  k cls color
 319         -> Graph k cls color
 320         -> (k, k)               -- ^ keys of the nodes to be coalesced
 321         -> (Graph k cls color, Maybe (k, k))
 322
 323 coalesceNodes aggressive triv graph (k1, k2)
 324         | (kMin, kMax)  <- if k1 < k2
 325                                 then (k1, k2)
 326                                 else (k2, k1)
 327
 328         -- the nodes being coalesced must be in the graph
 329         , Just nMin             <- lookupNode graph kMin
 330         , Just nMax             <- lookupNode graph kMax
 331
 332         -- can't coalesce conflicting modes
 333         , not $ elementOfUniqSet kMin (nodeConflicts nMax)
 334         , not $ elementOfUniqSet kMax (nodeConflicts nMin)
 335
 336         = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 337
 338         -- don't do the coalescing after all
 339         | otherwise
 340         = (graph, Nothing)
 341
 342 coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 343
 344         -- sanity checks
 345         | nodeClass nMin /= nodeClass nMax
 346         = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
 347
 348         | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
 349         = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
 350
 351         ---
 352         | otherwise
 353         = let
 354                 -- the new node gets all the edges from its two components
 355                 node    =
 356                  Node   { nodeId                = kMin
 357                         , nodeClass             = nodeClass nMin
 358                         , nodeColor             = Nothing
 359
 360                         -- nodes don't conflict with themselves..
 361                         , nodeConflicts
 362                                 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
 363                                         `delOneFromUniqSet` kMin
 364                                         `delOneFromUniqSet` kMax
 365
 366                         , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
 367                         , nodePreference        = nodePreference nMin ++ nodePreference nMax
 368
 369                         -- nodes don't coalesce with themselves..
 370                         , nodeCoalesce
 371                                 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
 372                                         `delOneFromUniqSet` kMin
 373                                         `delOneFromUniqSet` kMax
 374                         }
 375
 376           in    coalesceNodes_check aggressive triv graph kMin kMax node
 377
 378 coalesceNodes_check aggressive triv graph kMin kMax node
 379
 380         -- Unless we're coalescing aggressively, if the result node is not trivially
 381         --      colorable then don't do the coalescing.
 382         | not aggressive
 383         , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
 384         = (graph, Nothing)
 385
 386         | otherwise
 387         = let -- delete the old nodes from the graph and add the new one
 388                 graph'  = addNode kMin node
 389                         $ delNode kMin
 390                         $ delNode kMax
 391                         $ graph
 392
 393           in    (graph', Just (kMax, kMin))
 394
 395
 396 -- | validate the internal structure of a graph
 397 --      all its edges should point to valid nodes
 398 --      if they don't then throw an error
 399 --
 400 validateGraph
 401         :: (Uniquable k, Outputable k)
 402         => SDoc
 403         -> Graph k cls color
 404         -> Graph k cls color
 405
 406 validateGraph doc graph
 407  = let  edges   = unionUniqSets
 408                         (unionManyUniqSets
 409                                 (map nodeConflicts $ eltsUFM $ graphMap graph))
 410                         (unionManyUniqSets
 411                                 (map nodeCoalesce  $ eltsUFM $ graphMap graph))
 412
 413         nodes   = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 414
 415         badEdges = minusUniqSet edges nodes
 416
 417   in    if isEmptyUniqSet badEdges
 418          then   graph
 419          else   pprPanic "GraphOps.validateGraph"
 420                 ( text  "-- bad edges"
 421                 $$ vcat (map ppr $ uniqSetToList badEdges)
 422                 $$ text "----------------------------"
 423                 $$ doc)
 424
 425
 426 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
 427
 428 slurpNodeConflictCount
 429         :: Uniquable k
 430         => Graph k cls color
 431         -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
 432
 433 slurpNodeConflictCount graph
 434         = addListToUFM_C
 435                 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
 436                 emptyUFM
 437         $ map   (\node
 438                   -> let count  = sizeUniqSet $ nodeConflicts node
 439                      in  (count, (count, 1)))
 440         $ eltsUFM
 441         $ graphMap graph
 442
 443
 444 -- | Set the color of a certain node
 445 setColor
 446         :: Uniquable k
 447         => k -> color
 448         -> Graph k cls color -> Graph k cls color
 449
 450 setColor u color
 451         = graphMapModify
 452         $ adjustUFM
 453                 (\n -> n { nodeColor = Just color })
 454                 u
 455
 456
 457 adjustWithDefaultUFM
 458         :: Uniquable k
 459         => (a -> a) -> a -> k
 460         -> UniqFM a -> UniqFM a
 461
 462 adjustWithDefaultUFM f def k map
 463         = addToUFM_C
 464                 (\old new -> f old)
 465                 map
 466                 k def
 467
 468
 469 adjustUFM
 470         :: Uniquable k
 471         => (a -> a)
 472         -> k -> UniqFM a -> UniqFM a
 473
 474 adjustUFM f k map
 475  = case lookupUFM map k of
 476         Nothing -> map
 477         Just a  -> addToUFM map k (f a)
 478
 479