Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/0db230a4d0a3c48a26ed42448a64034402cca897 >--------------------------------------------------------------- commit 0db230a4d0a3c48a26ed42448a64034402cca897 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Feb 16 11:05:24 2012 +0000 Fix some instances where I had forgotten to consider varBndrFreeVars >--------------------------------------------------------------- compiler/supercompile/Supercompile.hs | 14 ++++++++++++-- .../supercompile/Supercompile/Drive/Process.hs | 2 +- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index e76dbe3..46dfeed 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -93,7 +93,17 @@ coreBindsToCoreTerm should_sc binds internal_sc_binds = [case bind of NonRec x e -> NonRec (localiseInternaliseId x) e Rec xes -> Rec (map (first localiseInternaliseId) xes) | bind <- sc_binds] - sc_xs_internal_xs = filter (\(x, _) -> isExportedId x || x `elemVarSet` dont_sc_binds_fvs) (sc_xs `zip` bindersOfBinds internal_sc_binds) + -- Decide which things we should export from the supercompiled term using a Church tuple. + -- We need to export to the top level of the module those bindings that are *any* of: + -- 1. Are exported by the module itself + -- 2. Are free variables of the non-supercompiled bindings + -- 3. Are free variables of the var binder for another top-level-exported thing + go exported exported' undecided + | null exported' = exported + | otherwise = go (exported' ++ exported) exported'' undecided' + where (exported'', undecided') = partition (\(x, _) -> x `elemVarSet` exported_xs') undecided + exported_xs' = unionVarSets (map (S.idFreeVars . fst) exported') + sc_xs_internal_xs = uncurry (go []) (partition (\(x, _) -> isExportedId x || x `elemVarSet` dont_sc_binds_fvs) (sc_xs `zip` bindersOfBinds internal_sc_binds)) sc_internal_xs = map snd sc_xs_internal_xs localiseInternaliseId x = setIdNotExported (x `setVarName` localiseName (varName x)) -- If we don't mark these Ids as not exported then we get lots of residual top-level bindings of the form x = y @@ -119,7 +129,7 @@ termUnfoldings :: S.Term -> [(Var, S.Term)] termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] where go new_fvs all_fvs all_xes - | isEmptyVarSet added_fvs = all_xes + | isEmptyVarSet added_fvs = all_xes -- FIXME: varBndrFreeVars? | otherwise = go (unionVarSets (map (S.termFreeVars . snd) added_xes)) (all_fvs `unionVarSet` added_fvs) (added_xes ++ all_xes) where added_fvs = new_fvs `minusVarSet` all_fvs added_xes = [ (x, e) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index 230a0c9..a3fd0ba 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -279,7 +279,7 @@ prepareTerm unfoldings e = pprTraceSC "unfoldings" (pPrintPrecLetRec noPrec (M.t where add_one_unfolding (input_fvs', tag_ids1) (x', e) = ((input_fvs'', tag_ids2), (x', renamedTerm anned_e)) where (tag_unf_ids, tag_ids2) = splitUniqSupply tag_ids1 anned_e = toAnnedTerm tag_unf_ids e - input_fvs'' = input_fvs' `unionVarSet` annedFreeVars anned_e + input_fvs'' = input_fvs' `unionVarSet` varBndrFreeVars x' `unionVarSet` annedFreeVars anned_e (_, h_fvs) = mapAccumL add_one_fv tag_ids2 (varSetElems input_fvs) where add_one_fv tag_ids2 x' = (tag_ids3, (x', environmentallyBound (mkTag (getKey i)))) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
