Cure space leak in coloring register allocator

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

diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs
index c3068b8..308cae0 100644 (file)
--- a/compiler/nativeGen/GraphOps.hs
+++ b/compiler/nativeGen/GraphOps.hs
@@ -1,13 +1,6 @@
-
 -- | Basic operations on graphs.
 --
-
-{-# 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
+{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module GraphOps (
        addNode,        delNode,        getNode,        lookupNode,     modNode,
@@ -35,7 +28,6 @@ import UniqFM
 import Data.List       hiding (union)
 import Data.Maybe
 
-
 -- | Lookup a node from the graph.
 lookupNode 
        :: Uniquable k
@@ -195,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
@@ -275,10 +267,11 @@ addPreference (u, c) color
 --
 coalesceGraph
        :: (Uniquable k, Ord k, Eq cls, Outputable k)
-       =>  Graph k cls color
+       => Triv k cls color
+       -> Graph k cls color
        -> (Graph k cls color, [(k, k)])
 
-coalesceGraph graph
+coalesceGraph triv graph
  = let
        -- find all the nodes that have coalescence edges
        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
@@ -297,7 +290,7 @@ coalesceGraph graph
        -- do the coalescing, returning the new graph and a list of pairs of keys
        --      that got coalesced together.
        (graph', mPairs)
-               = mapAccumL coalesceNodes graph cList
+               = mapAccumL (coalesceNodes False triv) graph cList
 
    in  (graph', catMaybes mPairs)
 
@@ -312,32 +305,33 @@ coalesceGraph graph
 
 coalesceNodes
        :: (Uniquable k, Ord k, Eq cls, Outputable k)
-       => Graph k cls color
+       => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                               --      less colorable (aggressive coalescing)
+       -> Triv  k cls color
+       -> Graph k cls color
        -> (k, k)               -- ^ keys of the nodes to be coalesced
        -> (Graph k cls color, Maybe (k, k))
 
-coalesceNodes graph (k1, k2)
+coalesceNodes aggressive triv graph (k1, k2)
        | (kMin, kMax)  <- if k1 < k2
                                then (k1, k2)
                                else (k2, k1)
 
-       -- nodes must be in the graph
-       , Just nMin     <- lookupNode graph kMin
-       , Just nMax     <- lookupNode graph kMax
+       -- the nodes being coalesced must be in the graph
+       , Just nMin             <- lookupNode graph kMin
+       , Just nMax             <- lookupNode graph kMax
 
-       -- can't coalesce conflicting nodes
+       -- can't coalesce conflicting modes
        , not $ elementOfUniqSet kMin (nodeConflicts nMax)
        , not $ elementOfUniqSet kMax (nodeConflicts nMin)
 
-       = coalesceNodes' graph kMin kMax nMin nMax
-
-
+       = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 
-       -- one of the nodes wasn't in the graph anymore
+       -- don't do the coalescing after all
        | otherwise
        = (graph, Nothing)
 
-coalesceNodes' graph kMin kMax nMin nMax
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 
        -- sanity checks
        | nodeClass nMin /= nodeClass nMax
@@ -371,9 +365,20 @@ coalesceNodes' graph kMin kMax nMin nMax
                                        `delOneFromUniqSet` kMax
                        }
 
-               -- delete the old nodes from the graph and add the new one
-               graph'  = addNode kMin node
-                       $ delNode kMin
+         in    coalesceNodes_check aggressive triv graph kMin kMax node
+
+coalesceNodes_check aggressive triv graph kMin kMax node
+
+       -- Unless we're coalescing aggressively, if the result node is not trivially
+       --      colorable then don't do the coalescing.
+       | not aggressive
+       , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+       = (graph, Nothing)
+
+       | otherwise
+       = let -- delete the old nodes from the graph and add the new one
+               graph'  = addNode kMin node
+                       $ delNode kMin
                        $ delNode kMax
                        $ graph
 
@@ -419,7 +424,7 @@ slurpNodeConflictCount
 
 slurpNodeConflictCount graph
        = addListToUFM_C
-               (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
+               (\(c1, n1) (_, n2) -> (c1, n1 + n2))
                emptyUFM
        $ map   (\node
                  -> let count  = sizeUniqSet $ nodeConflicts node
@@ -441,6 +446,7 @@ setColor u color
                u 
        
 
+{-# INLINE     adjustWithDefaultUFM #-}
 adjustWithDefaultUFM 
        :: Uniquable k 
        => (a -> a) -> a -> k 
@@ -448,11 +454,11 @@ adjustWithDefaultUFM
 
 adjustWithDefaultUFM f def k map
        = addToUFM_C 
-               (\old new -> f old)
+               (\old _ -> f old)
                map
                k def
                
-
+{-# INLINE adjustUFM #-}
 adjustUFM 
        :: Uniquable k
        => (a -> a)
@@ -462,5 +468,4 @@ adjustUFM f k map
  = case lookupUFM map k of
        Nothing -> map
        Just a  -> addToUFM map k (f a)
-