Be more paranoid about not creating space leaks in coloring allocator

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index c606918..38c28b4 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -227,14 +227,24 @@ cmmNativeGen dflags us cmm
                        Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
                        (vcat $ map ppr coalesced)
 
                        Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
                        (vcat $ map ppr coalesced)
 

+               -- if any of these dump flags are turned on we want to hang on to
+               --      intermediate structures in the allocator - otherwise ditch
+               --      them early so we don't end up creating space leaks.
+               let generateRegAllocStats = or
+                       [ dopt Opt_D_dump_asm_regalloc_stages dflags
+                       , dopt Opt_D_dump_asm_stats dflags
+                       , dopt Opt_D_dump_asm_conflicts dflags ]
+

                -- graph coloring register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = initUs usCoalesce
                        $ Color.regAlloc
                -- graph coloring register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = initUs usCoalesce
                        $ Color.regAlloc

+                               generateRegAllocStats

                                alloc_regs
                                (mkUniqSet [0..maxSpillSlots])
                                coalesced
 
                                alloc_regs
                                (mkUniqSet [0..maxSpillSlots])
                                coalesced
 

+               -- dump out what happened during register allocation

                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc "Registers allocated"
                        (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc "Registers allocated"
                        (vcat $ map (docToSDoc . pprNatCmmTop) alloced)

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index ecb5faf..45727c5 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -50,22 +50,23 @@ maxSpinCount        = 10
 -- | The top level of the graph coloring register allocator.
 --     
 regAlloc
 -- | The top level of the graph coloring register allocator.
 --     
 regAlloc

-       :: UniqFM (UniqSet Reg)         -- ^ the registers we can use for allocation
+       :: Bool                         -- ^ whether to generate RegAllocStats, or not.
+       -> UniqFM (UniqSet Reg)         -- ^ the registers we can use for allocation

        -> UniqSet Int                  -- ^ the set of available spill slots.
        -> [LiveCmmTop]                 -- ^ code annotated with liveness information.
        -> UniqSM 
                ( [NatCmmTop]           -- ^ code with registers allocated.
                , [RegAllocStats] )     -- ^ stats for each stage of allocation
                
        -> UniqSet Int                  -- ^ the set of available spill slots.
        -> [LiveCmmTop]                 -- ^ code annotated with liveness information.
        -> UniqSM 
                ( [NatCmmTop]           -- ^ code with registers allocated.
                , [RegAllocStats] )     -- ^ stats for each stage of allocation
                

-regAlloc regsFree slotsFree code
+regAlloc dump regsFree slotsFree code

  = do
        (code_final, debug_codeGraphs, graph_final)
  = do
        (code_final, debug_codeGraphs, graph_final)

-               <- regAlloc_spin 0 trivColorable regsFree slotsFree [] code
+               <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code

        
        return  ( code_final
                , reverse debug_codeGraphs )
 
        
        return  ( code_final
                , reverse debug_codeGraphs )
 

-regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code 
+regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code

  = do
        -- check that we're not running off down the garden path.
        when (spinCount > maxSpinCount)
  = do
        -- check that we're not running off down the garden path.
        when (spinCount > maxSpinCount)

@@ -122,7 +123,9 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
                        , raFinalCmm    = code_final }
 
                return  ( code_nat
                        , raFinalCmm    = code_final }
 
                return  ( code_nat

-                       , [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                       , if dump
+                               then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                               else []

                        , graph_colored)
 
         else do
                        , graph_colored)
 
         else do

@@ -143,8 +146,10 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
                        , raSpilled     = code_spilled }
                                
                -- try again
                        , raSpilled     = code_spilled }
                                
                -- try again

-               regAlloc_spin (spinCount + 1) triv regsFree slotsFree' 
-                       ([stat] ++ maybeToList stat1 ++ debug_codeGraphs)
+               regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
+                       (if dump
+                               then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                               else [])

                        code_relive
 
  
                        code_relive