GraphOps.hs 22.8 KB
Newer Older
1 2
-- | Basic operations on graphs.
--
3

4
module GraphOps (
5 6 7 8 9 10 11 12 13 14 15 16 17
        addNode,        delNode,        getNode,       lookupNode,     modNode,
        size,
        union,
        addConflict,    delConflict,    addConflicts,
        addCoalesce,    delCoalesce,
        addExclusion,   addExclusions,
        addPreference,
        coalesceNodes,  coalesceGraph,
        freezeNode,     freezeOneInGraph, freezeAllInGraph,
        scanGraph,
        setColor,
        validateGraph,
        slurpNodeConflictCount
18 19 20 21 22 23 24 25
)
where

import GraphBase

import Outputable
import Unique
import UniqSet
26
import UniqFM
27

28
import Data.List        hiding (union)
29 30 31
import Data.Maybe

-- | Lookup a node from the graph.
32 33 34 35
lookupNode
        :: Uniquable k
        => Graph k cls color
        -> k -> Maybe (Node  k cls color)
36

37 38
lookupNode graph k
        = lookupUFM (graphMap graph) k
39 40 41 42


-- | Get a node from the graph, throwing an error if it's not there
getNode
43 44 45
        :: Uniquable k
        => Graph k cls color
        -> k -> Node k cls color
46 47 48

getNode graph k
 = case lookupUFM (graphMap graph) k of
49 50
        Just node       -> node
        Nothing         -> panic "ColorOps.getNode: not found"
51 52 53 54


-- | Add a node to the graph, linking up its edges
addNode :: Uniquable k
55 56 57
        => k -> Node k cls color
        -> Graph k cls color -> Graph k cls color

58
addNode k node graph
59 60
 = let
        -- add back conflict edges from other nodes to this one
niteria's avatar
niteria committed
61
        map_conflict =
David Feuer's avatar
David Feuer committed
62
          nonDetFoldUniqSet
niteria's avatar
niteria committed
63 64 65 66 67 68
            -- It's OK to use nonDetFoldUFM here because the
            -- operation is commutative
            (adjustUFM_C (\n -> n { nodeConflicts =
                                      addOneToUniqSet (nodeConflicts n) k}))
            (graphMap graph)
            (nodeConflicts node)
69 70

        -- add back coalesce edges from other nodes to this one
niteria's avatar
niteria committed
71
        map_coalesce =
David Feuer's avatar
David Feuer committed
72
          nonDetFoldUniqSet
niteria's avatar
niteria committed
73 74 75 76 77 78
            -- It's OK to use nonDetFoldUFM here because the
            -- operation is commutative
            (adjustUFM_C (\n -> n { nodeCoalesce =
                                      addOneToUniqSet (nodeCoalesce n) k}))
            map_conflict
            (nodeCoalesce node)
79 80 81 82

  in    graph
        { graphMap      = addToUFM map_coalesce k node}

83 84

-- | Delete a node and all its edges from the graph.
85
delNode :: (Uniquable k)
86
        => k -> Graph k cls color -> Maybe (Graph k cls color)
87 88

delNode k graph
89 90 91
        | Just node     <- lookupNode graph k
        = let   -- delete conflict edges from other nodes to this one.
                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
David Feuer's avatar
David Feuer committed
92
                        $ nonDetEltsUniqSet (nodeConflicts node)
93 94 95

                -- delete coalesce edge from other nodes to this one.
                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
David Feuer's avatar
David Feuer committed
96
                        $ nonDetEltsUniqSet (nodeCoalesce node)
niteria's avatar
niteria committed
97
                        -- See Note [Unique Determinism and code generation]
98 99 100 101 102 103 104 105

                -- delete the node
                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2

          in    Just graph3

        | otherwise
        = Nothing
106

107

108
-- | Modify a node in the graph.
109
--      returns Nothing if the node isn't present.
110
--
111
modNode :: Uniquable k
112 113
        => (Node k cls color -> Node k cls color)
        -> k -> Graph k cls color -> Maybe (Graph k cls color)
114 115

modNode f k graph
116
 = case lookupNode graph k of
117 118 119 120 121 122 123
        Just Node{}
         -> Just
         $  graphMapModify
                 (\fm   -> let  Just node       = lookupUFM fm k
                                node'           = f node
                           in   addToUFM fm k node')
                graph
124

125
        Nothing -> Nothing
126

127

128
-- | Get the size of the graph, O(n)
129
size    :: Graph k cls color -> Int
130 131 132 133

size graph
        = sizeUFM $ graphMap graph

134 135

-- | Union two graphs together.
136
union   :: Graph k cls color -> Graph k cls color -> Graph k cls color
137 138 139 140

union   graph1 graph2
        = Graph
        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
141 142 143


-- | Add a conflict between nodes to the graph, creating the nodes required.
144
--      Conflicts are virtual regs which need to be colored differently.
145
addConflict
146 147 148
        :: Uniquable k
        => (k, cls) -> (k, cls)
        -> Graph k cls color -> Graph k cls color
149 150

addConflict (u1, c1) (u2, c2)
151 152 153 154 155 156 157 158 159 160 161
 = let  addNeighbor u c u'
                = adjustWithDefaultUFM
                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
                        (newNode u c)  { nodeConflicts = unitUniqSet u' }
                        u

   in   graphMapModify
        ( addNeighbor u1 c1 u2
        . addNeighbor u2 c2 u1)


162
-- | Delete a conflict edge. k1 -> k2
163 164 165 166 167 168
--      returns Nothing if the node isn't in the graph
delConflict
        :: Uniquable k
        => k -> k
        -> Graph k cls color -> Maybe (Graph k cls color)

169
delConflict k1 k2
170 171 172
        = modNode
                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
                k1
173 174 175


-- | Add some conflicts to the graph, creating nodes if required.
176
--      All the nodes in the set are taken to conflict with each other.
177
addConflicts
178 179 180 181
        :: Uniquable k
        => UniqSet k -> (k -> cls)
        -> Graph k cls color -> Graph k cls color

182 183
addConflicts conflicts getClass

184
        -- just a single node, but no conflicts, create the node anyway.
David Feuer's avatar
David Feuer committed
185
        | (u : [])      <- nonDetEltsUniqSet conflicts
186 187 188 189 190
        = graphMapModify
        $ adjustWithDefaultUFM
                id
                (newNode u (getClass u))
                u
191

192 193
        | otherwise
        = graphMapModify
David Feuer's avatar
David Feuer committed
194 195
        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
                $ nonDetEltsUniqSet conflicts
niteria's avatar
niteria committed
196
                -- See Note [Unique Determinism and code generation]
197 198


Ian Lynagh's avatar
Ian Lynagh committed
199 200 201 202
addConflictSet1 :: Uniquable k
                => k -> (k -> cls) -> UniqSet k
                -> UniqFM (Node k cls color)
                -> UniqFM (Node k cls color)
203
addConflictSet1 u getClass set
204 205
 = case delOneFromUniqSet set u of
    set' -> adjustWithDefaultUFM
206 207 208
                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
                (newNode u (getClass u))        { nodeConflicts = set' }
                u
209 210 211


-- | Add an exclusion to the graph, creating nodes if required.
212
--      These are extra colors that the node cannot use.
213
addExclusion
214 215 216 217 218 219 220 221 222 223
        :: (Uniquable k, Uniquable color)
        => k -> (k -> cls) -> color
        -> Graph k cls color -> Graph k cls color

addExclusion u getClass color
        = graphMapModify
        $ adjustWithDefaultUFM
                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
                u
224

225
addExclusions
226 227 228
        :: (Uniquable k, Uniquable color)
        => k -> (k -> cls) -> [color]
        -> Graph k cls color -> Graph k cls color
229 230

addExclusions u getClass colors graph
231
        = foldr (addExclusion u getClass) graph colors
232

233 234

-- | Add a coalescence edge to the graph, creating nodes if requried.
235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
--      It is considered adventageous to assign the same color to nodes in a coalesence.
addCoalesce
        :: Uniquable k
        => (k, cls) -> (k, cls)
        -> Graph k cls color -> Graph k cls color

addCoalesce (u1, c1) (u2, c2)
 = let  addCoalesce u c u'
         =      adjustWithDefaultUFM
                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }
                        u

   in   graphMapModify
        ( addCoalesce u1 c1 u2
250 251 252 253 254
        . addCoalesce u2 c2 u1)


-- | Delete a coalescence edge (k1 -> k2) from the graph.
delCoalesce
255 256 257
        :: Uniquable k
        => k -> k
        -> Graph k cls color    -> Maybe (Graph k cls color)
258 259

delCoalesce k1 k2
260 261
        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
                k1
262 263 264


-- | Add a color preference to the graph, creating nodes if required.
265 266
--      The most recently added preference is the most prefered.
--      The algorithm tries to assign a node it's prefered color if possible.
267
--
268 269 270 271 272 273 274 275 276 277 278
addPreference
        :: Uniquable k
        => (k, cls) -> color
        -> Graph k cls color -> Graph k cls color

addPreference (u, c) color
        = graphMapModify
        $ adjustWithDefaultUFM
                (\node -> node { nodePreference = color : (nodePreference node) })
                (newNode u c)  { nodePreference = [color] }
                u
279

280

281
-- | Do aggressive coalescing on this graph.
Gabor Greif's avatar
Gabor Greif committed
282
--      returns the new graph and the list of pairs of nodes that got coalesced together.
283
--      for each pair, the resulting node will have the least key and be second in the pair.
284 285
--
coalesceGraph
286 287 288 289 290 291 292 293
        :: (Uniquable k, Ord k, Eq cls, Outputable k)
        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
                                --      less colorable (aggressive coalescing)
        -> Triv k cls color
        -> Graph k cls color
        -> ( Graph k cls color
           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
                                --      coalescing was applied.
294

295
coalesceGraph aggressive triv graph
296
        = coalesceGraph' aggressive triv graph []
297

Ian Lynagh's avatar
Ian Lynagh committed
298 299 300 301 302 303 304 305
coalesceGraph'
        :: (Uniquable k, Ord k, Eq cls, Outputable k)
        => Bool
        -> Triv k cls color
        -> Graph k cls color
        -> [(k, k)]
        -> ( Graph k cls color
           , [(k, k)])
306
coalesceGraph' aggressive triv graph kkPairsAcc
307
 = let
308 309
        -- find all the nodes that have coalescence edges
        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
niteria's avatar
niteria committed
310 311
                $ nonDetEltsUFM $ graphMap graph
                -- See Note [Unique Determinism and code generation]
312 313 314 315 316 317 318 319 320

        -- build a list of pairs of keys for node's we'll try and coalesce
        --      every pair of nodes will appear twice in this list
        --      ie [(k1, k2), (k2, k1) ... ]
        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
        --      build a list of what nodes get coalesced together for later on.
        --
        cList   = [ (nodeId node1, k2)
                        | node1 <- cNodes
David Feuer's avatar
David Feuer committed
321
                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]
niteria's avatar
niteria committed
322
                        -- See Note [Unique Determinism and code generation]
323 324 325 326 327 328 329 330 331 332

        -- do the coalescing, returning the new graph and a list of pairs of keys
        --      that got coalesced together.
        (graph', mPairs)
                = mapAccumL (coalesceNodes aggressive triv) graph cList

        -- keep running until there are no more coalesces can be found
   in   case catMaybes mPairs of
         []     -> (graph', reverse kkPairsAcc)
         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
333 334


335
-- | Coalesce this pair of nodes unconditionally \/ aggressively.
336
--      The resulting node is the one with the least key.
337
--
338 339
--      returns: Just    the pair of keys if the nodes were coalesced
--                       the second element of the pair being the least one
340
--
341
--               Nothing if either of the nodes weren't in the graph
342 343

coalesceNodes
344
        :: (Uniquable k, Ord k, Eq cls)
345 346 347 348 349 350
        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
                                --      less colorable (aggressive coalescing)
        -> Triv  k cls color
        -> Graph k cls color
        -> (k, k)               -- ^ keys of the nodes to be coalesced
        -> (Graph k cls color, Maybe (k, k))
351

352
coalesceNodes aggressive triv graph (k1, k2)
353 354 355
        | (kMin, kMax)  <- if k1 < k2
                                then (k1, k2)
                                else (k2, k1)
356

357 358 359
        -- the nodes being coalesced must be in the graph
        , Just nMin     <- lookupNode graph kMin
        , Just nMax     <- lookupNode graph kMax
360

361 362 363
        -- can't coalesce conflicting modes
        , not $ elementOfUniqSet kMin (nodeConflicts nMax)
        , not $ elementOfUniqSet kMax (nodeConflicts nMin)
364

365 366
        -- can't coalesce the same node
        , nodeId nMin /= nodeId nMax
367

368
        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
369

370 371 372
        -- don't do the coalescing after all
        | otherwise
        = (graph, Nothing)
373

Ian Lynagh's avatar
Ian Lynagh committed
374
coalesceNodes_merge
375
        :: (Uniquable k, Eq cls)
Ian Lynagh's avatar
Ian Lynagh committed
376 377 378 379 380 381 382 383
        => Bool
        -> Triv  k cls color
        -> Graph k cls color
        -> k -> k
        -> Node k cls color
        -> Node k cls color
        -> (Graph k cls color, Maybe (k, k))

384
coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
385

386 387 388
        -- sanity checks
        | nodeClass nMin /= nodeClass nMax
        = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
389

390 391
        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
        = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
392

393 394 395 396 397 398 399 400
        ---
        | otherwise
        = let
                -- the new node gets all the edges from its two components
                node    =
                 Node   { nodeId                = kMin
                        , nodeClass             = nodeClass nMin
                        , nodeColor             = Nothing
401

402 403 404 405 406
                        -- nodes don't conflict with themselves..
                        , nodeConflicts
                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
                                        `delOneFromUniqSet` kMin
                                        `delOneFromUniqSet` kMax
407

408 409
                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
                        , nodePreference        = nodePreference nMin ++ nodePreference nMax
410

411 412 413 414 415 416
                        -- nodes don't coalesce with themselves..
                        , nodeCoalesce
                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
                                        `delOneFromUniqSet` kMin
                                        `delOneFromUniqSet` kMax
                        }
417

418
          in    coalesceNodes_check aggressive triv graph kMin kMax node
419

Ian Lynagh's avatar
Ian Lynagh committed
420
coalesceNodes_check
421
        :: Uniquable k
Ian Lynagh's avatar
Ian Lynagh committed
422 423 424 425 426 427 428
        => Bool
        -> Triv  k cls color
        -> Graph k cls color
        -> k -> k
        -> Node k cls color
        -> (Graph k cls color, Maybe (k, k))

429 430
coalesceNodes_check aggressive triv graph kMin kMax node

431 432 433 434 435
        -- Unless we're coalescing aggressively, if the result node is not trivially
        --      colorable then don't do the coalescing.
        | not aggressive
        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
        = (graph, Nothing)
436

437 438 439 440 441
        | otherwise
        = let -- delete the old nodes from the graph and add the new one
                Just graph1     = delNode kMax graph
                Just graph2     = delNode kMin graph1
                graph3          = addNode kMin node graph2
442

443
          in    (graph3, Just (kMax, kMin))
444

445 446

-- | Freeze a node
447 448 449 450
--      This is for the iterative coalescer.
--      By freezing a node we give up on ever coalescing it.
--      Move all its coalesce edges into the frozen set - and update
--      back edges from other nodes.
451 452
--
freezeNode
453 454 455 456
        :: Uniquable k
        => k                    -- ^ key of the node to freeze
        -> Graph k cls color    -- ^ the graph
        -> Graph k cls color    -- ^ graph with that node frozen
457 458 459 460

freezeNode k
  = graphMapModify
  $ \fm ->
461 462 463 464
    let -- freeze all the edges in the node to be frozen
        Just node = lookupUFM fm k
        node'   = node
                { nodeCoalesce          = emptyUniqSet }
465

466
        fm1     = addToUFM fm k node'
467

468 469 470 471 472 473
        -- update back edges pointing to this node
        freezeEdge k node
         = if elementOfUniqSet k (nodeCoalesce node)
                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
                else node       -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
                                -- If the edge isn't actually in the coelesce set then just ignore it.
474

David Feuer's avatar
David Feuer committed
475
        fm2     = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
niteria's avatar
niteria committed
476 477
                    -- It's OK to use nonDetFoldUFM here because the operation
                    -- is commutative
478
                        $ nodeCoalesce node
479

480
    in  fm2
481 482 483


-- | Freeze one node in the graph
484 485
--      This if for the iterative coalescer.
--      Look for a move related node of low degree and freeze it.
486
--
487 488 489 490
--      We probably don't need to scan the whole graph looking for the node of absolute
--      lowest degree. Just sample the first few and choose the one with the lowest
--      degree out of those. Also, we don't make any distinction between conflicts of different
--      classes.. this is just a heuristic, after all.
491
--
492 493
--      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
--              right here, and add it to a worklist if known triv\/non-move nodes.
494 495
--
freezeOneInGraph
496
        :: (Uniquable k)
497 498 499
        => Graph k cls color
        -> ( Graph k cls color          -- the new graph
           , Bool )                     -- whether we found a node to freeze
500 501

freezeOneInGraph graph
502 503
 = let  compareNodeDegree n1 n2
                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
504

505 506 507 508
        candidates
                = sortBy compareNodeDegree
                $ take 5        -- 5 isn't special, it's just a small number.
                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
509

510
   in   case candidates of
511

512 513
         -- there wasn't anything available to freeze
         []     -> (graph, False)
514

515 516 517 518
         -- we found something to freeze
         (n : _)
          -> ( freezeNode (nodeId n) graph
             , True)
519 520 521


-- | Freeze all the nodes in the graph
522
--      for debugging the iterative allocator.
523 524
--
freezeAllInGraph
525
        :: (Uniquable k)
526 527
        => Graph k cls color
        -> Graph k cls color
528 529

freezeAllInGraph graph
530 531
        = foldr freezeNode graph
                $ map nodeId
niteria's avatar
niteria committed
532 533
                $ nonDetEltsUFM $ graphMap graph
                -- See Note [Unique Determinism and code generation]
534 535 536 537 538


-- | Find all the nodes in the graph that meet some criteria
--
scanGraph
539
        :: (Node k cls color -> Bool)
540 541
        -> Graph k cls color
        -> [Node k cls color]
542 543

scanGraph match graph
niteria's avatar
niteria committed
544 545
        = filter match $ nonDetEltsUFM $ graphMap graph
          -- See Note [Unique Determinism and code generation]
546 547


548
-- | validate the internal structure of a graph
549 550
--      all its edges should point to valid nodes
--      If they don't then throw an error
551
--
552
validateGraph
553 554 555 556 557
        :: (Uniquable k, Outputable k, Eq color)
        => SDoc                         -- ^ extra debugging info to display on error
        -> Bool                         -- ^ whether this graph is supposed to be colored.
        -> Graph k cls color            -- ^ graph to validate
        -> Graph k cls color            -- ^ validated graph
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
558 559 560

validateGraph doc isColored graph

561 562
        -- Check that all edges point to valid nodes.
        | edges         <- unionManyUniqSets
niteria's avatar
niteria committed
563 564
                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)
                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))
565

niteria's avatar
niteria committed
566
        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph
567 568 569
        , badEdges      <- minusUniqSet edges nodes
        , not $ isEmptyUniqSet badEdges
        = pprPanic "GraphOps.validateGraph"
Gabor Greif's avatar
Gabor Greif committed
570
                (  text "Graph has edges that point to non-existent nodes"
David Feuer's avatar
David Feuer committed
571
                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)
572 573 574 575
                $$ doc )

        -- Check that no conflicting nodes have the same color
        | badNodes      <- filter (not . (checkNode graph))
niteria's avatar
niteria committed
576 577
                        $ nonDetEltsUFM $ graphMap graph
                           -- See Note [Unique Determinism and code generation]
578 579 580 581 582 583 584 585 586 587
        , not $ null badNodes
        = pprPanic "GraphOps.validateGraph"
                (  text "Node has same color as one of it's conflicts"
                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
                $$ doc)

        -- If this is supposed to be a colored graph,
        --      check that all nodes have a color.
        | isColored
        , badNodes      <- filter (\n -> isNothing $ nodeColor n)
niteria's avatar
niteria committed
588
                        $  nonDetEltsUFM $ graphMap graph
589 590 591 592 593 594 595 596 597 598
        , not $ null badNodes
        = pprPanic "GraphOps.validateGraph"
                (  text "Supposably colored graph has uncolored nodes."
                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
                $$ doc )


        -- graph looks ok
        | otherwise
        = graph
599

600

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
601
-- | If this node is colored, check that all the nodes which
602
--      conflict with it have different colors.
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
603
checkNode
604 605 606 607 608
        :: (Uniquable k, Eq color)
        => Graph k cls color
        -> Node  k cls color
        -> Bool                 -- ^ True if this node is ok

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
609
checkNode graph node
610 611
        | Just color            <- nodeColor node
        , Just neighbors        <- sequence $ map (lookupNode graph)
David Feuer's avatar
David Feuer committed
612
                                $  nonDetEltsUniqSet $ nodeConflicts node
niteria's avatar
niteria committed
613
            -- See Note [Unique Determinism and code generation]
614 615 616 617

        , neighbourColors       <- catMaybes $ map nodeColor neighbors
        , elem color neighbourColors
        = False
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
618

619 620
        | otherwise
        = True
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
621

622 623


624 625 626
-- | Slurp out a map of how many nodes had a certain number of conflict neighbours

slurpNodeConflictCount
627
        :: Graph k cls color
628
        -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
629 630

slurpNodeConflictCount graph
631 632 633 634 635 636
        = addListToUFM_C
                (\(c1, n1) (_, n2) -> (c1, n1 + n2))
                emptyUFM
        $ map   (\node
                  -> let count  = sizeUniqSet $ nodeConflicts node
                     in  (count, (count, 1)))
niteria's avatar
niteria committed
637 638
        $ nonDetEltsUFM
        -- See Note [Unique Determinism and code generation]
639
        $ graphMap graph
640 641


642
-- | Set the color of a certain node
643 644 645 646 647
setColor
        :: Uniquable k
        => k -> color
        -> Graph k cls color -> Graph k cls color

648
setColor u color
649 650 651 652 653 654 655 656 657 658 659
        = graphMapModify
        $ adjustUFM_C
                (\n -> n { nodeColor = Just color })
                u


{-# INLINE adjustWithDefaultUFM #-}
adjustWithDefaultUFM
        :: Uniquable k
        => (a -> a) -> a -> k
        -> UniqFM a -> UniqFM a
660 661

adjustWithDefaultUFM f def k map
662 663 664 665 666
        = addToUFM_C
                (\old _ -> f old)
                map
                k def

667 668
-- Argument order different from UniqFM's adjustUFM
{-# INLINE adjustUFM_C #-}
669 670 671 672
adjustUFM_C
        :: Uniquable k
        => (a -> a)
        -> k -> UniqFM a -> UniqFM a
673

674
adjustUFM_C f k map
675
 = case lookupUFM map k of
676 677
        Nothing -> map
        Just a  -> addToUFM map k (f a)
678