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

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index 18e8ba0..4d6b556 100644
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -1,3 +1,10 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 -----------------------------------------------------------------------------
 --
 -- The register allocator
@@ -82,7 +89,7 @@ The algorithm is roughly:
 
 module RegAllocLinear (
   	regAlloc,
-	RegAllocStats
+	RegAllocStats, pprStats
   ) where
 
 #include "HsVersions.h"
@@ -99,11 +106,12 @@ import UniqSet
 import UniqFM
 import UniqSupply
 import Outputable
+import State
 
 #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
@@ -498,7 +506,15 @@ genRaInsn block_live new_instrs instr r_dying w_dying =
     -- (j) free up stack slots for dead spilled regs
     -- TODO (can't be bothered right now)
 
-    return (patched_instr : w_spills ++ reverse r_spills
+    -- erase reg->reg moves where the source and destination are the same.
+    --	If the src temp didn't die in this instr but happened to be allocated
+    --	to the same real reg as the destination, then we can erase the move anyway.
+	squashed_instr	= case isRegRegMove patched_instr of
+				Just (src, dst)
+				 | src == dst	-> []
+				_		-> [patched_instr]
+
+    return (squashed_instr ++ w_spills ++ reverse r_spills
 		 ++ clobber_saves ++ new_instrs,
 	    fixup_blocks)
   }}
@@ -1000,7 +1016,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 +1062,53 @@ binSpillReasons reasons
 			SpillJoinRM r	-> (r, [0, 0, 0, 0, 1])) reasons)
 
 
+-- | Count reg-reg moves remaining in this code.
+countRegRegMovesNat :: NatCmmTop -> Int
+countRegRegMovesNat cmm
+	= execState (mapGenBlockTopM countBlock cmm) 0
+ where
+ 	countBlock b@(BasicBlock i instrs)
+	 = do	instrs'	<- mapM countInstr instrs
+	 	return	b
+
+	countInstr instr
+		| Just _	<- isRegRegMove instr
+		= do	modify (+ 1)
+			return instr
+
+		| otherwise
+		=	return instr
+
+
+-- | Pretty print some RegAllocStats
+pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc
+pprStats code statss
+ = let	-- sum up all the instrs inserted by the spiller
+ 	spills		= foldl' (plusUFM_C (zipWith (+)))
+ 				emptyUFM
+			$ map ra_spillInstrs statss
+
+	spillTotals	= foldl' (zipWith (+))
+				[0, 0, 0, 0, 0]
+			$ eltsUFM spills
+
+	-- count how many reg-reg-moves remain in the code
+	moves		= sum $ map countRegRegMovesNat code
+
+	pprSpill (reg, spills)
+		= parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
+
+   in	(  text "-- spills-added-total"
+	$$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
+	$$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
+	$$ text ""
+	$$ text "-- spills-added"
+   	$$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
+	$$ (vcat $ map pprSpill
+   		 $ ufmToList spills)
+	$$ text "")
+
+
 -- -----------------------------------------------------------------------------
 -- Utils