X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreFVs.lhs;h=fb6017eabff03ab1357d933643f4fa518ee4916d;hb=d1e15bd270b971d330238d99b66ff36074873f90;hp=c501255e3fe1ec411b7baf1802485536bb7ddc3a;hpb=db95d6e8d319b0c5cee1ccc23751e8190152ade3;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index c501255..fb6017e 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -5,23 +5,34 @@ 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, ruleRhsFreeVars, + exprFreeNames, exprsFreeNames, - mustHaveLocalBinding, + idRuleVars, idFreeVars, idFreeTyVars, + ruleRhsFreeVars, rulesRhsFreeVars, + ruleLhsFreeNames, ruleLhsFreeIds, - CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf, + CoreExprWithFVs, -- = AnnExpr Id VarSet + CoreBindWithFVs, -- = AnnBind Id VarSet + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsOf -- CoreExprWithFVs -> IdSet ) where #include "HsVersions.h" import CoreSyn -import Id ( Id, idFreeTyVars, hasNoBinding, idSpecialisation ) +import Id ( Id, idType, idSpecialisation, isLocalId ) +import IdInfo ( specInfoFreeVars ) +import NameSet +import UniqFM ( delFromUFM ) +import Name ( isExternalName ) import VarSet -import Var ( Var, isId ) +import Var ( Var, isId, isLocalVar, varName ) import Type ( tyVarsOfType ) +import TcType ( tyClsNamesOfType ) import Util ( mapAndUnzip ) import Outputable \end{code} @@ -64,8 +75,8 @@ type InterestingVarFun = Var -> Bool -- True <=> interesting \begin{code} type FV = InterestingVarFun - -> VarSet -- In scope - -> VarSet -- 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 @@ -73,21 +84,40 @@ union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand noVars :: FV noVars fv_cand in_scope = emptyVarSet --- At a variable occurrence, add in any free variables of its rule rhss --- Curiously, we gather the Id's free *type* variables from its binding --- site, but its free *rule-rhs* variables from its usage sites. This --- 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 +-- Comment about obselete code +-- We used to gather the free variables the RULES at a variable occurrence +-- with the following cryptic comment: +-- "At a variable occurrence, add in any free variables of its rule rhss +-- Curiously, we gather the Id's free *type* variables from its binding +-- site, but its free *rule-rhs* variables from its usage sites. This +-- 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" +-- Not only is this "weird", but it's also pretty bad because it can make +-- a function seem more recursive than it is. Suppose +-- f = ...g... +-- g = ... +-- RULE g x = ...f... +-- Then f is not mentioned in its own RHS, and needn't be a loop breaker +-- (though g may be). But if we collect the rule fvs from g's occurrence, +-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB +-- code in GHC.Enum.) +-- +-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the +-- function, so its free variables belong at the definition site. +-- +-- Deleted code looked like +-- foldVarSet add_rule_var var_itself_set (idRuleVars var) +-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var +-- | otherwise = set +-- SLPJ Feb06 + oneVar :: Id -> FV oneVar var fv_cand in_scope = 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 + if keep_it fv_cand in_scope var + then unitVarSet var + else emptyVarSet someVars :: VarSet -> FV someVars vars fv_cand in_scope @@ -121,52 +151,105 @@ 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) -expr_fvs (Case scrut bndr alts) - = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts) +expr_fvs (Case scrut bndr ty alts) + = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr + (foldr (union . alt_fvs) noVars alts) where alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) expr_fvs (Let (NonRec bndr rhs) body) - = expr_fvs rhs `union` addBndr bndr (expr_fvs body) + = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body) expr_fvs (Let (Rec pairs) body) - = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss) - where - (bndrs,rhss) = unzip pairs + = addBndrs (map fst pairs) + (foldr (union . rhs_fvs) (expr_fvs body) pairs) + +--------- +rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr) + -- Treat any RULES as extra RHSs of the binding + +--------- +exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs \end{code} +%************************************************************************ +%* * +\section{Free names} +%* * +%************************************************************************ + +exprFreeNames finds the free *external* *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 whether a 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. + +There's no need to delete local binders, because they will all +be *internal* names. \begin{code} -idRuleVars ::Id -> VarSet -idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) +ruleLhsFreeNames :: CoreRule -> NameSet +ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn +ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args }) + = addOneToNameSet (exprsFreeNames tpl_args) fn + +exprFreeNames :: CoreExpr -> NameSet +-- Find the free *external* names of an expression +exprFreeNames e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = varName v + go (Lit _) = emptyNameSet + go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars + go (App e1 e2) = go e1 `unionNameSets` go e2 + go (Lam v e) = go e `delFromNameSet` varName v + go (Note n e) = go e + go (Let (NonRec b r) e) = go e `unionNameSets` go r + go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e + go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty + `unionNameSets` unionManyNameSets (map go_alt as) + + go_alt (_,_,r) = go r + +exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es +\end{code} -idFreeVars :: Id -> VarSet -idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id +%************************************************************************ +%* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +%* * +%************************************************************************ -rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet -rulesSomeFreeVars interesting (Rules rules _) - = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules +\begin{code} ruleRhsFreeVars :: CoreRule -> VarSet -ruleRhsFreeVars (BuiltinRule _) = noFVs -ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) - = rule_fvs isLocalVar emptyVarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) + = delFromUFM fvs fn + -- Hack alert! + -- Don't include the Id in its own rhs free-var set. + -- Otherwise the occurrence analyser makes bindings recursive + -- that shoudn't be. E.g. + -- RULE: f (f x y) z ==> f x (f y z) where - rule_fvs = addBndrs tpl_vars (expr_fvs rhs) + fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet -ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet -ruleSomeFreeVars interesting (BuiltinRule _) = noFVs -ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) - = rule_fvs interesting emptyVarSet - where - rule_fvs = addBndrs tpl_vars $ - foldr (union . expr_fvs) (expr_fvs rhs) tpl_args +rulesRhsFreeVars :: [CoreRule] -> VarSet +rulesRhsFreeVars rules + = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules -ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet -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 locally-defined free Ids on the LHS of the rule +ruleLhsFreeIds (BuiltinRule {}) = noFVs +ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet \end{code} @@ -192,9 +275,13 @@ noFVs = emptyVarSet aFreeVar = unitVarSet unionFVs = unionVarSet -filters :: Var -> VarSet -> VarSet +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 @@ -222,8 +309,21 @@ filters :: Var -> VarSet -> VarSet -- 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) specInfoFreeVars (idSpecialisation id) \end{code} @@ -249,7 +349,7 @@ freeVars (Var v) 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 @@ -259,16 +359,17 @@ freeVars (App fun arg) fun2 = freeVars fun arg2 = freeVars arg -freeVars (Case scrut bndr alts) - = ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2, - AnnCase scrut2 bndr alts2) +freeVars (Case scrut bndr ty alts) +-- gaw 2004 + = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, + AnnCase scrut2 bndr ty alts2) where scrut2 = freeVars scrut (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 @@ -279,11 +380,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 @@ -291,7 +392,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