X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=d9ff1214bc508a85980b7dba737844c293ff475d;hb=f2cd56cf9fc310c9b587ecb5dfaee4ad6b580355;hp=18e8ba0da0bb2b14fb6a81b9590a9b8ea4d3a05e;hpb=ab676aa34302b346cc05181100b46d8490023971;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index 18e8ba0..d9ff121 100644
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -82,7 +82,7 @@ The algorithm is roughly:
 
 module RegAllocLinear (
   	regAlloc,
-	RegAllocStats
+	RegAllocStats, pprStats
   ) where
 
 #include "HsVersions.h"
@@ -103,7 +103,7 @@ import Outputable
 #ifndef DEBUG
 import Data.Maybe	( fromJust )
 #endif
-import Data.List	( nub, partition, mapAccumL)
+import Data.List	( nub, partition, mapAccumL, foldl')
 import Control.Monad	( when )
 import Data.Word
 import Data.Bits
@@ -1000,7 +1000,7 @@ getUniqueR = RegM $ \s ->
 -- | Record that a spill instruction was inserted, for profiling.
 recordSpill :: SpillReason -> RegM ()
 recordSpill spill
-	= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
+ 	= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
 
 -- -----------------------------------------------------------------------------
 
@@ -1046,6 +1046,31 @@ binSpillReasons reasons
 			SpillJoinRM r	-> (r, [0, 0, 0, 0, 1])) reasons)
 
 
+-- | Pretty print some RegAllocStats
+pprStats :: [RegAllocStats] -> SDoc
+pprStats statss
+ = let	spills		= foldl' (plusUFM_C (zipWith (+)))
+ 				emptyUFM
+			$ map ra_spillInstrs statss
+
+	spillTotals	= foldl' (zipWith (+))
+				[0, 0, 0, 0, 0]
+			$ eltsUFM spills
+
+	pprSpill (reg, spills)
+		= parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
+
+   in	(  text "-- spills-added-total"
+	$$ text "--    (allocs, clobbers, loads, joinRR, joinRM)"
+	$$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals)))
+	$$ text ""
+	$$ text "-- spills-added"
+   	$$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
+	$$ (vcat $ map pprSpill
+   		 $ ufmToList spills)
+	$$ text "")
+
+
 -- -----------------------------------------------------------------------------
 -- Utils