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,
13 idRuleVars, idFreeVars, idFreeTyVars,
14 ruleSomeFreeVars, ruleRhsFreeVars,
15 ruleLhsFreeNames, ruleLhsFreeIds,
17 CoreExprWithFVs, -- = AnnExpr Id VarSet
18 CoreBindWithFVs, -- = AnnBind Id VarSet
19 freeVars, -- CoreExpr -> CoreExprWithFVs
20 freeVarsOf -- CoreExprWithFVs -> IdSet
23 #include "HsVersions.h"
26 import Id ( Id, idType, idSpecialisation )
29 import Var ( Var, isId, isLocalVar, varName )
30 import Type ( tyVarsOfType )
31 import TcType ( namesOfType )
32 import Util ( mapAndUnzip )
37 %************************************************************************
39 \section{Finding the free variables of an expression}
41 %************************************************************************
43 This function simply finds the free variables of an expression.
44 So far as type variables are concerned, it only finds tyvars that are
46 * free in type arguments,
47 * free in the type of a binder,
49 but not those that are free in the type of variable occurrence.
52 exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
53 exprFreeVars = exprSomeFreeVars isLocalVar
55 exprsFreeVars :: [CoreExpr] -> VarSet
56 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
58 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
61 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
63 exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
66 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
68 type InterestingVarFun = Var -> Bool -- True <=> interesting
73 type FV = InterestingVarFun
75 -> VarSet -- Free vars
77 union :: FV -> FV -> FV
78 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
81 noVars fv_cand in_scope = emptyVarSet
83 -- At a variable occurrence, add in any free variables of its rule rhss
84 -- Curiously, we gather the Id's free *type* variables from its binding
85 -- site, but its free *rule-rhs* variables from its usage sites. This
86 -- is a little weird. The reason is that the former is more efficient,
87 -- but the latter is more fine grained, and a makes a difference when
88 -- a variable mentions itself one of its own rule RHSs
90 oneVar var fv_cand in_scope
92 foldVarSet add_rule_var var_itself_set (idRuleVars var)
94 var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
95 | otherwise = emptyVarSet
96 add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
99 someVars :: VarSet -> FV
100 someVars vars fv_cand in_scope
101 = filterVarSet (keep_it fv_cand in_scope) vars
103 keep_it fv_cand in_scope var
104 | var `elemVarSet` in_scope = False
109 addBndr :: CoreBndr -> FV -> FV
110 addBndr bndr fv fv_cand in_scope
111 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
112 | otherwise = inside_fvs
114 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
116 addBndrs :: [CoreBndr] -> FV -> FV
117 addBndrs bndrs fv = foldr addBndr fv bndrs
122 expr_fvs :: CoreExpr -> FV
124 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
125 expr_fvs (Var var) = oneVar var
126 expr_fvs (Lit lit) = noVars
127 expr_fvs (Note _ expr) = expr_fvs expr
128 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
129 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
131 expr_fvs (Case scrut bndr alts)
132 = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
134 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
136 expr_fvs (Let (NonRec bndr rhs) body)
137 = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
139 expr_fvs (Let (Rec pairs) body)
140 = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
142 (bndrs,rhss) = unzip pairs
146 %************************************************************************
150 %************************************************************************
152 exprFreeNames finds the free *names* of an expression, notably
153 including the names of type constructors (which of course do not show
154 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
155 when deciding whethera rule is an orphan. In particular, suppose that
156 T is defined in this module; we want to avoid declaring that a rule like
157 fromIntegral T = fromIntegral_T
158 is an orphan. Of course it isn't, an declaring it an orphan would
159 make the whole module an orphan module, which is bad.
162 ruleLhsFreeNames :: IdCoreRule -> NameSet
163 ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn)
164 ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs)
165 = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
167 exprFreeNames :: CoreExpr -> NameSet
168 exprFreeNames (Var v) = unitNameSet (varName v)
169 exprFreeNames (Lit _) = emptyNameSet
170 exprFreeNames (Type ty) = namesOfType ty
171 exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
172 exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v
173 exprFreeNames (Note n e) = exprFreeNames e
175 exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b)
176 `unionNameSets` exprFreeNames r
178 exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e)
183 exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets`
184 (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
187 altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
189 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
191 del_binders :: NameSet -> [Var] -> NameSet
192 del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs
195 %************************************************************************
197 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
199 %************************************************************************
203 ruleRhsFreeVars :: CoreRule -> VarSet
204 ruleRhsFreeVars (BuiltinRule _ _) = noFVs
205 ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
206 = rule_fvs isLocalVar emptyVarSet
208 rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
210 ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
211 ruleSomeFreeVars interesting (BuiltinRule _ _) = noFVs
212 ruleSomeFreeVars interesting (Rule _ _ tpl_vars tpl_args rhs)
213 = rule_fvs interesting emptyVarSet
215 rule_fvs = addBndrs tpl_vars $
216 foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
218 ruleLhsFreeIds :: CoreRule -> VarSet
219 -- This finds all the free Ids on the LHS of the rule
220 -- *including* imported ids
221 ruleLhsFreeIds (BuiltinRule _ _) = noFVs
222 ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
223 = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
227 %************************************************************************
229 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
231 %************************************************************************
233 The free variable pass annotates every node in the expression with its
234 NON-GLOBAL free variables and type variables.
237 type CoreBindWithFVs = AnnBind Id VarSet
238 type CoreExprWithFVs = AnnExpr Id VarSet
239 -- Every node annotated with its free variables,
240 -- both Ids and TyVars
242 freeVarsOf :: CoreExprWithFVs -> IdSet
243 freeVarsOf (free_vars, _) = free_vars
246 aFreeVar = unitVarSet
247 unionFVs = unionVarSet
249 delBindersFV :: [Var] -> VarSet -> VarSet
250 delBindersFV bs fvs = foldr delBinderFV fvs bs
252 delBinderFV :: Var -> VarSet -> VarSet
253 -- This way round, so we can do it multiple times using foldr
255 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
257 -- (a) the free variables of b's type
258 -- (b) the idSpecVars of b
260 -- This is really important for some lambdas:
261 -- In (\x::a -> x) the only mention of "a" is in the binder.
264 -- let x::a = b in ...
265 -- we should really note that "a" is free in this expression.
266 -- It'll be pinned inside the /\a by the binding for b, but
267 -- it seems cleaner to make sure that a is in the free-var set
268 -- when it is mentioned.
270 -- This also shows up in recursive bindings. Consider:
271 -- /\a -> letrec x::a = x in E
272 -- Now, there are no explicit free type variables in the RHS of x,
273 -- but nevertheless "a" is free in its definition. So we add in
274 -- the free tyvars of the types of the binders, and include these in the
275 -- free vars of the group, attached to the top level of each RHS.
277 -- This actually happened in the defn of errorIO in IOBase.lhs:
278 -- errorIO (ST io) = case (errorIO# io) of
281 -- bottom = bottom -- Never evaluated
283 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
284 | otherwise = s `delVarSet` b
286 idFreeVars :: Id -> VarSet
287 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
289 idFreeTyVars :: Id -> TyVarSet
290 -- Only local Ids conjured up locally, can have free type variables.
291 -- (During type checking top-level Ids can have free tyvars)
292 idFreeTyVars id = tyVarsOfType (idType id)
293 -- | isLocalId id = tyVarsOfType (idType id)
294 -- | otherwise = emptyVarSet
296 idRuleVars ::Id -> VarSet
297 idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
301 %************************************************************************
303 \subsection{Free variables (and types)}
305 %************************************************************************
308 freeVars :: CoreExpr -> CoreExprWithFVs
313 -- ToDo: insert motivating example for why we *need*
314 -- to include the idSpecVars in the FV list.
315 -- Actually [June 98] I don't think it's necessary
316 -- fvs = fvs_v `unionVarSet` idSpecVars v
318 fvs | isLocalVar v = aFreeVar v
321 freeVars (Lit lit) = (noFVs, AnnLit lit)
322 freeVars (Lam b body)
323 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
325 body' = freeVars body
327 freeVars (App fun arg)
328 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
333 freeVars (Case scrut bndr alts)
334 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
335 AnnCase scrut2 bndr alts2)
337 scrut2 = freeVars scrut
339 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
340 alts_fvs = foldr1 unionFVs alts_fvs_s
342 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
347 freeVars (Let (NonRec binder rhs) body)
348 = (freeVarsOf rhs2 `unionFVs` body_fvs,
349 AnnLet (AnnNonRec binder rhs2) body2)
352 body2 = freeVars body
353 body_fvs = binder `delBinderFV` freeVarsOf body2
355 freeVars (Let (Rec binds) body)
356 = (foldl delVarSet group_fvs binders,
357 -- The "delBinderFV" part may have added one of the binders
358 -- via the idSpecVars part, so we must delete it again
359 AnnLet (AnnRec (binders `zip` rhss2)) body2)
361 (binders, rhss) = unzip binds
363 rhss2 = map freeVars rhss
364 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
365 group_fvs = delBindersFV binders all_fvs
367 body2 = freeVars body
368 body_fvs = freeVarsOf body2
370 freeVars (Note (Coerce to_ty from_ty) expr)
371 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
372 AnnNote (Coerce to_ty from_ty) expr2)
374 expr2 = freeVars expr
375 tfvs1 = tyVarsOfType from_ty
376 tfvs2 = tyVarsOfType to_ty
378 freeVars (Note other_note expr)
379 = (freeVarsOf expr2, AnnNote other_note expr2)
381 expr2 = freeVars expr
383 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)