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