Try and allocate vregs spilled/reloaded from some slot to the same hreg

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

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 45e51b9..a2b98f1 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -27,6 +27,7 @@ import UniqSet
 import UniqFM
 import Bag
 import Outputable
+import DynFlags
 
 import Data.List
 import Data.Maybe
@@ -43,7 +44,7 @@ maxSpinCount  = 10
 -- | The top level of the graph coloring register allocator.
 --     
 regAlloc
-       :: Bool                         -- ^ whether to generate RegAllocStats, or not.
+       :: DynFlags
        -> UniqFM (UniqSet Reg)         -- ^ the registers we can use for allocation
        -> UniqSet Int                  -- ^ the set of available spill slots.
        -> [LiveCmmTop]                 -- ^ code annotated with liveness information.
@@ -51,16 +52,25 @@ regAlloc
                ( [NatCmmTop]           -- ^ code with registers allocated.
                , [RegAllocStats] )     -- ^ stats for each stage of allocation
                
-regAlloc dump regsFree slotsFree code
+regAlloc dflags regsFree slotsFree code
  = do
        (code_final, debug_codeGraphs, _)
-               <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
+               <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
        
        return  ( code_final
                , reverse debug_codeGraphs )
 
-regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
+regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
  = do
+       -- if any of these dump flags are turned on we want to hang on to
+       --      intermediate structures in the allocator - otherwise tell the
+       --      allocator to ditch them early so we don't end up creating space leaks.
+       let dump = or
+               [ dopt Opt_D_dump_asm_regalloc_stages dflags
+               , dopt Opt_D_dump_asm_stats dflags
+               , dopt Opt_D_dump_asm_conflicts dflags ]
+
+
        -- check that we're not running off down the garden path.
        when (spinCount > maxSpinCount)
         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
@@ -102,11 +112,14 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
        
        -- try and color the graph 
        let (graph_colored, rsSpill, rmCoalesce)
-                       = {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph
+                       = {-# SCC "ColorGraph" #-}
+                          Color.colorGraph
+                               (dopt Opt_RegsIterative dflags)
+                               regsFree triv spill graph
 
        -- rewrite regs in the code that have been coalesced
        let patchF reg  = case lookupUFM rmCoalesce reg of
-                               Just reg'       -> reg'
+                               Just reg'       -> patchF reg'
                                Nothing         -> reg
        let code_coalesced
                        = map (patchEraseLive patchF) code
@@ -122,7 +135,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                let code_spillclean     = map cleanSpills code_patched
 
                -- strip off liveness information
-               let code_nat            = map stripLive code_patched
+               let code_nat            = map stripLive code_spillclean
 
                -- rewrite SPILL/RELOAD pseudos into real instructions
                let spillNatTop         = mapGenBlockTop spillNatBlock
@@ -176,7 +189,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                -- space leak avoidance
                seqList statList `seq` return ()
 
-               regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
+               regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
                        statList
                        code_relive
 
@@ -233,16 +246,18 @@ buildGraph code
        let (conflictList, moveList) =
                unzip $ map slurpConflicts code
 
-       let conflictBag         = unionManyBags conflictList
-       let moveBag             = unionManyBags moveList
+       -- Slurp out the spill/reload coalesces
+       let moveList2           = map slurpReloadCoalesce code
 
        -- Add the reg-reg conflicts to the graph
+       let conflictBag         = unionManyBags conflictList
        let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 
        -- Add the coalescences edges to the graph.
+       let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
        let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
                        
-       return  graph_coalesce
+       return  $ Color.validateGraph (text "urk") graph_coalesce
 
 
 -- | Add some conflict edges to the graph.
@@ -313,7 +328,7 @@ patchRegsFromGraph graph code
                        (  text "There is no node in the graph for register " <> ppr reg
                        $$ ppr code
                        $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
-       
+
    in  patchEraseLive patchF code