From 83a47256f9914c1bd15841dd1806981793b50c7e Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Fri, 17 Aug 2007 16:22:54 +0000
Subject: [PATCH] Add vreg-population-lifetimes to drop-asm-stats

---
 compiler/nativeGen/AsmCodeGen.lhs   |   34 +++++++++++++++++++++++++---------
 compiler/nativeGen/RegAllocColor.hs |    6 ++++--
 compiler/nativeGen/RegAllocStats.hs |   21 ++++++++++++++++++---
 3 files changed, 47 insertions(+), 14 deletions(-)

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 177ef0e..c9779ee 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -421,9 +421,12 @@ cmmNativeGenDump dflags mod modLocation dump
 	 $ do	-- make the drop file name based on the object file name
 	 	let dropFile	= (init $ ml_obj_file modLocation) ++ "drop-asm-stats"
 
+		-- slurp out all the regalloc stats
+		let stats	= concat $ catMaybes $ map cdRegAllocStats dump
+
+		---- Spiller
 		-- slurp out the stats from all the spiller stages
-		let spillStats	= [ s	| s@RegAllocStatsSpill{}
-					<- concat [ c | Just c <- map cdRegAllocStats dump]]
+		let spillStats	= [ s	| s@RegAllocStatsSpill{} <- stats]
 
 		-- build a map of how many spill load/stores were inserted for each vreg
 		let spillLS	= foldl' (plusUFM_C Spill.accSpillLS) emptyUFM
@@ -434,15 +437,28 @@ cmmNativeGenDump dflags mod modLocation dump
 		    pprSpillLS	(r, loads, stores) =
 			(parens $ (hcat $ punctuate (text ", ") [doubleQuotes (ppr r), int loads, int stores]))
 
-		-- write out the file
-		let out		= showSDoc
-				(  text "-- (spills-added)"
-				$$ text "--    Spill instructions inserted for each virtual reg."
-				$$ text "--    (reg name, spill loads added, spill stores added)."
-				$$ (vcat $ map pprSpillLS $ eltsUFM spillLS)
+
+		let outSpill	= ( text "-- (spills-added)"
+				$$  text "--    Spill instructions inserted for each virtual reg."
+				$$  text "--    (reg_name, spill_loads_added, spill_stores_added)."
+				$$  (vcat $ map pprSpillLS $ eltsUFM spillLS)
+				$$  text "\n")
+
+		---- Lifetimes
+		-- slurp out the maps of all the reg lifetimes
+		let lifetimes	= map raLifetimes stats
+		let lifeMap	= foldl' plusUFM emptyUFM $ map raLifetimes stats
+		let lifeBins	= binLifetimeCount lifeMap
+
+		let outLife	= ( text "-- (vreg-population-lifetimes)"
+				$$  text "--   Number of vregs which lived for a certain number of instructions"
+				$$  text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
+				$$ (vcat $ map ppr $ eltsUFM lifeBins)
 				$$ text "\n")
 
-		writeFile dropFile out
+		-- write out the file
+		writeFile dropFile
+			(showSDoc $ vcat [outSpill, outLife])
 
 		return ()
 
diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 933c8ab..40e3bc3 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -103,7 +103,8 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
 			RegAllocStatsColored
 			{ raLiveCmm	= code
 			, raGraph	= graph_colored
-			, raPatchedCmm	= code_patched }
+			, raPatchedCmm	= code_patched
+			, raLifetimes	= fmLife }
 
 		return	( code_nat
 			, debug_codeGraphs ++ [stat]
@@ -123,7 +124,8 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
 			RegAllocStatsSpill
 			{ raLiveCmm	= code_spilled
 			, raGraph	= graph_colored
-			, raSpillStats	= spillStats }
+			, raSpillStats	= spillStats
+			, raLifetimes	= fmLife }
 			    	
 		-- try again
 		regAlloc_spin (spinCount + 1) triv regsFree slotsFree' 
diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
index 751c556..844ffcd 100644
--- a/compiler/nativeGen/RegAllocStats.hs
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -4,7 +4,8 @@
 
 module RegAllocStats (
 	RegAllocStats (..),
-	regDotColor
+	regDotColor,
+	binLifetimeCount
 )
 
 where
@@ -26,13 +27,15 @@ data RegAllocStats
 	= RegAllocStatsSpill
 	{ raLiveCmm	:: [LiveCmmTop]			-- ^ code we tried to allocate regs for
 	, raGraph	:: Color.Graph Reg RegClass Reg	-- ^ the partially colored graph
-	, raSpillStats	:: SpillStats }			-- ^ spiller stats
+	, raSpillStats	:: SpillStats 			-- ^ spiller stats
+	, raLifetimes	:: UniqFM (Reg, Int) }		-- ^ number of instrs each reg lives for
 
 	-- a successful coloring
 	| RegAllocStatsColored
 	{ raLiveCmm	:: [LiveCmmTop]			-- ^ the code we allocated regs for
 	, raGraph	:: Color.Graph Reg RegClass Reg -- ^ the colored graph
-	, raPatchedCmm	:: [LiveCmmTop] }		-- ^ code with register allocation
+	, raPatchedCmm	:: [LiveCmmTop] 		-- ^ code with register allocation
+	, raLifetimes	:: UniqFM (Reg, Int) }		-- ^ number of instrs each reg lives for
 
 
 instance Outputable RegAllocStats where
@@ -66,6 +69,18 @@ instance Outputable RegAllocStats where
 
 
 -----
+binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int)
+binLifetimeCount fm
+ = let	lifes	= map (\l -> (l, (l, 1)))
+ 		$ map snd
+		$ eltsUFM fm
+
+   in	addListToUFM_C
+		(\(l1, c1) (l2, c2) -> (l1, c1 + c2))
+		emptyUFM
+		lifes
+
+-----
 -- Register colors for drawing conflict graphs
 --	Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
 
-- 
1.7.10.4