From eeea62298b2ee975f84f1d50c71ac458ffb7c6a4 Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Fri, 24 Aug 2007 10:13:05 +0000
Subject: [PATCH] Be more paranoid about not creating space leaks in coloring
 allocator

---
 compiler/nativeGen/AsmCodeGen.lhs   |   10 ++++++++++
 compiler/nativeGen/RegAllocColor.hs |   19 ++++++++++++-------
 2 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index c606918..38c28b4 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -227,14 +227,24 @@ cmmNativeGen dflags us cmm
 			Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
 			(vcat $ map ppr coalesced)
 
+	 	-- if any of these dump flags are turned on we want to hang on to
+		--	intermediate structures in the allocator - otherwise ditch
+		--	them early so we don't end up creating space leaks.
+		let generateRegAllocStats = or
+			[ dopt Opt_D_dump_asm_regalloc_stages dflags
+			, dopt Opt_D_dump_asm_stats dflags
+			, dopt Opt_D_dump_asm_conflicts dflags ]
+
 		-- graph coloring register allocation
 		let ((alloced, regAllocStats), usAlloc)
 			= initUs usCoalesce
 			$ Color.regAlloc
+				generateRegAllocStats
 				alloc_regs
 				(mkUniqSet [0..maxSpillSlots])
 				coalesced
 
+		-- dump out what happened during register allocation
 		dumpIfSet_dyn dflags
 			Opt_D_dump_asm_regalloc "Registers allocated"
 			(vcat $ map (docToSDoc . pprNatCmmTop) alloced)
diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index ecb5faf..45727c5 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -50,22 +50,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)
@@ -122,7 +123,9 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
 			, raFinalCmm	= code_final }
 
 		return	( code_nat
-			, [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+			, if dump
+				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+				else []
 			, graph_colored)
 
 	 else do
@@ -143,8 +146,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
 
  
-- 
1.7.10.4