Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/b4585b8c910fa473fe673187a99e78e9d2cc8439 >--------------------------------------------------------------- commit b4585b8c910fa473fe673187a99e78e9d2cc8439 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
