X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FFreeVars.lhs;h=9ed5f09348b2e31c5f99258d46f56907007d6bf8;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=b0b39e371c45ac3c6e8c5ce66815070b7a5989f7;hpb=ba013704bfb94aa133fb28f342e0d432698a5d6d;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index b0b39e3..9ed5f09 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -1,43 +1,25 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % Taken quite directly from the Peyton Jones/Lester paper. \begin{code} module FreeVars ( - -- Cheap and cheerful variant... - exprFreeVars, - - -- Complicated and expensive variant for float-out freeVars, - freeVarsOf, freeTyVarsOf, - CoreExprWithFVs, -- For the above functions - AnnCoreExpr, -- Dito - FVInfo(..), LeakInfo(..) + freeVarsOf, + CoreExprWithFVs, CoreBindWithFVs ) where #include "HsVersions.h" -import AnnCoreSyn -- output - import CoreSyn -import CoreUtils ( idSpecVars ) -import Id ( idType, getIdArity, isBottomingId, - emptyIdSet, unitIdSet, mkIdSet, unionIdSets, - elementOfIdSet, minusIdSet, unionManyIdSets, - IdSet, Id - ) -import IdInfo ( ArityInfo(..) ) -import PrimOp ( PrimOp(..) ) +import CoreUtils ( idFreeVars ) +import Id ( Id ) +import VarSet +import Var ( IdOrTyVar, isId ) +import Name ( isLocallyDefined ) import Type ( tyVarsOfType, Type ) -import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, - intersectTyVarSets, - TyVarSet, TyVar - ) -import BasicTypes ( Unused ) -import UniqSet ( unionUniqSets, addOneToUniqSet ) -import Util ( panic, assertPanic ) - +import Util ( mapAndUnzip ) \end{code} %************************************************************************ @@ -49,72 +31,53 @@ import Util ( panic, assertPanic ) The free variable pass annotates every node in the expression with its NON-GLOBAL free variables and type variables. -The ``free type variables'' are defined to be those which are mentioned -in type applications, {\em not} ones which lie buried in the types of Ids. - -*** ALAS: we *do* need to collect tyvars from lambda-bound ids. *** -I've half-convinced myself we don't for case- and letrec bound ids -but I might be wrong. (SLPJ, date unknown) - -\begin{code} -type CoreExprWithFVs = AnnCoreExpr Id Id Unused FVInfo - -type TyVarCands = TyVarSet -- for when we carry around lists of -type IdCands = IdSet -- "candidate" TyVars/Ids. -noTyVarCands = emptyTyVarSet -noIdCands = emptyIdSet - -data FVInfo - = FVInfo IdSet -- Free ids - TyVarSet -- Free tyvars - LeakInfo - -noFreeIds = emptyIdSet -noFreeTyVars = emptyTyVarSet -noFreeAnything = (noFreeIds, noFreeTyVars) -aFreeId i = unitIdSet i -aFreeTyVar t = unitTyVarSet t -is_among = elementOfIdSet -munge_id_ty i = tyVarsOfType (idType i) -combine = unionUniqSets -- used both for {Id,TyVar}Sets -add = addOneToUniqSet - -combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2) - = FVInfo (fvs1 `combine` fvs2) - (tfvs1 `combine` tfvs2) - (leak1 `orLeak` leak2) -\end{code} - -Leak-free-ness is based only on the value, not the type. In -particular, nested collections of constructors are guaranteed leak -free. Function applications are not, except for PAPs. - -Applications of error gets (LeakFree bigArity) -- a hack! - \begin{code} -data LeakInfo - = MightLeak - | LeakFree Int -- Leak free, and guarantees to absorb this # of - -- args before becoming leaky. +type CoreBindWithFVs = AnnBind Id IdOrTyVarSet +type CoreExprWithFVs = AnnExpr Id IdOrTyVarSet + -- Every node annotated with its free variables, + -- both Ids and TyVars -lEAK_FREE_0 = LeakFree 0 -lEAK_FREE_BIG = LeakFree bigArity - where - bigArity = 1000::Int -- NB: arbitrary - -orLeak :: LeakInfo -> LeakInfo -> LeakInfo -orLeak MightLeak _ = MightLeak -orLeak _ MightLeak = MightLeak -orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m) +freeVarsOf :: CoreExprWithFVs -> IdSet +freeVarsOf (free_vars, _) = free_vars + +noFVs = emptyVarSet +aFreeVar = unitVarSet +unionFVs = unionVarSet + +filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet + +-- (b `filters` s) removes the binder b from the free variable set s, +-- but *adds* to s +-- (a) the free variables of b's type +-- (b) the idSpecVars of b +-- +-- This is really important for some lambdas: +-- In (\x::a -> x) the only mention of "a" is in the binder. +-- +-- Also in +-- let x::a = b in ... +-- we should really note that "a" is free in this expression. +-- It'll be pinned inside the /\a by the binding for b, but +-- it seems cleaner to make sure that a is in the free-var set +-- when it is mentioned. +-- +-- This also shows up in recursive bindings. Consider: +-- /\a -> letrec x::a = x in E +-- Now, there are no explicit free type variables in the RHS of x, +-- but nevertheless "a" is free in its definition. So we add in +-- the free tyvars of the types of the binders, and include these in the +-- free vars of the group, attached to the top level of each RHS. +-- +-- This actually happened in the defn of errorIO in IOBase.lhs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +filters b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b + | otherwise = s `delVarSet` b \end{code} -Main public interface: -\begin{code} -freeVars :: CoreExpr -> CoreExprWithFVs - -freeVars expr = fvExpr noIdCands noTyVarCands expr - -\end{code} %************************************************************************ %* * @@ -122,331 +85,86 @@ freeVars expr = fvExpr noIdCands noTyVarCands expr %* * %************************************************************************ -We do the free-variable stuff by passing around ``candidates lists'' -of @Ids@ and @TyVars@ that may be considered free. This is useful, -e.g., to avoid considering top-level binders as free variables---don't -put them on the candidates list. - \begin{code} +freeVars :: CoreExpr -> CoreExprWithFVs -fvExpr :: IdCands -- In-scope Ids - -> TyVarCands -- In-scope tyvars - -> CoreExpr - -> CoreExprWithFVs - -fvExpr id_cands tyvar_cands (Var v) - = (FVInfo fvs noFreeTyVars leakiness, AnnVar v) +freeVars (Var v) + = (fvs, AnnVar v) where - {- - ToDo: insert motivating example for why we *need* - to include the idSpecVars in the FV list. - -} - fvs = fvs_v `unionIdSets` mkIdSet (idSpecVars v) - - fvs_v - | v `is_among` id_cands = aFreeId v - | otherwise = noFreeIds - - leakiness - | isBottomingId v = lEAK_FREE_BIG -- Hack - | otherwise = case getIdArity v of - UnknownArity -> lEAK_FREE_0 - ArityAtLeast arity -> LeakFree arity - ArityExactly arity -> LeakFree arity + -- ToDo: insert motivating example for why we *need* + -- to include the idSpecVars in the FV list. + -- Actually [June 98] I don't think it's necessary + -- fvs = fvs_v `unionVarSet` idSpecVars v -fvExpr id_cands tyvar_cands (Lit k) - = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k) + fvs | isLocallyDefined v = aFreeVar v + | otherwise = noFVs -fvExpr id_cands tyvar_cands (Con c args) - = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args) +freeVars (Con con args) + = (foldr (unionFVs . freeVarsOf) noFVs args2, AnnCon con args2) where - (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args + args2 = map freeVars args -fvExpr id_cands tyvar_cands (Prim op args) - = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args) +freeVars (Lam b body) + = (b `filters` freeVarsOf body', AnnLam b body') where - (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-} - args_to_use - = case op of - CCallOp _ _ _ _ res_ty -> TyArg res_ty : args - _ -> args + body' = freeVars body --- this Lam stuff could probably be improved by rewriting (WDP 96/03) - -fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body) - = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder) - (freeTyVarsOf body2 `combine` munge_id_ty binder) - leakiness, - AnnLam b body2) +freeVars (App fun arg) + = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2) where - -- We need to collect free tyvars from the binders - body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body - - leakiness = case leakinessOf body2 of - MightLeak -> LeakFree 1 - LeakFree n -> LeakFree (n + 1) + fun2 = freeVars fun + arg2 = freeVars arg -fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body) - = (FVInfo (freeVarsOf body2) - (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar) - (leakinessOf body2), - AnnLam b body2) +freeVars (Case scrut bndr alts) + = ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2, + AnnCase scrut2 bndr alts2) where - body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body + scrut2 = freeVars scrut --- ditto on rewriting this App stuff (WDP 96/03) + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = foldr1 unionFVs alts_fvs_s -fvExpr id_cands tyvar_cands (App fun arg) - = (FVInfo (freeVarsOf fun2 `combine` fvs_arg) - (freeTyVarsOf fun2 `combine` tfvs_arg) - leakiness, - AnnApp fun2 arg) - where - fun2 = fvExpr id_cands tyvar_cands fun - fun2_leakiness = leakinessOf fun2 + fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args, + (con, args, rhs2)) + where + rhs2 = freeVars rhs - (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg] - - leakiness = if (notValArg arg) then - fun2_leakiness - else - case fun2_leakiness of - LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >= - other -> MightLeak - -fvExpr id_cands tyvar_cands (Case expr alts) - = (combineFVInfo expr_fvinfo alts_fvinfo, - AnnCase expr2 alts') +freeVars (Let (NonRec binder rhs) body) + = (freeVarsOf rhs2 `unionFVs` body_fvs, + AnnLet (AnnNonRec binder rhs2) body2) where - expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr - (alts_fvinfo, alts') = annotate_alts alts - - annotate_alts (AlgAlts alts deflt) - = (fvinfo, AnnAlgAlts alts' deflt') - where - (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts) - (deflt_fvinfo, deflt') = annotate_default deflt - fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s - - ann_boxed_alt (con, params, rhs) - = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params) - (freeTyVarsOf rhs' `combine` param_ftvs) - (leakinessOf rhs'), - (con, params, rhs')) - where - rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs - param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params - -- We need to collect free tyvars from the binders - - annotate_alts (PrimAlts alts deflt) - = (fvinfo, AnnPrimAlts alts' deflt') - where - (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts) - (deflt_fvinfo, deflt') = annotate_default deflt - fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s - - ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs')) - where - rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs - - annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG, - AnnNoDefault) - - annotate_default (BindDefault binder rhs) - = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder) - (freeTyVarsOf rhs' `combine` binder_ftvs) - (leakinessOf rhs'), - AnnBindDefault binder rhs') - where - rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs - binder_ftvs = munge_id_ty binder - -- We need to collect free tyvars from the binder - --- Don't forget to notice that the idSpecVars of the binder --- are free in the whole expression; albeit not in the RHS or body - -fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body) - = (FVInfo (freeVarsOf rhs' `combine` body_fvs `combine` mkIdSet (idSpecVars binder)) - (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs) - (leakinessOf rhs' `orLeak` leakinessOf body2), - AnnLet (AnnNonRec binder rhs') body2) + rhs2 = freeVars rhs + body2 = freeVars body + body_fvs = binder `filters` freeVarsOf body2 + +freeVars (Let (Rec binds) body) + = (foldl delVarSet group_fvs binders, + -- The "filters" part may have added one of the binders + -- via the idSpecVars part, so we must delete it again + AnnLet (AnnRec (binders `zip` rhss2)) body2) where - rhs' = fvRhs id_cands tyvar_cands (binder, rhs) - body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body - body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder - binder_ftvs = munge_id_ty binder - -- We need to collect free tyvars from the binder + (binders, rhss) = unzip binds -fvExpr id_cands tyvar_cands (Let (Rec binds) body) - = (FVInfo (binds_fvs `combine` body_fvs) - (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs) - (leakiness_of_rhss `orLeak` leakinessOf body2), - AnnLet (AnnRec (binders `zip` rhss')) body2) - where - (binders, rhss) = unzip binds - new_id_cands = binders_set `combine` id_cands - binders_set = mkIdSet binders - rhss' = map (fvRhs new_id_cands tyvar_cands) binds - - FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss - = foldr1 combineFVInfo [info | (info,_) <- rhss'] - - -- Don't forget to notice that the idSpecVars of the binder - -- are free in the whole expression; albeit not in the RHS or body - binds_fvs = (foldr (unionIdSets . mkIdSet . idSpecVars) rhss_fvs binders) - `minusIdSet` - binders_set + rhss2 = map freeVars rhss + all_fvs = foldr (unionFVs . fst) body_fvs rhss2 + group_fvs = foldr filters all_fvs binders - body2 = fvExpr new_id_cands tyvar_cands body - body_fvs = freeVarsOf body2 `minusIdSet` binders_set - binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders - -- We need to collect free tyvars from the binders + body2 = freeVars body + body_fvs = freeVarsOf body2 -fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr) - = (FVInfo (freeVarsOf expr2) - (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2) - (leakinessOf expr2), +freeVars (Note (Coerce to_ty from_ty) expr) + = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2, AnnNote (Coerce to_ty from_ty) expr2) where - expr2 = fvExpr id_cands tyvar_cands expr - tfvs1 = freeTy tyvar_cands from_ty - tfvs2 = freeTy tyvar_cands to_ty + expr2 = freeVars expr + tfvs1 = tyVarsOfType from_ty + tfvs2 = tyVarsOfType to_ty -fvExpr id_cands tyvar_cands (Note other_note expr) - = (fvinfo, AnnNote other_note expr2) +freeVars (Note other_note expr) + = (freeVarsOf expr2, AnnNote other_note expr2) where - expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr + expr2 = freeVars expr -fvRhs id_cands tyvar_cands (bndr,rhs) - = fvExpr id_cands tyvar_cands rhs +freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) \end{code} -\begin{code} -freeArgs :: IdCands -> TyVarCands - -> [CoreArg] - -> (IdSet, TyVarSet) - -freeArgs icands tcands [] = noFreeAnything -freeArgs icands tcands (arg:args) - -- this code is written this funny way only for "efficiency" purposes - = let - free_first_arg@(arg_fvs, tfvs) = free_arg arg - in - if (null args) then - free_first_arg - else - case (freeArgs icands tcands args) of { (irest, trest) -> - (arg_fvs `combine` irest, tfvs `combine` trest) } - where - free_arg (LitArg _) = noFreeAnything - free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty) - free_arg (VarArg v) - | v `is_among` icands = (aFreeId v, noFreeTyVars) - | otherwise = noFreeAnything - ---------- -freeTy :: TyVarCands -> Type -> TyVarSet - -freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands - -freeVarsOf :: CoreExprWithFVs -> IdSet -freeVarsOf (FVInfo free_vars _ _, _) = free_vars - -freeTyVarsOf :: CoreExprWithFVs -> TyVarSet -freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars - -leakinessOf :: CoreExprWithFVs -> LeakInfo -leakinessOf (FVInfo _ _ leakiness, _) = leakiness -\end{code} - - -%************************************************************************ -%* * -\section{Finding the free variables of an expression} -%* * -%************************************************************************ - -This function simply finds the free variables of an expression. - -\begin{code} -type InterestingIdFun - = Id -- The Id being looked at - -> Bool -- True <=> interesting - -exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet -exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e -\end{code} - - -\begin{code} -expr_fvs :: InterestingIdFun -- "Interesting id" predicate - -> IdSet -- In scope ids - -> CoreExpr - -> IdSet - -expr_fvs fv_cand in_scope (Var v) = id_fvs fv_cand in_scope v -expr_fvs fv_cand in_scope (Lit lit) = noFreeIds -expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args -expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args -expr_fvs fv_cand in_scope (Note _ expr) = expr_fvs fv_cand in_scope expr -expr_fvs fv_cand in_scope (App fun arg) = expr_fvs fv_cand in_scope fun `combine` - arg_fvs fv_cand in_scope arg - - -expr_fvs fv_cand in_scope (Lam (ValBinder b) body) - = (expr_fvs fv_cand (in_scope `add` b) body) -expr_fvs fv_cand in_scope (Lam (TyBinder b) body) - = expr_fvs fv_cand in_scope body - -expr_fvs fv_cand in_scope (Case scrut alts) - = expr_fvs fv_cand in_scope scrut `combine` alts_fvs - where - alts_fvs - = case alts of - AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs) - where - alt_fvs = map do_alg_alt alg_alts - deflt_fvs = do_deflt deflt - - PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs) - where - alt_fvs = map do_prim_alt prim_alts - deflt_fvs = do_deflt deflt - - do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet - do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs - where - new_in_scope = in_scope `combine` mkIdSet args - - do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs - - do_deflt NoDefault = noFreeIds - do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs - -expr_fvs fv_cand in_scope (Let (NonRec b r) body) - = expr_fvs fv_cand in_scope r `combine` - expr_fvs fv_cand (in_scope `add` b) body - -expr_fvs fv_cand in_scope (Let (Rec pairs) body) - = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine` - expr_fvs fv_cand in_scope' body - where - in_scope' = in_scope `combine` mkIdSet (map fst pairs) - - - - --------------------------------------- -arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v -arg_fvs fv_cand in_scope other_arg = noFreeIds - --------------------------------------- -args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args - - --------------------------------------- -id_fvs fv_cand in_scope v - | v `elementOfIdSet` in_scope = noFreeIds - | fv_cand v = aFreeId v - | otherwise = noFreeIds -\end{code}