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