\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,
+ exprFreeNames, exprsFreeNames,
+
+ 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, getIdSpecialisation )
+import Id ( Id, idType, idSpecialisation, isLocalId )
+import IdInfo ( specInfoFreeVars )
+import NameSet
+import UniqFM ( delFromUFM )
+import Name ( isExternalName )
import VarSet
-import Var ( IdOrTyVar, isId )
-import Name ( isLocallyDefined )
-import Type ( tyVarsOfType, Type )
+import Var ( Var, isId, isLocalVar, varName )
+import Type ( tyVarsOfType )
+import TcType ( tyClsNamesOfType )
import Util ( mapAndUnzip )
+import Outputable
\end{code}
+
%************************************************************************
%* *
\section{Finding the free variables of an expression}
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
-- 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
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)
-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)
= addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
where
(bndrs,rhss) = unzip pairs
+
+---------
+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 -> IdOrTyVarSet
-idRuleVars id = rulesRhsFreeVars (getIdSpecialisation 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 -> 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
-ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
- = rule_fvs interesting emptyVarSet
+\begin{code}
+ruleRhsFreeVars :: CoreRule -> VarSet
+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 $
- foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
+ fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
+
+rulesRhsFreeVars :: [CoreRule] -> VarSet
+rulesRhsFreeVars rules
+ = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
-ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
-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}
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
aFreeVar = unitVarSet
unionFVs = unionVarSet
-filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet
+delBindersFV :: [Var] -> VarSet -> VarSet
+delBindersFV bs fvs = foldr delBinderFV fvs bs
--- (b `filters` s) removes the binder b from the free variable set s,
+delBinderFV :: Var -> VarSet -> VarSet
+-- This way round, so we can do it multiple times using foldr
+
+-- (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
-- 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}
-- 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
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
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
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
projects / ghc-hetmet.git / blobdiff