Cure space leak in coloring register allocator

We now do a deep seq on the graph after it is 'built', but before coloring.
Without this, the colorer will just force bits of it and the heap will
fill up with half evaluated pieces of graph from previous build/spill
stages and zillions of apply thunks.

diff --git a/compiler/nativeGen/GraphColor.hs b/compiler/nativeGen/GraphColor.hs
index a0c54e4..c33286b 100644 (file)
--- a/compiler/nativeGen/GraphColor.hs
+++ b/compiler/nativeGen/GraphColor.hs
@@ -78,7 +78,7 @@ colorGraph colors triv spill graph0
                        $$ dotGraph (\x -> text "white") triv graph1) -}
 
         else   ( graph_prob
-               , mkUniqSet ksNoColor
+               , mkUniqSet ksNoColor
                , listToUFM rsCoalesce)
        
 

diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs
index f918fd2..308cae0 100644 (file)
--- a/compiler/nativeGen/GraphOps.hs
+++ b/compiler/nativeGen/GraphOps.hs
@@ -187,13 +187,13 @@ addConflicts conflicts getClass
 
        | otherwise
        = graphMapModify
-       $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
+       $ (\fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
                $ uniqSetToList conflicts)
 
 
 addConflictSet1 u getClass set 
- = let set'    = delOneFromUniqSet set u
-   in  adjustWithDefaultUFM 
+ = case delOneFromUniqSet set u of
+    set' -> adjustWithDefaultUFM
                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
                (newNode u (getClass u))        { nodeConflicts = set' }
                u
@@ -468,5 +468,4 @@ adjustUFM f k map
  = case lookupUFM map k of
        Nothing -> map
        Just a  -> addToUFM map k (f a)
-       
 

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 8449b5e..45e51b9 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -1,15 +1,7 @@
 -- | Graph coloring register allocator.
 --
 -- TODO:
---     Live range splitting:
---             At the moment regs that are spilled are spilled for all time, even though
---             we might be able to allocate them a hardreg in different parts of the code.
---
---     As we're aggressively coalescing before register allocation proper we're not currently
---     using the coalescence information present in the graph.
---
 --     The function that choosing the potential spills could be a bit cleverer.
---
 --     Colors in graphviz graphs could be nicer.
 --
 {-# OPTIONS -fno-warn-missing-signatures #-}
@@ -35,7 +27,6 @@ import UniqSet
 import UniqFM
 import Bag
 import Outputable
-import Util
 
 import Data.List
 import Data.Maybe
@@ -82,6 +73,14 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
        -- build a conflict graph from the code.
        graph           <- {-# SCC "BuildGraph" #-} buildGraph code
 
+       -- VERY IMPORTANT:
+       --      We really do want the graph to be fully evaluated _before_ we start coloring.
+       --      If we don't do this now then when the call to Color.colorGraph forces bits of it,
+       --      the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
+       --
+       seqGraph graph `seq` return ()
+
+
        -- build a map of how many instructions each reg lives for.
        --      this is lazy, it won't be computed unless we need to spill
 
@@ -137,7 +136,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                        , raPatched     = code_patched
                        , raSpillClean  = code_spillclean
                        , raFinal       = code_final
-                       , raSRMs        = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
+                       , raSRMs        = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 
 
                let statList =
@@ -145,7 +144,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                                else []
 
                -- space leak avoidance
-               seqList statList $! return ()
+               seqList statList `seq` return ()
 
                return  ( code_final
                        , statList
@@ -175,7 +174,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                                else []
 
                -- space leak avoidance
-               seqList statList $! return ()
+               seqList statList `seq` return ()
 
                regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
                        statList
@@ -320,6 +319,63 @@ patchRegsFromGraph graph code
 
 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 plusUFMs_C f maps
-       = foldl (plusUFM_C f) emptyUFM maps
-       
+       = foldl' (plusUFM_C f) emptyUFM maps
+
+
+-----
+-- for when laziness just isn't what you wanted...
+--
+seqGraph :: Color.Graph Reg RegClass Reg -> ()
+seqGraph graph         = seqNodes (eltsUFM (Color.graphMap graph))
+
+seqNodes :: [Color.Node Reg RegClass Reg] -> ()
+seqNodes ns
+ = case ns of
+       []              -> ()
+       (n : ns)        -> seqNode n `seq` seqNodes ns
+
+seqNode :: Color.Node Reg RegClass Reg -> ()
+seqNode node
+       =     seqReg      (Color.nodeId node)
+       `seq` seqRegClass (Color.nodeClass node)
+       `seq` seqMaybeReg (Color.nodeColor node)
+       `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
+       `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
+       `seq` (seqRegList (Color.nodePreference node))
+       `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
+
+seqReg :: Reg -> ()
+seqReg reg
+ = case reg of
+       RealReg _       -> ()
+       VirtualRegI _   -> ()
+       VirtualRegHi _  -> ()
+       VirtualRegF _   -> ()
+       VirtualRegD _   -> ()
+
+seqRegClass :: RegClass -> ()
+seqRegClass c
+ = case c of
+       RcInteger       -> ()
+       RcFloat         -> ()
+       RcDouble        -> ()
+
+seqMaybeReg :: Maybe Reg -> ()
+seqMaybeReg mr
+ = case mr of
+       Nothing         -> ()
+       Just r          -> seqReg r
+
+seqRegList :: [Reg] -> ()
+seqRegList rs
+ = case rs of
+       []              -> ()
+       (r : rs)        -> seqReg r `seq` seqRegList rs
+
+seqList :: [a] -> ()
+seqList ls
+ = case ls of
+       []              -> ()
+       (r : rs)        -> r `seq` seqList rs
+