Main.hs 11.3 KB
Newer Older
1
{-# OPTIONS -fno-warn-missing-signatures #-}
2 3
-- | Graph coloring register allocator.
--
4
-- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer.
5
--
6

7
module RegAlloc.Graph.Main ( 
8
	regAlloc
9 10 11 12 13
) 

where

import qualified GraphColor	as Color
14
import RegAlloc.Liveness
15 16 17 18
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillClean
import RegAlloc.Graph.SpillCost
import RegAlloc.Graph.Stats
19 20 21 22 23 24
import RegAlloc.Graph.TrivColorable
import Instruction
import TargetReg
import RegClass
import Reg

25 26 27

import UniqSupply
import UniqSet
28
import UniqFM
29 30
import Bag
import Outputable
31
import DynFlags
32 33 34 35 36

import Data.List
import Data.Maybe
import Control.Monad

Ian Lynagh's avatar
Ian Lynagh committed
37
-- | The maximum number of build\/spill cycles we'll allow.
38 39 40 41 42 43 44 45 46 47
--	We should only need 3 or 4 cycles tops.
--	If we run for any longer than this we're probably in an infinite loop,
--	It's probably better just to bail out and report a bug at this stage.
maxSpinCount	:: Int
maxSpinCount	= 10


-- | The top level of the graph coloring register allocator.
--	
regAlloc
48 49
	:: (Outputable instr, Instruction instr)
	=> DynFlags
50
	-> UniqFM (UniqSet RealReg)	-- ^ the registers we can use for allocation
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
51
	-> UniqSet Int			-- ^ the set of available spill slots.
52 53
	-> [LiveCmmTop instr]		-- ^ code annotated with liveness information.
	-> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
Thomas Schilling's avatar
Thomas Schilling committed
54 55
           -- ^ code with registers allocated and stats for each stage of
           -- allocation
56
		
57
regAlloc dflags regsFree slotsFree code
58
 = do
59 60 61
	-- TODO: the regClass function is currently hard coded to the default target
	--	 architecture. Would prefer to determine this from dflags.
	--	 There are other uses of targetRegClass later in this module.
62 63 64
	let triv = trivColorable 
			targetVirtualRegSqueeze
			targetRealRegSqueeze
65

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
66
 	(code_final, debug_codeGraphs, _)
67 68 69
		<- regAlloc_spin dflags 0 
			triv
			regsFree slotsFree [] code
70 71
	
	return	( code_final
72
		, reverse debug_codeGraphs )
73

74 75 76 77 78 79 80 81
regAlloc_spin 
	dflags 
	spinCount 
	(triv 		:: Color.Triv VirtualReg RegClass RealReg)
	(regsFree 	:: UniqFM (UniqSet RealReg))
	slotsFree 
	debug_codeGraphs 
	code
82
 = do
83 84 85 86 87 88 89 90
 	-- if any of these dump flags are turned on we want to hang on to
	--	intermediate structures in the allocator - otherwise tell the
	--	allocator to ditch them early so we don't end up creating space leaks.
	let dump = or
		[ dopt Opt_D_dump_asm_regalloc_stages dflags
		, dopt Opt_D_dump_asm_stats dflags
		, dopt Opt_D_dump_asm_conflicts dflags ]

91 92 93 94 95
	-- check that we're not running off down the garden path.
	when (spinCount > maxSpinCount)
	 $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
	 	(  text "It looks like the register allocator is stuck in an infinite loop."
		$$ text "max cycles  = " <> int maxSpinCount
96
	 	$$ text "regsFree    = " <> (hcat	$ punctuate space $ map ppr
97 98 99 100
						$ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
		$$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))

 	-- build a conflict graph from the code.
101 102
	(graph	:: Color.Graph VirtualReg RegClass RealReg)
		<- {-# SCC "BuildGraph" #-} buildGraph code
103

104 105 106 107 108 109 110 111
	-- VERY IMPORTANT:
	--	We really do want the graph to be fully evaluated _before_ we start coloring.
	--	If we don't do this now then when the call to Color.colorGraph forces bits of it,
	--	the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
	--
	seqGraph graph `seq` return ()


112 113 114
	-- build a map of the cost of spilling each instruction
	--	this will only actually be computed if we have to spill something.
	let spillCosts	= foldl' plusSpillCostInfo zeroSpillCostInfo
115
			$ map slurpSpillCostInfo code
116

117 118
	-- the function to choose regs to leave uncolored
	let spill	= chooseSpill spillCosts
119

120 121 122 123 124 125
	-- record startup state
	let stat1	=
		if spinCount == 0
		 then	Just $ RegAllocStatsStart
		 	{ raLiveCmm	= code
			, raGraph	= graph
126
			, raSpillCosts	= spillCosts }
127
		 else	Nothing
128 129
	
	-- try and color the graph 
130
	let (graph_colored, rsSpill, rmCoalesce)
131 132 133
			= {-# SCC "ColorGraph" #-}
			   Color.colorGraph
			    	(dopt Opt_RegsIterative dflags)
134
				spinCount
135
			    	regsFree triv spill graph
136

137
	-- rewrite regs in the code that have been coalesced
138 139 140 141 142 143 144 145 146
	let patchF reg	
		| RegVirtual vr	<- reg
		= case lookupUFM rmCoalesce vr of
			Just vr'	-> patchF (RegVirtual vr')
			Nothing		-> reg
			
		| otherwise
		= reg

147 148
	let code_coalesced
			= map (patchEraseLive patchF) code
149 150


151 152 153
	-- see if we've found a coloring
	if isEmptyUniqSet rsSpill
	 then do
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
154 155 156 157 158 159 160 161
		-- if -fasm-lint is turned on then validate the graph
		let graph_colored_lint	=
			if dopt Opt_DoAsmLinting dflags
				then Color.validateGraph (text "")
					True 	-- require all nodes to be colored
					graph_colored
				else graph_colored

162
		-- patch the registers using the info in the graph
163
	 	let code_patched	= map (patchRegsFromGraph graph_colored_lint) code_coalesced
164

165 166 167
		-- clean out unneeded SPILL/RELOADs
		let code_spillclean	= map cleanSpills code_patched

168 169 170
		-- strip off liveness information, 
		--	and rewrite SPILL/RELOAD pseudos into real instructions along the way
		let code_final		= map stripLive code_spillclean
171

172 173
--		let spillNatTop		= mapGenBlockTop spillNatBlock
--		let code_final		= map spillNatTop code_nat
174
		
175 176 177
		-- record what happened in this stage for debugging
		let stat		=
			RegAllocStatsColored
178 179 180 181 182 183 184
			{ raGraph		= graph
			, raGraphColored	= graph_colored_lint
			, raCoalesced		= rmCoalesce
			, raPatched		= code_patched
			, raSpillClean		= code_spillclean
			, raFinal		= code_final
			, raSRMs		= foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
185

186 187 188

		let statList =
			if dump	then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
189
				else []
190 191

		-- space leak avoidance
192
		seqList statList `seq` return ()
193 194 195

		return	( code_final
			, statList
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
196
			, graph_colored_lint)
197

198
	 -- we couldn't find a coloring, time to spill something
199
	 else do
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
200 201 202 203 204 205 206 207
		-- if -fasm-lint is turned on then validate the graph
		let graph_colored_lint	=
			if dopt Opt_DoAsmLinting dflags
				then Color.validateGraph (text "")
					False 	-- don't require nodes to be colored
					graph_colored
				else graph_colored

208
	 	-- spill the uncolored regs
209
		(code_spilled, slotsFree', spillStats)
210
			<- regSpill code_coalesced slotsFree rsSpill
211

212 213 214
		-- recalculate liveness
		let code_nat	= map stripLive code_spilled
		code_relive	<- mapM regLiveness code_nat
215 216 217 218

		-- record what happened in this stage for debugging
		let stat	=
			RegAllocStatsSpill
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
219
			{ raGraph	= graph_colored_lint
220
			, raCoalesced	= rmCoalesce
221
			, raSpillStats	= spillStats
222
			, raSpillCosts	= spillCosts
223
			, raSpilled	= code_spilled }
224
			    	
225 226
		let statList =
			if dump
227
				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
228 229 230
				else []

		-- space leak avoidance
231
		seqList statList `seq` return ()
232

233
		regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
234
			statList
235 236 237 238 239 240 241
			code_relive



-- | Build a graph from the liveness and coalesce information in this code.

buildGraph 
242 243
	:: Instruction instr
	=> [LiveCmmTop instr]
244
	-> UniqSM (Color.Graph VirtualReg RegClass RealReg)
245 246 247
	
buildGraph code
 = do
248 249 250 251
	-- Slurp out the conflicts and reg->reg moves from this code
	let (conflictList, moveList) =
		unzip $ map slurpConflicts code

252 253
	-- Slurp out the spill/reload coalesces
	let moveList2		= map slurpReloadCoalesce code
254

255
 	-- Add the reg-reg conflicts to the graph
256
	let conflictBag		= unionManyBags conflictList
257
	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
258 259

	-- Add the coalescences edges to the graph.
260
	let moveBag		= unionBags (unionManyBags moveList2) (unionManyBags moveList)
261
	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
262
			
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
263
	return	graph_coalesce
264 265 266


-- | Add some conflict edges to the graph.
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
267
--	Conflicts between virtual and real regs are recorded as exclusions.
268 269 270
--
graphAddConflictSet 
	:: UniqSet Reg
271 272
	-> Color.Graph VirtualReg RegClass RealReg
	-> Color.Graph VirtualReg RegClass RealReg
273 274
	
graphAddConflictSet set graph
275 276
 = let	virtuals	= mkUniqSet 
 			[ vr | RegVirtual vr <- uniqSetToList set ]
277
 
278 279 280
	graph1	= Color.addConflicts virtuals classOfVirtualReg graph

	graph2	= foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
281
			graph1
282 283 284
			[ (vr, rr) 
				| RegVirtual vr <- uniqSetToList set
				, RegReal    rr <- uniqSetToList set]
285 286 287 288

   in	graph2
	

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
289
-- | Add some coalesence edges to the graph
290 291 292 293
--	Coalesences between virtual and real regs are recorded as preferences.
--
graphAddCoalesce 
	:: (Reg, Reg) 
294 295
	-> Color.Graph VirtualReg RegClass RealReg
	-> Color.Graph VirtualReg RegClass RealReg
296 297
	
graphAddCoalesce (r1, r2) graph
298 299 300
	| RegReal rr 		<- r1
	, RegVirtual vr 	<- r2
	= Color.addPreference (vr, classOfVirtualReg vr) rr graph
301
	
302 303 304
	| RegReal rr 		<- r2
	, RegVirtual vr		<- r1
	= Color.addPreference (vr, classOfVirtualReg vr) rr graph
305
	
306 307 308 309 310 311
	| RegVirtual vr1	<- r1
	, RegVirtual vr2	<- r2
	= Color.addCoalesce 
		(vr1, classOfVirtualReg vr1) 
		(vr2, classOfVirtualReg vr2) 
		graph
312

313 314 315 316 317 318
	-- We can't coalesce two real regs, but there could well be existing
	--	hreg,hreg moves in the input code. We'll just ignore these
	--	for coalescing purposes.
	| RegReal _		<- r1
	, RegReal _	 	<- r2
	= graph
319 320 321

graphAddCoalesce _ _
	= panic "graphAddCoalesce: bogus"
322
	
323 324 325

-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph 
326
	:: (Outputable instr, Instruction instr)
327
	=> Color.Graph VirtualReg RegClass RealReg
328
	-> LiveCmmTop instr -> LiveCmmTop instr
329 330 331 332 333 334

patchRegsFromGraph graph code
 = let
 	-- a function to lookup the hardreg for a virtual reg from the graph.
 	patchF reg
		-- leave real regs alone.
335
		| RegReal{}	<- reg
336 337 338
		= reg

		-- this virtual has a regular node in the graph.
339 340
 		| RegVirtual vr	<- reg
		, Just node	<- Color.lookupNode graph vr
341
		= case Color.nodeColor node of
342 343
			Just color	-> RegReal    color
			Nothing		-> RegVirtual vr
344 345 346 347 348 349
			
		-- no node in the graph for this virtual, bad news.
		| otherwise
		= pprPanic "patchRegsFromGraph: register mapping failed." 
			(  text "There is no node in the graph for register " <> ppr reg
			$$ ppr code
350 351 352 353 354 355
			$$ Color.dotGraph 
				(\_ -> text "white") 
				(trivColorable 
					targetVirtualRegSqueeze
					targetRealRegSqueeze)
				graph)
356

357 358 359
   in	patchEraseLive patchF code
   

360 361 362
-----
-- for when laziness just isn't what you wanted...
--
363
seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
364 365
seqGraph graph		= seqNodes (eltsUFM (Color.graphMap graph))

366
seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
367 368 369 370 371
seqNodes ns
 = case ns of
 	[]		-> ()
	(n : ns)	-> seqNode n `seq` seqNodes ns

372
seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
373
seqNode node
374 375 376 377 378 379 380 381 382
	=     seqVirtualReg	(Color.nodeId node)
	`seq` seqRegClass 	(Color.nodeClass node)
	`seq` seqMaybeRealReg 	(Color.nodeColor node)
	`seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node)))
	`seq` (seqRealRegList 	 (uniqSetToList (Color.nodeExclusions node)))
	`seq` (seqRealRegList (Color.nodePreference node))
	`seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node)))

seqVirtualReg :: VirtualReg -> ()
383
seqVirtualReg reg = reg `seq` ()
384

385
seqRealReg :: RealReg -> ()
386
seqRealReg reg = reg `seq` ()
387

388
seqRegClass :: RegClass -> ()
389
seqRegClass c = c `seq` ()
390

391 392
seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg mr
393 394
 = case mr of
 	Nothing		-> ()
395 396 397 398 399 400 401
	Just r		-> seqRealReg r

seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList rs
 = case rs of
 	[]		-> ()
	(r : rs)	-> seqVirtualReg r `seq` seqVirtualRegList rs
402

403 404
seqRealRegList :: [RealReg] -> ()
seqRealRegList rs
405 406
 = case rs of
 	[]		-> ()
407
	(r : rs)	-> seqRealReg r `seq` seqRealRegList rs
408 409 410 411 412 413 414

seqList :: [a] -> ()
seqList ls
 = case ls of
 	[]		-> ()
	(r : rs)	-> r `seq` seqList rs

415