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 -- Comment about obselete code
88 -- We used to gather the free variables the RULES at a variable occurrence
89 -- with the following cryptic comment:
90 -- "At a variable occurrence, add in any free variables of its rule rhss
91 -- Curiously, we gather the Id's free *type* variables from its binding
92 -- site, but its free *rule-rhs* variables from its usage sites. This
93 -- is a little weird. The reason is that the former is more efficient,
94 -- but the latter is more fine grained, and a makes a difference when
95 -- a variable mentions itself one of its own rule RHSs"
96 -- Not only is this "weird", but it's also pretty bad because it can make
97 -- a function seem more recursive than it is. Suppose
100 -- RULE g x = ...f...
101 -- Then f is not mentioned in its own RHS, and needn't be a loop breaker
102 -- (though g may be). But if we collect the rule fvs from g's occurrence,
103 -- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB
104 -- code in GHC.Enum.)
106 -- Anyway, it seems plain wrong. The RULE is like an extra RHS for the
107 -- function, so its free variables belong at the definition site.
109 -- Deleted code looked like
110 -- foldVarSet add_rule_var var_itself_set (idRuleVars var)
111 -- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
116 oneVar var fv_cand in_scope
118 if keep_it fv_cand in_scope var
122 someVars :: VarSet -> FV
123 someVars vars fv_cand in_scope
124 = filterVarSet (keep_it fv_cand in_scope) vars
126 keep_it fv_cand in_scope var
127 | var `elemVarSet` in_scope = False
132 addBndr :: CoreBndr -> FV -> FV
133 addBndr bndr fv fv_cand in_scope
134 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
135 | otherwise = inside_fvs
137 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
139 addBndrs :: [CoreBndr] -> FV -> FV
140 addBndrs bndrs fv = foldr addBndr fv bndrs
145 expr_fvs :: CoreExpr -> FV
147 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
148 expr_fvs (Var var) = oneVar var
149 expr_fvs (Lit lit) = noVars
150 expr_fvs (Note _ expr) = expr_fvs expr
151 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
152 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
154 expr_fvs (Case scrut bndr ty alts)
155 = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
156 (foldr (union . alt_fvs) noVars alts)
158 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
160 expr_fvs (Let (NonRec bndr rhs) body)
161 = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
163 expr_fvs (Let (Rec pairs) body)
164 = addBndrs (map fst pairs)
165 (foldr (union . rhs_fvs) (expr_fvs body) pairs)
168 rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
169 -- Treat any RULES as extra RHSs of the binding
172 exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
176 %************************************************************************
180 %************************************************************************
182 exprFreeNames finds the free *external* *names* of an expression, notably
183 including the names of type constructors (which of course do not show
184 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
185 when deciding whether a rule is an orphan. In particular, suppose that
186 T is defined in this module; we want to avoid declaring that a rule like
187 fromIntegral T = fromIntegral_T
188 is an orphan. Of course it isn't, an declaring it an orphan would
189 make the whole module an orphan module, which is bad.
191 There's no need to delete local binders, because they will all
195 ruleLhsFreeNames :: CoreRule -> NameSet
196 ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
197 ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
198 = addOneToNameSet (exprsFreeNames tpl_args) fn
200 exprFreeNames :: CoreExpr -> NameSet
201 -- Find the free *external* names of an expression
206 | isExternalName n = unitNameSet n
207 | otherwise = emptyNameSet
209 go (Lit _) = emptyNameSet
210 go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
211 go (App e1 e2) = go e1 `unionNameSets` go e2
212 go (Lam v e) = go e `delFromNameSet` varName v
214 go (Let (NonRec b r) e) = go e `unionNameSets` go r
215 go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
216 go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty
217 `unionNameSets` unionManyNameSets (map go_alt as)
219 go_alt (_,_,r) = go r
221 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
224 %************************************************************************
226 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
228 %************************************************************************
232 ruleRhsFreeVars :: CoreRule -> VarSet
233 ruleRhsFreeVars (BuiltinRule {}) = noFVs
234 ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
237 -- Don't include the Id in its own rhs free-var set.
238 -- Otherwise the occurrence analyser makes bindings recursive
239 -- that shoudn't be. E.g.
240 -- RULE: f (f x y) z ==> f x (f y z)
242 fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
244 rulesRhsFreeVars :: [CoreRule] -> VarSet
245 rulesRhsFreeVars rules
246 = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
248 ruleLhsFreeIds :: CoreRule -> VarSet
249 -- This finds all locally-defined free Ids on the LHS of the rule
250 ruleLhsFreeIds (BuiltinRule {}) = noFVs
251 ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
252 = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
256 %************************************************************************
258 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
260 %************************************************************************
262 The free variable pass annotates every node in the expression with its
263 NON-GLOBAL free variables and type variables.
266 type CoreBindWithFVs = AnnBind Id VarSet
267 type CoreExprWithFVs = AnnExpr Id VarSet
268 -- Every node annotated with its free variables,
269 -- both Ids and TyVars
271 freeVarsOf :: CoreExprWithFVs -> IdSet
272 freeVarsOf (free_vars, _) = free_vars
275 aFreeVar = unitVarSet
276 unionFVs = unionVarSet
278 delBindersFV :: [Var] -> VarSet -> VarSet
279 delBindersFV bs fvs = foldr delBinderFV fvs bs
281 delBinderFV :: Var -> VarSet -> VarSet
282 -- This way round, so we can do it multiple times using foldr
284 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
286 -- (a) the free variables of b's type
287 -- (b) the idSpecVars of b
289 -- This is really important for some lambdas:
290 -- In (\x::a -> x) the only mention of "a" is in the binder.
293 -- let x::a = b in ...
294 -- we should really note that "a" is free in this expression.
295 -- It'll be pinned inside the /\a by the binding for b, but
296 -- it seems cleaner to make sure that a is in the free-var set
297 -- when it is mentioned.
299 -- This also shows up in recursive bindings. Consider:
300 -- /\a -> letrec x::a = x in E
301 -- Now, there are no explicit free type variables in the RHS of x,
302 -- but nevertheless "a" is free in its definition. So we add in
303 -- the free tyvars of the types of the binders, and include these in the
304 -- free vars of the group, attached to the top level of each RHS.
306 -- This actually happened in the defn of errorIO in IOBase.lhs:
307 -- errorIO (ST io) = case (errorIO# io) of
310 -- bottom = bottom -- Never evaluated
312 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
313 | otherwise = s `delVarSet` b
315 idFreeVars :: Id -> VarSet
316 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
318 idFreeTyVars :: Id -> TyVarSet
319 -- Only local Ids conjured up locally, can have free type variables.
320 -- (During type checking top-level Ids can have free tyvars)
321 idFreeTyVars id = tyVarsOfType (idType id)
322 -- | isLocalId id = tyVarsOfType (idType id)
323 -- | otherwise = emptyVarSet
325 idRuleVars ::Id -> VarSet
326 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
330 %************************************************************************
332 \subsection{Free variables (and types)}
334 %************************************************************************
337 freeVars :: CoreExpr -> CoreExprWithFVs
342 -- ToDo: insert motivating example for why we *need*
343 -- to include the idSpecVars in the FV list.
344 -- Actually [June 98] I don't think it's necessary
345 -- fvs = fvs_v `unionVarSet` idSpecVars v
347 fvs | isLocalVar v = aFreeVar v
350 freeVars (Lit lit) = (noFVs, AnnLit lit)
351 freeVars (Lam b body)
352 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
354 body' = freeVars body
356 freeVars (App fun arg)
357 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
362 freeVars (Case scrut bndr ty alts)
364 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
365 AnnCase scrut2 bndr ty alts2)
367 scrut2 = freeVars scrut
369 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
370 alts_fvs = foldr1 unionFVs alts_fvs_s
372 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
377 freeVars (Let (NonRec binder rhs) body)
378 = (freeVarsOf rhs2 `unionFVs` body_fvs,
379 AnnLet (AnnNonRec binder rhs2) body2)
382 body2 = freeVars body
383 body_fvs = binder `delBinderFV` freeVarsOf body2
385 freeVars (Let (Rec binds) body)
386 = (foldl delVarSet group_fvs binders,
387 -- The "delBinderFV" part may have added one of the binders
388 -- via the idSpecVars part, so we must delete it again
389 AnnLet (AnnRec (binders `zip` rhss2)) body2)
391 (binders, rhss) = unzip binds
393 rhss2 = map freeVars rhss
394 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
395 group_fvs = delBindersFV binders all_fvs
397 body2 = freeVars body
398 body_fvs = freeVarsOf body2
400 freeVars (Note (Coerce to_ty from_ty) expr)
401 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
402 AnnNote (Coerce to_ty from_ty) expr2)
404 expr2 = freeVars expr
405 tfvs1 = tyVarsOfType from_ty
406 tfvs2 = tyVarsOfType to_ty
408 freeVars (Note other_note expr)
409 = (freeVarsOf expr2, AnnNote other_note expr2)
411 expr2 = freeVars expr
413 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)