X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=21d7ed1d758d81db8cd728ca2f3e4943e0be5958;hb=fff4dee0483eda0b675057f8259a161ff16467f4;hp=271c1a5ebcdbb976369383557d9b491293002bd3;hpb=a12bf21a5e9c2b7888cd0ed0c60b9ec1e7295df1;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 271c1a5..21d7ed1 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -1,8 +1,6 @@
 -- | Graph coloring register allocator.
 --
--- TODO:
---	The function that choosing the potential spills could be a bit cleverer.
---	Colors in graphviz graphs could be nicer.
+-- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer.
 --
 {-# OPTIONS -fno-warn-missing-signatures #-}
 
@@ -17,7 +15,9 @@ import qualified GraphColor	as Color
 import RegLiveness
 import RegSpill
 import RegSpillClean
+import RegSpillCost
 import RegAllocStats
+-- import RegCoalesce
 import MachRegs
 import MachInstrs
 import PprMach
@@ -70,7 +70,6 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 		, dopt Opt_D_dump_asm_stats dflags
 		, dopt Opt_D_dump_asm_conflicts dflags ]
 
-
 	-- check that we're not running off down the garden path.
 	when (spinCount > maxSpinCount)
 	 $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
@@ -91,11 +90,13 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 	seqGraph graph `seq` return ()
 
 
-	-- build a map of how many instructions each reg lives for.
-	--	this is lazy, it won't be computed unless we need to spill
+	-- 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
+			$ map slurpSpillCostInfo code
 
-	let fmLife	= {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
-			$ map lifetimeCount code
+	-- the function to choose regs to leave uncolored
+	let spill	= chooseSpill spillCosts
 
 	-- record startup state
 	let stat1	=
@@ -103,23 +104,20 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 		 then	Just $ RegAllocStatsStart
 		 	{ raLiveCmm	= code
 			, raGraph	= graph
-			, raLifetimes	= fmLife }
+			, raSpillCosts	= spillCosts }
 		 else	Nothing
-
-
-	-- the function to choose regs to leave uncolored
-	let spill	= chooseSpill_maxLife fmLife
 	
 	-- try and color the graph 
 	let (graph_colored, rsSpill, rmCoalesce)
 			= {-# SCC "ColorGraph" #-}
 			   Color.colorGraph
 			    	(dopt Opt_RegsIterative dflags)
+				spinCount
 			    	regsFree triv spill graph
 
 	-- rewrite regs in the code that have been coalesced
 	let patchF reg	= case lookupUFM rmCoalesce reg of
-				Just reg'	-> reg'
+				Just reg'	-> patchF reg'
 				Nothing		-> reg
 	let code_coalesced
 			= map (patchEraseLive patchF) code
@@ -128,8 +126,16 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 	-- see if we've found a coloring
 	if isEmptyUniqSet rsSpill
 	 then do
+		-- 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
+
 		-- patch the registers using the info in the graph
-	 	let code_patched	= map (patchRegsFromGraph graph_colored) code_coalesced
+	 	let code_patched	= map (patchRegsFromGraph graph_colored_lint) code_coalesced
 
 		-- clean out unneeded SPILL/RELOADs
 		let code_spillclean	= map cleanSpills code_patched
@@ -144,12 +150,13 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 		-- record what happened in this stage for debugging
 		let stat		=
 			RegAllocStatsColored
-			{ raGraph	= graph_colored
-			, raCoalesced	= rmCoalesce
-			, raPatched	= code_patched
-			, raSpillClean	= code_spillclean
-			, raFinal	= code_final
-			, raSRMs	= foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
+			{ 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 }
 
 
 		let statList =
@@ -161,9 +168,18 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 
 		return	( code_final
 			, statList
-			, graph_colored)
+			, graph_colored_lint)
 
+	 -- we couldn't find a coloring, time to spill something
 	 else do
+		-- 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
+
 	 	-- spill the uncolored regs
 		(code_spilled, slotsFree', spillStats)
 			<- regSpill code_coalesced slotsFree rsSpill
@@ -175,10 +191,10 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 		-- record what happened in this stage for debugging
 		let stat	=
 			RegAllocStatsSpill
-			{ raGraph	= graph_colored
+			{ raGraph	= graph_colored_lint
 			, raCoalesced	= rmCoalesce
 			, raSpillStats	= spillStats
-			, raLifetimes	= fmLife
+			, raSpillCosts	= spillCosts
 			, raSpilled	= code_spilled }
 			    	
 		let statList =
@@ -193,46 +209,7 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 			statList
 			code_relive
 
- 
------
--- Simple maxconflicts isn't always good, because we
---	can naievely end up spilling vregs that only live for one or two instrs.
---	
-{-
-chooseSpill_maxConflicts
-	:: Color.Graph Reg RegClass Reg
-	-> Reg
-	
-chooseSpill_maxConflicts graph
- = let	node	= maximumBy 
- 			(\n1 n2 -> compare 
- 				(sizeUniqSet $ Color.nodeConflicts n1) 
-				(sizeUniqSet $ Color.nodeConflicts n2))
- 		$ eltsUFM $ Color.graphMap graph
-		
-   in	Color.nodeId node
--} 
-   
------
-chooseSpill_maxLife
-	:: UniqFM (Reg, Int)
-	-> Color.Graph Reg RegClass Reg
-	-> Reg
-
-chooseSpill_maxLife life graph
- = let	node	= maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
-		$ eltsUFM $ Color.graphMap graph
-
-	-- Orphan vregs die in the same instruction they are born in.
-	--	They will be in the graph, but not in the liveness map.
-	--	Their liveness is 0.
-	getLife n
-	 = case lookupUFM life (Color.nodeId n) of
-	 	Just (_, l)	-> l
-		Nothing		-> 0
 
-   in	Color.nodeId node
-   
 
 -- | Build a graph from the liveness and coalesce information in this code.
 
@@ -246,13 +223,15 @@ buildGraph code
 	let (conflictList, moveList) =
 		unzip $ map slurpConflicts code
 
-	let conflictBag		= unionManyBags conflictList
-	let moveBag		= unionManyBags moveList
+	-- Slurp out the spill/reload coalesces
+	let moveList2		= map slurpReloadCoalesce code
 
  	-- Add the reg-reg conflicts to the graph
+	let conflictBag		= unionManyBags conflictList
 	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
 
 	-- Add the coalescences edges to the graph.
+	let moveBag		= unionBags (unionManyBags moveList2) (unionManyBags moveList)
 	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
 			
 	return	graph_coalesce
@@ -326,15 +305,10 @@ patchRegsFromGraph graph code
 			(  text "There is no node in the graph for register " <> ppr reg
 			$$ ppr code
 			$$ Color.dotGraph (\_ -> text "white") trivColorable graph)
-	
+
    in	patchEraseLive patchF code
    
 
-plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
-plusUFMs_C f maps
-	= foldl' (plusUFM_C f) emptyUFM maps
-
-
 -----
 -- for when laziness just isn't what you wanted...
 --