Eliminate more dead reg->reg moves in linear allocator

[ghc-hetmet.git] / compiler / nativeGen / RegAllocLinear.hs

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index 18e8ba0..d761bae 100644 (file)
--- 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
@@ -498,7 +498,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 +1008,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 +1054,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