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