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