From 682d5e9674ec8cf94b3af815a752fa03c9a9d6fe Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Fri, 24 Aug 2007 14:31:32 +0000
Subject: [PATCH] Erase unneeded spill/reloads after register allocation

---
 compiler/nativeGen/RegAllocColor.hs |   11 +++--
 compiler/nativeGen/RegAllocStats.hs |   12 ++++--
 compiler/nativeGen/RegSpillClean.hs |   80 +++++++++++++++++++++++++++++++++++
 3 files changed, 96 insertions(+), 7 deletions(-)
 create mode 100644 compiler/nativeGen/RegSpillClean.hs

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 45727c5..5a3401f 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -23,6 +23,7 @@ where
 import qualified GraphColor	as Color
 import RegLiveness
 import RegSpill
+import RegSpillClean
 import RegAllocStats
 import MachRegs
 import MachInstrs
@@ -108,6 +109,9 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		-- patch the registers using the info in the graph
 	 	let code_patched	= map (patchRegsFromGraph graph_colored) code
 
+		-- clean out unneeded SPILL/RELOADs
+		let code_spillclean	= map cleanSpills code_patched
+
 		-- strip off liveness information
 		let code_nat		= map stripLive code_patched
 
@@ -119,10 +123,11 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		let stat		=
 			RegAllocStatsColored
 			{ raGraph	= graph_colored
-			, raPatchedCmm	= code_patched
-			, raFinalCmm	= code_final }
+			, raPatched	= code_patched
+			, raSpillClean	= code_spillclean
+			, raFinal	= code_final }
 
-		return	( code_nat
+		return	( code_final
 			, if dump
 				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 				else []
diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
index a762f83..7e08c1c 100644
--- a/compiler/nativeGen/RegAllocStats.hs
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -47,8 +47,9 @@ data RegAllocStats
 	-- a successful coloring
 	| RegAllocStatsColored
 	{ raGraph	:: Color.Graph Reg RegClass Reg -- ^ the colored graph
-	, raPatchedCmm	:: [LiveCmmTop] 		-- ^ code after register allocation 
-	, raFinalCmm	:: [NatCmmTop] }		-- ^ final code
+	, raPatched	:: [LiveCmmTop] 		-- ^ code with vregs replaced by hregs
+	, raSpillClean  :: [LiveCmmTop]			-- ^ code with unneeded spill/reloads cleaned out
+	, raFinal	:: [NatCmmTop] }		-- ^ final code
 
 instance Outputable RegAllocStats where
 
@@ -77,10 +78,13 @@ instance Outputable RegAllocStats where
 	$$ Color.dotGraph regDotColor trivColorable (raGraph s)
 	$$ text ""
 	$$ text "#  Native code after register allocation."
-	$$ ppr (raPatchedCmm s)
+	$$ ppr (raPatched s)
+	$$ text ""
+	$$ text "#  Clean out unneeded spill/reloads."
+	$$ ppr (raSpillClean s)
 	$$ text ""
 	$$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
-	$$ ppr (raFinalCmm s)
+	$$ ppr (raFinal s)
 	$$ text ""
 
 
diff --git a/compiler/nativeGen/RegSpillClean.hs b/compiler/nativeGen/RegSpillClean.hs
new file mode 100644
index 0000000..c451dc4
--- /dev/null
+++ b/compiler/nativeGen/RegSpillClean.hs
@@ -0,0 +1,80 @@
+-- | Clean out unneeded spill/reload instrs
+--
+module RegSpillClean (
+	cleanSpills
+)
+where
+
+import RegLiveness
+import RegAllocInfo
+import MachRegs
+import MachInstrs
+import Cmm
+
+import UniqSet
+
+
+-- | Clean out unneeded spill/reloads from this top level thing.
+cleanSpills :: LiveCmmTop -> LiveCmmTop
+cleanSpills cmm
+	= mapBlockTop cleanBlock cmm
+ where
+	cleanBlock (BasicBlock id instrs)
+		= BasicBlock id
+		$ cleanSpill  emptyUniqSet []
+		$ cleanReload emptyUniqSet []
+		$ instrs
+
+
+-- | Clean out unneeded reload instructions.
+--	Walking forwards across the code
+--	  If there are no writes to a reg between a reload and the
+--	  last spill or reload then we don't need the reload.
+--
+cleanReload
+	:: UniqSet Reg 		-- ^ hregs that were reloaded but not written to yet
+	-> [LiveInstr]		-- ^ acc
+	-> [LiveInstr] 		-- ^ instrs to clean (in backwards order)
+	-> [LiveInstr]		-- ^ cleaned instrs  (in forward   order)
+
+cleanReload valid acc []	= acc
+cleanReload valid acc (li@(Instr instr live) : instrs)
+	| SPILL reg slot	<- instr
+	, valid'		<- addOneToUniqSet valid reg
+	= cleanReload valid' (li : acc) instrs
+
+	| RELOAD slot reg	<- instr
+	= if elementOfUniqSet reg valid
+	   then	cleanReload valid acc instrs
+	   else cleanReload (addOneToUniqSet valid reg) (li : acc) instrs
+
+	| RU read written	<- regUsage instr
+	, valid'		<- minusUniqSet valid (mkUniqSet written)
+	= cleanReload valid' (li : acc) instrs
+
+
+-- | Clean out unneeded spill instructions.
+--	Walking backwards across the code.
+--	 If there were no reloads from a slot between a spill and the last one
+--	 then the slot was never read and we don't need the spill.
+
+cleanSpill
+	:: UniqSet Int 		-- ^ slots that have been spilled, but not reload from
+	-> [LiveInstr]		-- ^ acc
+	-> [LiveInstr]		-- ^ instrs to clean (in forwards order)
+	-> [LiveInstr]		-- ^ cleaned instrs  (in backwards order)
+
+cleanSpill unused acc []	= acc
+cleanSpill unused acc (li@(Instr instr live) : instrs)
+	| SPILL reg slot	<- instr
+	= if elementOfUniqSet slot unused
+	   then cleanSpill unused acc instrs
+	   else cleanSpill (addOneToUniqSet unused slot) (li : acc) instrs
+
+	| RELOAD slot reg	<- instr
+	, unused'		<- delOneFromUniqSet unused slot
+	= cleanSpill unused' (li : acc) instrs
+
+	| otherwise
+	= cleanSpill unused (li : acc) instrs
+
-- 
1.7.10.4