[commit: ghc] : Fix some instances where I had forgotten to consider varBndrFreeVars (0db230a)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/0db230a4d0a3c48a26ed42448a64034402cca897

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

commit 0db230a4d0a3c48a26ed42448a64034402cca897
Author: Max Bolingbroke <[email protected]>
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))))