2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 Taken quite directly from the Peyton Jones/Lester paper.
8 exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
9 exprsFreeVars, -- [CoreExpr] -> VarSet
11 exprSomeFreeVars, exprsSomeFreeVars,
12 exprFreeNames, exprsFreeNames,
14 idRuleVars, idFreeVars, idFreeTyVars,
15 ruleRhsFreeVars, rulesRhsFreeVars,
16 ruleLhsFreeNames, ruleLhsFreeIds,
18 CoreExprWithFVs, -- = AnnExpr Id VarSet
19 CoreBindWithFVs, -- = AnnBind Id VarSet
20 freeVars, -- CoreExpr -> CoreExprWithFVs
21 freeVarsOf -- CoreExprWithFVs -> IdSet
24 #include "HsVersions.h"
27 import Id ( Id, idType, idSpecialisation, isLocalId )
28 import IdInfo ( specInfoFreeVars )
30 import UniqFM ( delFromUFM )
31 import Name ( isExternalName )
33 import Var ( Var, isId, isLocalVar, varName )
34 import Type ( tyVarsOfType )
35 import TcType ( tyClsNamesOfType )
36 import Util ( mapAndUnzip )
41 %************************************************************************
43 \section{Finding the free variables of an expression}
45 %************************************************************************
47 This function simply finds the free variables of an expression.
48 So far as type variables are concerned, it only finds tyvars that are
50 * free in type arguments,
51 * free in the type of a binder,
53 but not those that are free in the type of variable occurrence.
56 exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
57 exprFreeVars = exprSomeFreeVars isLocalVar
59 exprsFreeVars :: [CoreExpr] -> VarSet
60 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
62 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
65 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
67 exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
70 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
72 type InterestingVarFun = Var -> Bool -- True <=> interesting
77 type FV = InterestingVarFun
79 -> VarSet -- Free vars
81 union :: FV -> FV -> FV
82 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
85 noVars fv_cand in_scope = emptyVarSet
87 -- At a variable occurrence, add in any free variables of its rule rhss
88 -- Curiously, we gather the Id's free *type* variables from its binding
89 -- site, but its free *rule-rhs* variables from its usage sites. This
90 -- is a little weird. The reason is that the former is more efficient,
91 -- but the latter is more fine grained, and a makes a difference when
92 -- a variable mentions itself one of its own rule RHSs
94 oneVar var fv_cand in_scope
96 foldVarSet add_rule_var var_itself_set (idRuleVars var)
98 var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
99 | otherwise = emptyVarSet
100 add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
103 someVars :: VarSet -> FV
104 someVars vars fv_cand in_scope
105 = filterVarSet (keep_it fv_cand in_scope) vars
107 keep_it fv_cand in_scope var
108 | var `elemVarSet` in_scope = False
113 addBndr :: CoreBndr -> FV -> FV
114 addBndr bndr fv fv_cand in_scope
115 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
116 | otherwise = inside_fvs
118 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
120 addBndrs :: [CoreBndr] -> FV -> FV
121 addBndrs bndrs fv = foldr addBndr fv bndrs
126 expr_fvs :: CoreExpr -> FV
128 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
129 expr_fvs (Var var) = oneVar var
130 expr_fvs (Lit lit) = noVars
131 expr_fvs (Note _ expr) = expr_fvs expr
132 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
133 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
135 expr_fvs (Case scrut bndr ty alts)
136 = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
137 (foldr (union . alt_fvs) noVars alts)
139 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
141 expr_fvs (Let (NonRec bndr rhs) body)
142 = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
144 expr_fvs (Let (Rec pairs) body)
145 = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
147 (bndrs,rhss) = unzip pairs
150 exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
154 %************************************************************************
158 %************************************************************************
160 exprFreeNames finds the free *external* *names* of an expression, notably
161 including the names of type constructors (which of course do not show
162 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
163 when deciding whether a rule is an orphan. In particular, suppose that
164 T is defined in this module; we want to avoid declaring that a rule like
165 fromIntegral T = fromIntegral_T
166 is an orphan. Of course it isn't, an declaring it an orphan would
167 make the whole module an orphan module, which is bad.
169 There's no need to delete local binders, because they will all
173 ruleLhsFreeNames :: CoreRule -> NameSet
174 ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
175 ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
176 = addOneToNameSet (exprsFreeNames tpl_args) fn
178 exprFreeNames :: CoreExpr -> NameSet
179 -- Find the free *external* names of an expression
184 | isExternalName n = unitNameSet n
185 | otherwise = emptyNameSet
187 go (Lit _) = emptyNameSet
188 go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
189 go (App e1 e2) = go e1 `unionNameSets` go e2
190 go (Lam v e) = go e `delFromNameSet` varName v
192 go (Let (NonRec b r) e) = go e `unionNameSets` go r
193 go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
194 go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty
195 `unionNameSets` unionManyNameSets (map go_alt as)
197 go_alt (_,_,r) = go r
199 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
202 %************************************************************************
204 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
206 %************************************************************************
210 ruleRhsFreeVars :: CoreRule -> VarSet
211 ruleRhsFreeVars (BuiltinRule {}) = noFVs
212 ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
215 -- Don't include the Id in its own rhs free-var set.
216 -- Otherwise the occurrence analyser makes bindings recursive
217 -- that shoudn't be. E.g.
218 -- RULE: f (f x y) z ==> f x (f y z)
220 fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
222 rulesRhsFreeVars :: [CoreRule] -> VarSet
223 rulesRhsFreeVars rules
224 = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
226 ruleLhsFreeIds :: CoreRule -> VarSet
227 -- This finds all locally-defined free Ids on the LHS of the rule
228 ruleLhsFreeIds (BuiltinRule {}) = noFVs
229 ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
230 = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
234 %************************************************************************
236 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
238 %************************************************************************
240 The free variable pass annotates every node in the expression with its
241 NON-GLOBAL free variables and type variables.
244 type CoreBindWithFVs = AnnBind Id VarSet
245 type CoreExprWithFVs = AnnExpr Id VarSet
246 -- Every node annotated with its free variables,
247 -- both Ids and TyVars
249 freeVarsOf :: CoreExprWithFVs -> IdSet
250 freeVarsOf (free_vars, _) = free_vars
253 aFreeVar = unitVarSet
254 unionFVs = unionVarSet
256 delBindersFV :: [Var] -> VarSet -> VarSet
257 delBindersFV bs fvs = foldr delBinderFV fvs bs
259 delBinderFV :: Var -> VarSet -> VarSet
260 -- This way round, so we can do it multiple times using foldr
262 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
264 -- (a) the free variables of b's type
265 -- (b) the idSpecVars of b
267 -- This is really important for some lambdas:
268 -- In (\x::a -> x) the only mention of "a" is in the binder.
271 -- let x::a = b in ...
272 -- we should really note that "a" is free in this expression.
273 -- It'll be pinned inside the /\a by the binding for b, but
274 -- it seems cleaner to make sure that a is in the free-var set
275 -- when it is mentioned.
277 -- This also shows up in recursive bindings. Consider:
278 -- /\a -> letrec x::a = x in E
279 -- Now, there are no explicit free type variables in the RHS of x,
280 -- but nevertheless "a" is free in its definition. So we add in
281 -- the free tyvars of the types of the binders, and include these in the
282 -- free vars of the group, attached to the top level of each RHS.
284 -- This actually happened in the defn of errorIO in IOBase.lhs:
285 -- errorIO (ST io) = case (errorIO# io) of
288 -- bottom = bottom -- Never evaluated
290 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
291 | otherwise = s `delVarSet` b
293 idFreeVars :: Id -> VarSet
294 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
296 idFreeTyVars :: Id -> TyVarSet
297 -- Only local Ids conjured up locally, can have free type variables.
298 -- (During type checking top-level Ids can have free tyvars)
299 idFreeTyVars id = tyVarsOfType (idType id)
300 -- | isLocalId id = tyVarsOfType (idType id)
301 -- | otherwise = emptyVarSet
303 idRuleVars ::Id -> VarSet
304 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
308 %************************************************************************
310 \subsection{Free variables (and types)}
312 %************************************************************************
315 freeVars :: CoreExpr -> CoreExprWithFVs
320 -- ToDo: insert motivating example for why we *need*
321 -- to include the idSpecVars in the FV list.
322 -- Actually [June 98] I don't think it's necessary
323 -- fvs = fvs_v `unionVarSet` idSpecVars v
325 fvs | isLocalVar v = aFreeVar v
328 freeVars (Lit lit) = (noFVs, AnnLit lit)
329 freeVars (Lam b body)
330 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
332 body' = freeVars body
334 freeVars (App fun arg)
335 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
340 freeVars (Case scrut bndr ty alts)
342 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
343 AnnCase scrut2 bndr ty alts2)
345 scrut2 = freeVars scrut
347 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
348 alts_fvs = foldr1 unionFVs alts_fvs_s
350 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
355 freeVars (Let (NonRec binder rhs) body)
356 = (freeVarsOf rhs2 `unionFVs` body_fvs,
357 AnnLet (AnnNonRec binder rhs2) body2)
360 body2 = freeVars body
361 body_fvs = binder `delBinderFV` freeVarsOf body2
363 freeVars (Let (Rec binds) body)
364 = (foldl delVarSet group_fvs binders,
365 -- The "delBinderFV" part may have added one of the binders
366 -- via the idSpecVars part, so we must delete it again
367 AnnLet (AnnRec (binders `zip` rhss2)) body2)
369 (binders, rhss) = unzip binds
371 rhss2 = map freeVars rhss
372 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
373 group_fvs = delBindersFV binders all_fvs
375 body2 = freeVars body
376 body_fvs = freeVarsOf body2
378 freeVars (Note (Coerce to_ty from_ty) expr)
379 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
380 AnnNote (Coerce to_ty from_ty) expr2)
382 expr2 = freeVars expr
383 tfvs1 = tyVarsOfType from_ty
384 tfvs2 = tyVarsOfType to_ty
386 freeVars (Note other_note expr)
387 = (freeVarsOf expr2, AnnNote other_note expr2)
389 expr2 = freeVars expr
391 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)