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
10 bindFreeVars, -- CoreBind -> VarSet
12 exprSomeFreeVars, exprsSomeFreeVars,
13 exprFreeNames, exprsFreeNames,
15 idRuleVars, idFreeVars, idFreeTyVars,
16 ruleRhsFreeVars, rulesRhsFreeVars,
17 ruleLhsFreeNames, ruleLhsFreeIds,
19 CoreExprWithFVs, -- = AnnExpr Id VarSet
20 CoreBindWithFVs, -- = AnnBind Id VarSet
21 freeVars, -- CoreExpr -> CoreExprWithFVs
22 freeVarsOf -- CoreExprWithFVs -> IdSet
25 #include "HsVersions.h"
28 import Id ( Id, idType, idSpecialisation, isLocalId )
29 import IdInfo ( specInfoFreeVars )
31 import UniqFM ( delFromUFM )
32 import Name ( isExternalName )
34 import Var ( Var, isId, isLocalVar, varName )
35 import Type ( tyVarsOfType )
36 import TcType ( tyClsNamesOfType )
37 import Util ( mapAndUnzip )
42 %************************************************************************
44 \section{Finding the free variables of an expression}
46 %************************************************************************
48 This function simply finds the free variables of an expression.
49 So far as type variables are concerned, it only finds tyvars that are
51 * free in type arguments,
52 * free in the type of a binder,
54 but not those that are free in the type of variable occurrence.
57 exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
58 exprFreeVars = exprSomeFreeVars isLocalVar
60 exprsFreeVars :: [CoreExpr] -> VarSet
61 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
63 bindFreeVars :: CoreBind -> VarSet
64 bindFreeVars (NonRec b r) = exprFreeVars r
65 bindFreeVars (Rec prs) = addBndrs (map fst prs)
66 (foldr (union . rhs_fvs) noVars prs)
67 isLocalVar emptyVarSet
69 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
72 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
74 exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
77 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
79 type InterestingVarFun = Var -> Bool -- True <=> interesting
84 type FV = InterestingVarFun
86 -> VarSet -- Free vars
88 union :: FV -> FV -> FV
89 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
92 noVars fv_cand in_scope = emptyVarSet
94 -- Comment about obselete code
95 -- We used to gather the free variables the RULES at a variable occurrence
96 -- with the following cryptic comment:
97 -- "At a variable occurrence, add in any free variables of its rule rhss
98 -- Curiously, we gather the Id's free *type* variables from its binding
99 -- site, but its free *rule-rhs* variables from its usage sites. This
100 -- is a little weird. The reason is that the former is more efficient,
101 -- but the latter is more fine grained, and a makes a difference when
102 -- a variable mentions itself one of its own rule RHSs"
103 -- Not only is this "weird", but it's also pretty bad because it can make
104 -- a function seem more recursive than it is. Suppose
107 -- RULE g x = ...f...
108 -- Then f is not mentioned in its own RHS, and needn't be a loop breaker
109 -- (though g may be). But if we collect the rule fvs from g's occurrence,
110 -- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB
111 -- code in GHC.Enum.)
113 -- Anyway, it seems plain wrong. The RULE is like an extra RHS for the
114 -- function, so its free variables belong at the definition site.
116 -- Deleted code looked like
117 -- foldVarSet add_rule_var var_itself_set (idRuleVars var)
118 -- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
123 oneVar var fv_cand in_scope
125 if keep_it fv_cand in_scope var
129 someVars :: VarSet -> FV
130 someVars vars fv_cand in_scope
131 = filterVarSet (keep_it fv_cand in_scope) vars
133 keep_it fv_cand in_scope var
134 | var `elemVarSet` in_scope = False
139 addBndr :: CoreBndr -> FV -> FV
140 addBndr bndr fv fv_cand in_scope
141 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
142 | otherwise = inside_fvs
144 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
146 addBndrs :: [CoreBndr] -> FV -> FV
147 addBndrs bndrs fv = foldr addBndr fv bndrs
152 expr_fvs :: CoreExpr -> FV
154 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
155 expr_fvs (Var var) = oneVar var
156 expr_fvs (Lit lit) = noVars
157 expr_fvs (Note _ expr) = expr_fvs expr
158 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
159 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
161 expr_fvs (Case scrut bndr ty alts)
162 = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
163 (foldr (union . alt_fvs) noVars alts)
165 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
167 expr_fvs (Let (NonRec bndr rhs) body)
168 = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
170 expr_fvs (Let (Rec pairs) body)
171 = addBndrs (map fst pairs)
172 (foldr (union . rhs_fvs) (expr_fvs body) pairs)
175 rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
176 -- Treat any RULES as extra RHSs of the binding
179 exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
183 %************************************************************************
187 %************************************************************************
189 exprFreeNames finds the free *external* *names* of an expression, notably
190 including the names of type constructors (which of course do not show
191 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
192 when deciding whether a rule is an orphan. In particular, suppose that
193 T is defined in this module; we want to avoid declaring that a rule like
194 fromIntegral T = fromIntegral_T
195 is an orphan. Of course it isn't, an declaring it an orphan would
196 make the whole module an orphan module, which is bad.
198 There's no need to delete local binders, because they will all
202 ruleLhsFreeNames :: CoreRule -> NameSet
203 ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
204 ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
205 = addOneToNameSet (exprsFreeNames tpl_args) fn
207 exprFreeNames :: CoreExpr -> NameSet
208 -- Find the free *external* names of an expression
213 | isExternalName n = unitNameSet n
214 | otherwise = emptyNameSet
216 go (Lit _) = emptyNameSet
217 go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
218 go (App e1 e2) = go e1 `unionNameSets` go e2
219 go (Lam v e) = go e `delFromNameSet` varName v
221 go (Let (NonRec b r) e) = go e `unionNameSets` go r
222 go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
223 go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty
224 `unionNameSets` unionManyNameSets (map go_alt as)
226 go_alt (_,_,r) = go r
228 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
231 %************************************************************************
233 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
235 %************************************************************************
239 ruleRhsFreeVars :: CoreRule -> VarSet
240 ruleRhsFreeVars (BuiltinRule {}) = noFVs
241 ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
244 -- Don't include the Id in its own rhs free-var set.
245 -- Otherwise the occurrence analyser makes bindings recursive
246 -- that shoudn't be. E.g.
247 -- RULE: f (f x y) z ==> f x (f y z)
249 fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
251 rulesRhsFreeVars :: [CoreRule] -> VarSet
252 rulesRhsFreeVars rules
253 = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
255 ruleLhsFreeIds :: CoreRule -> VarSet
256 -- This finds all locally-defined free Ids on the LHS of the rule
257 ruleLhsFreeIds (BuiltinRule {}) = noFVs
258 ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
259 = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
263 %************************************************************************
265 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
267 %************************************************************************
269 The free variable pass annotates every node in the expression with its
270 NON-GLOBAL free variables and type variables.
273 type CoreBindWithFVs = AnnBind Id VarSet
274 type CoreExprWithFVs = AnnExpr Id VarSet
275 -- Every node annotated with its free variables,
276 -- both Ids and TyVars
278 freeVarsOf :: CoreExprWithFVs -> IdSet
279 freeVarsOf (free_vars, _) = free_vars
282 aFreeVar = unitVarSet
283 unionFVs = unionVarSet
285 delBindersFV :: [Var] -> VarSet -> VarSet
286 delBindersFV bs fvs = foldr delBinderFV fvs bs
288 delBinderFV :: Var -> VarSet -> VarSet
289 -- This way round, so we can do it multiple times using foldr
291 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
293 -- (a) the free variables of b's type
294 -- (b) the idSpecVars of b
296 -- This is really important for some lambdas:
297 -- In (\x::a -> x) the only mention of "a" is in the binder.
300 -- let x::a = b in ...
301 -- we should really note that "a" is free in this expression.
302 -- It'll be pinned inside the /\a by the binding for b, but
303 -- it seems cleaner to make sure that a is in the free-var set
304 -- when it is mentioned.
306 -- This also shows up in recursive bindings. Consider:
307 -- /\a -> letrec x::a = x in E
308 -- Now, there are no explicit free type variables in the RHS of x,
309 -- but nevertheless "a" is free in its definition. So we add in
310 -- the free tyvars of the types of the binders, and include these in the
311 -- free vars of the group, attached to the top level of each RHS.
313 -- This actually happened in the defn of errorIO in IOBase.lhs:
314 -- errorIO (ST io) = case (errorIO# io) of
317 -- bottom = bottom -- Never evaluated
319 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
320 | otherwise = s `delVarSet` b
322 idFreeVars :: Id -> VarSet
323 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
325 idFreeTyVars :: Id -> TyVarSet
326 -- Only local Ids conjured up locally, can have free type variables.
327 -- (During type checking top-level Ids can have free tyvars)
328 idFreeTyVars id = tyVarsOfType (idType id)
329 -- | isLocalId id = tyVarsOfType (idType id)
330 -- | otherwise = emptyVarSet
332 idRuleVars ::Id -> VarSet
333 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
337 %************************************************************************
339 \subsection{Free variables (and types)}
341 %************************************************************************
344 freeVars :: CoreExpr -> CoreExprWithFVs
349 -- ToDo: insert motivating example for why we *need*
350 -- to include the idSpecVars in the FV list.
351 -- Actually [June 98] I don't think it's necessary
352 -- fvs = fvs_v `unionVarSet` idSpecVars v
354 fvs | isLocalVar v = aFreeVar v
357 freeVars (Lit lit) = (noFVs, AnnLit lit)
358 freeVars (Lam b body)
359 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
361 body' = freeVars body
363 freeVars (App fun arg)
364 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
369 freeVars (Case scrut bndr ty alts)
371 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
372 AnnCase scrut2 bndr ty alts2)
374 scrut2 = freeVars scrut
376 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
377 alts_fvs = foldr1 unionFVs alts_fvs_s
379 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
384 freeVars (Let (NonRec binder rhs) body)
385 = (freeVarsOf rhs2 `unionFVs` body_fvs,
386 AnnLet (AnnNonRec binder rhs2) body2)
389 body2 = freeVars body
390 body_fvs = binder `delBinderFV` freeVarsOf body2
392 freeVars (Let (Rec binds) body)
393 = (foldl delVarSet group_fvs binders,
394 -- The "delBinderFV" part may have added one of the binders
395 -- via the idSpecVars part, so we must delete it again
396 AnnLet (AnnRec (binders `zip` rhss2)) body2)
398 (binders, rhss) = unzip binds
400 rhss2 = map freeVars rhss
401 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
402 group_fvs = delBindersFV binders all_fvs
404 body2 = freeVars body
405 body_fvs = freeVarsOf body2
407 freeVars (Note (Coerce to_ty from_ty) expr)
408 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
409 AnnNote (Coerce to_ty from_ty) expr2)
411 expr2 = freeVars expr
412 tfvs1 = tyVarsOfType from_ty
413 tfvs2 = tyVarsOfType to_ty
415 freeVars (Note other_note expr)
416 = (freeVarsOf expr2, AnnNote other_note expr2)
418 expr2 = freeVars expr
420 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)