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