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