compiler/utils/GraphOps.hs

   1 {-# OPTIONS -fno-warn-missing-signatures #-}
   2 -- | Basic operations on graphs.
   3 --
   4
   5 module GraphOps (
   6         addNode,        delNode,        getNode,        lookupNode,     modNode,
   7         size,
   8         union,
   9         addConflict,    delConflict,    addConflicts,
  10         addCoalesce,    delCoalesce,
  11         addExclusion,   addExclusions,
  12         addPreference,
  13         coalesceNodes,  coalesceGraph,
  14         freezeNode,     freezeOneInGraph, freezeAllInGraph,
  15         scanGraph,
  16         setColor,
  17         validateGraph,
  18         slurpNodeConflictCount
  19 )
  20 where
  21
  22 import GraphBase
  23
  24 import Outputable
  25 import Unique
  26 import UniqSet
  27 import UniqFM
  28
  29 import Data.List        hiding (union)
  30 import Data.Maybe
  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_C (\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_C (\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 -- | Delete a node and all its edges from the graph.
  80 delNode :: (Uniquable k, Outputable k)
  81         => k -> Graph k cls color -> Maybe (Graph k cls color)
  82
  83 delNode k graph
  84         | Just node     <- lookupNode graph k
  85         = let   -- delete conflict edges from other nodes to this one.
  86                 graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
  87                         $ uniqSetToList (nodeConflicts node)
  88
  89                 -- delete coalesce edge from other nodes to this one.
  90                 graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
  91                         $ uniqSetToList (nodeCoalesce node)
  92
  93                 -- delete the node
  94                 graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2
  95
  96           in    Just graph3
  97
  98         | otherwise
  99         = Nothing
 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
 122 -- | Get the size of the graph, O(n)
 123 size    :: Uniquable k
 124         => Graph k cls color -> Int
 125
 126 size graph
 127         = sizeUFM $ graphMap graph
 128
 129
 130 -- | Union two graphs together.
 131 union   :: Uniquable k
 132         => Graph k cls color -> Graph k cls color -> Graph k cls color
 133
 134 union   graph1 graph2
 135         = Graph
 136         { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
 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 addExclusions
 217         :: (Uniquable k, Uniquable color)
 218         => k -> (k -> cls) -> [color]
 219         -> Graph k cls color -> Graph k cls color
 220
 221 addExclusions u getClass colors graph
 222         = foldr (addExclusion u getClass) graph colors
 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         => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
 279                                 --      less colorable (aggressive coalescing)
 280         -> Triv k cls color
 281         -> Graph k cls color
 282         -> ( Graph k cls color
 283            , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
 284                                 --      coalescing was applied.
 285
 286 coalesceGraph aggressive triv graph
 287         = coalesceGraph' aggressive triv graph []
 288
 289 coalesceGraph' aggressive triv graph kkPairsAcc
 290  = let
 291         -- find all the nodes that have coalescence edges
 292         cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
 293                 $ eltsUFM $ graphMap graph
 294
 295         -- build a list of pairs of keys for node's we'll try and coalesce
 296         --      every pair of nodes will appear twice in this list
 297         --      ie [(k1, k2), (k2, k1) ... ]
 298         --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
 299         --      build a list of what nodes get coalesced together for later on.
 300         --
 301         cList   = [ (nodeId node1, k2)
 302                         | node1 <- cNodes
 303                         , k2    <- uniqSetToList $ nodeCoalesce node1 ]
 304
 305         -- do the coalescing, returning the new graph and a list of pairs of keys
 306         --      that got coalesced together.
 307         (graph', mPairs)
 308                 = mapAccumL (coalesceNodes aggressive triv) graph cList
 309
 310         -- keep running until there are no more coalesces can be found
 311    in   case catMaybes mPairs of
 312          []     -> (graph', reverse kkPairsAcc)
 313          pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
 314
 315
 316 -- | Coalesce this pair of nodes unconditionally \/ agressively.
 317 --      The resulting node is the one with the least key.
 318 --
 319 --      returns: Just    the pair of keys if the nodes were coalesced
 320 --                       the second element of the pair being the least one
 321 --
 322 --               Nothing if either of the nodes weren't in the graph
 323
 324 coalesceNodes
 325         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 326         => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
 327                                 --      less colorable (aggressive coalescing)
 328         -> Triv  k cls color
 329         -> Graph k cls color
 330         -> (k, k)               -- ^ keys of the nodes to be coalesced
 331         -> (Graph k cls color, Maybe (k, k))
 332
 333 coalesceNodes aggressive triv graph (k1, k2)
 334         | (kMin, kMax)  <- if k1 < k2
 335                                 then (k1, k2)
 336                                 else (k2, k1)
 337
 338         -- the nodes being coalesced must be in the graph
 339         , Just nMin     <- lookupNode graph kMin
 340         , Just nMax     <- lookupNode graph kMax
 341
 342         -- can't coalesce conflicting modes
 343         , not $ elementOfUniqSet kMin (nodeConflicts nMax)
 344         , not $ elementOfUniqSet kMax (nodeConflicts nMin)
 345
 346         -- can't coalesce the same node
 347         , nodeId nMin /= nodeId nMax
 348
 349         = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 350
 351         -- don't do the coalescing after all
 352         | otherwise
 353         = (graph, Nothing)
 354
 355 coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 356
 357         -- sanity checks
 358         | nodeClass nMin /= nodeClass nMax
 359         = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
 360
 361         | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
 362         = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
 363
 364         ---
 365         | otherwise
 366         = let
 367                 -- the new node gets all the edges from its two components
 368                 node    =
 369                  Node   { nodeId                = kMin
 370                         , nodeClass             = nodeClass nMin
 371                         , nodeColor             = Nothing
 372
 373                         -- nodes don't conflict with themselves..
 374                         , nodeConflicts
 375                                 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
 376                                         `delOneFromUniqSet` kMin
 377                                         `delOneFromUniqSet` kMax
 378
 379                         , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
 380                         , nodePreference        = nodePreference nMin ++ nodePreference nMax
 381
 382                         -- nodes don't coalesce with themselves..
 383                         , nodeCoalesce
 384                                 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
 385                                         `delOneFromUniqSet` kMin
 386                                         `delOneFromUniqSet` kMax
 387                         }
 388
 389           in    coalesceNodes_check aggressive triv graph kMin kMax node
 390
 391 coalesceNodes_check aggressive triv graph kMin kMax node
 392
 393         -- Unless we're coalescing aggressively, if the result node is not trivially
 394         --      colorable then don't do the coalescing.
 395         | not aggressive
 396         , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
 397         = (graph, Nothing)
 398
 399         | otherwise
 400         = let -- delete the old nodes from the graph and add the new one
 401                 Just graph1     = delNode kMax graph
 402                 Just graph2     = delNode kMin graph1
 403                 graph3          = addNode kMin node graph2
 404
 405           in    (graph3, Just (kMax, kMin))
 406
 407
 408 -- | Freeze a node
 409 --      This is for the iterative coalescer.
 410 --      By freezing a node we give up on ever coalescing it.
 411 --      Move all its coalesce edges into the frozen set - and update
 412 --      back edges from other nodes.
 413 --
 414 freezeNode
 415         :: Uniquable k
 416         => k                    -- ^ key of the node to freeze
 417         -> Graph k cls color    -- ^ the graph
 418         -> Graph k cls color    -- ^ graph with that node frozen
 419
 420 freezeNode k
 421   = graphMapModify
 422   $ \fm ->
 423     let -- freeze all the edges in the node to be frozen
 424         Just node = lookupUFM fm k
 425         node'   = node
 426                 { nodeCoalesce          = emptyUniqSet }
 427
 428         fm1     = addToUFM fm k node'
 429
 430         -- update back edges pointing to this node
 431         freezeEdge k node
 432          = if elementOfUniqSet k (nodeCoalesce node)
 433                 then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
 434                 else node       -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
 435                                 -- If the edge isn't actually in the coelesce set then just ignore it.
 436
 437         fm2     = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1
 438                         $ nodeCoalesce node
 439
 440     in  fm2
 441
 442
 443 -- | Freeze one node in the graph
 444 --      This if for the iterative coalescer.
 445 --      Look for a move related node of low degree and freeze it.
 446 --
 447 --      We probably don't need to scan the whole graph looking for the node of absolute
 448 --      lowest degree. Just sample the first few and choose the one with the lowest
 449 --      degree out of those. Also, we don't make any distinction between conflicts of different
 450 --      classes.. this is just a heuristic, after all.
 451 --
 452 --      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
 453 --              right here, and add it to a worklist if known triv\/non-move nodes.
 454 --
 455 freezeOneInGraph
 456         :: (Uniquable k, Outputable k)
 457         => Graph k cls color
 458         -> ( Graph k cls color          -- the new graph
 459            , Bool )                     -- whether we found a node to freeze
 460
 461 freezeOneInGraph graph
 462  = let  compareNodeDegree n1 n2
 463                 = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
 464
 465         candidates
 466                 = sortBy compareNodeDegree
 467                 $ take 5        -- 5 isn't special, it's just a small number.
 468                 $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
 469
 470    in   case candidates of
 471
 472          -- there wasn't anything available to freeze
 473          []     -> (graph, False)
 474
 475          -- we found something to freeze
 476          (n : _)
 477           -> ( freezeNode (nodeId n) graph
 478              , True)
 479
 480
 481 -- | Freeze all the nodes in the graph
 482 --      for debugging the iterative allocator.
 483 --
 484 freezeAllInGraph
 485         :: (Uniquable k, Outputable k)
 486         => Graph k cls color
 487         -> Graph k cls color
 488
 489 freezeAllInGraph graph
 490         = foldr freezeNode graph
 491                 $ map nodeId
 492                 $ eltsUFM $ graphMap graph
 493
 494
 495 -- | Find all the nodes in the graph that meet some criteria
 496 --
 497 scanGraph
 498         :: Uniquable k
 499         => (Node k cls color -> Bool)
 500         -> Graph k cls color
 501         -> [Node k cls color]
 502
 503 scanGraph match graph
 504         = filter match $ eltsUFM $ graphMap graph
 505
 506
 507 -- | validate the internal structure of a graph
 508 --      all its edges should point to valid nodes
 509 --      If they don't then throw an error
 510 --
 511 validateGraph
 512         :: (Uniquable k, Outputable k, Eq color)
 513         => SDoc                         -- ^ extra debugging info to display on error
 514         -> Bool                         -- ^ whether this graph is supposed to be colored.
 515         -> Graph k cls color            -- ^ graph to validate
 516         -> Graph k cls color            -- ^ validated graph
 517
 518 validateGraph doc isColored graph
 519
 520         -- Check that all edges point to valid nodes.
 521         | edges         <- unionManyUniqSets
 522                                 (  (map nodeConflicts       $ eltsUFM $ graphMap graph)
 523                                 ++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
 524
 525         , nodes         <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 526         , badEdges      <- minusUniqSet edges nodes
 527         , not $ isEmptyUniqSet badEdges
 528         = pprPanic "GraphOps.validateGraph"
 529                 (  text "Graph has edges that point to non-existant nodes"
 530                 $$ text "  bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
 531                 $$ doc )
 532
 533         -- Check that no conflicting nodes have the same color
 534         | badNodes      <- filter (not . (checkNode graph))
 535                         $ eltsUFM $ graphMap graph
 536         , not $ null badNodes
 537         = pprPanic "GraphOps.validateGraph"
 538                 (  text "Node has same color as one of it's conflicts"
 539                 $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
 540                 $$ doc)
 541
 542         -- If this is supposed to be a colored graph,
 543         --      check that all nodes have a color.
 544         | isColored
 545         , badNodes      <- filter (\n -> isNothing $ nodeColor n)
 546                         $  eltsUFM $ graphMap graph
 547         , not $ null badNodes
 548         = pprPanic "GraphOps.validateGraph"
 549                 (  text "Supposably colored graph has uncolored nodes."
 550                 $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
 551                 $$ doc )
 552
 553
 554         -- graph looks ok
 555         | otherwise
 556         = graph
 557
 558
 559 -- | If this node is colored, check that all the nodes which
 560 --      conflict with it have different colors.
 561 checkNode
 562         :: (Uniquable k, Eq color)
 563         => Graph k cls color
 564         -> Node  k cls color
 565         -> Bool                 -- ^ True if this node is ok
 566
 567 checkNode graph node
 568         | Just color            <- nodeColor node
 569         , Just neighbors        <- sequence $ map (lookupNode graph)
 570                                 $  uniqSetToList $ nodeConflicts node
 571
 572         , neighbourColors       <- catMaybes $ map nodeColor neighbors
 573         , elem color neighbourColors
 574         = False
 575
 576         | otherwise
 577         = True
 578
 579
 580
 581 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
 582
 583 slurpNodeConflictCount
 584         :: Uniquable k
 585         => Graph k cls color
 586         -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
 587
 588 slurpNodeConflictCount graph
 589         = addListToUFM_C
 590                 (\(c1, n1) (_, n2) -> (c1, n1 + n2))
 591                 emptyUFM
 592         $ map   (\node
 593                   -> let count  = sizeUniqSet $ nodeConflicts node
 594                      in  (count, (count, 1)))
 595         $ eltsUFM
 596         $ graphMap graph
 597
 598
 599 -- | Set the color of a certain node
 600 setColor
 601         :: Uniquable k
 602         => k -> color
 603         -> Graph k cls color -> Graph k cls color
 604
 605 setColor u color
 606         = graphMapModify
 607         $ adjustUFM_C
 608                 (\n -> n { nodeColor = Just color })
 609                 u
 610
 611
 612 {-# INLINE      adjustWithDefaultUFM #-}
 613 adjustWithDefaultUFM
 614         :: Uniquable k
 615         => (a -> a) -> a -> k
 616         -> UniqFM a -> UniqFM a
 617
 618 adjustWithDefaultUFM f def k map
 619         = addToUFM_C
 620                 (\old _ -> f old)
 621                 map
 622                 k def
 623
 624 -- Argument order different from UniqFM's adjustUFM
 625 {-# INLINE adjustUFM_C #-}
 626 adjustUFM_C
 627         :: Uniquable k
 628         => (a -> a)
 629         -> k -> UniqFM a -> UniqFM a
 630
 631 adjustUFM_C f k map
 632  = case lookupUFM map k of
 633         Nothing -> map
 634         Just a  -> addToUFM map k (f a)
 635