Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ab9c02f371da4fd3ac5c727bbb2dd0050ff7defd >--------------------------------------------------------------- commit ab9c02f371da4fd3ac5c727bbb2dd0050ff7defd Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Tue Jul 17 15:02:03 2012 +0100 Include the init_xes when deciding which extra bindings need to be resid >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/Split2.hs | 15 +++++++++------ 1 files changed, 9 insertions(+), 6 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs b/compiler/supercompile/Supercompile/Drive/Split2.hs index 618efbc..a84ba88 100644 --- a/compiler/supercompile/Supercompile/Drive/Split2.hs +++ b/compiler/supercompile/Supercompile/Drive/Split2.hs @@ -326,12 +326,15 @@ 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) - where (h_to_do, h') = M.partitionWithKey (\x _ -> x `elemVarSet` do_fvs) h + = go (foldr (M.delete . fst) init_h init_xes) init_deeds init_xes + (foldr (\(x, e) fvs -> varBndrFreeVars x `unionVarSet` fvedTermFreeVars e `unionVarSet` fvs) (fvedTermFreeVars e) init_xes) + where go h deeds xes do_fvs + -- | pprTrace "go" (ppr do_fvs $$ ppr (M.keysSet h)) False = undefined + | M.null h_to_do = return (resid_tgs, deeds, bindManyMixedLiftedness fvedTermFreeVars xes e) + | otherwise = do (extra_deedss, extra_xes) <- liftM unzip $ mapM (\(x, e) -> {- pprTrace "go1" (ppr x) $ -} 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 extra_xes) + where (h_to_do, h') = M.partitionWithKey (\x _ -> x `elemVarSet` do_fvs) h {- _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
