never executed always true always false
1 -- | Graph Coloring.
2 -- This is a generic graph coloring library, abstracted over the type of
3 -- the node keys, nodes and colors.
4 --
5
6 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8
9 module GHC.Data.Graph.Color (
10 module GHC.Data.Graph.Base,
11 module GHC.Data.Graph.Ops,
12 module GHC.Data.Graph.Ppr,
13 colorGraph
14 )
15
16 where
17
18 import GHC.Prelude
19
20 import GHC.Data.Graph.Base
21 import GHC.Data.Graph.Ops
22 import GHC.Data.Graph.Ppr
23
24 import GHC.Types.Unique
25 import GHC.Types.Unique.FM
26 import GHC.Types.Unique.Set
27 import GHC.Utils.Outputable
28 import GHC.Utils.Panic
29
30 import Data.Maybe
31 import Data.List (mapAccumL)
32
33
34 -- | Try to color a graph with this set of colors.
35 -- Uses Chaitin's algorithm to color the graph.
36 -- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
37 -- are pushed onto a stack and removed from the graph.
38 -- Once this process is complete the graph can be colored by removing nodes from
39 -- the stack (ie in reverse order) and assigning them colors different to their neighbors.
40 --
41 colorGraph
42 :: forall k cls color.
43 ( Uniquable k, Uniquable cls, Uniquable color
44 , Eq cls, Ord k
45 , Outputable k, Outputable cls, Outputable color)
46 => Bool -- ^ whether to do iterative coalescing
47 -> Int -- ^ how many times we've tried to color this graph so far.
48 -> UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
49 -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable.
50 -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
51 -> Graph k cls color -- ^ the graph to color.
52
53 -> ( Graph k cls color -- the colored graph.
54 , UniqSet k -- the set of nodes that we couldn't find a color for.
55 , UniqFM k k ) -- map of regs (r1 -> r2) that were coalesced
56 -- r1 should be replaced by r2 in the source
57
58 colorGraph iterative spinCount colors triv spill graph0
59 = let
60 -- If we're not doing iterative coalescing then do an aggressive coalescing first time
61 -- around and then conservative coalescing for subsequent passes.
62 --
63 -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
64 -- there is a lot of register pressure and we do it on every round then it can make the
65 -- graph less colorable and prevent the algorithm from converging in a sensible number
66 -- of cycles.
67 --
68 (graph_coalesced, kksCoalesce1)
69 = if iterative
70 then (graph0, [])
71 else if spinCount == 0
72 then coalesceGraph True triv graph0
73 else coalesceGraph False triv graph0
74
75 -- run the scanner to slurp out all the trivially colorable nodes
76 -- (and do coalescing if iterative coalescing is enabled)
77 (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)])
78 = colorScan iterative triv spill graph_coalesced
79
80 -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
81 -- We need to apply all the coalescences found by the scanner to the original
82 -- graph before doing assignColors.
83 --
84 -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing
85 -- to force all the (conservative) coalescences found during scanning.
86 --
87 (graph_scan_coalesced, _)
88 = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
89
90 -- color the trivially colorable nodes
91 -- during scanning, keys of triv nodes were added to the front of the list as they were found
92 -- this colors them in the reverse order, as required by the algorithm.
93 (graph_triv, ksNoTriv)
94 = assignColors colors graph_scan_coalesced ksTriv
95
96 -- try and color the problem nodes
97 -- problem nodes are the ones that were left uncolored because they weren't triv.
98 -- theres a change we can color them here anyway.
99 (graph_prob, ksNoColor)
100 = assignColors colors graph_triv ksProblems
101
102 -- if the trivially colorable nodes didn't color then something is probably wrong
103 -- with the provided triv function.
104 --
105 in if not $ null ksNoTriv
106 then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
107 ( empty
108 $$ text "ksTriv = " <> ppr ksTriv
109 $$ text "ksNoTriv = " <> ppr ksNoTriv
110 $$ text "colors = " <> ppr colors
111 $$ empty
112 $$ dotGraph (\_ -> text "white") triv graph_triv)
113
114 else ( graph_prob
115 , mkUniqSet ksNoColor -- the nodes that didn't color (spills)
116 , if iterative
117 then (listToUFM kksCoalesce2)
118 else (listToUFM kksCoalesce1))
119
120
121 -- | Scan through the conflict graph separating out trivially colorable and
122 -- potentially uncolorable (problem) nodes.
123 --
124 -- Checking whether a node is trivially colorable or not is a reasonably expensive operation,
125 -- so after a triv node is found and removed from the graph it's no good to return to the 'start'
126 -- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
127 --
128 -- To ward against this, during each pass through the graph we collect up a list of triv nodes
129 -- that were found, and only remove them once we've finished the pass. The more nodes we can delete
130 -- at once the more likely it is that nodes we've already checked will become trivially colorable
131 -- for the next pass.
132 --
133 -- TODO: add work lists to finding triv nodes is easier.
134 -- If we've just scanned the graph, and removed triv nodes, then the only
135 -- nodes that we need to rescan are the ones we've removed edges from.
136
137 colorScan
138 :: ( Uniquable k, Uniquable cls, Uniquable color
139 , Ord k, Eq cls
140 , Outputable k, Outputable cls)
141 => Bool -- ^ whether to do iterative coalescing
142 -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable
143 -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
144 -> Graph k cls color -- ^ the graph to scan
145
146 -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce
147
148 colorScan iterative triv spill graph
149 = colorScan_spin iterative triv spill graph [] [] []
150
151 colorScan_spin
152 :: ( Uniquable k, Uniquable cls, Uniquable color
153 , Ord k, Eq cls
154 , Outputable k, Outputable cls)
155 => Bool
156 -> Triv k cls color
157 -> (Graph k cls color -> k)
158 -> Graph k cls color
159 -> [k]
160 -> [k]
161 -> [(k, k)]
162 -> ([k], [k], [(k, k)])
163
164 colorScan_spin iterative triv spill graph
165 ksTriv ksSpill kksCoalesce
166
167 -- if the graph is empty then we're done
168 | isNullUFM $ graphMap graph
169 = (ksTriv, ksSpill, reverse kksCoalesce)
170
171 -- Simplify:
172 -- Look for trivially colorable nodes.
173 -- If we can find some then remove them from the graph and go back for more.
174 --
175 | nsTrivFound@(_:_)
176 <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
177
178 -- for iterative coalescing we only want non-move related
179 -- nodes here
180 && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
181 $ graph
182
183 , ksTrivFound <- map nodeId nsTrivFound
184 , graph2 <- foldr (\k g -> let Just g' = delNode k g
185 in g')
186 graph ksTrivFound
187
188 = colorScan_spin iterative triv spill graph2
189 (ksTrivFound ++ ksTriv)
190 ksSpill
191 kksCoalesce
192
193 -- Coalesce:
194 -- If we're doing iterative coalescing and no triv nodes are available
195 -- then it's time for a coalescing pass.
196 | iterative
197 = case coalesceGraph False triv graph of
198
199 -- we were able to coalesce something
200 -- go back to Simplify and see if this frees up more nodes to be trivially colorable.
201 (graph2, kksCoalesceFound@(_:_))
202 -> colorScan_spin iterative triv spill graph2
203 ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
204
205 -- Freeze:
206 -- nothing could be coalesced (or was triv),
207 -- time to choose a node to freeze and give up on ever coalescing it.
208 (graph2, [])
209 -> case freezeOneInGraph graph2 of
210
211 -- we were able to freeze something
212 -- hopefully this will free up something for Simplify
213 (graph3, True)
214 -> colorScan_spin iterative triv spill graph3
215 ksTriv ksSpill kksCoalesce
216
217 -- we couldn't find something to freeze either
218 -- time for a spill
219 (graph3, False)
220 -> colorScan_spill iterative triv spill graph3
221 ksTriv ksSpill kksCoalesce
222
223 -- spill time
224 | otherwise
225 = colorScan_spill iterative triv spill graph
226 ksTriv ksSpill kksCoalesce
227
228
229 -- Select:
230 -- we couldn't find any triv nodes or things to freeze or coalesce,
231 -- and the graph isn't empty yet.. We'll have to choose a spill
232 -- candidate and leave it uncolored.
233 --
234 colorScan_spill
235 :: ( Uniquable k, Uniquable cls, Uniquable color
236 , Ord k, Eq cls
237 , Outputable k, Outputable cls)
238 => Bool
239 -> Triv k cls color
240 -> (Graph k cls color -> k)
241 -> Graph k cls color
242 -> [k]
243 -> [k]
244 -> [(k, k)]
245 -> ([k], [k], [(k, k)])
246
247 colorScan_spill iterative triv spill graph
248 ksTriv ksSpill kksCoalesce
249
250 = let kSpill = spill graph
251 Just graph' = delNode kSpill graph
252 in colorScan_spin iterative triv spill graph'
253 ksTriv (kSpill : ksSpill) kksCoalesce
254
255
256 -- | Try to assign a color to all these nodes.
257
258 assignColors
259 :: forall k cls color.
260 ( Uniquable k, Uniquable cls, Uniquable color
261 , Outputable cls)
262 => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
263 -> Graph k cls color -- ^ the graph
264 -> [k] -- ^ nodes to assign a color to.
265 -> ( Graph k cls color -- the colored graph
266 , [k]) -- the nodes that didn't color.
267
268 assignColors colors graph ks
269 = assignColors' colors graph [] ks
270
271 where assignColors' :: UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
272 -> Graph k cls color -- ^ the graph
273 -> [k] -- ^ nodes to assign a color to.
274 -> [k]
275 -> ( Graph k cls color -- the colored graph
276 , [k])
277 assignColors' _ graph prob []
278 = (graph, prob)
279
280 assignColors' colors graph prob (k:ks)
281 = case assignColor colors k graph of
282
283 -- couldn't color this node
284 Nothing -> assignColors' colors graph (k : prob) ks
285
286 -- this node colored ok, so do the rest
287 Just graph' -> assignColors' colors graph' prob ks
288
289
290 assignColor colors u graph
291 | Just c <- selectColor colors graph u
292 = Just (setColor u c graph)
293
294 | otherwise
295 = Nothing
296
297
298
299 -- | Select a color for a certain node
300 -- taking into account preferences, neighbors and exclusions.
301 -- returns Nothing if no color can be assigned to this node.
302 --
303 selectColor
304 :: ( Uniquable k, Uniquable cls, Uniquable color
305 , Outputable cls)
306 => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
307 -> Graph k cls color -- ^ the graph
308 -> k -- ^ key of the node to select a color for.
309 -> Maybe color
310
311 selectColor colors graph u
312 = let -- lookup the node
313 Just node = lookupNode graph u
314
315 -- lookup the available colors for the class of this node.
316 colors_avail
317 = case lookupUFM colors (nodeClass node) of
318 Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
319 Just cs -> cs
320
321 -- find colors we can't use because they're already being used
322 -- by a node that conflicts with this one.
323 Just nsConflicts
324 = sequence
325 $ map (lookupNode graph)
326 $ nonDetEltsUniqSet
327 $ nodeConflicts node
328 -- See Note [Unique Determinism and code generation]
329
330 colors_conflict = mkUniqSet
331 $ catMaybes
332 $ map nodeColor nsConflicts
333
334 -- the prefs of our neighbors
335 colors_neighbor_prefs
336 = mkUniqSet
337 $ concatMap nodePreference nsConflicts
338
339 -- colors that are still valid for us
340 colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node)
341 colors_ok = minusUniqSet colors_ok_ex colors_conflict
342
343 -- the colors that we prefer, and are still ok
344 colors_ok_pref = intersectUniqSets
345 (mkUniqSet $ nodePreference node) colors_ok
346
347 -- the colors that we could choose while being nice to our neighbors
348 colors_ok_nice = minusUniqSet
349 colors_ok colors_neighbor_prefs
350
351 -- the best of all possible worlds..
352 colors_ok_pref_nice
353 = intersectUniqSets
354 colors_ok_nice colors_ok_pref
355
356 -- make the decision
357 chooseColor
358
359 -- everyone is happy, yay!
360 | not $ isEmptyUniqSet colors_ok_pref_nice
361 , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
362 (nodePreference node)
363 = Just c
364
365 -- we've got one of our preferences
366 | not $ isEmptyUniqSet colors_ok_pref
367 , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref)
368 (nodePreference node)
369 = Just c
370
371 -- it wasn't a preference, but it was still ok
372 | not $ isEmptyUniqSet colors_ok
373 , c : _ <- nonDetEltsUniqSet colors_ok
374 -- See Note [Unique Determinism and code generation]
375 = Just c
376
377 -- no colors were available for us this time.
378 -- looks like we're going around the loop again..
379 | otherwise
380 = Nothing
381
382 in chooseColor
383
384
385