Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules

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

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 0a5c160..27b603c 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -13,6 +13,13 @@
 --     Colors in graphviz graphs could be nicer.
 --
 
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module RegAllocColor ( 
        regAlloc,
        regDotColor
@@ -23,6 +30,7 @@ where
 import qualified GraphColor    as Color
 import RegLiveness
 import RegSpill
+import RegSpillClean
 import RegAllocStats
 import MachRegs
 import MachInstrs
@@ -50,22 +58,23 @@ maxSpinCount        = 10
 -- | 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
                
-regAlloc regsFree slotsFree code
+regAlloc dump regsFree slotsFree code
  = 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 )
 
-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)
@@ -106,16 +115,30 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
         then do
                -- patch the registers using the info in the graph
                let code_patched        = map (patchRegsFromGraph graph_colored) code
+
+               -- clean out unneeded SPILL/RELOADs
+               let code_spillclean     = map cleanSpills code_patched
+
+               -- strip off liveness information
                let code_nat            = map stripLive code_patched
+
+               -- rewrite SPILL/REALOAD pseudos into real instructions
+               let spillNatTop         = mapGenBlockTop spillNatBlock
+               let code_final          = map spillNatTop code_nat
                
                -- record what happened in this stage for debugging
                let stat                =
                        RegAllocStatsColored
                        { raGraph       = graph_colored
-                       , raPatchedCmm  = code_patched }
-
-               return  ( code_nat
-                       , [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                       , raPatched     = code_patched
+                       , raSpillClean  = code_spillclean
+                       , raFinal       = code_final
+                       , raSRMs        = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
+
+               return  ( code_final
+                       , if dump
+                               then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                               else []
                        , graph_colored)
 
         else do
@@ -136,8 +159,10 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
                        , 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