compiler/utils/GraphOps.hs

   1 -- | Basic operations on graphs.
   2 --
   3 --      TODO: refine coalescing crieteria
   4
   5 {-# OPTIONS -fno-warn-missing-signatures #-}
   6
   7 module GraphOps (
   8         addNode,        delNode,        getNode,        lookupNode,     modNode,
   9         size,
  10         union,
  11         addConflict,    delConflict,    addConflicts,
  12         addCoalesce,    delCoalesce,
  13         addExclusion,
  14         addPreference,
  15         coalesceNodes,  coalesceGraph,
  16         freezeNode,     freezeOneInGraph, freezeAllInGraph,
  17         scanGraph,
  18         setColor,
  19         validateGraph,
  20         slurpNodeConflictCount
  21 )
  22 where
  23
  24 import GraphBase
  25
  26 import Outputable
  27 import Unique
  28 import UniqSet
  29 import UniqFM
  30
  31 import Data.List        hiding (union)
  32 import Data.Maybe
  33
  34 -- | Lookup a node from the graph.
  35 lookupNode
  36         :: Uniquable k
  37         => Graph k cls color
  38         -> k -> Maybe (Node  k cls color)
  39
  40 lookupNode graph k
  41         = lookupUFM (graphMap graph) k
  42
  43
  44 -- | Get a node from the graph, throwing an error if it's not there
  45 getNode
  46         :: Uniquable k
  47         => Graph k cls color
  48         -> k -> Node k cls color
  49
  50 getNode graph k
  51  = case lookupUFM (graphMap graph) k of
  52         Just node       -> node
  53         Nothing         -> panic "ColorOps.getNode: not found"
  54
  55
  56 -- | Add a node to the graph, linking up its edges
  57 addNode :: Uniquable k
  58         => k -> Node k cls color
  59         -> Graph k cls color -> Graph k cls color
  60
  61 addNode k node graph
  62  = let
  63         -- add back conflict edges from other nodes to this one
  64         map_conflict
  65                 = foldUniqSet
  66                         (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
  67                         (graphMap graph)
  68                         (nodeConflicts node)
  69
  70         -- add back coalesce edges from other nodes to this one
  71         map_coalesce
  72                 = foldUniqSet
  73                         (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
  74                         map_conflict
  75                         (nodeCoalesce node)
  76
  77   in    graph
  78         { graphMap      = addToUFM map_coalesce k node}
  79
  80
  81 -- | Delete a node and all its edges from the graph.
  82 delNode :: (Uniquable k, Outputable k)
  83         => k -> Graph k cls color -> Maybe (Graph k cls color)
  84
  85 delNode k graph
  86         | Just node     <- lookupNode graph k
  87         = let   -- 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    Just graph3
  99
 100         | otherwise
 101         = Nothing
 102
 103
 104 -- | Modify a node in the graph.
 105 --      returns Nothing if the node isn't present.
 106 --
 107 modNode :: Uniquable k
 108         => (Node k cls color -> Node k cls color)
 109         -> k -> Graph k cls color -> Maybe (Graph k cls color)
 110
 111 modNode f k graph
 112  = case lookupNode graph k of
 113         Just Node{}
 114          -> Just
 115          $  graphMapModify
 116                  (\fm   -> let  Just node       = lookupUFM fm k
 117                                 node'           = f node
 118                            in   addToUFM fm k node')
 119                 graph
 120
 121         Nothing -> Nothing
 122
 123
 124 -- | Get the size of the graph, O(n)
 125 size    :: Uniquable k
 126         => Graph k cls color -> Int
 127
 128 size graph
 129         = sizeUFM $ graphMap graph
 130
 131
 132 -- | Union two graphs together.
 133 union   :: Uniquable k
 134         => Graph k cls color -> Graph k cls color -> Graph k cls color
 135
 136 union   graph1 graph2
 137         = Graph
 138         { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
 139
 140
 141 -- | Add a conflict between nodes to the graph, creating the nodes required.
 142 --      Conflicts are virtual regs which need to be colored differently.
 143 addConflict
 144         :: Uniquable k
 145         => (k, cls) -> (k, cls)
 146         -> Graph k cls color -> Graph k cls color
 147
 148 addConflict (u1, c1) (u2, c2)
 149  = let  addNeighbor u c u'
 150                 = adjustWithDefaultUFM
 151                         (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
 152                         (newNode u c)  { nodeConflicts = unitUniqSet u' }
 153                         u
 154
 155    in   graphMapModify
 156         ( addNeighbor u1 c1 u2
 157         . addNeighbor u2 c2 u1)
 158
 159
 160 -- | Delete a conflict edge. k1 -> k2
 161 --      returns Nothing if the node isn't in the graph
 162 delConflict
 163         :: Uniquable k
 164         => k -> k
 165         -> Graph k cls color -> Maybe (Graph k cls color)
 166
 167 delConflict k1 k2
 168         = modNode
 169                 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
 170                 k1
 171
 172
 173 -- | Add some conflicts to the graph, creating nodes if required.
 174 --      All the nodes in the set are taken to conflict with each other.
 175 addConflicts
 176         :: Uniquable k
 177         => UniqSet k -> (k -> cls)
 178         -> Graph k cls color -> Graph k cls color
 179
 180 addConflicts conflicts getClass
 181
 182         -- just a single node, but no conflicts, create the node anyway.
 183         | (u : [])      <- uniqSetToList conflicts
 184         = graphMapModify
 185         $ adjustWithDefaultUFM
 186                 id
 187                 (newNode u (getClass u))
 188                 u
 189
 190         | otherwise
 191         = graphMapModify
 192         $ (\fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
 193                 $ uniqSetToList conflicts)
 194
 195
 196 addConflictSet1 u getClass set
 197  = case delOneFromUniqSet set u of
 198     set' -> adjustWithDefaultUFM
 199                 (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
 200                 (newNode u (getClass u))        { nodeConflicts = set' }
 201                 u
 202
 203
 204 -- | Add an exclusion to the graph, creating nodes if required.
 205 --      These are extra colors that the node cannot use.
 206 addExclusion
 207         :: (Uniquable k, Uniquable color)
 208         => k -> (k -> cls) -> color
 209         -> Graph k cls color -> Graph k cls color
 210
 211 addExclusion u getClass color
 212         = graphMapModify
 213         $ adjustWithDefaultUFM
 214                 (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
 215                 (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
 216                 u
 217
 218
 219 -- | Add a coalescence edge to the graph, creating nodes if requried.
 220 --      It is considered adventageous to assign the same color to nodes in a coalesence.
 221 addCoalesce
 222         :: Uniquable k
 223         => (k, cls) -> (k, cls)
 224         -> Graph k cls color -> Graph k cls color
 225
 226 addCoalesce (u1, c1) (u2, c2)
 227  = let  addCoalesce u c u'
 228          =      adjustWithDefaultUFM
 229                         (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
 230                         (newNode u c)  { nodeCoalesce = unitUniqSet u' }
 231                         u
 232
 233    in   graphMapModify
 234         ( addCoalesce u1 c1 u2
 235         . addCoalesce u2 c2 u1)
 236
 237
 238 -- | Delete a coalescence edge (k1 -> k2) from the graph.
 239 delCoalesce
 240         :: Uniquable k
 241         => k -> k
 242         -> Graph k cls color    -> Maybe (Graph k cls color)
 243
 244 delCoalesce k1 k2
 245         = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
 246                 k1
 247
 248
 249 -- | Add a color preference to the graph, creating nodes if required.
 250 --      The most recently added preference is the most prefered.
 251 --      The algorithm tries to assign a node it's prefered color if possible.
 252 --
 253 addPreference
 254         :: Uniquable k
 255         => (k, cls) -> color
 256         -> Graph k cls color -> Graph k cls color
 257
 258 addPreference (u, c) color
 259         = graphMapModify
 260         $ adjustWithDefaultUFM
 261                 (\node -> node { nodePreference = color : (nodePreference node) })
 262                 (newNode u c)  { nodePreference = [color] }
 263                 u
 264
 265
 266 -- | Do agressive coalescing on this graph.
 267 --      returns the new graph and the list of pairs of nodes that got coaleced together.
 268 --      for each pair, the resulting node will have the least key and be second in the pair.
 269 --
 270 coalesceGraph
 271         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 272         => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
 273                                 --      less colorable (aggressive coalescing)
 274         -> Triv k cls color
 275         -> Graph k cls color
 276         -> ( Graph k cls color
 277            , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
 278                                 --      coalescing was applied.
 279
 280 coalesceGraph aggressive triv graph
 281         = coalesceGraph' aggressive triv graph []
 282
 283 coalesceGraph' aggressive triv graph kkPairsAcc
 284  = let
 285         -- find all the nodes that have coalescence edges
 286         cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
 287                 $ eltsUFM $ graphMap graph
 288
 289         -- build a list of pairs of keys for node's we'll try and coalesce
 290         --      every pair of nodes will appear twice in this list
 291         --      ie [(k1, k2), (k2, k1) ... ]
 292         --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
 293         --      build a list of what nodes get coalesced together for later on.
 294         --
 295         cList   = [ (nodeId node1, k2)
 296                         | node1 <- cNodes
 297                         , k2    <- uniqSetToList $ nodeCoalesce node1 ]
 298
 299         -- do the coalescing, returning the new graph and a list of pairs of keys
 300         --      that got coalesced together.
 301         (graph', mPairs)
 302                 = mapAccumL (coalesceNodes aggressive triv) graph cList
 303
 304         -- keep running until there are no more coalesces can be found
 305    in   case catMaybes mPairs of
 306          []     -> (graph', reverse kkPairsAcc)
 307          pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
 308
 309
 310 -- | Coalesce this pair of nodes unconditionally / agressively.
 311 --      The resulting node is the one with the least key.
 312 --
 313 --      returns: Just    the pair of keys if the nodes were coalesced
 314 --                       the second element of the pair being the least one
 315 --
 316 --               Nothing if either of the nodes weren't in the graph
 317
 318 coalesceNodes
 319         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 320         => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
 321                                 --      less colorable (aggressive coalescing)
 322         -> Triv  k cls color
 323         -> Graph k cls color
 324         -> (k, k)               -- ^ keys of the nodes to be coalesced
 325         -> (Graph k cls color, Maybe (k, k))
 326
 327 coalesceNodes aggressive triv graph (k1, k2)
 328         | (kMin, kMax)  <- if k1 < k2
 329                                 then (k1, k2)
 330                                 else (k2, k1)
 331
 332         -- the nodes being coalesced must be in the graph
 333         , Just nMin     <- lookupNode graph kMin
 334         , Just nMax     <- lookupNode graph kMax
 335
 336         -- can't coalesce conflicting modes
 337         , not $ elementOfUniqSet kMin (nodeConflicts nMax)
 338         , not $ elementOfUniqSet kMax (nodeConflicts nMin)
 339
 340         = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 341
 342         -- don't do the coalescing after all
 343         | otherwise
 344         = (graph, Nothing)
 345
 346 coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 347
 348         -- sanity checks
 349         | nodeClass nMin /= nodeClass nMax
 350         = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
 351
 352         | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
 353         = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
 354
 355         | nodeId nMin == nodeId nMax
 356         = error "GraphOps.coalesceNodes: can't coalesce the same node."
 357
 358         ---
 359         | otherwise
 360         = let
 361                 -- the new node gets all the edges from its two components
 362                 node    =
 363                  Node   { nodeId                = kMin
 364                         , nodeClass             = nodeClass nMin
 365                         , nodeColor             = Nothing
 366
 367                         -- nodes don't conflict with themselves..
 368                         , nodeConflicts
 369                                 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
 370                                         `delOneFromUniqSet` kMin
 371                                         `delOneFromUniqSet` kMax
 372
 373                         , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
 374                         , nodePreference        = nodePreference nMin ++ nodePreference nMax
 375
 376                         -- nodes don't coalesce with themselves..
 377                         , nodeCoalesce
 378                                 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
 379                                         `delOneFromUniqSet` kMin
 380                                         `delOneFromUniqSet` kMax
 381                         }
 382
 383           in    coalesceNodes_check aggressive triv graph kMin kMax node
 384
 385 coalesceNodes_check aggressive triv graph kMin kMax node
 386
 387         -- Unless we're coalescing aggressively, if the result node is not trivially
 388         --      colorable then don't do the coalescing.
 389         | not aggressive
 390         , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
 391         = (graph, Nothing)
 392
 393         | otherwise
 394         = let -- delete the old nodes from the graph and add the new one
 395                 Just graph1     = delNode kMax graph
 396                 Just graph2     = delNode kMin graph1
 397                 graph3          = addNode kMin node graph2
 398
 399           in    (graph3, Just (kMax, kMin))
 400
 401
 402 -- | Freeze a node
 403 --      This is for the iterative coalescer.
 404 --      By freezing a node we give up on ever coalescing it.
 405 --      Move all its coalesce edges into the frozen set - and update
 406 --      back edges from other nodes.
 407 --
 408 freezeNode
 409         :: Uniquable k
 410         => k                    -- ^ key of the node to freeze
 411         -> Graph k cls color    -- ^ the graph
 412         -> Graph k cls color    -- ^ graph with that node frozen
 413
 414 freezeNode k
 415   = graphMapModify
 416   $ \fm ->
 417     let
 418         -- freeze all the edges in the node to be frozen
 419         Just node = lookupUFM fm k
 420         node'   = node
 421                 { nodeCoalesce          = emptyUniqSet }
 422
 423         fm1     = addToUFM fm k node'
 424
 425         -- update back edges pointing to this node
 426         freezeEdge k node
 427          = if elementOfUniqSet k (nodeCoalesce node)
 428                 then node
 429                         { nodeCoalesce          = delOneFromUniqSet (nodeCoalesce node) k }
 430                 else    panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
 431
 432         fm2     = foldUniqSet (adjustUFM (freezeEdge k)) fm1
 433                         $ nodeCoalesce node
 434
 435     in  fm2
 436
 437
 438 -- | Freeze one node in the graph
 439 --      This if for the iterative coalescer.
 440 --      Look for a move related node of low degree and freeze it.
 441 --
 442 --      We probably don't need to scan the whole graph looking for the node of absolute
 443 --      lowest degree. Just sample the first few and choose the one with the lowest
 444 --      degree out of those. Also, we don't make any distinction between conflicts of different
 445 --      classes.. this is just a heuristic, after all.
 446 --
 447 --      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
 448 --              right here, and add it to a worklist if known triv/non-move nodes.
 449 --
 450 freezeOneInGraph
 451         :: (Uniquable k, Outputable k)
 452         => Graph k cls color
 453         -> ( Graph k cls color          -- the new graph
 454            , Bool )                     -- whether we found a node to freeze
 455
 456 freezeOneInGraph graph
 457  = let  compareNodeDegree n1 n2
 458                 = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
 459
 460         candidates
 461                 = sortBy compareNodeDegree
 462                 $ take 5        -- 5 isn't special, it's just a small number.
 463                 $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
 464
 465    in   case candidates of
 466
 467          -- there wasn't anything available to freeze
 468          []     -> (graph, False)
 469
 470          -- we found something to freeze
 471          (n : _)
 472           -> ( freezeNode (nodeId n) graph
 473              , True)
 474
 475
 476 -- | Freeze all the nodes in the graph
 477 --      for debugging the iterative allocator.
 478 --
 479 freezeAllInGraph
 480         :: (Uniquable k, Outputable k)
 481         => Graph k cls color
 482         -> Graph k cls color
 483
 484 freezeAllInGraph graph
 485         = foldr freezeNode graph
 486                 $ map nodeId
 487                 $ eltsUFM $ graphMap graph
 488
 489
 490 -- | Find all the nodes in the graph that meet some criteria
 491 --
 492 scanGraph
 493         :: Uniquable k
 494         => (Node k cls color -> Bool)
 495         -> Graph k cls color
 496         -> [Node k cls color]
 497
 498 scanGraph match graph
 499         = filter match $ eltsUFM $ graphMap graph
 500
 501
 502 -- | validate the internal structure of a graph
 503 --      all its edges should point to valid nodes
 504 --      If they don't then throw an error
 505 --
 506 validateGraph
 507         :: (Uniquable k, Outputable k, Eq color)
 508         => SDoc                         -- ^ extra debugging info to display on error
 509         -> Bool                         -- ^ whether this graph is supposed to be colored.
 510         -> Graph k cls color            -- ^ graph to validate
 511         -> Graph k cls color            -- ^ validated graph
 512
 513 validateGraph doc isColored graph
 514
 515         -- Check that all edges point to valid nodes.
 516         | edges         <- unionManyUniqSets
 517                                 (  (map nodeConflicts       $ eltsUFM $ graphMap graph)
 518                                 ++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
 519
 520         , nodes         <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 521         , badEdges      <- minusUniqSet edges nodes
 522         , not $ isEmptyUniqSet badEdges
 523         = pprPanic "GraphOps.validateGraph"
 524                 (  text "Graph has edges that point to non-existant nodes"
 525                 $$ text "  bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
 526                 $$ doc )
 527
 528         -- Check that no conflicting nodes have the same color
 529         | badNodes      <- filter (not . (checkNode graph))
 530                         $ eltsUFM $ graphMap graph
 531         , not $ null badNodes
 532         = pprPanic "GraphOps.validateGraph"
 533                 (  text "Node has same color as one of it's conflicts"
 534                 $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
 535                 $$ doc)
 536
 537         -- If this is supposed to be a colored graph,
 538         --      check that all nodes have a color.
 539         | isColored
 540         , badNodes      <- filter (\n -> isNothing $ nodeColor n)
 541                         $  eltsUFM $ graphMap graph
 542         , not $ null badNodes
 543         = pprPanic "GraphOps.validateGraph"
 544                 (  text "Supposably colored graph has uncolored nodes."
 545                 $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
 546                 $$ doc )
 547
 548
 549         -- graph looks ok
 550         | otherwise
 551         = graph
 552
 553
 554 -- | If this node is colored, check that all the nodes which
 555 --      conflict with it have different colors.
 556 checkNode
 557         :: (Uniquable k, Eq color)
 558         => Graph k cls color
 559         -> Node  k cls color
 560         -> Bool                 -- ^ True if this node is ok
 561
 562 checkNode graph node
 563         | Just color            <- nodeColor node
 564         , Just neighbors        <- sequence $ map (lookupNode graph)
 565                                 $  uniqSetToList $ nodeConflicts node
 566
 567         , neighbourColors       <- catMaybes $ map nodeColor neighbors
 568         , elem color neighbourColors
 569         = False
 570
 571         | otherwise
 572         = True
 573
 574
 575
 576 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
 577
 578 slurpNodeConflictCount
 579         :: Uniquable k
 580         => Graph k cls color
 581         -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
 582
 583 slurpNodeConflictCount graph
 584         = addListToUFM_C
 585                 (\(c1, n1) (_, n2) -> (c1, n1 + n2))
 586                 emptyUFM
 587         $ map   (\node
 588                   -> let count  = sizeUniqSet $ nodeConflicts node
 589                      in  (count, (count, 1)))
 590         $ eltsUFM
 591         $ graphMap graph
 592
 593
 594 -- | Set the color of a certain node
 595 setColor
 596         :: Uniquable k
 597         => k -> color
 598         -> Graph k cls color -> Graph k cls color
 599
 600 setColor u color
 601         = graphMapModify
 602         $ adjustUFM
 603                 (\n -> n { nodeColor = Just color })
 604                 u
 605
 606
 607 {-# INLINE      adjustWithDefaultUFM #-}
 608 adjustWithDefaultUFM
 609         :: Uniquable k
 610         => (a -> a) -> a -> k
 611         -> UniqFM a -> UniqFM a
 612
 613 adjustWithDefaultUFM f def k map
 614         = addToUFM_C
 615                 (\old _ -> f old)
 616                 map
 617                 k def
 618
 619 {-# INLINE adjustUFM #-}
 620 adjustUFM
 621         :: Uniquable k
 622         => (a -> a)
 623         -> k -> UniqFM a -> UniqFM a
 624
 625 adjustUFM f k map
 626  = case lookupUFM map k of
 627         Nothing -> map
 628         Just a  -> addToUFM map k (f a)
 629