compiler/nativeGen/GraphOps.hs

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