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