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