X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreFVs.lhs;h=1c3021738bc5cb35c14164e3a6e740c3f2e9f6ca;hb=17629712b35948e3751a39747dcc9ee0cbfb72aa;hp=a6f39b37b0969e36d3cbbeb333e1be1717eaeadd;hpb=5ca77490a603e0175bb717343884533ad8de017d;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index a6f39b3..1c30217 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -5,24 +5,35 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} module CoreFVs ( - exprFreeVars, exprsFreeVars, + exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprsFreeVars, -- [CoreExpr] -> VarSet + exprSomeFreeVars, exprsSomeFreeVars, - idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars, - CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf, + idRuleVars, idFreeVars, idFreeTyVars, + ruleSomeFreeVars, ruleRhsFreeVars, + ruleLhsFreeNames, ruleLhsFreeIds, + + CoreExprWithFVs, -- = AnnExpr Id VarSet + CoreBindWithFVs, -- = AnnBind Id VarSet + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsOf -- CoreExprWithFVs -> IdSet ) where #include "HsVersions.h" import CoreSyn -import Id ( Id, idFreeTyVars, getIdSpecialisation ) +import Id ( Id, idType, idSpecialisation ) +import NameSet import VarSet -import Var ( IdOrTyVar, isId ) -import Name ( isLocallyDefined ) -import Type ( tyVarsOfType, Type ) +import Var ( Var, isId, isLocalVar, varName ) +import Type ( tyVarsOfType ) +import TcType ( namesOfType ) import Util ( mapAndUnzip ) +import Outputable \end{code} + %************************************************************************ %* * \section{Finding the free variables of an expression} @@ -38,30 +49,30 @@ So far as type variables are concerned, it only finds tyvars that are but not those that are free in the type of variable occurrence. \begin{code} -exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars -exprFreeVars = exprSomeFreeVars isLocallyDefined +exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars +exprFreeVars = exprSomeFreeVars isLocalVar -exprsFreeVars :: [CoreExpr] -> IdOrTyVarSet +exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting -> CoreExpr - -> IdOrTyVarSet + -> VarSet exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting -> [CoreExpr] - -> IdOrTyVarSet + -> VarSet exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet -type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting +type InterestingVarFun = Var -> Bool -- True <=> interesting \end{code} \begin{code} type FV = InterestingVarFun - -> IdOrTyVarSet -- In scope - -> IdOrTyVarSet -- Free vars + -> VarSet -- In scope + -> VarSet -- Free vars union :: FV -> FV -> FV union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope @@ -75,16 +86,17 @@ noVars fv_cand in_scope = emptyVarSet -- is a little weird. The reason is that the former is more efficient, -- but the latter is more fine grained, and a makes a difference when -- a variable mentions itself one of its own rule RHSs -oneVar :: IdOrTyVar -> FV +oneVar :: Id -> FV oneVar var fv_cand in_scope - = foldVarSet add_rule_var var_itself_set (idRuleVars var) + = ASSERT( isId var ) + foldVarSet add_rule_var var_itself_set (idRuleVars var) where var_itself_set | keep_it fv_cand in_scope var = unitVarSet var | otherwise = emptyVarSet add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var | otherwise = set -someVars :: IdOrTyVarSet -> FV +someVars :: VarSet -> FV someVars vars fv_cand in_scope = filterVarSet (keep_it fv_cand in_scope) vars @@ -111,7 +123,7 @@ expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) = someVars (tyVarsOfType ty) expr_fvs (Var var) = oneVar var -expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args +expr_fvs (Lit lit) = noVars expr_fvs (Note _ expr) = expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) @@ -131,19 +143,71 @@ expr_fvs (Let (Rec pairs) body) \end{code} +%************************************************************************ +%* * +\section{Free names} +%* * +%************************************************************************ + +exprFreeNames finds the free *names* of an expression, notably +including the names of type constructors (which of course do not show +up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used +when deciding whethera rule is an orphan. In particular, suppose that +T is defined in this module; we want to avoid declaring that a rule like + fromIntegral T = fromIntegral_T +is an orphan. Of course it isn't, an declaring it an orphan would +make the whole module an orphan module, which is bad. \begin{code} -idRuleVars ::Id -> IdOrTyVarSet -idRuleVars id = rulesRhsFreeVars (getIdSpecialisation id) +ruleLhsFreeNames :: IdCoreRule -> NameSet +ruleLhsFreeNames (fn, BuiltinRule _) = unitNameSet (varName fn) +ruleLhsFreeNames (fn, Rule _ tpl_vars tpl_args rhs) + = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn) + +exprFreeNames :: CoreExpr -> NameSet +exprFreeNames (Var v) = unitNameSet (varName v) +exprFreeNames (Lit _) = emptyNameSet +exprFreeNames (Type ty) = namesOfType ty +exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2 +exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v +exprFreeNames (Note n e) = exprFreeNames e + +exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b) + `unionNameSets` exprFreeNames r + +exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e) + `del_binders` bs + where + (bs, rs) = unzip prs + +exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets` + (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b) + +-- Helpers +altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs + +exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es + +del_binders :: NameSet -> [Var] -> NameSet +del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs +\end{code} -idFreeVars :: Id -> IdOrTyVarSet -idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id +%************************************************************************ +%* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +%* * +%************************************************************************ -rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> IdOrTyVarSet -rulesSomeFreeVars interesting (Rules rules _) - = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules -ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet +\begin{code} +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule _) = noFVs +ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) + = rule_fvs isLocalVar emptyVarSet + where + rule_fvs = addBndrs tpl_vars (expr_fvs rhs) + +ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet ruleSomeFreeVars interesting (BuiltinRule _) = noFVs ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) = rule_fvs interesting emptyVarSet @@ -151,10 +215,12 @@ ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) rule_fvs = addBndrs tpl_vars $ foldr (union . expr_fvs) (expr_fvs rhs) tpl_args -ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet -ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs -ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs) - = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars +ruleLhsFreeIds :: CoreRule -> VarSet +-- This finds all the free Ids on the LHS of the rule +-- *including* imported ids +ruleLhsFreeIds (BuiltinRule _) = noFVs +ruleLhsFreeIds (Rule _ tpl_vars tpl_args rhs) + = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars \end{code} @@ -168,8 +234,8 @@ The free variable pass annotates every node in the expression with its NON-GLOBAL free variables and type variables. \begin{code} -type CoreBindWithFVs = AnnBind Id IdOrTyVarSet -type CoreExprWithFVs = AnnExpr Id IdOrTyVarSet +type CoreBindWithFVs = AnnBind Id VarSet +type CoreExprWithFVs = AnnExpr Id VarSet -- Every node annotated with its free variables, -- both Ids and TyVars @@ -180,9 +246,13 @@ noFVs = emptyVarSet aFreeVar = unitVarSet unionFVs = unionVarSet -filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet +delBindersFV :: [Var] -> VarSet -> VarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> VarSet -> VarSet +-- This way round, so we can do it multiple times using foldr --- (b `filters` s) removes the binder b from the free variable set s, +-- (b `delBinderFV` 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 @@ -210,8 +280,21 @@ filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet -- where -- bottom = bottom -- Never evaluated -filters b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b - | otherwise = s `delVarSet` b +delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b + | otherwise = s `delVarSet` b + +idFreeVars :: Id -> VarSet +idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id + +idFreeTyVars :: Id -> TyVarSet +-- Only local Ids conjured up locally, can have free type variables. +-- (During type checking top-level Ids can have free tyvars) +idFreeTyVars id = tyVarsOfType (idType id) +-- | isLocalId id = tyVarsOfType (idType id) +-- | otherwise = emptyVarSet + +idRuleVars ::Id -> VarSet +idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) \end{code} @@ -232,16 +315,12 @@ freeVars (Var v) -- Actually [June 98] I don't think it's necessary -- fvs = fvs_v `unionVarSet` idSpecVars v - fvs | isLocallyDefined v = aFreeVar v - | otherwise = noFVs - -freeVars (Con con args) - = (foldr (unionFVs . freeVarsOf) noFVs args2, AnnCon con args2) - where - args2 = map freeVars args + fvs | isLocalVar v = aFreeVar v + | otherwise = noFVs +freeVars (Lit lit) = (noFVs, AnnLit lit) freeVars (Lam b body) - = (b `filters` freeVarsOf body', AnnLam b body') + = (b `delBinderFV` freeVarsOf body', AnnLam b body') where body' = freeVars body @@ -252,7 +331,7 @@ freeVars (App fun arg) arg2 = freeVars arg freeVars (Case scrut bndr alts) - = ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2, + = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2, AnnCase scrut2 bndr alts2) where scrut2 = freeVars scrut @@ -260,7 +339,7 @@ freeVars (Case scrut bndr alts) (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts alts_fvs = foldr1 unionFVs alts_fvs_s - fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args, + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), (con, args, rhs2)) where rhs2 = freeVars rhs @@ -271,11 +350,11 @@ freeVars (Let (NonRec binder rhs) body) where rhs2 = freeVars rhs body2 = freeVars body - body_fvs = binder `filters` freeVarsOf body2 + body_fvs = binder `delBinderFV` freeVarsOf body2 freeVars (Let (Rec binds) body) = (foldl delVarSet group_fvs binders, - -- The "filters" part may have added one of the binders + -- The "delBinderFV" 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 @@ -283,7 +362,7 @@ freeVars (Let (Rec binds) body) rhss2 = map freeVars rhss all_fvs = foldr (unionFVs . fst) body_fvs rhss2 - group_fvs = foldr filters all_fvs binders + group_fvs = delBindersFV binders all_fvs body2 = freeVars body body_fvs = freeVarsOf body2