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