2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 Taken quite directly from the Peyton Jones/Lester paper.
8 {-# OPTIONS -fno-warn-incomplete-patterns #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
17 exprsFreeVars, -- [CoreExpr] -> VarSet
18 bindFreeVars, -- CoreBind -> VarSet
20 exprSomeFreeVars, exprsSomeFreeVars,
21 exprFreeNames, exprsFreeNames,
23 idRuleVars, idFreeVars, varTypeTyVars,
24 ruleRhsFreeVars, rulesFreeVars,
25 ruleLhsFreeNames, ruleLhsFreeIds,
27 CoreExprWithFVs, -- = AnnExpr Id VarSet
28 CoreBindWithFVs, -- = AnnBind Id VarSet
29 freeVars, -- CoreExpr -> CoreExprWithFVs
30 freeVarsOf -- CoreExprWithFVs -> IdSet
33 #include "HsVersions.h"
49 %************************************************************************
51 \section{Finding the free variables of an expression}
53 %************************************************************************
55 This function simply finds the free variables of an expression.
56 So far as type variables are concerned, it only finds tyvars that are
58 * free in type arguments,
59 * free in the type of a binder,
61 but not those that are free in the type of variable occurrence.
64 exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
65 exprFreeVars = exprSomeFreeVars isLocalVar
67 exprsFreeVars :: [CoreExpr] -> VarSet
68 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
70 bindFreeVars :: CoreBind -> VarSet
71 bindFreeVars (NonRec _ r) = exprFreeVars r
72 bindFreeVars (Rec prs) = addBndrs (map fst prs)
73 (foldr (union . rhs_fvs) noVars prs)
74 isLocalVar emptyVarSet
76 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
79 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
81 exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
84 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
86 type InterestingVarFun = Var -> Bool -- True <=> interesting
91 type FV = InterestingVarFun
93 -> VarSet -- Free vars
95 union :: FV -> FV -> FV
96 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
99 noVars _ _ = emptyVarSet
101 -- Comment about obselete code
102 -- We used to gather the free variables the RULES at a variable occurrence
103 -- with the following cryptic comment:
104 -- "At a variable occurrence, add in any free variables of its rule rhss
105 -- Curiously, we gather the Id's free *type* variables from its binding
106 -- site, but its free *rule-rhs* variables from its usage sites. This
107 -- is a little weird. The reason is that the former is more efficient,
108 -- but the latter is more fine grained, and a makes a difference when
109 -- a variable mentions itself one of its own rule RHSs"
110 -- Not only is this "weird", but it's also pretty bad because it can make
111 -- a function seem more recursive than it is. Suppose
114 -- RULE g x = ...f...
115 -- Then f is not mentioned in its own RHS, and needn't be a loop breaker
116 -- (though g may be). But if we collect the rule fvs from g's occurrence,
117 -- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB
118 -- code in GHC.Enum.)
120 -- Anyway, it seems plain wrong. The RULE is like an extra RHS for the
121 -- function, so its free variables belong at the definition site.
123 -- Deleted code looked like
124 -- foldVarSet add_rule_var var_itself_set (idRuleVars var)
125 -- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
130 oneVar var fv_cand in_scope
132 if keep_it fv_cand in_scope var
136 someVars :: VarSet -> FV
137 someVars vars fv_cand in_scope
138 = filterVarSet (keep_it fv_cand in_scope) vars
140 keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
141 keep_it fv_cand in_scope var
142 | var `elemVarSet` in_scope = False
147 addBndr :: CoreBndr -> FV -> FV
148 addBndr bndr fv fv_cand in_scope
149 = someVars (varTypeTyVars bndr) fv_cand in_scope
150 -- Include type varibles in the binder's type
151 -- (not just Ids; coercion variables too!)
152 `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr)
154 addBndrs :: [CoreBndr] -> FV -> FV
155 addBndrs bndrs fv = foldr addBndr fv bndrs
160 expr_fvs :: CoreExpr -> FV
162 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
163 expr_fvs (Var var) = oneVar var
164 expr_fvs (Lit _) = noVars
165 expr_fvs (Note _ expr) = expr_fvs expr
166 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
167 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
168 expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyVarsOfType co)
170 expr_fvs (Case scrut bndr ty alts)
171 = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
172 (foldr (union . alt_fvs) noVars alts)
174 alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
176 expr_fvs (Let (NonRec bndr rhs) body)
177 = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
179 expr_fvs (Let (Rec pairs) body)
180 = addBndrs (map fst pairs)
181 (foldr (union . rhs_fvs) (expr_fvs body) pairs)
184 rhs_fvs :: (Id,CoreExpr) -> FV
185 rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
186 -- Treat any RULES as extra RHSs of the binding
189 exprs_fvs :: [CoreExpr] -> FV
190 exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
194 %************************************************************************
198 %************************************************************************
200 exprFreeNames finds the free *external* *names* of an expression, notably
201 including the names of type constructors (which of course do not show
202 up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
203 when deciding whether a rule is an orphan. In particular, suppose that
204 T is defined in this module; we want to avoid declaring that a rule like
205 fromIntegral T = fromIntegral_T
206 is an orphan. Of course it isn't, an declaring it an orphan would
207 make the whole module an orphan module, which is bad.
209 There's no need to delete local binders, because they will all
213 ruleLhsFreeNames :: CoreRule -> NameSet
214 ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
215 ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args })
216 = addOneToNameSet (exprsFreeNames tpl_args) fn
218 exprFreeNames :: CoreExpr -> NameSet
219 -- Find the free *external* names of an expression
224 | isExternalName n = unitNameSet n
225 | otherwise = emptyNameSet
227 go (Lit _) = emptyNameSet
228 go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
229 go (App e1 e2) = go e1 `unionNameSets` go e2
230 go (Lam v e) = go e `delFromNameSet` idName v
232 go (Cast e co) = go e `unionNameSets` tyClsNamesOfType co
233 go (Let (NonRec _ r) e) = go e `unionNameSets` go r
234 go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
235 go (Case e _ ty as) = go e `unionNameSets` tyClsNamesOfType ty
236 `unionNameSets` unionManyNameSets (map go_alt as)
238 go_alt (_,_,r) = go r
240 exprsFreeNames :: [CoreExpr] -> NameSet
241 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
244 %************************************************************************
246 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
248 %************************************************************************
252 ruleRhsFreeVars :: CoreRule -> VarSet
253 ruleRhsFreeVars (BuiltinRule {}) = noFVs
254 ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
255 = delFromUFM fvs fn -- Note [Rule free var hack]
257 fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
259 ruleFreeVars :: CoreRule -> VarSet -- All free variables, both left and right
260 ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
261 = delFromUFM fvs fn -- Note [Rule free var hack]
263 fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
265 rulesFreeVars :: [CoreRule] -> VarSet
266 rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
268 ruleLhsFreeIds :: CoreRule -> VarSet
269 -- This finds all locally-defined free Ids on the LHS of the rule
270 ruleLhsFreeIds (BuiltinRule {}) = noFVs
271 ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
272 = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
275 Note [Rule free var hack]
276 ~~~~~~~~~~~~~~~~~~~~~~~~~
277 Don't include the Id in its own rhs free-var set.
278 Otherwise the occurrence analyser makes bindings recursive
279 that shoudn't be. E.g.
280 RULE: f (f x y) z ==> f x (f y z)
282 Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM.
284 %************************************************************************
286 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
288 %************************************************************************
290 The free variable pass annotates every node in the expression with its
291 NON-GLOBAL free variables and type variables.
294 type CoreBindWithFVs = AnnBind Id VarSet
295 type CoreExprWithFVs = AnnExpr Id VarSet
296 -- Every node annotated with its free variables,
297 -- both Ids and TyVars
299 freeVarsOf :: CoreExprWithFVs -> IdSet
300 freeVarsOf (free_vars, _) = free_vars
305 aFreeVar :: Var -> VarSet
306 aFreeVar = unitVarSet
308 unionFVs :: VarSet -> VarSet -> VarSet
309 unionFVs = unionVarSet
311 delBindersFV :: [Var] -> VarSet -> VarSet
312 delBindersFV bs fvs = foldr delBinderFV fvs bs
314 delBinderFV :: Var -> VarSet -> VarSet
315 -- This way round, so we can do it multiple times using foldr
317 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
319 -- (a) the free variables of b's type
320 -- (b) the idSpecVars of b
322 -- This is really important for some lambdas:
323 -- In (\x::a -> x) the only mention of "a" is in the binder.
326 -- let x::a = b in ...
327 -- we should really note that "a" is free in this expression.
328 -- It'll be pinned inside the /\a by the binding for b, but
329 -- it seems cleaner to make sure that a is in the free-var set
330 -- when it is mentioned.
332 -- This also shows up in recursive bindings. Consider:
333 -- /\a -> letrec x::a = x in E
334 -- Now, there are no explicit free type variables in the RHS of x,
335 -- but nevertheless "a" is free in its definition. So we add in
336 -- the free tyvars of the types of the binders, and include these in the
337 -- free vars of the group, attached to the top level of each RHS.
339 -- This actually happened in the defn of errorIO in IOBase.lhs:
340 -- errorIO (ST io) = case (errorIO# io) of
343 -- bottom = bottom -- Never evaluated
345 delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b
346 -- Include coercion variables too!
348 varTypeTyVars :: Var -> TyVarSet
349 -- Find the type variables free in the type of the variable
350 -- Remember, coercion variables can mention type variables...
352 | isLocalId var || isCoVar var = tyVarsOfType (idType var)
353 | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
355 idFreeVars :: Id -> VarSet
356 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id
358 idRuleVars ::Id -> VarSet
359 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
363 %************************************************************************
365 \subsection{Free variables (and types)}
367 %************************************************************************
370 freeVars :: CoreExpr -> CoreExprWithFVs
375 -- ToDo: insert motivating example for why we *need*
376 -- to include the idSpecVars in the FV list.
377 -- Actually [June 98] I don't think it's necessary
378 -- fvs = fvs_v `unionVarSet` idSpecVars v
380 fvs | isLocalVar v = aFreeVar v
383 freeVars (Lit lit) = (noFVs, AnnLit lit)
384 freeVars (Lam b body)
385 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
387 body' = freeVars body
389 freeVars (App fun arg)
390 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
395 freeVars (Case scrut bndr ty alts)
396 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
397 AnnCase scrut2 bndr ty alts2)
399 scrut2 = freeVars scrut
401 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
402 alts_fvs = foldr1 unionFVs alts_fvs_s
404 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
409 freeVars (Let (NonRec binder rhs) body)
410 = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` idRuleVars binder,
411 -- Remember any rules; cf rhs_fvs above
412 AnnLet (AnnNonRec binder rhs2) body2)
415 body2 = freeVars body
416 body_fvs = binder `delBinderFV` freeVarsOf body2
418 freeVars (Let (Rec binds) body)
419 = (delBindersFV binders all_fvs,
420 AnnLet (AnnRec (binders `zip` rhss2)) body2)
422 (binders, rhss) = unzip binds
424 rhss2 = map freeVars rhss
425 rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
426 all_fvs = foldr (unionFVs . idRuleVars) rhs_body_fvs binders
427 -- The "delBinderFV" happens after adding the idSpecVars,
428 -- since the latter may add some of the binders as fvs
430 body2 = freeVars body
431 body_fvs = freeVarsOf body2
434 freeVars (Cast expr co)
435 = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
437 expr2 = freeVars expr
438 cfvs = tyVarsOfType co
440 freeVars (Note other_note expr)
441 = (freeVarsOf expr2, AnnNote other_note expr2)
443 expr2 = freeVars expr
445 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)