Add vreg-population-lifetimes to drop-asm-stats

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 177ef0e..c9779ee 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -421,9 +421,12 @@ cmmNativeGenDump dflags mod modLocation dump
         $ do   -- make the drop file name based on the object file name
                let dropFile    = (init $ ml_obj_file modLocation) ++ "drop-asm-stats"
 
+               -- slurp out all the regalloc stats
+               let stats       = concat $ catMaybes $ map cdRegAllocStats dump
+
+               ---- Spiller
                -- slurp out the stats from all the spiller stages
-               let spillStats  = [ s   | s@RegAllocStatsSpill{}
-                                       <- concat [ c | Just c <- map cdRegAllocStats dump]]
+               let spillStats  = [ s   | s@RegAllocStatsSpill{} <- stats]
 
                -- build a map of how many spill load/stores were inserted for each vreg
                let spillLS     = foldl' (plusUFM_C Spill.accSpillLS) emptyUFM
@@ -434,15 +437,28 @@ cmmNativeGenDump dflags mod modLocation dump
                    pprSpillLS  (r, loads, stores) =
                        (parens $ (hcat $ punctuate (text ", ") [doubleQuotes (ppr r), int loads, int stores]))
 
-               -- write out the file
-               let out         = showSDoc
-                               (  text "-- (spills-added)"
-                               $$ text "--    Spill instructions inserted for each virtual reg."
-                               $$ text "--    (reg name, spill loads added, spill stores added)."
-                               $$ (vcat $ map pprSpillLS $ eltsUFM spillLS)
+
+               let outSpill    = ( text "-- (spills-added)"
+                               $$  text "--    Spill instructions inserted for each virtual reg."
+                               $$  text "--    (reg_name, spill_loads_added, spill_stores_added)."
+                               $$  (vcat $ map pprSpillLS $ eltsUFM spillLS)
+                               $$  text "\n")
+
+               ---- Lifetimes
+               -- slurp out the maps of all the reg lifetimes
+               let lifetimes   = map raLifetimes stats
+               let lifeMap     = foldl' plusUFM emptyUFM $ map raLifetimes stats
+               let lifeBins    = binLifetimeCount lifeMap
+
+               let outLife     = ( text "-- (vreg-population-lifetimes)"
+                               $$  text "--   Number of vregs which lived for a certain number of instructions"
+                               $$  text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
+                               $$ (vcat $ map ppr $ eltsUFM lifeBins)
                                $$ text "\n")
 
-               writeFile dropFile out
+               -- write out the file
+               writeFile dropFile
+                       (showSDoc $ vcat [outSpill, outLife])
 
                return ()
 

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 933c8ab..40e3bc3 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -103,7 +103,8 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
                        RegAllocStatsColored
                        { raLiveCmm     = code
                        , raGraph       = graph_colored
-                       , raPatchedCmm  = code_patched }
+                       , raPatchedCmm  = code_patched
+                       , raLifetimes   = fmLife }
 
                return  ( code_nat
                        , debug_codeGraphs ++ [stat]
@@ -123,7 +124,8 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
                        RegAllocStatsSpill
                        { raLiveCmm     = code_spilled
                        , raGraph       = graph_colored
-                       , raSpillStats  = spillStats }
+                       , raSpillStats  = spillStats
+                       , raLifetimes   = fmLife }
                                
                -- try again
                regAlloc_spin (spinCount + 1) triv regsFree slotsFree' 

diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
index 751c556..844ffcd 100644 (file)
--- a/compiler/nativeGen/RegAllocStats.hs
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -4,7 +4,8 @@
 
 module RegAllocStats (
        RegAllocStats (..),
-       regDotColor
+       regDotColor,
+       binLifetimeCount
 )
 
 where
@@ -26,13 +27,15 @@ data RegAllocStats
        = RegAllocStatsSpill
        { raLiveCmm     :: [LiveCmmTop]                 -- ^ code we tried to allocate regs for
        , raGraph       :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
-       , raSpillStats  :: SpillStats }                 -- ^ spiller stats
+       , raSpillStats  :: SpillStats                   -- ^ spiller stats
+       , raLifetimes   :: UniqFM (Reg, Int) }          -- ^ number of instrs each reg lives for
 
        -- a successful coloring
        | RegAllocStatsColored
        { raLiveCmm     :: [LiveCmmTop]                 -- ^ the code we allocated regs for
        , raGraph       :: Color.Graph Reg RegClass Reg -- ^ the colored graph
-       , raPatchedCmm  :: [LiveCmmTop] }               -- ^ code with register allocation
+       , raPatchedCmm  :: [LiveCmmTop]                 -- ^ code with register allocation
+       , raLifetimes   :: UniqFM (Reg, Int) }          -- ^ number of instrs each reg lives for
 
 
 instance Outputable RegAllocStats where
@@ -66,6 +69,18 @@ instance Outputable RegAllocStats where
 
 
 -----
+binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int)
+binLifetimeCount fm
+ = let lifes   = map (\l -> (l, (l, 1)))
+               $ map snd
+               $ eltsUFM fm
+
+   in  addListToUFM_C
+               (\(l1, c1) (l2, c2) -> (l1, c1 + c2))
+               emptyUFM
+               lifes
+
+-----
 -- Register colors for drawing conflict graphs
 --     Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.