X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=27b603c2faadae70d6182b5b84041a14c7d8f630;hp=0a5c1603398a03e6702e8fc02dd62d812a0f1c69;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=3aa061857b4df40fc641ef748d5f651d664b22f2

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 0a5c160..27b603c 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -13,6 +13,13 @@
 --	Colors in graphviz graphs could be nicer.
 --
 
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module RegAllocColor ( 
 	regAlloc,
 	regDotColor
@@ -23,6 +30,7 @@ where
 import qualified GraphColor	as Color
 import RegLiveness
 import RegSpill
+import RegSpillClean
 import RegAllocStats
 import MachRegs
 import MachInstrs
@@ -50,22 +58,23 @@ maxSpinCount	= 10
 -- | The top level of the graph coloring register allocator.
 --	
 regAlloc
-	:: UniqFM (UniqSet Reg)		-- ^ the registers we can use for allocation
+	:: Bool				-- ^ whether to generate RegAllocStats, or not.
+	-> UniqFM (UniqSet Reg)		-- ^ the registers we can use for allocation
 	-> UniqSet Int			-- ^ the set of available spill slots.
 	-> [LiveCmmTop]			-- ^ code annotated with liveness information.
 	-> UniqSM 
 		( [NatCmmTop]		-- ^ code with registers allocated.
 		, [RegAllocStats] )	-- ^ stats for each stage of allocation
 		
-regAlloc regsFree slotsFree code
+regAlloc dump regsFree slotsFree code
  = do
  	(code_final, debug_codeGraphs, graph_final)
-		<- regAlloc_spin 0 trivColorable regsFree slotsFree [] code
+		<- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
 	
 	return	( code_final
 		, reverse debug_codeGraphs )
 
-regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code 
+regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
  = do
 	-- check that we're not running off down the garden path.
 	when (spinCount > maxSpinCount)
@@ -106,16 +115,30 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
 	 then do
 		-- patch the registers using the info in the graph
 	 	let code_patched	= map (patchRegsFromGraph graph_colored) code
+
+		-- clean out unneeded SPILL/RELOADs
+		let code_spillclean	= map cleanSpills code_patched
+
+		-- strip off liveness information
 		let code_nat		= map stripLive code_patched
+
+		-- rewrite SPILL/REALOAD pseudos into real instructions
+		let spillNatTop		= mapGenBlockTop spillNatBlock
+		let code_final		= map spillNatTop code_nat
 		
 		-- record what happened in this stage for debugging
 		let stat		=
 			RegAllocStatsColored
 			{ raGraph	= graph_colored
-			, raPatchedCmm	= code_patched }
-
-		return	( code_nat
-			, [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+			, raPatched	= code_patched
+			, raSpillClean	= code_spillclean
+			, raFinal	= code_final
+			, raSRMs	= foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
+
+		return	( code_final
+			, if dump
+				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+				else []
 			, graph_colored)
 
 	 else do
@@ -136,8 +159,10 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
 			, raSpilled	= code_spilled }
 			    	
 		-- try again
-		regAlloc_spin (spinCount + 1) triv regsFree slotsFree' 
-			([stat] ++ maybeToList stat1 ++ debug_codeGraphs)
+		regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
+			(if dump
+				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+				else [])
 			code_relive