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, namesOfType )
31 import Util ( mapAndUnzip )
36 %************************************************************************
38 \section{Finding the free variables of an expression}
40 %************************************************************************
42 This function simply finds the free variables of an expression.
43 So far as type variables are concerned, it only finds tyvars that are
45 * free in type arguments,
46 * free in the type of a binder,
48 but not those that are free in the type of variable occurrence.
51 exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
52 exprFreeVars = exprSomeFreeVars isLocalVar
54 exprsFreeVars :: [CoreExpr] -> VarSet
55 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
57 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
60 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
62 exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
65 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
67 type InterestingVarFun = Var -> Bool -- True <=> interesting
72 type FV = InterestingVarFun
74 -> VarSet -- Free vars
76 union :: FV -> FV -> FV
77 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
80 noVars fv_cand in_scope = emptyVarSet
82 -- At a variable occurrence, add in any free variables of its rule rhss
83 -- Curiously, we gather the Id's free *type* variables from its binding
84 -- site, but its free *rule-rhs* variables from its usage sites. This
85 -- is a little weird. The reason is that the former is more efficient,
86 -- but the latter is more fine grained, and a makes a difference when
87 -- a variable mentions itself one of its own rule RHSs
89 oneVar var fv_cand in_scope
91 foldVarSet add_rule_var var_itself_set (idRuleVars var)
93 var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
94 | otherwise = emptyVarSet
95 add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
98 someVars :: VarSet -> FV
99 someVars vars fv_cand in_scope
100 = filterVarSet (keep_it fv_cand in_scope) vars
102 keep_it fv_cand in_scope var
103 | var `elemVarSet` in_scope = False
108 addBndr :: CoreBndr -> FV -> FV
109 addBndr bndr fv fv_cand in_scope
110 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
111 | otherwise = inside_fvs
113 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
115 addBndrs :: [CoreBndr] -> FV -> FV
116 addBndrs bndrs fv = foldr addBndr fv bndrs
121 expr_fvs :: CoreExpr -> FV
123 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
124 expr_fvs (Var var) = oneVar var
125 expr_fvs (Lit lit) = noVars
126 expr_fvs (Note _ expr) = expr_fvs expr
127 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
128 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
130 expr_fvs (Case scrut bndr alts)
131 = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
133 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
135 expr_fvs (Let (NonRec bndr rhs) body)
136 = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
138 expr_fvs (Let (Rec pairs) body)
139 = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
141 (bndrs,rhss) = unzip pairs
145 %************************************************************************
149 %************************************************************************
151 exprFreeNames finds the free *names* of an expression, notably
152 including the names of type constructors (which of course do not show
153 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
154 when deciding whethera rule is an orphan. In particular, suppose that
155 T is defined in this module; we want to avoid declaring that a rule like
156 fromIntegral T = fromIntegral_T
157 is an orphan. Of course it isn't, an declaring it an orphan would
158 make the whole module an orphan module, which is bad.
161 ruleLhsFreeNames :: IdCoreRule -> NameSet
162 ruleLhsFreeNames (fn, BuiltinRule _) = unitNameSet (varName fn)
163 ruleLhsFreeNames (fn, Rule _ tpl_vars tpl_args rhs)
164 = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
166 exprFreeNames :: CoreExpr -> NameSet
167 exprFreeNames (Var v) = unitNameSet (varName v)
168 exprFreeNames (Lit _) = emptyNameSet
169 exprFreeNames (Type ty) = namesOfType ty
170 exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
171 exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v
172 exprFreeNames (Note n e) = exprFreeNames e
174 exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b)
175 `unionNameSets` exprFreeNames r
177 exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e)
182 exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets`
183 (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
186 altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
188 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
190 del_binders :: NameSet -> [Var] -> NameSet
191 del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs
194 %************************************************************************
196 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
198 %************************************************************************
202 rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
203 rulesSomeFreeVars interesting (Rules rules _)
204 = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
206 ruleRhsFreeVars :: CoreRule -> VarSet
207 ruleRhsFreeVars (BuiltinRule _) = noFVs
208 ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
209 = rule_fvs isLocalVar emptyVarSet
211 rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
213 ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
214 ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
215 ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
216 = rule_fvs interesting emptyVarSet
218 rule_fvs = addBndrs tpl_vars $
219 foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
221 ruleLhsFreeIds :: CoreRule -> VarSet
222 -- This finds all the free Ids on the LHS of the rule
223 -- *including* imported ids
224 ruleLhsFreeIds (BuiltinRule _) = noFVs
225 ruleLhsFreeIds (Rule _ tpl_vars tpl_args rhs)
226 = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
230 %************************************************************************
232 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
234 %************************************************************************
236 The free variable pass annotates every node in the expression with its
237 NON-GLOBAL free variables and type variables.
240 type CoreBindWithFVs = AnnBind Id VarSet
241 type CoreExprWithFVs = AnnExpr Id VarSet
242 -- Every node annotated with its free variables,
243 -- both Ids and TyVars
245 freeVarsOf :: CoreExprWithFVs -> IdSet
246 freeVarsOf (free_vars, _) = free_vars
249 aFreeVar = unitVarSet
250 unionFVs = unionVarSet
252 delBindersFV :: [Var] -> VarSet -> VarSet
253 delBindersFV bs fvs = foldr delBinderFV fvs bs
255 delBinderFV :: Var -> VarSet -> VarSet
256 -- This way round, so we can do it multiple times using foldr
258 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
260 -- (a) the free variables of b's type
261 -- (b) the idSpecVars of b
263 -- This is really important for some lambdas:
264 -- In (\x::a -> x) the only mention of "a" is in the binder.
267 -- let x::a = b in ...
268 -- we should really note that "a" is free in this expression.
269 -- It'll be pinned inside the /\a by the binding for b, but
270 -- it seems cleaner to make sure that a is in the free-var set
271 -- when it is mentioned.
273 -- This also shows up in recursive bindings. Consider:
274 -- /\a -> letrec x::a = x in E
275 -- Now, there are no explicit free type variables in the RHS of x,
276 -- but nevertheless "a" is free in its definition. So we add in
277 -- the free tyvars of the types of the binders, and include these in the
278 -- free vars of the group, attached to the top level of each RHS.
280 -- This actually happened in the defn of errorIO in IOBase.lhs:
281 -- errorIO (ST io) = case (errorIO# io) of
284 -- bottom = bottom -- Never evaluated
286 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
287 | otherwise = s `delVarSet` b
289 idFreeVars :: Id -> VarSet
290 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
292 idFreeTyVars :: Id -> TyVarSet
293 -- Only local Ids conjured up locally, can have free type variables.
294 -- (During type checking top-level Ids can have free tyvars)
295 idFreeTyVars id = tyVarsOfType (idType id)
296 -- | isLocalId id = tyVarsOfType (idType id)
297 -- | otherwise = emptyVarSet
299 idRuleVars ::Id -> VarSet
300 idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
304 %************************************************************************
306 \subsection{Free variables (and types)}
308 %************************************************************************
311 freeVars :: CoreExpr -> CoreExprWithFVs
316 -- ToDo: insert motivating example for why we *need*
317 -- to include the idSpecVars in the FV list.
318 -- Actually [June 98] I don't think it's necessary
319 -- fvs = fvs_v `unionVarSet` idSpecVars v
321 fvs | isLocalVar v = aFreeVar v
324 freeVars (Lit lit) = (noFVs, AnnLit lit)
325 freeVars (Lam b body)
326 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
328 body' = freeVars body
330 freeVars (App fun arg)
331 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
336 freeVars (Case scrut bndr alts)
337 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
338 AnnCase scrut2 bndr alts2)
340 scrut2 = freeVars scrut
342 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
343 alts_fvs = foldr1 unionFVs alts_fvs_s
345 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
350 freeVars (Let (NonRec binder rhs) body)
351 = (freeVarsOf rhs2 `unionFVs` body_fvs,
352 AnnLet (AnnNonRec binder rhs2) body2)
355 body2 = freeVars body
356 body_fvs = binder `delBinderFV` freeVarsOf body2
358 freeVars (Let (Rec binds) body)
359 = (foldl delVarSet group_fvs binders,
360 -- The "delBinderFV" part may have added one of the binders
361 -- via the idSpecVars part, so we must delete it again
362 AnnLet (AnnRec (binders `zip` rhss2)) body2)
364 (binders, rhss) = unzip binds
366 rhss2 = map freeVars rhss
367 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
368 group_fvs = delBindersFV binders all_fvs
370 body2 = freeVars body
371 body_fvs = freeVarsOf body2
373 freeVars (Note (Coerce to_ty from_ty) expr)
374 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
375 AnnNote (Coerce to_ty from_ty) expr2)
377 expr2 = freeVars expr
378 tfvs1 = tyVarsOfType from_ty
379 tfvs2 = tyVarsOfType to_ty
381 freeVars (Note other_note expr)
382 = (freeVarsOf expr2, AnnNote other_note expr2)
384 expr2 = freeVars expr
386 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)