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 ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds,
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, idSpecialisation )
28 import Var ( Var, isId, isLocalVar, varName )
29 import Type ( tyVarsOfType )
30 import TcType ( tyClsNamesOfType )
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)
131 expr_fvs (Case scrut bndr ty alts)
132 = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
133 (foldr (union . alt_fvs) noVars alts)
135 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
137 expr_fvs (Let (NonRec bndr rhs) body)
138 = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
140 expr_fvs (Let (Rec pairs) body)
141 = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
143 (bndrs,rhss) = unzip pairs
147 %************************************************************************
151 %************************************************************************
153 exprFreeNames finds the free *names* of an expression, notably
154 including the names of type constructors (which of course do not show
155 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
156 when deciding whether a rule is an orphan. In particular, suppose that
157 T is defined in this module; we want to avoid declaring that a rule like
158 fromIntegral T = fromIntegral_T
159 is an orphan. Of course it isn't, an declaring it an orphan would
160 make the whole module an orphan module, which is bad.
163 ruleLhsFreeNames :: IdCoreRule -> NameSet
164 ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn)
165 ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs)
166 = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
168 exprFreeNames :: CoreExpr -> NameSet
169 exprFreeNames (Var v) = unitNameSet (varName v)
170 exprFreeNames (Lit _) = emptyNameSet
171 exprFreeNames (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
172 exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
173 exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v
174 exprFreeNames (Note n e) = exprFreeNames e
176 exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b)
177 `unionNameSets` exprFreeNames r
179 exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e)
185 exprFreeNames (Case e b ty as) = exprFreeNames e `unionNameSets` tyClsNamesOfType ty
187 (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
190 altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
192 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
194 del_binders :: NameSet -> [Var] -> NameSet
195 del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs
198 %************************************************************************
200 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
202 %************************************************************************
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 ruleLhsFreeIds :: CoreRule -> VarSet
214 -- This finds all the free Ids on the LHS of the rule
215 -- *including* imported ids
216 ruleLhsFreeIds (BuiltinRule _ _) = noFVs
217 ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
218 = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
222 %************************************************************************
224 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
226 %************************************************************************
228 The free variable pass annotates every node in the expression with its
229 NON-GLOBAL free variables and type variables.
232 type CoreBindWithFVs = AnnBind Id VarSet
233 type CoreExprWithFVs = AnnExpr Id VarSet
234 -- Every node annotated with its free variables,
235 -- both Ids and TyVars
237 freeVarsOf :: CoreExprWithFVs -> IdSet
238 freeVarsOf (free_vars, _) = free_vars
241 aFreeVar = unitVarSet
242 unionFVs = unionVarSet
244 delBindersFV :: [Var] -> VarSet -> VarSet
245 delBindersFV bs fvs = foldr delBinderFV fvs bs
247 delBinderFV :: Var -> VarSet -> VarSet
248 -- This way round, so we can do it multiple times using foldr
250 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
252 -- (a) the free variables of b's type
253 -- (b) the idSpecVars of b
255 -- This is really important for some lambdas:
256 -- In (\x::a -> x) the only mention of "a" is in the binder.
259 -- let x::a = b in ...
260 -- we should really note that "a" is free in this expression.
261 -- It'll be pinned inside the /\a by the binding for b, but
262 -- it seems cleaner to make sure that a is in the free-var set
263 -- when it is mentioned.
265 -- This also shows up in recursive bindings. Consider:
266 -- /\a -> letrec x::a = x in E
267 -- Now, there are no explicit free type variables in the RHS of x,
268 -- but nevertheless "a" is free in its definition. So we add in
269 -- the free tyvars of the types of the binders, and include these in the
270 -- free vars of the group, attached to the top level of each RHS.
272 -- This actually happened in the defn of errorIO in IOBase.lhs:
273 -- errorIO (ST io) = case (errorIO# io) of
276 -- bottom = bottom -- Never evaluated
278 delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
279 | otherwise = s `delVarSet` b
281 idFreeVars :: Id -> VarSet
282 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
284 idFreeTyVars :: Id -> TyVarSet
285 -- Only local Ids conjured up locally, can have free type variables.
286 -- (During type checking top-level Ids can have free tyvars)
287 idFreeTyVars id = tyVarsOfType (idType id)
288 -- | isLocalId id = tyVarsOfType (idType id)
289 -- | otherwise = emptyVarSet
291 idRuleVars ::Id -> VarSet
292 idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
296 %************************************************************************
298 \subsection{Free variables (and types)}
300 %************************************************************************
303 freeVars :: CoreExpr -> CoreExprWithFVs
308 -- ToDo: insert motivating example for why we *need*
309 -- to include the idSpecVars in the FV list.
310 -- Actually [June 98] I don't think it's necessary
311 -- fvs = fvs_v `unionVarSet` idSpecVars v
313 fvs | isLocalVar v = aFreeVar v
316 freeVars (Lit lit) = (noFVs, AnnLit lit)
317 freeVars (Lam b body)
318 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
320 body' = freeVars body
322 freeVars (App fun arg)
323 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
328 freeVars (Case scrut bndr ty alts)
330 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
331 AnnCase scrut2 bndr ty alts2)
333 scrut2 = freeVars scrut
335 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
336 alts_fvs = foldr1 unionFVs alts_fvs_s
338 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
343 freeVars (Let (NonRec binder rhs) body)
344 = (freeVarsOf rhs2 `unionFVs` body_fvs,
345 AnnLet (AnnNonRec binder rhs2) body2)
348 body2 = freeVars body
349 body_fvs = binder `delBinderFV` freeVarsOf body2
351 freeVars (Let (Rec binds) body)
352 = (foldl delVarSet group_fvs binders,
353 -- The "delBinderFV" part may have added one of the binders
354 -- via the idSpecVars part, so we must delete it again
355 AnnLet (AnnRec (binders `zip` rhss2)) body2)
357 (binders, rhss) = unzip binds
359 rhss2 = map freeVars rhss
360 all_fvs = foldr (unionFVs . fst) body_fvs rhss2
361 group_fvs = delBindersFV binders all_fvs
363 body2 = freeVars body
364 body_fvs = freeVarsOf body2
366 freeVars (Note (Coerce to_ty from_ty) expr)
367 = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
368 AnnNote (Coerce to_ty from_ty) expr2)
370 expr2 = freeVars expr
371 tfvs1 = tyVarsOfType from_ty
372 tfvs2 = tyVarsOfType to_ty
374 freeVars (Note other_note expr)
375 = (freeVarsOf expr2, AnnNote other_note expr2)
377 expr2 = freeVars expr
379 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)