X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FGraph%2FMain.hs;h=cdbe98755acf48e3a1952bb997911b94a1b5d850;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hp=94b18aeb0a1b7bb0950504b56833001dfb016e7f;hpb=f9288086f935c97812b2d80defcff38baf7b6a6c;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index 94b18ae..cdbe987 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -11,7 +11,6 @@ module RegAlloc.Graph.Main (
 where
 
 import qualified GraphColor	as Color
-import qualified GraphBase	as Color
 import RegAlloc.Liveness
 import RegAlloc.Graph.Spill
 import RegAlloc.Graph.SpillClean
@@ -44,7 +43,6 @@ maxSpinCount	= 10
 
 
 -- | The top level of the graph coloring register allocator.
---	
 regAlloc
 	:: (Outputable instr, Instruction instr)
 	=> DynFlags
@@ -170,15 +168,14 @@ regAlloc_spin
 		--	and rewrite SPILL/RELOAD pseudos into real instructions along the way
 		let code_final		= map stripLive code_spillclean
 
---		let spillNatTop		= mapGenBlockTop spillNatBlock
---		let code_final		= map spillNatTop code_nat
-		
 		-- record what happened in this stage for debugging
 		let stat		=
 			RegAllocStatsColored
-			{ raGraph		= graph
+			{ raCode		= code
+			, raGraph		= graph
 			, raGraphColored	= graph_colored_lint
 			, raCoalesced		= rmCoalesce
+			, raCodeCoalesced	= code_coalesced
 			, raPatched		= code_patched
 			, raSpillClean		= code_spillclean
 			, raFinal		= code_final
@@ -211,13 +208,16 @@ regAlloc_spin
 			<- regSpill code_coalesced slotsFree rsSpill
 
 		-- recalculate liveness
-		let code_nat	= map stripLive code_spilled
-		code_relive	<- mapM regLiveness code_nat
+		-- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency
+		--       order required by computeLiveness. If they're not in the correct order
+		--       that function will panic.
+		code_relive	<- mapM (regLiveness . reverseBlocksInTops) code_spilled
 
 		-- record what happened in this stage for debugging
 		let stat	=
 			RegAllocStatsSpill
-			{ raGraph	= graph_colored_lint
+			{ raCode	= code
+			, raGraph	= graph_colored_lint
 			, raCoalesced	= rmCoalesce
 			, raSpillStats	= spillStats
 			, raSpillCosts	= spillCosts
@@ -236,9 +236,7 @@ regAlloc_spin
 			code_relive
 
 
-
 -- | Build a graph from the liveness and coalesce information in this code.
-
 buildGraph 
 	:: Instruction instr
 	=> [LiveCmmTop instr]
@@ -266,7 +264,6 @@ buildGraph code
 
 -- | Add some conflict edges to the graph.
 --	Conflicts between virtual and real regs are recorded as exclusions.
---
 graphAddConflictSet 
 	:: UniqSet Reg
 	-> Color.Graph VirtualReg RegClass RealReg
@@ -289,7 +286,6 @@ graphAddConflictSet set graph
 
 -- | Add some coalesence edges to the graph
 --	Coalesences between virtual and real regs are recorded as preferences.
---
 graphAddCoalesce 
 	:: (Reg, Reg) 
 	-> Color.Graph VirtualReg RegClass RealReg
@@ -311,9 +307,16 @@ graphAddCoalesce (r1, r2) graph
 		(vr2, classOfVirtualReg vr2) 
 		graph
 
-	| otherwise
-	= panic "RegAlloc.Graph.Main.graphAddCoalesce: can't coalesce two real regs"
+	-- 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
 
+graphAddCoalesce _ _
+	= panic "graphAddCoalesce: bogus"
+	
 
 -- | Patch registers in code using the reg -> reg mapping in this graph.
 patchRegsFromGraph 
@@ -374,25 +377,13 @@ seqNode node
 	`seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node)))
 
 seqVirtualReg :: VirtualReg -> ()
-seqVirtualReg reg
- = case reg of
-	VirtualRegI _	-> ()
-	VirtualRegHi _	-> ()
-	VirtualRegF _	-> ()
-	VirtualRegD _	-> ()
+seqVirtualReg reg = reg `seq` ()
 
 seqRealReg :: RealReg -> ()
-seqRealReg reg
- = case reg of
- 	RealRegSingle _ -> ()
-	RealRegPair _ _	-> ()
+seqRealReg reg = reg `seq` ()
 
 seqRegClass :: RegClass -> ()
-seqRegClass c
- = case c of
- 	RcInteger	-> ()
-	RcFloat		-> ()
-	RcDouble	-> ()
+seqRegClass c = c `seq` ()
 
 seqMaybeRealReg :: Maybe RealReg -> ()
 seqMaybeRealReg mr