X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocStats.hs;h=a38db1d88edbe6ae2ff840753e6b098e140a657f;hb=f8c572418898d4c0e703f6d67510c9c37b51cc6e;hp=015453e7c97d0e9b4227a40f408278215a0f4931;hpb=f2cd56cf9fc310c9b587ecb5dfaee4ad6b580355;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
index 015453e..a38db1d 100644
--- a/compiler/nativeGen/RegAllocStats.hs
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -10,7 +10,9 @@ module RegAllocStats (
 	pprStatsSpills,
 	pprStatsLifetimes,
 	pprStatsConflict,
-	pprStatsLifeConflict
+	pprStatsLifeConflict,
+
+	countSRMs, addSRM
 )
 
 where
@@ -19,12 +21,16 @@ where
 
 import qualified GraphColor as Color
 import RegLiveness
+import RegAllocInfo
 import RegSpill
 import MachRegs
+import MachInstrs
+import Cmm
 
 import Outputable
 import UniqFM
 import UniqSet
+import State
 
 import Data.List
 
@@ -46,8 +52,10 @@ data RegAllocStats
 	-- a successful coloring
 	| RegAllocStatsColored
 	{ raGraph	:: Color.Graph Reg RegClass Reg -- ^ the colored graph
-	, raPatchedCmm	:: [LiveCmmTop] }		-- ^ code after register allocation
-
+	, raPatched	:: [LiveCmmTop] 		-- ^ code with vregs replaced by hregs
+	, raSpillClean  :: [LiveCmmTop]			-- ^ code with unneeded spill/reloads cleaned out
+	, raFinal	:: [NatCmmTop] 			-- ^ final code
+	, raSRMs	:: (Int, Int, Int) }		-- ^ spill/reload/reg-reg moves present in this code
 
 instance Outputable RegAllocStats where
 
@@ -70,14 +78,25 @@ instance Outputable RegAllocStats where
 	$$ text "#  Code with spills inserted."
 	$$ (ppr (raSpilled s))
 
- ppr (s@RegAllocStatsColored{})
+ ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
  	=  text "#  Colored"
 	$$ text "#  Register conflict graph."
 	$$ 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 (raFinal s)
+	$$ text ""
+	$$  text "#  Score:"
+	$$ (text "#          spills  inserted: " <> int spills)
+	$$ (text "#          reloads inserted: " <> int reloads)
+	$$ (text "#   reg-reg moves remaining: " <> int moves)
+	$$ text ""
 
 -- | Do all the different analysis on this list of RegAllocStats
 pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
@@ -95,31 +114,16 @@ pprStatsSpills
 	:: [RegAllocStats] -> SDoc
 
 pprStatsSpills stats
- = let	-- slurp out the stats from all the spiller stages
-	spillStats	= [ s	| s@RegAllocStatsSpill{} <- stats]
-
-	-- build a map of how many spill load/stores were inserted for each vreg
-	spillSL		= foldl' (plusUFM_C accSpillSL) emptyUFM
-			$ map (spillStoreLoad . raSpillStats) spillStats
-
-	-- print the count of load/spills as a tuple so we can read back from the file easilly
-	pprSpillSL (r, loads, stores)
-	 = (parens $ (hcat $ punctuate (text ", ") [doubleQuotes (ppr r), int loads, int stores]))
+ = let
+	finals	= [ s	| s@RegAllocStatsColored{} <- stats]
 
-	-- sum up the total number of spill instructions inserted
-	spillList	= eltsUFM spillSL
-	spillTotal	= foldl' (\(s1, l1) (s2, l2) -> (s1 + s2, l1 + l2))
-				(0, 0)
-			$ map (\(n, s, l) -> (s, l))
-			$ spillList
+	-- sum up how many stores/loads/reg-reg-moves were left in the code
+	total	= foldl' addSRM (0, 0, 0)
+		$ map raSRMs finals
 
     in	(  text "-- spills-added-total"
-	$$ text "--    (stores, loads)"
-	$$ (ppr spillTotal)
-	$$ text ""
-    	$$ text "-- spills-added"
-	$$ text "--    (reg_name, stores, loads)"
-	$$ (vcat $ map pprSpillSL $ spillList)
+	$$ text "--    (stores, loads, reg_reg_moves_remaining)"
+	$$ ppr total
 	$$ text "")
 
 
@@ -176,8 +180,10 @@ pprStatsLifeConflict stats graph
  = let	lifeMap	= foldl' plusUFM emptyUFM
  			[ raLifetimes s	| s@RegAllocStatsStart{} <- stats ]
 
- 	scatter	= map	(\r ->  let Just (_, lifetime)	= lookupUFM lifeMap r
-				    Just node		= Color.lookupNode graph r
+ 	scatter	= map	(\r ->  let lifetime	= case lookupUFM lifeMap r of
+							Just (_, l)	-> l
+							Nothing		-> 0
+				    Just node	= Color.lookupNode graph r
 				in parens $ hcat $ punctuate (text ", ")
 					[ doubleQuotes $ ppr $ Color.nodeId node
 					, ppr $ sizeUniqSet (Color.nodeConflicts node)
@@ -192,6 +198,37 @@ pprStatsLifeConflict stats graph
 	$$ text "\n")
 
 
+-- | Count spill/reload/reg-reg moves.
+--	Lets us see how well the register allocator has done.
+--
+countSRMs :: LiveCmmTop -> (Int, Int, Int)
+countSRMs cmm
+	= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+
+countSRM_block (BasicBlock i instrs)
+ = do	instrs'	<- mapM countSRM_instr instrs
+ 	return	$ BasicBlock i instrs'
+
+countSRM_instr li@(Instr instr live)
+	| SPILL reg slot	<- instr
+	= do	modify 	$ \(s, r, m)	-> (s + 1, r, m)
+		return li
+
+	| RELOAD slot reg	<- instr
+	= do	modify	$ \(s, r, m)	-> (s, r + 1, m)
+		return li
+
+	| Just _		<- isRegRegMove instr
+	= do	modify	$ \(s, r, m)	-> (s, r, m + 1)
+		return li
+
+	| otherwise
+	=	return li
+
+-- sigh..
+addSRM (s1, r1, m1) (s2, r2, m2)
+	= (s1+s2, r1+r2, m1+m2)
+
 -----
 -- Register colors for drawing conflict graphs
 --	Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.