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