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