X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=1968be4f0e6621db26a81052493ea1c031e4035f;hp=5a3401f1fdeb8cea5f6d32134a007af9b9dc0c90;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=682d5e9674ec8cf94b3af815a752fa03c9a9d6fe

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 5a3401f..1968be4 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -13,6 +13,13 @@
 --	Colors in graphviz graphs could be nicer.
 --
 
+{-# OPTIONS -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/CodingStyle#Warnings
+-- for details
+
 module RegAllocColor ( 
 	regAlloc,
 	regDotColor
@@ -27,7 +34,6 @@ import RegSpillClean
 import RegAllocStats
 import MachRegs
 import MachInstrs
-import RegCoalesce
 import PprMach
 
 import UniqSupply
@@ -100,14 +106,22 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 	let spill	= chooseSpill_maxLife fmLife
 	
 	-- try and color the graph 
-	let (graph_colored, rsSpill)	
+	let (graph_colored, rsSpill, rmCoalesce)
 			= Color.colorGraph regsFree triv spill graph
 
+	-- rewrite regs in the code that have been coalesced
+	let patchF reg	= case lookupUFM rmCoalesce reg of
+				Just reg'	-> reg'
+				Nothing		-> reg
+	let code_coalesced
+			= map (patchEraseLive patchF) code
+
+
 	-- see if we've found a coloring
 	if isEmptyUniqSet rsSpill
 	 then do
 		-- patch the registers using the info in the graph
-	 	let code_patched	= map (patchRegsFromGraph graph_colored) code
+	 	let code_patched	= map (patchRegsFromGraph graph_colored) code_coalesced
 
 		-- clean out unneeded SPILL/RELOADs
 		let code_spillclean	= map cleanSpills code_patched
@@ -123,9 +137,11 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		let stat		=
 			RegAllocStatsColored
 			{ raGraph	= graph_colored
+			, raCoalesced	= rmCoalesce
 			, raPatched	= code_patched
 			, raSpillClean	= code_spillclean
-			, raFinal	= code_final }
+			, raFinal	= code_final
+			, raSRMs	= foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 
 		return	( code_final
 			, if dump
@@ -136,7 +152,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 	 else do
 	 	-- spill the uncolored regs
 		(code_spilled, slotsFree', spillStats)
-			<- regSpill code slotsFree rsSpill
+			<- regSpill code_coalesced slotsFree rsSpill
 			
 		-- recalculate liveness
 		let code_nat	= map stripLive code_spilled
@@ -146,6 +162,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		let stat	=
 			RegAllocStatsSpill
 			{ raGraph	= graph_colored
+			, raCoalesced	= rmCoalesce
 			, raSpillStats	= spillStats
 			, raLifetimes	= fmLife
 			, raSpilled	= code_spilled }
@@ -206,16 +223,20 @@ buildGraph
 	
 buildGraph code
  = do
- 	-- Add the reg-reg conflicts to the graph
-	let conflictSets	= unionManyBags (map slurpConflicts code)
-	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictSets
+	-- Slurp out the conflicts and reg->reg moves from this code
+	let (conflictList, moveList) =
+		unzip $ map slurpConflicts code
+
+	let conflictBag		= unionManyBags conflictList
+	let moveBag		= unionManyBags moveList
 
+ 	-- Add the reg-reg conflicts to the graph
+	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
 
 	-- Add the coalescences edges to the graph.
-	let coalesce		= unionManyBags (map slurpJoinMovs code)
-	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict coalesce
+	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
 			
-	return	$ graph_coalesce
+	return	graph_coalesce
 
 
 -- | Add some conflict edges to the graph.