X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=933c8ab5d59696fe8fa12e926c52b5db696d378d;hp=6a71412bcfa152c34ac5bdbcc308825ec1c4a9f6;hb=f0d0e9d63ee27a12e80b6f069be5e9d4b55ca545;hpb=ca9e6d1e1d759fd20f23e6ab24859b812991fca7

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 6a71412..933c8ab 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -20,11 +20,10 @@ module RegAllocColor (
 
 where
 
-#include "nativeGen/NCG.h"
-
 import qualified GraphColor	as Color
 import RegLiveness
 import RegSpill
+import RegAllocStats
 import MachRegs
 import MachInstrs
 import RegCoalesce
@@ -56,8 +55,7 @@ regAlloc
 	-> [LiveCmmTop]					-- ^ code annotated with liveness information.
 	-> UniqSM 
 		( [NatCmmTop]				-- ^ code with registers allocated.
-		, [ ( [LiveCmmTop]
-		    , Color.Graph Reg RegClass Reg) ])	-- ^ code and graph for each pass
+		, [RegAllocStats] )			-- ^ stats for each stage of allocation
 		
 regAlloc regsFree slotsFree code
  = do
@@ -100,22 +98,36 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
 	 	let code_patched	= map (patchRegsFromGraph graph_colored) code
 		let code_nat		= map stripLive code_patched
 		
+		-- record what happened in this stage for debugging
+		let stat		=
+			RegAllocStatsColored
+			{ raLiveCmm	= code
+			, raGraph	= graph_colored
+			, raPatchedCmm	= code_patched }
+
 		return	( code_nat
-			, debug_codeGraphs ++ [(code, graph_colored), (code_patched, graph_colored)]
+			, debug_codeGraphs ++ [stat]
 			, graph_colored)
 
 	 else do
 	 	-- spill the uncolored regs
-		(code_spilled, slotsFree')
+		(code_spilled, slotsFree', spillStats)
 			<- regSpill code slotsFree rsSpill
 			
 		-- recalculate liveness
 		let code_nat	= map stripLive code_spilled
 		code_relive	<- mapM regLiveness code_nat
+
+		-- record what happened in this stage for debugging
+		let stat	=
+			RegAllocStatsSpill
+			{ raLiveCmm	= code_spilled
+			, raGraph	= graph_colored
+			, raSpillStats	= spillStats }
 			    	
 		-- try again
 		regAlloc_spin (spinCount + 1) triv regsFree slotsFree' 
-			(debug_codeGraphs ++ [(code, graph_colored)])
+			(debug_codeGraphs ++ [stat])
 			code_relive
 
  
@@ -251,81 +263,6 @@ patchRegsFromGraph graph code
    in	patchEraseLive patchF code
    
 
------
--- Register colors for drawing conflict graphs
---	Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
-
-
--- reg colors for x86
-#if i386_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = let	Just	str	= lookupUFM regColors reg
-   in	text str
-
-regColors 
- = listToUFM
- $  	[ (eax,	"#00ff00")
-	, (ebx,	"#0000ff")
-	, (ecx,	"#00ffff")
-	, (edx,	"#0080ff")
-	
-	, (fake0, "#ff00ff")
-	, (fake1, "#ff00aa")
-	, (fake2, "#aa00ff")
-	, (fake3, "#aa00aa")
-	, (fake4, "#ff0055")
-	, (fake5, "#5500ff") ]
-#endif 
-
-
--- reg colors for x86_64 
-#if x86_64_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = let	Just	str	= lookupUFM regColors reg
-   in	text str
-
-regColors
- = listToUFM
- $	[ (rax, "#00ff00"), (eax, "#00ff00")
-	, (rbx,	"#0000ff"), (ebx, "#0000ff")
-	, (rcx,	"#00ffff"), (ecx, "#00ffff")
-	, (rdx,	"#0080ff"), (edx, "#00ffff")
-	, (r8,  "#00ff80")
-	, (r9,  "#008080")
-	, (r10, "#0040ff")
-	, (r11, "#00ff40")
-	, (r12, "#008040")
-	, (r13, "#004080")
-	, (r14, "#004040")
-	, (r15, "#002080") ]
-	
-	++ zip (map RealReg [16..31]) (repeat "red")
-#endif
-
-
--- reg colors for ppc
-#if powerpc_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = case regClass reg of
- 	RcInteger	-> text "blue"
-	RcFloat		-> text "red"
-#endif
-
-
-{-
-toX11Color (r, g, b)
- = let	rs	= padL 2 '0' (showHex r "")
- 	gs	= padL 2 '0' (showHex r "")
-	bs	= padL 2 '0' (showHex r "")
-
-	padL n c s
-		= replicate (n - length s) c ++ s
-  in	"#" ++ rs ++ gs ++ bs
--}
-
 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 plusUFMs_C f maps
 	= foldl (plusUFM_C f) emptyUFM maps