From f0d0e9d63ee27a12e80b6f069be5e9d4b55ca545 Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Fri, 17 Aug 2007 12:15:57 +0000
Subject: [PATCH] Refactor dumping of register allocator statistics.

---
 compiler/nativeGen/AsmCodeGen.lhs   |   20 ++---
 compiler/nativeGen/RegAllocColor.hs |  101 +++++--------------------
 compiler/nativeGen/RegAllocStats.hs |  141 +++++++++++++++++++++++++++++++++++
 compiler/nativeGen/RegSpill.hs      |   94 ++++++++++++++---------
 compiler/utils/State.hs             |   36 +++++++--
 5 files changed, 259 insertions(+), 133 deletions(-)
 create mode 100644 compiler/nativeGen/RegAllocStats.hs

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index ec02204..fa9e77c 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -20,6 +20,7 @@ import RegAllocInfo
 import NCGMonad
 import PositionIndependentCode
 import RegAllocLinear
+import RegAllocStats
 import RegLiveness
 import RegCoalesce
 import qualified RegAllocColor	as Color
@@ -158,12 +159,11 @@ nativeCodeGen dflags cmms us
      -> dumpIfSet_dyn dflags
 		Opt_D_dump_asm_regalloc_stages
 			"(asm-regalloc-stages)"
-			(vcat $ map (\(stage, (code, graph)) ->
-					( text "-- Stage " <> int stage
-					  $$ ppr code
-					  $$ Color.dotGraph Color.regDotColor trivColorable graph))
+			(vcat $ map (\(stage, stats) ->
+					 text "-- Stage " <> int stage
+					 $$ ppr stats)
 					(zip [0..] codeGraphs)))
-	$ map cdCodeGraphs dump
+	$ map cdRegAllocStats dump
 
     -- Build a global register conflict graph.
     --	If you want to see the graph for just one basic block then use asm-regalloc-stages instead.
@@ -256,7 +256,7 @@ data CmmNativeGenDump
 	, cdNative		:: [NatCmmTop]
 	, cdLiveness		:: [LiveCmmTop]
 	, cdCoalesce		:: [LiveCmmTop]
-	, cdCodeGraphs		:: [([LiveCmmTop], Color.Graph Reg RegClass Reg)]
+	, cdRegAllocStats	:: [RegAllocStats]
 	, cdColoredGraph	:: Maybe (Color.Graph Reg RegClass Reg)
 	, cdAlloced		:: [NatCmmTop] }
 
@@ -314,7 +314,7 @@ cmmNativeGen dflags cmm
 		native
 
     	---- allocate registers
-	(alloced, ppr_alloced, ppr_coalesce, ppr_codeGraphs, ppr_coloredGraph)
+	(alloced, ppr_alloced, ppr_coalesce, ppr_regAllocStats, ppr_coloredGraph)
 	 <- (\withLiveness
 	 -> {-# SCC "regAlloc" #-}
 	   do
@@ -331,7 +331,7 @@ cmmNativeGen dflags cmm
 			coalesced	<- regCoalesce withLiveness
 
 			-- graph coloring register allocation
-			(alloced, codeGraphs)
+			(alloced, regAllocStats)
 				<- Color.regAlloc 
 					alloc_regs
 					(mkUniqSet [0..maxSpillSlots]) 
@@ -340,7 +340,7 @@ cmmNativeGen dflags cmm
 			return 	( alloced
 				, dchoose dflags Opt_D_dump_asm_regalloc 	alloced []
 				, dchoose dflags Opt_D_dump_asm_coalesce 	coalesced []
-				, dchoose dflags Opt_D_dump_asm_regalloc_stages	codeGraphs []
+				, dchoose dflags Opt_D_dump_asm_regalloc_stages	regAllocStats []
 				, dchoose dflags Opt_D_dump_asm_conflicts 	Nothing Nothing)
 
 		 else do
@@ -384,7 +384,7 @@ cmmNativeGen dflags cmm
 		, cdNative		= ppr_native
 		, cdLiveness		= ppr_withLiveness
 		, cdCoalesce		= ppr_coalesce
-		, cdCodeGraphs		= ppr_codeGraphs
+		, cdRegAllocStats	= ppr_regAllocStats
 		, cdColoredGraph	= ppr_coloredGraph
 		, cdAlloced		= ppr_alloced }
 
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
diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
new file mode 100644
index 0000000..751c556
--- /dev/null
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -0,0 +1,141 @@
+
+-- Carries interesting info for debugging / profiling of the 
+--	graph coloring register allocator.
+
+module RegAllocStats (
+	RegAllocStats (..),
+	regDotColor
+)
+
+where
+
+#include "nativeGen/NCG.h"
+
+import qualified GraphColor as Color
+import RegLiveness
+import RegSpill
+import MachRegs
+
+import Outputable
+import UniqFM
+
+
+data RegAllocStats
+
+	-- a spill stage
+	= RegAllocStatsSpill
+	{ raLiveCmm	:: [LiveCmmTop]			-- ^ code we tried to allocate regs for
+	, raGraph	:: Color.Graph Reg RegClass Reg	-- ^ the partially colored graph
+	, raSpillStats	:: SpillStats }			-- ^ spiller stats
+
+	-- 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
+
+
+instance Outputable RegAllocStats where
+
+ ppr (s@RegAllocStatsSpill{})
+ 	= text "-- Spill"
+
+	$$ text "-- Native code with liveness information."
+	$$ ppr (raLiveCmm s)
+	$$ text " "
+
+	$$ text "-- Register conflict graph."
+	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+
+	$$ text "-- Spill statistics."
+	$$ ppr (raSpillStats s)
+
+
+ ppr (s@RegAllocStatsColored{})
+ 	= text "-- Colored"
+
+	$$ text "-- Native code with liveness information."
+	$$ ppr (raLiveCmm s)
+	$$ text " "
+
+	$$ text "-- Register conflict graph."
+	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
+
+	$$ text "-- Native code after register allocation."
+	$$ ppr (raPatchedCmm s)
+
+
+-----
+-- 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
+-}
diff --git a/compiler/nativeGen/RegSpill.hs b/compiler/nativeGen/RegSpill.hs
index 4921cf1..d426876 100644
--- a/compiler/nativeGen/RegSpill.hs
+++ b/compiler/nativeGen/RegSpill.hs
@@ -1,6 +1,7 @@
 
 module RegSpill (
-	regSpill
+	regSpill,
+	SpillStats(..)
 )
 
 where
@@ -13,6 +14,7 @@ import MachRegs
 import MachInstrs
 import Cmm
 
+import State
 import Unique
 import UniqFM
 import UniqSet
@@ -36,8 +38,9 @@ regSpill
 	-> UniqSet Int			-- ^ available stack slots
 	-> UniqSet Reg			-- ^ the regs to spill
 	-> UniqSM
-		([LiveCmmTop]		-- ^ code will spill instructions
-		, UniqSet Int)		-- ^ left over slots
+		([LiveCmmTop]		-- code will spill instructions
+		, UniqSet Int		-- left over slots
+		, SpillStats )		-- stats about what happened during spilling
 
 regSpill code slotsFree regs
 
@@ -58,12 +61,13 @@ regSpill code slotsFree regs
 		us	<- getUs
 
 		-- run the spiller on all the blocks
-		let (# code', _ #)	=
-			runSpill (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
+		let (code', state')	=
+			runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
 				 (initSpillS us)
 
 		return	( code'
-			, minusUniqSet slotsFree (mkUniqSet slots) )
+			, minusUniqSet slotsFree (mkUniqSet slots)
+			, makeSpillStats state')
 
 
 regSpill_block regSlotMap (BasicBlock i instrs)
@@ -133,9 +137,12 @@ spillRead regSlotMap instr reg
 	= do	delta		<- getDelta
 	 	(instr', nReg)	<- patchInstr reg instr
 
-		let pre	 	= [ COMMENT FSLIT("spill read")
+		let pre	 	= [ COMMENT FSLIT("spill load")
 				  , mkLoadInstr nReg delta slot ]
 
+		modify $ \s -> s
+			{ stateSpillLS 	= addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 1, 0) }
+
 	 	return	( instr', (pre, []))
 
 	| otherwise	= panic "RegSpill.spillRead: no slot defined for spilled reg"
@@ -145,9 +152,12 @@ spillWrite regSlotMap instr reg
 	= do	delta		<- getDelta
 	 	(instr', nReg)	<- patchInstr reg instr
 
-		let post	= [ COMMENT FSLIT("spill write")
+		let post	= [ COMMENT FSLIT("spill store")
 				  , mkSpillInstr nReg delta slot ]
 
+		modify $ \s -> s
+			{ stateSpillLS 	= addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 0, 1) }
+
 	 	return	( instr', ([], post))
 
 	| otherwise	= panic "RegSpill.spillWrite: no slot defined for spilled reg"
@@ -160,14 +170,18 @@ spillModify regSlotMap instr reg
 		let pre		= [ COMMENT FSLIT("spill mod load")
 				  , mkLoadInstr  nReg delta slot ]
 
-		let post	= [ COMMENT FSLIT("spill mod write")
+		let post	= [ COMMENT FSLIT("spill mod store")
 				  , mkSpillInstr nReg delta slot ]
 
+		modify $ \s -> s
+			{ stateSpillLS 	= addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 1, 1) }
+
 		return	( instr', (pre, post))
 
 	| otherwise	= panic "RegSpill.spillModify: no slot defined for spilled reg"
 
 
+
 -- | rewrite uses of this virtual reg in an instr to use a different virtual reg
 patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
 patchInstr reg instr
@@ -184,50 +198,58 @@ patchReg1 old new instr
    in	patchRegs instr patchF
 
 
--------------------------------------------------------------------------------------------
+------------------------------------------------------
 -- Spiller monad
 
 data SpillS
 	= SpillS
 	{ stateDelta	:: Int
-	, stateUS	:: UniqSupply }
+	, stateUS	:: UniqSupply
+	, stateSpillLS	:: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
 
 initSpillS uniqueSupply
 	= SpillS
 	{ stateDelta	= 0
-	, stateUS	= uniqueSupply }
+	, stateUS	= uniqueSupply
+	, stateSpillLS	= emptyUFM }
 
-newtype SpillM a
-	= SpillM
-	{ runSpill :: SpillS  -> (# a, SpillS #) }
-
-instance Monad SpillM where
-    return x	= SpillM $ \s -> (# x, s #)
-
-    m >>= n	= SpillM $ \s ->
-			case runSpill m s of
-			  (# r, s' #)	-> runSpill (n r) s'
+type SpillM a	= State SpillS a
 
 setDelta :: Int -> SpillM ()
 setDelta delta
-	= SpillM $ \s -> (# (), s { stateDelta = delta } #)
+	= modify $ \s -> s { stateDelta = delta }
 
 getDelta  :: SpillM Int
-getDelta = SpillM $ \s -> (# stateDelta s, s #)
+getDelta = gets stateDelta
 
 newUnique :: SpillM Unique
 newUnique
-	= SpillM $ \s
-	-> case splitUniqSupply (stateUS s) of
-		(us1, us2)
-		  -> 	(# uniqFromSupply us1
-		  	, s { stateUS = us2 } #)
-
-mapAccumLM _ s []	= return (s, [])
-mapAccumLM f s (x:xs)
- = do
-	(s1, x')	<- f s x
-	(s2, xs')	<- mapAccumLM f s1 xs
-	return		(s2, x' : xs')
+ = do	us	<- gets stateUS
+ 	case splitUniqSupply us of
+	 (us1, us2)
+	  -> do let uniq = uniqFromSupply us1
+	  	modify $ \s -> s { stateUS = us2 }
+		return uniq
+
+accSpillLS (r1, l1, s1) (r2, l2, s2)
+	= (r1, l1 + l2, s1 + s2)
+
+
+
+----------------------------------------------------
+-- Spiller stats
+
+data SpillStats
+	= SpillStats
+	{ spillLoadStore	:: UniqFM (Reg, Int, Int) }
+
+makeSpillStats :: SpillS -> SpillStats
+makeSpillStats s
+	= SpillStats
+	{ spillLoadStore	= stateSpillLS s }
 
+instance Outputable SpillStats where
+ ppr s
+ 	= (vcat $ map (\(r, l, s) -> ppr r <+> int l <+> int s)
+			$ eltsUFM (spillLoadStore s))
 
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
index faed566..8f89734 100644
--- a/compiler/utils/State.hs
+++ b/compiler/utils/State.hs
@@ -3,29 +3,55 @@ module State where
 
 newtype State s a
 	= State
-	{ runState :: s -> (# a, s #) }
+	{ runState' :: s -> (# a, s #) }
 
 instance Monad (State s) where
     return x	= State $ \s -> (# x, s #)
     m >>= n	= State $ \s ->
-    			case runState m s of
-			  (# r, s' #)	-> runState (n r) s'
+    			case runState' m s of
+			  (# r, s' #)	-> runState' (n r) s'
 
 get ::	State s s
 get	= State $ \s -> (# s, s #)
 
+gets :: (s -> a) -> State s a
+gets f 	= State $ \s -> (# f s, s #)
+
 put :: 	s -> State s ()
 put s'	= State $ \s -> (# (), s' #)
 
 modify :: (s -> s) -> State s ()
 modify f = State $ \s -> (# (), f s #)
 
+
 evalState :: State s a -> s -> a
 evalState s i
-	= case runState s i of
+	= case runState' s i of
 		(# a, s' #)	-> a
 
+
 execState :: State s a -> s -> s
 execState s i
-	= case runState s i of
+	= case runState' s i of
 		(# a, s' #) 	-> s'
+
+
+runState :: State s a -> s -> (a, s)
+runState s i
+	= case runState' s i of
+		(# a, s' #)	-> (a, s')
+
+
+mapAccumLM
+	:: Monad m
+	=> (acc -> x -> m (acc, y))	-- ^ combining funcction
+	-> acc				-- ^ initial state
+	-> [x]				-- ^ inputs
+	-> m (acc, [y])			-- ^ final state, outputs
+
+mapAccumLM _ s []	= return (s, [])
+mapAccumLM f s (x:xs)
+ = do
+	(s1, x')	<- f s x
+	(s2, xs')	<- mapAccumLM f s1 xs
+	return		(s2, x' : xs')
-- 
1.7.10.4