X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=a2b98f1f6a31e32bc71dfac6ed57013f81a930de;hb=295d2a0018243d94a7bd4e72d88d056db32ff3cf;hp=45e51b927fd44eb2665c0097b33140da44d5916a;hpb=b7f448a4ebb2b924f279bf49432f07338f41a764;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 45e51b9..a2b98f1 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -27,6 +27,7 @@ import UniqSet
 import UniqFM
 import Bag
 import Outputable
+import DynFlags
 
 import Data.List
 import Data.Maybe
@@ -43,7 +44,7 @@ maxSpinCount	= 10
 -- | The top level of the graph coloring register allocator.
 --	
 regAlloc
-	:: Bool				-- ^ whether to generate RegAllocStats, or not.
+	:: DynFlags
 	-> UniqFM (UniqSet Reg)		-- ^ the registers we can use for allocation
 	-> UniqSet Int			-- ^ the set of available spill slots.
 	-> [LiveCmmTop]			-- ^ code annotated with liveness information.
@@ -51,16 +52,25 @@ regAlloc
 		( [NatCmmTop]		-- ^ code with registers allocated.
 		, [RegAllocStats] )	-- ^ stats for each stage of allocation
 		
-regAlloc dump regsFree slotsFree code
+regAlloc dflags regsFree slotsFree code
  = do
  	(code_final, debug_codeGraphs, _)
-		<- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
+		<- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
 	
 	return	( code_final
 		, reverse debug_codeGraphs )
 
-regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
+regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
  = do
+ 	-- 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 ]
+
+
 	-- check that we're not running off down the garden path.
 	when (spinCount > maxSpinCount)
 	 $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
@@ -102,11 +112,14 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 	
 	-- try and color the graph 
 	let (graph_colored, rsSpill, rmCoalesce)
-			= {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph
+			= {-# SCC "ColorGraph" #-}
+			   Color.colorGraph
+			    	(dopt Opt_RegsIterative dflags)
+			    	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
@@ -122,7 +135,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		let code_spillclean	= map cleanSpills code_patched
 
 		-- strip off liveness information
-		let code_nat		= map stripLive code_patched
+		let code_nat		= map stripLive code_spillclean
 
 		-- rewrite SPILL/RELOAD pseudos into real instructions
 		let spillNatTop		= mapGenBlockTop spillNatBlock
@@ -176,7 +189,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		-- space leak avoidance
 		seqList statList `seq` return ()
 
-		regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
+		regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
 			statList
 			code_relive
 
@@ -233,16 +246,18 @@ 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
+	return	$ Color.validateGraph (text "urk") graph_coalesce
 
 
 -- | Add some conflict edges to the graph.
@@ -313,7 +328,7 @@ 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