0e5027768ad7dd064d36fb9e73e1f33af0b50bbe
[ghc.git] / compiler / coreSyn / CoreFVs.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 Taken quite directly from the Peyton Jones/Lester paper.
6 -}
7
8 {-# LANGUAGE CPP #-}
9
10 -- | A module concerned with finding the free variables of an expression.
11 module CoreFVs (
12 -- * Free variables of expressions and binding groups
13 exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
14 exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
15 exprsFreeVars, -- [CoreExpr] -> VarSet
16 bindFreeVars, -- CoreBind -> VarSet
17
18 -- * Selective free variables of expressions
19 InterestingVarFun,
20 exprSomeFreeVars, exprsSomeFreeVars,
21
22 -- * Free variables of Rules, Vars and Ids
23 varTypeTyVars,
24 idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
25 idRuleVars, idRuleRhsVars, stableUnfoldingVars,
26 ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
27 ruleLhsFreeIds, exprsOrphNames,
28 vectsFreeVars,
29
30 -- * Core syntax tree annotation with free variables
31 CoreExprWithFVs, -- = AnnExpr Id VarSet
32 CoreBindWithFVs, -- = AnnBind Id VarSet
33 freeVars, -- CoreExpr -> CoreExprWithFVs
34 freeVarsOf -- CoreExprWithFVs -> IdSet
35 ) where
36
37 #include "HsVersions.h"
38
39 import CoreSyn
40 import Id
41 import IdInfo
42 import NameSet
43 import UniqFM
44 import Name
45 import VarSet
46 import Var
47 import TcType
48 import Coercion
49 import Maybes( orElse )
50 import Util
51 import BasicTypes( Activation )
52 import Outputable
53
54 {-
55 ************************************************************************
56 * *
57 \section{Finding the free variables of an expression}
58 * *
59 ************************************************************************
60
61 This function simply finds the free variables of an expression.
62 So far as type variables are concerned, it only finds tyvars that are
63
64 * free in type arguments,
65 * free in the type of a binder,
66
67 but not those that are free in the type of variable occurrence.
68 -}
69
70 -- | Find all locally-defined free Ids or type variables in an expression
71 exprFreeVars :: CoreExpr -> VarSet
72 exprFreeVars = exprSomeFreeVars isLocalVar
73
74 -- | Find all locally-defined free Ids in an expression
75 exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
76 exprFreeIds = exprSomeFreeVars isLocalId
77
78 -- | Find all locally-defined free Ids or type variables in several expressions
79 exprsFreeVars :: [CoreExpr] -> VarSet
80 exprsFreeVars = mapUnionVarSet exprFreeVars
81
82 -- | Find all locally defined free Ids in a binding group
83 bindFreeVars :: CoreBind -> VarSet
84 bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet
85 bindFreeVars (Rec prs) = addBndrs (map fst prs)
86 (foldr (union . rhs_fvs) noVars prs)
87 isLocalVar emptyVarSet
88
89 -- | Finds free variables in an expression selected by a predicate
90 exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting
91 -> CoreExpr
92 -> VarSet
93 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
94
95 -- | Finds free variables in several expressions selected by a predicate
96 exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
97 -> [CoreExpr]
98 -> VarSet
99 exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
100
101 -- | Predicate on possible free variables: returns @True@ iff the variable is interesting
102 type InterestingVarFun = Var -> Bool
103
104 type FV = InterestingVarFun
105 -> VarSet -- Locally bound
106 -> VarSet -- Free vars
107 -- Return the vars that are both (a) interesting
108 -- and (b) not locally bound
109 -- See function keep_it
110
111 keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
112 keep_it fv_cand in_scope var
113 | var `elemVarSet` in_scope = False
114 | fv_cand var = True
115 | otherwise = False
116
117 union :: FV -> FV -> FV
118 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
119
120 noVars :: FV
121 noVars _ _ = emptyVarSet
122
123 -- Comment about obselete code
124 -- We used to gather the free variables the RULES at a variable occurrence
125 -- with the following cryptic comment:
126 -- "At a variable occurrence, add in any free variables of its rule rhss
127 -- Curiously, we gather the Id's free *type* variables from its binding
128 -- site, but its free *rule-rhs* variables from its usage sites. This
129 -- is a little weird. The reason is that the former is more efficient,
130 -- but the latter is more fine grained, and a makes a difference when
131 -- a variable mentions itself one of its own rule RHSs"
132 -- Not only is this "weird", but it's also pretty bad because it can make
133 -- a function seem more recursive than it is. Suppose
134 -- f = ...g...
135 -- g = ...
136 -- RULE g x = ...f...
137 -- Then f is not mentioned in its own RHS, and needn't be a loop breaker
138 -- (though g may be). But if we collect the rule fvs from g's occurrence,
139 -- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB
140 -- code in GHC.Enum.)
141 --
142 -- Anyway, it seems plain wrong. The RULE is like an extra RHS for the
143 -- function, so its free variables belong at the definition site.
144 --
145 -- Deleted code looked like
146 -- foldVarSet add_rule_var var_itself_set (idRuleVars var)
147 -- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
148 -- | otherwise = set
149 -- SLPJ Feb06
150
151 oneVar :: Id -> FV
152 oneVar var fv_cand in_scope
153 = ASSERT( isId var )
154 if keep_it fv_cand in_scope var
155 then unitVarSet var
156 else emptyVarSet
157
158 someVars :: VarSet -> FV
159 someVars vars fv_cand in_scope
160 = filterVarSet (keep_it fv_cand in_scope) vars
161
162 addBndr :: CoreBndr -> FV -> FV
163 addBndr bndr fv fv_cand in_scope
164 = someVars (varTypeTyVars bndr) fv_cand in_scope
165 -- Include type varibles in the binder's type
166 -- (not just Ids; coercion variables too!)
167 `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr)
168
169 addBndrs :: [CoreBndr] -> FV -> FV
170 addBndrs bndrs fv = foldr addBndr fv bndrs
171
172 expr_fvs :: CoreExpr -> FV
173
174 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
175 expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co)
176 expr_fvs (Var var) = oneVar var
177 expr_fvs (Lit _) = noVars
178 expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr
179 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
180 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
181 expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
182
183 expr_fvs (Case scrut bndr ty alts)
184 = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
185 (foldr (union . alt_fvs) noVars alts)
186 where
187 alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
188
189 expr_fvs (Let (NonRec bndr rhs) body)
190 = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
191
192 expr_fvs (Let (Rec pairs) body)
193 = addBndrs (map fst pairs)
194 (foldr (union . rhs_fvs) (expr_fvs body) pairs)
195
196 ---------
197 rhs_fvs :: (Id,CoreExpr) -> FV
198 rhs_fvs (bndr, rhs) = expr_fvs rhs `union`
199 someVars (bndrRuleAndUnfoldingVars bndr)
200 -- Treat any RULES as extra RHSs of the binding
201
202 ---------
203 exprs_fvs :: [CoreExpr] -> FV
204 exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
205
206 tickish_fvs :: Tickish Id -> FV
207 tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids)
208 tickish_fvs _ = noVars
209
210 {-
211 ************************************************************************
212 * *
213 \section{Free names}
214 * *
215 ************************************************************************
216 -}
217
218 -- | Finds the free /external/ names of an expression, notably
219 -- including the names of type constructors (which of course do not show
220 -- up in 'exprFreeVars').
221 exprOrphNames :: CoreExpr -> NameSet
222 -- There's no need to delete local binders, because they will all
223 -- be /internal/ names.
224 exprOrphNames e
225 = go e
226 where
227 go (Var v)
228 | isExternalName n = unitNameSet n
229 | otherwise = emptyNameSet
230 where n = idName v
231 go (Lit _) = emptyNameSet
232 go (Type ty) = orphNamesOfType ty -- Don't need free tyvars
233 go (Coercion co) = orphNamesOfCo co
234 go (App e1 e2) = go e1 `unionNameSet` go e2
235 go (Lam v e) = go e `delFromNameSet` idName v
236 go (Tick _ e) = go e
237 go (Cast e co) = go e `unionNameSet` orphNamesOfCo co
238 go (Let (NonRec _ r) e) = go e `unionNameSet` go r
239 go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e
240 go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty
241 `unionNameSet` unionNameSets (map go_alt as)
242
243 go_alt (_,_,r) = go r
244
245 -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
246 exprsOrphNames :: [CoreExpr] -> NameSet
247 exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
248
249 {-
250 ************************************************************************
251 * *
252 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
253 * *
254 ************************************************************************
255 -}
256
257 -- | Those variables free in the right hand side of a rule
258 ruleRhsFreeVars :: CoreRule -> VarSet
259 ruleRhsFreeVars (BuiltinRule {}) = noFVs
260 ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
261 = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
262 -- See Note [Rule free var hack]
263
264 -- | Those variables free in the both the left right hand sides of a rule
265 ruleFreeVars :: CoreRule -> VarSet
266 ruleFreeVars (BuiltinRule {}) = noFVs
267 ruleFreeVars (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack]
268 , ru_bndrs = bndrs
269 , ru_rhs = rhs, ru_args = args })
270 = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
271
272
273 idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
274 -- Just the variables free on the *rhs* of a rule
275 idRuleRhsVars is_active id
276 = mapUnionVarSet get_fvs (idCoreRules id)
277 where
278 get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
279 , ru_rhs = rhs, ru_act = act })
280 | is_active act
281 -- See Note [Finding rule RHS free vars] in OccAnal.hs
282 = delFromUFM fvs fn -- Note [Rule free var hack]
283 where
284 fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
285 get_fvs _ = noFVs
286
287 -- | Those variables free in the right hand side of several rules
288 rulesFreeVars :: [CoreRule] -> VarSet
289 rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
290
291 ruleLhsFreeIds :: CoreRule -> VarSet
292 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
293 ruleLhsFreeIds (BuiltinRule {}) = noFVs
294 ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
295 = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
296
297 {-
298 Note [Rule free var hack] (Not a hack any more)
299 ~~~~~~~~~~~~~~~~~~~~~~~~~
300 We used not to include the Id in its own rhs free-var set.
301 Otherwise the occurrence analyser makes bindings recursive:
302 f x y = x+y
303 RULE: f (f x y) z ==> f x (f y z)
304 However, the occurrence analyser distinguishes "non-rule loop breakers"
305 from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will
306 put this 'f' in a Rec block, but will mark the binding as a non-rule loop
307 breaker, which is perfectly inlinable.
308 -}
309
310 -- |Free variables of a vectorisation declaration
311 vectsFreeVars :: [CoreVect] -> VarSet
312 vectsFreeVars = mapUnionVarSet vectFreeVars
313 where
314 vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet
315 vectFreeVars (NoVect _) = noFVs
316 vectFreeVars (VectType _ _ _) = noFVs
317 vectFreeVars (VectClass _) = noFVs
318 vectFreeVars (VectInst _) = noFVs
319 -- this function is only concerned with values, not types
320
321 {-
322 ************************************************************************
323 * *
324 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
325 * *
326 ************************************************************************
327
328 The free variable pass annotates every node in the expression with its
329 NON-GLOBAL free variables and type variables.
330 -}
331
332 -- | Every node in a binding group annotated with its
333 -- (non-global) free variables, both Ids and TyVars
334 type CoreBindWithFVs = AnnBind Id VarSet
335 -- | Every node in an expression annotated with its
336 -- (non-global) free variables, both Ids and TyVars
337 type CoreExprWithFVs = AnnExpr Id VarSet
338
339 freeVarsOf :: CoreExprWithFVs -> IdSet
340 -- ^ Inverse function to 'freeVars'
341 freeVarsOf (free_vars, _) = free_vars
342
343 noFVs :: VarSet
344 noFVs = emptyVarSet
345
346 aFreeVar :: Var -> VarSet
347 aFreeVar = unitVarSet
348
349 unionFVs :: VarSet -> VarSet -> VarSet
350 unionFVs = unionVarSet
351
352 delBindersFV :: [Var] -> VarSet -> VarSet
353 delBindersFV bs fvs = foldr delBinderFV fvs bs
354
355 delBinderFV :: Var -> VarSet -> VarSet
356 -- This way round, so we can do it multiple times using foldr
357
358 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
359 -- but *adds* to s
360 --
361 -- the free variables of b's type
362 --
363 -- This is really important for some lambdas:
364 -- In (\x::a -> x) the only mention of "a" is in the binder.
365 --
366 -- Also in
367 -- let x::a = b in ...
368 -- we should really note that "a" is free in this expression.
369 -- It'll be pinned inside the /\a by the binding for b, but
370 -- it seems cleaner to make sure that a is in the free-var set
371 -- when it is mentioned.
372 --
373 -- This also shows up in recursive bindings. Consider:
374 -- /\a -> letrec x::a = x in E
375 -- Now, there are no explicit free type variables in the RHS of x,
376 -- but nevertheless "a" is free in its definition. So we add in
377 -- the free tyvars of the types of the binders, and include these in the
378 -- free vars of the group, attached to the top level of each RHS.
379 --
380 -- This actually happened in the defn of errorIO in IOBase.hs:
381 -- errorIO (ST io) = case (errorIO# io) of
382 -- _ -> bottom
383 -- where
384 -- bottom = bottom -- Never evaluated
385
386 delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b
387 -- Include coercion variables too!
388
389 varTypeTyVars :: Var -> TyVarSet
390 -- Find the type/kind variables free in the type of the id/tyvar
391 varTypeTyVars var = tyVarsOfType (varType var)
392
393 idFreeVars :: Id -> VarSet
394 -- Type variables, rule variables, and inline variables
395 idFreeVars id = ASSERT( isId id)
396 varTypeTyVars id `unionVarSet`
397 idRuleAndUnfoldingVars id
398
399 bndrRuleAndUnfoldingVars ::Var -> VarSet
400 -- A 'let' can bind a type variable, and idRuleVars assumes
401 -- it's seeing an Id. This function tests first.
402 bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
403 | otherwise = idRuleAndUnfoldingVars v
404
405 idRuleAndUnfoldingVars :: Id -> VarSet
406 idRuleAndUnfoldingVars id = ASSERT( isId id)
407 idRuleVars id `unionVarSet`
408 idUnfoldingVars id
409
410 idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
411 idRuleVars id = ASSERT( isId id) ruleInfoFreeVars (idSpecialisation id)
412
413 idUnfoldingVars :: Id -> VarSet
414 -- Produce free vars for an unfolding, but NOT for an ordinary
415 -- (non-inline) unfolding, since it is a dup of the rhs
416 -- and we'll get exponential behaviour if we look at both unf and rhs!
417 -- But do look at the *real* unfolding, even for loop breakers, else
418 -- we might get out-of-scope variables
419 idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet
420
421 stableUnfoldingVars :: Unfolding -> Maybe VarSet
422 stableUnfoldingVars unf
423 = case unf of
424 CoreUnfolding { uf_tmpl = rhs, uf_src = src }
425 | isStableSource src
426 -> Just (exprFreeVars rhs)
427 DFunUnfolding { df_bndrs = bndrs, df_args = args }
428 -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
429 -- DFuns are top level, so no fvs from types of bndrs
430 _other -> Nothing
431
432 {-
433 ************************************************************************
434 * *
435 \subsection{Free variables (and types)}
436 * *
437 ************************************************************************
438 -}
439
440 freeVars :: CoreExpr -> CoreExprWithFVs
441 -- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
442 freeVars (Var v)
443 = (fvs, AnnVar v)
444 where
445 -- ToDo: insert motivating example for why we *need*
446 -- to include the idSpecVars in the FV list.
447 -- Actually [June 98] I don't think it's necessary
448 -- fvs = fvs_v `unionVarSet` idSpecVars v
449
450 fvs | isLocalVar v = aFreeVar v
451 | otherwise = noFVs
452
453 freeVars (Lit lit) = (noFVs, AnnLit lit)
454 freeVars (Lam b body)
455 = (b `delBinderFV` freeVarsOf body', AnnLam b body')
456 where
457 body' = freeVars body
458
459 freeVars (App fun arg)
460 = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
461 where
462 fun2 = freeVars fun
463 arg2 = freeVars arg
464
465 freeVars (Case scrut bndr ty alts)
466 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
467 AnnCase scrut2 bndr ty alts2)
468 where
469 scrut2 = freeVars scrut
470
471 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
472 alts_fvs = foldr unionFVs noFVs alts_fvs_s
473
474 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
475 (con, args, rhs2))
476 where
477 rhs2 = freeVars rhs
478
479 freeVars (Let (NonRec binder rhs) body)
480 = (freeVarsOf rhs2
481 `unionFVs` body_fvs
482 `unionFVs` bndrRuleAndUnfoldingVars binder,
483 -- Remember any rules; cf rhs_fvs above
484 AnnLet (AnnNonRec binder rhs2) body2)
485 where
486 rhs2 = freeVars rhs
487 body2 = freeVars body
488 body_fvs = binder `delBinderFV` freeVarsOf body2
489
490 freeVars (Let (Rec binds) body)
491 = (delBindersFV binders all_fvs,
492 AnnLet (AnnRec (binders `zip` rhss2)) body2)
493 where
494 (binders, rhss) = unzip binds
495
496 rhss2 = map freeVars rhss
497 rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
498 all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders
499 -- The "delBinderFV" happens after adding the idSpecVars,
500 -- since the latter may add some of the binders as fvs
501
502 body2 = freeVars body
503 body_fvs = freeVarsOf body2
504
505 freeVars (Cast expr co)
506 = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
507 where
508 expr2 = freeVars expr
509 cfvs = tyCoVarsOfCo co
510
511 freeVars (Tick tickish expr)
512 = (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2)
513 where
514 expr2 = freeVars expr
515 tickishFVs (Breakpoint _ ids) = mkVarSet ids
516 tickishFVs _ = emptyVarSet
517
518 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
519
520 freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)