Fix Trac #2111: improve error handling for 'rec' in do-notation

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

diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
index 728225a..58a69fa 100644 (file)
--- a/compiler/nativeGen/RegAllocStats.hs
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -1,7 +1,7 @@
+{-# OPTIONS -fno-warn-missing-signatures #-}
 -- Carries interesting info for debugging / profiling of the 
 --     graph coloring register allocator.
 --
-{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module RegAllocStats (
        RegAllocStats (..),
@@ -24,6 +24,7 @@ import qualified GraphColor as Color
 import RegLiveness
 import RegAllocInfo
 import RegSpill
+import RegSpillCost
 import MachRegs
 import MachInstrs
 import Cmm
@@ -40,20 +41,21 @@ data RegAllocStats
        -- initial graph
        = RegAllocStatsStart
        { raLiveCmm     :: [LiveCmmTop]                   -- ^ initial code, with liveness
-       , raGraph       :: Color.Graph Reg RegClass Reg  -- ^ the initial, uncolored graph
-       , raLifetimes   :: UniqFM (Reg, Int) }            -- ^ number of instrs each reg lives for
+       , raGraph       :: Color.Graph Reg RegClass Reg   -- ^ the initial, uncolored graph
+       , raSpillCosts  :: SpillCostInfo }                -- ^ information to help choose which regs to spill
 
        -- a spill stage
        | RegAllocStatsSpill
        { raGraph       :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
        , raCoalesced   :: UniqFM Reg                   -- ^ the regs that were coaleced
        , raSpillStats  :: SpillStats                   -- ^ spiller stats
-       , raLifetimes   :: UniqFM (Reg, Int)            -- ^ number of instrs each reg lives for
+       , raSpillCosts  :: SpillCostInfo                -- ^ number of instrs each reg lives for
        , raSpilled     :: [LiveCmmTop] }               -- ^ code with spill instructions added
 
        -- a successful coloring
        | RegAllocStatsColored
-       { raGraph       :: Color.Graph Reg RegClass Reg -- ^ the colored graph
+       { raGraph        :: Color.Graph Reg RegClass Reg -- ^ the uncolored graph
+       , raGraphColored :: Color.Graph Reg RegClass Reg -- ^ the coalesced and colored graph
        , raCoalesced   :: UniqFM Reg                   -- ^ the regs that were coaleced
        , raPatched     :: [LiveCmmTop]                 -- ^ code with vregs replaced by hregs
        , raSpillClean  :: [LiveCmmTop]                 -- ^ code with unneeded spill/reloads cleaned out
@@ -84,6 +86,10 @@ instance Outputable RegAllocStats where
                        $$ text ""
                else empty)
 
+       $$ text "#  Spill costs.  reg uses defs lifetime degree cost"
+       $$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
+       $$ text ""
+
        $$ text "#  Spills inserted."
        $$ ppr (raSpillStats s)
        $$ text ""
@@ -95,10 +101,14 @@ instance Outputable RegAllocStats where
  ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
        =  text "#  Colored"
 
-       $$ text "#  Register conflict graph."
+       $$ text "#  Register conflict graph (initial)."
        $$ Color.dotGraph regDotColor trivColorable (raGraph s)
        $$ text ""
 
+       $$ text "#  Register conflict graph (colored)."
+       $$ Color.dotGraph regDotColor trivColorable (raGraphColored s)
+       $$ text ""
+
        $$ (if (not $ isNullUFM $ raCoalesced s)
                then    text "#  Registers coalesced."
                        $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
@@ -156,9 +166,11 @@ pprStatsLifetimes
        :: [RegAllocStats] -> SDoc
 
 pprStatsLifetimes stats
- = let lifeMap         = foldl' plusUFM emptyUFM
-                               [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
-       lifeBins        = binLifetimeCount lifeMap
+ = let info            = foldl' plusSpillCostInfo zeroSpillCostInfo
+                               [ raSpillCosts s
+                                       | s@RegAllocStatsStart{} <- stats ]
+
+       lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info
 
    in  (  text "-- vreg-population-lifetimes"
        $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
@@ -201,8 +213,9 @@ pprStatsLifeConflict
        -> SDoc
 
 pprStatsLifeConflict stats graph
- = let lifeMap = foldl' plusUFM emptyUFM
-                       [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
+ = let lifeMap = lifeMapFromSpillCostInfo
+               $ foldl' plusSpillCostInfo zeroSpillCostInfo
+               $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
 
        scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of
                                                        Just (_, l)     -> l
@@ -278,11 +291,10 @@ regColors
        , (fake3, "#aa00aa")
        , (fake4, "#ff0055")
        , (fake5, "#5500ff") ]
-#endif
 
 
 -- reg colors for x86_64
-#if x86_64_TARGET_ARCH
+#elif x86_64_TARGET_ARCH
 regDotColor :: Reg -> SDoc
 regDotColor reg
  = let Just    str     = lookupUFM regColors reg
@@ -304,16 +316,19 @@ regColors
        , (r15, "#002080") ]
 
        ++ zip (map RealReg [16..31]) (repeat "red")
-#endif
 
 
 -- reg colors for ppc
-#if powerpc_TARGET_ARCH
+#elif powerpc_TARGET_ARCH
 regDotColor :: Reg -> SDoc
 regDotColor reg
  = case regClass reg of
        RcInteger       -> text "blue"
        RcFloat         -> text "red"
+       RcDouble        -> text "green"
+
+#else
+#error ToDo: regDotColor
 #endif