[commit: ghc] supercompiler: Small fixes to Split2 (46ca464)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/46ca464e264287bd20cf9530292e42fab4b03910

>---------------------------------------------------------------

commit 46ca464e264287bd20cf9530292e42fab4b03910
Author: Max Bolingbroke <[email protected]>
Date:   Fri Jul 13 14:37:19 2012 +0100

    Small fixes to Split2

>---------------------------------------------------------------

 compiler/supercompile/Supercompile/Drive/Split2.hs |   10 +++++++---
 1 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs b/compiler/supercompile/Supercompile/Drive/Split2.hs
index 99f0c18..618efbc 100644
--- a/compiler/supercompile/Supercompile/Drive/Split2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split2.hs
@@ -322,8 +322,12 @@ recurseStack opt k (init_resid_tgs, init_deeds, init_e) = (\f -> foldM f (init_r
 recurseHeap :: Monad m
             => (State -> m (Deeds, Out FVedTerm))
             -> PushedHeap -> (ResidTags, Deeds, [(Var, FVedTerm)], FVedTerm) -> m (ResidTags, Deeds, FVedTerm)
-recurseHeap opt init_h (resid_tgs, init_deeds, init_xes, e) = go init_h init_deeds init_xes (fvedTermFreeVars e)
-  where go h deeds xes do_fvs | M.null h_to_do = return (resid_tgs, deeds, letRec xes e)
+recurseHeap opt init_h (resid_tgs, init_deeds, init_xes, e)
+  -- Unfortunately, it is necessary to remove elements from init_h that already have a residual binding in init_xes.
+  -- The reason for this is that if the stack has an initial update and a value is in focus, we can get a residual
+  -- binding for that from either the "stack" or the "heap" portion. What we must avoid is binding both in a let at the same time!
+  = go (foldr (M.delete . fst) init_h init_xes) init_deeds init_xes (fvedTermFreeVars e)
+  where go h deeds xes do_fvs | M.null h_to_do = return (resid_tgs, deeds, bindManyMixedLiftedness fvedTermFreeVars xes e)
                               | otherwise      = do (extra_deedss, extra_xes) <- liftM unzip $ mapM (\(x, e) -> liftM (second ((,) x)) $ opt e) (M.toList h_to_do)
                                                     go h' (plusDeedss extra_deedss `plusDeeds` deeds) (extra_xes ++ xes)
                                                        (foldr (\(x, e) do_fvs -> varBndrFreeVars x `unionVarSet` fvedTermFreeVars e `unionVarSet` do_fvs) emptyVarSet xes)
@@ -490,7 +494,7 @@ solve :: S.Set Context
       -> S.Set Context
 solve generalised = M.keysSet . go_graph
   where
-    go_graph = uncurry (flip $ go M.empty) . first M.toAscList . sccs
+    go_graph = uncurry (flip $ go M.empty) . sccs
 
     -- NB: the input list is ascending, so lower indexes come first, so we process all predecessors of a SCC before the SCC itself
     go :: M.Map Context (M.Map Context (Maybe Context))         -- Successor |-> Predecessor |-> Just context (iff you end up in a *single* context by inlining along this edge, and which context that is). INVARIANT: no empty maps in range of first mapping