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, ruleSomeLhsFreeVars, ruleRhsFreeVars,
16 CoreExprWithFVs, -- = AnnExpr Id VarSet
17 CoreBindWithFVs, -- = AnnBind Id VarSet
18 freeVars, -- CoreExpr -> CoreExprWithFVs
19 freeVarsOf -- CoreExprWithFVs -> IdSet
22 #include "HsVersions.h"
25 import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
27 import Var ( Var, isId, isLocalVar )
28 import Type ( tyVarsOfType )
29 import Util ( mapAndUnzip )
34 %************************************************************************
36 \section{Finding the free variables of an expression}
38 %************************************************************************
40 This function simply finds the free variables of an expression.
41 So far as type variables are concerned, it only finds tyvars that are
43 * free in type arguments,
44 * free in the type of a binder,
46 but not those that are free in the type of variable occurrence.
49 exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
50 exprFreeVars = exprSomeFreeVars isLocalVar
52 exprsFreeVars :: [CoreExpr] -> VarSet
53 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
55 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
58 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
60 exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
63 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
65 type InterestingVarFun = Var -> Bool -- True <=> interesting
70 type FV = InterestingVarFun
72 -> VarSet -- Free vars
74 union :: FV -> FV -> FV
75 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
78 noVars fv_cand in_scope = emptyVarSet
80 -- At a variable occurrence, add in any free variables of its rule rhss
81 -- Curiously, we gather the Id's free *type* variables from its binding
82 -- site, but its free *rule-rhs* variables from its usage sites. This
83 -- is a little weird. The reason is that the former is more efficient,
84 -- but the latter is more fine grained, and a makes a difference when
85 -- a variable mentions itself one of its own rule RHSs
87 oneVar var fv_cand in_scope
89 foldVarSet add_rule_var var_itself_set (idRuleVars var)
91 var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
92 | otherwise = emptyVarSet
93 add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
96 someVars :: VarSet -> FV
97 someVars vars fv_cand in_scope
98 = filterVarSet (keep_it fv_cand in_scope) vars
100 keep_it fv_cand in_scope var
101 | var `elemVarSet` in_scope = False
106 addBndr :: CoreBndr -> FV -> FV
107 addBndr bndr fv fv_cand in_scope
108 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
109 | otherwise = inside_fvs
111 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
113 addBndrs :: [CoreBndr] -> FV -> FV
114 addBndrs bndrs fv = foldr addBndr fv bndrs
119 expr_fvs :: CoreExpr -> FV
121 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
122 expr_fvs (Var var) = oneVar var
123 expr_fvs (Lit lit) = noVars
124 expr_fvs (Note _ expr) = expr_fvs expr
125 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
126 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
128 expr_fvs (Case scrut bndr alts)
129 = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
131 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
133 expr_fvs (Let (NonRec bndr rhs) body)
134 = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
136 expr_fvs (Let (Rec pairs) body)
137 = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
139 (bndrs,rhss) = unzip pairs
145 rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
146 rulesSomeFreeVars interesting (Rules rules _)
147 = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
149 ruleRhsFreeVars :: CoreRule -> VarSet
150 ruleRhsFreeVars (BuiltinRule _) = noFVs
151 ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
152 = rule_fvs isLocalVar emptyVarSet
154 rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
156 ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
157 ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
158 ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
159 = rule_fvs interesting emptyVarSet
161 rule_fvs = addBndrs tpl_vars $
162 foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
164 ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet
165 ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
166 ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
167 = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
171 %************************************************************************
173 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
175 %************************************************************************
177 The free variable pass annotates every node in the expression with its
178 NON-GLOBAL free variables and type variables.
181 type CoreBindWithFVs = AnnBind Id VarSet
182 type CoreExprWithFVs = AnnExpr Id VarSet
183 -- Every node annotated with its free variables,
184 -- both Ids and TyVars
186 freeVarsOf :: CoreExprWithFVs -> IdSet
187 freeVarsOf (free_vars, _) = free_vars
190 aFreeVar = unitVarSet
191 unionFVs = unionVarSet
193 delBindersFV :: [Var] -> VarSet -> VarSet
194 delBindersFV bs fvs = foldr delBinderFV fvs bs
196 delBinderFV :: Var -> VarSet -> VarSet
197 -- This way round, so we can do it multiple times using foldr
199 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
201 -- (a) the free variables of b's type
202 -- (b) the idSpecVars of b
204 -- This is really important for some lambdas:
205 -- In (\x::a -> x) the only mention of "a" is in the binder.
208 -- let x::a = b in ...
209 -- we should really note that "a" is free in this expression.
210 -- It'll be pinned inside the /\a by the binding for b, but
211 -- it seems cleaner to make sure that a is in the free-var set
212 -- when it is mentioned.
214 -- This also shows up in recursive bindings. Consider:
215 -- /\a -> letrec x::a = x in E
216 -- Now, there are no explicit free type variables in the RHS of x,
217 -- but nevertheless "a" is free in its definition. So we add in
218 -- the free tyvars of the types of the binders, and include these in the
219 -- free vars of the group, attached to the top level of each RHS.
221 -- This actually happened in the defn of errorIO in IOBase.lhs:
222 -- errorIO (ST io) = case (errorIO# io) of
225 -- bottom = bottom -- Never evaluated
227 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
228 | otherwise = s `delVarSet` b
230 idFreeVars :: Id -> VarSet
231 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
233 idFreeTyVars :: Id -> TyVarSet
234 -- Only local Ids conjured up locally, can have free type variables.
235 -- (During type checking top-level Ids can have free tyvars)
236 idFreeTyVars id = tyVarsOfType (idType id)
237 -- | isLocalId id = tyVarsOfType (idType id)
238 -- | otherwise = emptyVarSet
240 idRuleVars ::Id -> VarSet
241 idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
245 %************************************************************************
247 \subsection{Free variables (and types)}
249 %************************************************************************
252 freeVars :: CoreExpr -> CoreExprWithFVs
257 -- ToDo: insert motivating example for why we *need*
258 -- to include the idSpecVars in the FV list.
259 -- Actually [June 98] I don't think it's necessary
260 -- fvs = fvs_v `unionVarSet` idSpecVars v
262 fvs | isLocalVar v = aFreeVar v
265 freeVars (Lit lit) = (noFVs, AnnLit lit)
266 freeVars (Lam b body)
267 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
269 body' = freeVars body
271 freeVars (App fun arg)
272 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
277 freeVars (Case scrut bndr alts)
278 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
279 AnnCase scrut2 bndr alts2)
281 scrut2 = freeVars scrut
283 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
284 alts_fvs = foldr1 unionFVs alts_fvs_s
286 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
291 freeVars (Let (NonRec binder rhs) body)
292 = (freeVarsOf rhs2 `unionFVs` body_fvs,
293 AnnLet (AnnNonRec binder rhs2) body2)
296 body2 = freeVars body
297 body_fvs = binder `delBinderFV` freeVarsOf body2
299 freeVars (Let (Rec binds) body)
300 = (foldl delVarSet group_fvs binders,
301 -- The "delBinderFV" part may have added one of the binders
302 -- via the idSpecVars part, so we must delete it again
303 AnnLet (AnnRec (binders `zip` rhss2)) body2)
305 (binders, rhss) = unzip binds
307 rhss2 = map freeVars rhss
308 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
309 group_fvs = delBindersFV binders all_fvs
311 body2 = freeVars body
312 body_fvs = freeVarsOf body2
314 freeVars (Note (Coerce to_ty from_ty) expr)
315 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
316 AnnNote (Coerce to_ty from_ty) expr2)
318 expr2 = freeVars expr
319 tfvs1 = tyVarsOfType from_ty
320 tfvs2 = tyVarsOfType to_ty
322 freeVars (Note other_note expr)
323 = (freeVarsOf expr2, AnnNote other_note expr2)
325 expr2 = freeVars expr
327 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)