GraphColor.hs 11.6 KB
Newer Older
1
{-# OPTIONS -fno-warn-missing-signatures #-}
2

Ian Lynagh's avatar
Ian Lynagh committed
3 4 5 6 7 8 9
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

10 11 12 13
-- | Graph Coloring.
--	This is a generic graph coloring library, abstracted over the type of
--	the node keys, nodes and colors.
--
14

15 16 17 18 19 20 21 22 23 24 25 26 27 28
module GraphColor ( 
	module GraphBase,
	module GraphOps,
	module GraphPpr,
	colorGraph
)

where

import GraphBase
import GraphOps
import GraphPpr

import Unique
29
import UniqFM
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
import UniqSet
import Outputable	

import Data.Maybe
import Data.List
	

-- | Try to color a graph with this set of colors.
--	Uses Chaitin's algorithm to color the graph.
--	The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
--	are pushed onto a stack and removed from the graph.
--	Once this process is complete the graph can be colored by removing nodes from
--	the stack (ie in reverse order) and assigning them colors different to their neighbors.
--
colorGraph
45 46
	:: ( Uniquable  k, Uniquable cls,  Uniquable  color
	   , Eq color, Eq cls, Ord k
47
	   , Outputable k, Outputable cls, Outputable color)
48
	=> Bool				-- ^ whether to do iterative coalescing
49
	-> Int				-- ^ how many times we've tried to color this graph so far.
50
	-> UniqFM (UniqSet color)	-- ^ map of (node class -> set of colors available for this class).
51 52 53
	-> Triv   k cls color 		-- ^ fn to decide whether a node is trivially colorable.
	-> (Graph k cls color -> k)	-- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
	-> Graph  k cls color 		-- ^ the graph to color.
54 55 56 57 58

	-> ( Graph k cls color 		-- the colored graph.
	   , UniqSet k			-- the set of nodes that we couldn't find a color for.
	   , UniqFM  k )		-- map of regs (r1 -> r2) that were coaleced
	   				--	 r1 should be replaced by r2 in the source
59

60
colorGraph iterative spinCount colors triv spill graph0
61
 = let
62 63 64 65 66 67 68 69
	-- If we're not doing iterative coalescing then do an aggressive coalescing first time
	--	around and then conservative coalescing for subsequent passes.
	--
	--	Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
	--	there is a lot of register pressure and we do it on every round then it can make the
	--	graph less colorable and prevent the algorithm from converging in a sensible number
	--	of cycles.
	--
70
	(graph_coalesced, kksCoalesce1)
71 72 73 74 75
	 = if iterative
		then (graph0, [])
		else if spinCount == 0
			then coalesceGraph True  triv graph0
			else coalesceGraph False triv graph0
76 77

 	-- run the scanner to slurp out all the trivially colorable nodes
78 79 80 81 82 83 84
	--	(and do coalescing if iterative coalescing is enabled)
  	(ksTriv, ksProblems, kksCoalesce2)
		= colorScan iterative triv spill graph_coalesced

 	-- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
	--	We need to apply all the coalescences found by the scanner to the original
	--	graph before doing assignColors.
85 86 87 88
	--
	--	Because we've got the whole, non-pruned graph here we turn on aggressive coalecing
	--	to force all the (conservative) coalescences found during scanning.
	--
89
	(graph_scan_coalesced, _)
90
		= mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
91 92
 
	-- color the trivially colorable nodes
93 94
	--	during scanning, keys of triv nodes were added to the front of the list as they were found
	--	this colors them in the reverse order, as required by the algorithm.
95
	(graph_triv, ksNoTriv)
96
		= assignColors colors graph_scan_coalesced ksTriv
97 98

 	-- try and color the problem nodes
99 100 101 102
	-- 	problem nodes are the ones that were left uncolored because they weren't triv.
	--	theres a change we can color them here anyway.
	(graph_prob, ksNoColor)
		= assignColors colors graph_triv ksProblems
103

104
	-- if the trivially colorable nodes didn't color then something is probably wrong
105
	--	with the provided triv function.
106
        --
107
   in	if not $ null ksNoTriv
108 109
   	 then	pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
	 		(  empty
110 111
			$$ text "ksTriv    = " <> ppr ksTriv
			$$ text "ksNoTriv  = " <> ppr ksNoTriv
112
			$$ text "colors    = " <> ppr colors
113
			$$ empty
114
			$$ dotGraph (\_ -> text "white") triv graph_triv) 
115 116

	 else	( graph_prob
117 118 119 120
		, mkUniqSet ksNoColor	-- the nodes that didn't color (spills)
		, if iterative
			then (listToUFM kksCoalesce2)
			else (listToUFM kksCoalesce1))
121
	
122 123 124 125 126 127 128 129 130 131 132 133 134

-- | Scan through the conflict graph separating out trivially colorable and
--	potentially uncolorable (problem) nodes.
--
--	Checking whether a node is trivially colorable or not is a resonably expensive operation,
--	so after a triv node is found and removed from the graph it's no good to return to the 'start'
--	of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
--
--	To ward against this, during each pass through the graph we collect up a list of triv nodes
--	that were found, and only remove them once we've finished the pass. The more nodes we can delete
--	at once the more likely it is that nodes we've already checked will become trivially colorable
--	for the next pass.
--
135 136 137 138
--	TODO: 	add work lists to finding triv nodes is easier.
--		If we've just scanned the graph, and removed triv nodes, then the only
--		nodes that we need to rescan are the ones we've removed edges from.

139
colorScan
140 141
	:: ( Uniquable k, Uniquable cls, Uniquable color
	   , Ord k, 	  Eq cls
142
	   , Outputable k, Outputable cls)
143 144
	=> Bool				-- ^ whether to do iterative coalescing
	-> Triv k cls color		-- ^ fn to decide whether a node is trivially colorable
145 146 147
	-> (Graph k cls color -> k)	-- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
	-> Graph k cls color		-- ^ the graph to scan

148
	-> ([k], [k], [(k, k)])		--  triv colorable nodes, problem nodes, pairs of nodes to coalesce
149

150 151
colorScan iterative triv spill graph
	= colorScan_spin iterative triv spill graph [] [] []
152

153 154
colorScan_spin iterative triv spill graph
	ksTriv ksSpill kksCoalesce
155 156 157

	-- if the graph is empty then we're done
	| isNullUFM $ graphMap graph
158
	= (ksTriv, ksSpill, reverse kksCoalesce)
159 160 161 162 163 164 165 166 167 168 169 170 171 172

	-- Simplify:
	--	Look for trivially colorable nodes.
	--	If we can find some then remove them from the graph and go back for more.
	--
	| nsTrivFound@(_:_)
		<-  scanGraph	(\node -> triv 	(nodeClass node) (nodeConflicts node) (nodeExclusions node)

				  -- for iterative coalescing we only want non-move related
				  --	nodes here
				  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
			$ graph

	, ksTrivFound	<- map nodeId nsTrivFound
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
173
	, graph2	<- foldr (\k g -> let Just g' = delNode k g
174 175 176
	   				  in  g')
				graph ksTrivFound

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
177
	= colorScan_spin iterative triv spill graph2
178
		(ksTrivFound ++ ksTriv)
179
		ksSpill
180 181 182 183
		kksCoalesce

	-- Coalesce:
	-- 	If we're doing iterative coalescing and no triv nodes are avaliable
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
184
	--	then it's time for a coalescing pass.
185 186 187 188
	| iterative
	= case coalesceGraph False triv graph of

		-- we were able to coalesce something
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
189
		--	go back to Simplify and see if this frees up more nodes to be trivially colorable.
190 191
		(graph2, kksCoalesceFound @(_:_))
		 -> colorScan_spin iterative triv spill graph2
192
			ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212

		-- Freeze:
		-- nothing could be coalesced (or was triv),
		--	time to choose a node to freeze and give up on ever coalescing it.
		(graph2, [])
		 -> case freezeOneInGraph graph2 of

			-- we were able to freeze something
			--	hopefully this will free up something for Simplify
			(graph3, True)
			 -> colorScan_spin iterative triv spill graph3
			 	ksTriv ksSpill kksCoalesce

		 	-- we couldn't find something to freeze either
			--	time for a spill
		 	(graph3, False)
			 -> colorScan_spill iterative triv spill graph3
			 	ksTriv ksSpill kksCoalesce

	-- spill time
213
	| otherwise
214 215
	= colorScan_spill iterative triv spill graph
		ksTriv ksSpill kksCoalesce
216 217


218 219 220 221 222 223 224
-- Select:
-- we couldn't find any triv nodes or things to freeze or coalesce,
--	and the graph isn't empty yet.. We'll have to choose a spill
--	candidate and leave it uncolored.
--
colorScan_spill iterative triv spill graph
	ksTriv ksSpill kksCoalesce
225

226 227
 = let	kSpill		= spill graph
 	Just graph'	= delNode kSpill graph
228 229
   in	colorScan_spin iterative triv spill graph'
   		ksTriv (kSpill : ksSpill) kksCoalesce
230 231 232 233 234
	

-- | Try to assign a color to all these nodes.

assignColors 
235 236
	:: ( Uniquable k, Uniquable cls, Uniquable color
	   , Eq color, Outputable cls)
237 238 239 240 241 242 243 244 245
	=> UniqFM (UniqSet color)	-- ^ map of (node class -> set of colors available for this class).
	-> Graph k cls color		-- ^ the graph
	-> [k]				-- ^ nodes to assign a color to.
	-> ( Graph k cls color		-- the colored graph
	   , [k])			-- the nodes that didn't color.

assignColors colors graph ks 
 	= assignColors' colors graph [] ks

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
246
 where	assignColors' _ graph prob []
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
		= (graph, prob)

	assignColors' colors graph prob (k:ks)
	 = case assignColor colors k graph of

		-- couldn't color this node
	 	Nothing		-> assignColors' colors graph (k : prob) ks

		-- this node colored ok, so do the rest
		Just graph'	-> assignColors' colors graph' prob ks


	assignColor colors u graph
		| Just c	<- selectColor colors graph u
		= Just (setColor u c graph)

		| otherwise
		= Nothing

	
	
-- | Select a color for a certain node
--	taking into account preferences, neighbors and exclusions.
--	returns Nothing if no color can be assigned to this node.
--
selectColor
273 274
	:: ( Uniquable k, Uniquable cls, Uniquable color
	   , Eq color, Outputable cls)
275 276 277 278 279 280 281 282 283 284
	=> UniqFM (UniqSet color)	-- ^ map of (node class -> set of colors available for this class).
	-> Graph k cls color		-- ^ the graph
	-> k				-- ^ key of the node to select a color for.
	-> Maybe color
	
selectColor colors graph u 
 = let	-- lookup the node
 	Just node	= lookupNode graph u

	-- lookup the available colors for the class of this node.
285 286 287 288
	colors_avail
	 = case lookupUFM colors (nodeClass node) of
	 	Nothing	-> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
		Just cs	-> cs
289

290
	-- find colors we can't use because they're already being used
291 292 293 294 295 296 297 298 299 300 301
	--	by a node that conflicts with this one.
	Just nsConflicts 	
			= sequence
			$ map (lookupNode graph)
			$ uniqSetToList 
			$ nodeConflicts node
		
	colors_conflict	= mkUniqSet 
			$ catMaybes 
			$ map nodeColor nsConflicts
	
302 303 304 305 306 307
	-- the prefs of our neighbors
	colors_neighbor_prefs
			= mkUniqSet
			$ concat $ map nodePreference nsConflicts

	-- colors that are still valid for us
308 309 310 311 312 313
	colors_ok_ex	= minusUniqSet colors_avail (nodeExclusions node)
	colors_ok	= minusUniqSet colors_ok_ex colors_conflict
				
	-- the colors that we prefer, and are still ok
	colors_ok_pref	= intersectUniqSets
				(mkUniqSet $ nodePreference node) colors_ok
314 315 316 317 318 319 320 321 322 323

	-- the colors that we could choose while being nice to our neighbors
	colors_ok_nice	= minusUniqSet
				colors_ok colors_neighbor_prefs

	-- the best of all possible worlds..
	colors_ok_pref_nice
			= intersectUniqSets
				colors_ok_nice colors_ok_pref

324 325 326
	-- make the decision
	chooseColor

327 328 329 330 331 332 333
		-- everyone is happy, yay!
		| not $ isEmptyUniqSet colors_ok_pref_nice
		, c : _		<- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
					(nodePreference node)
		= Just c

		-- we've got one of our preferences
334
		| not $ isEmptyUniqSet colors_ok_pref	
335 336
		, c : _		<- filter (\x -> elementOfUniqSet x colors_ok_pref)
					(nodePreference node)
337 338 339 340
		= Just c
		
		-- it wasn't a preference, but it was still ok
		| not $ isEmptyUniqSet colors_ok
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
341
		, c : _		<- uniqSetToList colors_ok
342 343
		= Just c
		
344 345
		-- no colors were available for us this time.
		--	looks like we're going around the loop again..
346 347 348 349 350 351 352
		| otherwise
		= Nothing
		
   in	chooseColor