[commit: ghc] supercompiler: Fix some FV issues so that map-map actually doesn't loop (b4585b8)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/b4585b8c910fa473fe673187a99e78e9d2cc8439

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

commit b4585b8c910fa473fe673187a99e78e9d2cc8439
Author: Max Bolingbroke <[email protected]>
Date:   Wed Jul 4 16:35:22 2012 +0100

    Fix some FV issues so that map-map actually doesn't loop

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

 compiler/supercompile/Supercompile.hs              |    2 +-
 .../supercompile/Supercompile/Core/FreeVars.hs     |    2 +-
 .../Supercompile/Evaluator/FreeVars.hs             |    4 ++--
 3 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs
index acc5811..5f59e69 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -151,7 +151,7 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] []
     go new_fvs all_fvs all_xwhy_nots all_xes
       | isEmptyVarSet added_fvs = pprTrace "termUnfoldings" (vcat [hang (text why_not <> text ":") 2 (vcat (map ppr xs)) | (why_not, xs) <- groups snd fst all_xwhy_nots]) $
                                   all_xes
-      | otherwise               = go (unionVarSets (map (S.termFreeVars . snd) added_xes)) (all_fvs `unionVarSet` added_fvs)
+      | otherwise               = go (unionVarSets (map (\(x, e) -> S.idBndrFreeVars x `unionVarSet` S.termFreeVars e) added_xes)) (all_fvs `unionVarSet` added_fvs)
                                      (added_xwhy_nots ++ all_xwhy_nots) (added_xes ++ all_xes)
       where added_fvs = new_fvs `minusVarSet` all_fvs
             (added_xwhy_nots, added_xes)
diff --git a/compiler/supercompile/Supercompile/Core/FreeVars.hs b/compiler/supercompile/Supercompile/Core/FreeVars.hs
index bc4f6a3..ab26191 100644
--- a/compiler/supercompile/Supercompile/Core/FreeVars.hs
+++ b/compiler/supercompile/Supercompile/Core/FreeVars.hs
@@ -71,7 +71,7 @@ mkFreeVars rec = (unitVarSet, term, term', alternatives, value, value')
     term' (PrimOp _ tys es)  = unionVarSets (map typ tys) `unionVarSet` unionVarSets (map term es)
     term' (Case e x ty alts) = typ ty `unionVarSet` term e `unionVarSet` nonRecBinderFreeVars x (alternatives alts)
     term' (Let x e1 e2)      = term e1 `unionVarSet` nonRecBinderFreeVars x (term e2)
-    term' (LetRec xes e)     = (unionVarSets (map term es) `unionVarSet` term e `unionVarSet` unionVarSets (map idFreeVars xs)) `delVarSetList` xs
+    term' (LetRec xes e)     = (unionVarSets (map term es) `unionVarSet` term e `unionVarSet` unionVarSets (map idBndrFreeVars xs)) `delVarSetList` xs
       where (xs, es) = unzip xes
     term' (Cast e co)        = term e `unionVarSet` tyCoVarsOfCo co
     
diff --git a/compiler/supercompile/Supercompile/Evaluator/FreeVars.hs b/compiler/supercompile/Supercompile/Evaluator/FreeVars.hs
index a8d8e72..598ddbb 100644
--- a/compiler/supercompile/Supercompile/Evaluator/FreeVars.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/FreeVars.hs
@@ -51,7 +51,7 @@ stackFrameOpenFreeVars kf = case kf of
     Scrutinise x' ty in_alts -> (emptyVarSet, (nonRecBinderFreeVars x' (inFreeVars annedAltsFreeVars in_alts)) `unionVarSet` tyVarsOfType ty)
     PrimApply _ tys as in_es -> (emptyVarSet, unionVarSets (map tyVarsOfType tys) `unionVarSet` unionVarSets (map annedFreeVars as) `unionVarSet` unionVarSets (map (inFreeVars annedTermFreeVars) in_es))
     StrictLet x' in_e2       -> (emptyVarSet, nonRecBinderFreeVars x' (inFreeVars annedTermFreeVars in_e2))
-    Update x'                -> (unitVarSet x', varBndrFreeVars x')
+    Update x'                -> (unitVarSet x', idBndrFreeVars x')
     CastIt co'               -> (emptyVarSet, tyCoVarsOfCo co')
 
 
@@ -71,7 +71,7 @@ pureHeapVars :: PureHeap -> (HowBound -> BoundVars, FreeVars)
         InternallyBound -> (bvs_internal `extendVarSet` x', bvs_lambda, bvs_let)
         LambdaBound     -> (bvs_internal, bvs_lambda `extendVarSet` x', bvs_let)
         LetBound        -> (bvs_internal, bvs_lambda, bvs_let `extendVarSet` x'),
-        fvs `unionVarSet` heapBindingFreeVars hb)
+        fvs `unionVarSet` varBndrFreeVars x' `unionVarSet` heapBindingFreeVars hb)
     
     stackOpenFreeVars' :: Stack -> FreeVars -> (BoundVars, FreeVars)
     stackOpenFreeVars' k fvs = case stackOpenFreeVars k of (k_bvs, k_fvs) -> (k_bvs, fvs `unionVarSet` k_fvs)