Small improvement to GraphColor.selectColor

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

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 1968be4..8449b5e 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -12,13 +12,7 @@
 --
 --     Colors in graphviz graphs could be nicer.
 --
-
-{-# OPTIONS -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/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module RegAllocColor ( 
        regAlloc,
@@ -41,6 +35,7 @@ import UniqSet
 import UniqFM
 import Bag
 import Outputable
+import Util
 
 import Data.List
 import Data.Maybe
@@ -67,7 +62,7 @@ regAlloc
                
 regAlloc dump regsFree slotsFree code
  = do
-       (code_final, debug_codeGraphs, graph_final)
+       (code_final, debug_codeGraphs, _)
                <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
        
        return  ( code_final
@@ -85,11 +80,12 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
 
        -- build a conflict graph from the code.
-       graph           <- buildGraph code
+       graph           <- {-# SCC "BuildGraph" #-} buildGraph code
 
        -- build a map of how many instructions each reg lives for.
        --      this is lazy, it won't be computed unless we need to spill
-       let fmLife      = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2))
+
+       let fmLife      = {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
                        $ map lifetimeCount code
 
        -- record startup state
@@ -107,7 +103,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
        
        -- try and color the graph 
        let (graph_colored, rsSpill, rmCoalesce)
-                       = Color.colorGraph regsFree triv spill graph
+                       = {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph
 
        -- rewrite regs in the code that have been coalesced
        let patchF reg  = case lookupUFM rmCoalesce reg of
@@ -129,7 +125,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                -- strip off liveness information
                let code_nat            = map stripLive code_patched
 
-               -- rewrite SPILL/REALOAD pseudos into real instructions
+               -- rewrite SPILL/RELOAD pseudos into real instructions
                let spillNatTop         = mapGenBlockTop spillNatBlock
                let code_final          = map spillNatTop code_nat
                
@@ -143,17 +139,23 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                        , raFinal       = code_final
                        , raSRMs        = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 
-               return  ( code_final
-                       , if dump
-                               then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+
+               let statList =
+                       if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
                                else []
+
+               -- space leak avoidance
+               seqList statList $! return ()
+
+               return  ( code_final
+                       , statList
                        , graph_colored)
 
         else do
                -- spill the uncolored regs
                (code_spilled, slotsFree', spillStats)
                        <- regSpill code_coalesced slotsFree rsSpill
-                       
+
                -- recalculate liveness
                let code_nat    = map stripLive code_spilled
                code_relive     <- mapM regLiveness code_nat
@@ -167,11 +169,16 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                        , raLifetimes   = fmLife
                        , raSpilled     = code_spilled }
                                
-               -- try again
-               regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
-                       (if dump
+               let statList =
+                       if dump
                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
-                               else [])
+                               else []
+
+               -- space leak avoidance
+               seqList statList $! return ()
+
+               regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
+                       statList
                        code_relive
 
  
@@ -270,10 +277,10 @@ graphAddCoalesce
        -> Color.Graph Reg RegClass Reg
        
 graphAddCoalesce (r1, r2) graph
-       | RealReg regno <- r1
+       | RealReg _ <- r1
        = Color.addPreference (regWithClass r2) r1 graph
        
-       | RealReg regno <- r2
+       | RealReg _ <- r2
        = Color.addPreference (regWithClass r1) r2 graph
        
        | otherwise
@@ -306,7 +313,7 @@ patchRegsFromGraph graph code
                = pprPanic "patchRegsFromGraph: register mapping failed." 
                        (  text "There is no node in the graph for register " <> ppr reg
                        $$ ppr code
-                       $$ Color.dotGraph (\x -> text "white") trivColorable graph)
+                       $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
        
    in  patchEraseLive patchF code
    
@@ -315,3 +322,4 @@ plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 plusUFMs_C f maps
        = foldl (plusUFM_C f) emptyUFM maps
        
+