Re-add FunTy (big patch)
[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,
14 exprFreeVarsDSet,
15 exprFreeVarsList,
16 exprFreeIds,
17 exprFreeIdsDSet,
18 exprFreeIdsList,
19 exprsFreeIdsDSet,
20 exprsFreeIdsList,
21 exprsFreeVars,
22 exprsFreeVarsList,
23 bindFreeVars,
24
25 -- * Selective free variables of expressions
26 InterestingVarFun,
27 exprSomeFreeVars, exprsSomeFreeVars,
28 exprSomeFreeVarsList, exprsSomeFreeVarsList,
29
30 -- * Free variables of Rules, Vars and Ids
31 varTypeTyCoVars,
32 varTypeTyCoFVs,
33 idUnfoldingVars, idFreeVars, dIdFreeVars,
34 idRuleAndUnfoldingVars, idRuleAndUnfoldingVarsDSet,
35 idFVs,
36 idRuleVars, idRuleRhsVars, stableUnfoldingVars,
37 ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
38 rulesFreeVarsDSet,
39 ruleLhsFreeIds, ruleLhsFreeIdsList,
40 vectsFreeVars,
41
42 expr_fvs,
43
44 -- * Orphan names
45 orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
46 orphNamesOfTypes, orphNamesOfCoCon,
47 exprsOrphNames, orphNamesOfFamInst,
48
49 -- * Core syntax tree annotation with free variables
50 FVAnn, -- annotation, abstract
51 CoreExprWithFVs, -- = AnnExpr Id FVAnn
52 CoreExprWithFVs', -- = AnnExpr' Id FVAnn
53 CoreBindWithFVs, -- = AnnBind Id FVAnn
54 CoreAltWithFVs, -- = AnnAlt Id FVAnn
55 freeVars, -- CoreExpr -> CoreExprWithFVs
56 freeVarsOf, -- CoreExprWithFVs -> DIdSet
57 freeVarsOfType, -- CoreExprWithFVs -> TyCoVarSet
58 freeVarsOfAnn, freeVarsOfTypeAnn,
59 exprTypeFV -- CoreExprWithFVs -> Type
60 ) where
61
62 #include "HsVersions.h"
63
64 import CoreSyn
65 import Id
66 import IdInfo
67 import NameSet
68 import UniqFM
69 import Literal ( literalType )
70 import Name
71 import VarSet
72 import Var
73 import Type
74 import TyCoRep
75 import TyCon
76 import CoAxiom
77 import FamInstEnv
78 import TysPrim( funTyConName )
79 import Coercion
80 import Maybes( orElse )
81 import Util
82 import BasicTypes( Activation )
83 import Outputable
84 import FV
85
86 {-
87 ************************************************************************
88 * *
89 \section{Finding the free variables of an expression}
90 * *
91 ************************************************************************
92
93 This function simply finds the free variables of an expression.
94 So far as type variables are concerned, it only finds tyvars that are
95
96 * free in type arguments,
97 * free in the type of a binder,
98
99 but not those that are free in the type of variable occurrence.
100 -}
101
102 -- | Find all locally-defined free Ids or type variables in an expression
103 -- returning a non-deterministic set.
104 exprFreeVars :: CoreExpr -> VarSet
105 exprFreeVars = fvVarSet . exprFVs
106
107 -- | Find all locally-defined free Ids or type variables in an expression
108 -- returning a composable FV computation. See Note [FV naming coventions] in FV
109 -- for why export it.
110 exprFVs :: CoreExpr -> FV
111 exprFVs = filterFV isLocalVar . expr_fvs
112
113 -- | Find all locally-defined free Ids or type variables in an expression
114 -- returning a deterministic set.
115 exprFreeVarsDSet :: CoreExpr -> DVarSet
116 exprFreeVarsDSet = fvDVarSet . exprFVs
117
118 -- | Find all locally-defined free Ids or type variables in an expression
119 -- returning a deterministically ordered list.
120 exprFreeVarsList :: CoreExpr -> [Var]
121 exprFreeVarsList = fvVarList . exprFVs
122
123 -- | Find all locally-defined free Ids in an expression
124 exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
125 exprFreeIds = exprSomeFreeVars isLocalId
126
127 -- | Find all locally-defined free Ids in an expression
128 -- returning a deterministic set.
129 exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids
130 exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId
131
132 -- | Find all locally-defined free Ids in an expression
133 -- returning a deterministically ordered list.
134 exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids
135 exprFreeIdsList = exprSomeFreeVarsList isLocalId
136
137 -- | Find all locally-defined free Ids in several expressions
138 -- returning a deterministic set.
139 exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids
140 exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId
141
142 -- | Find all locally-defined free Ids in several expressions
143 -- returning a deterministically ordered list.
144 exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids
145 exprsFreeIdsList = exprsSomeFreeVarsList isLocalId
146
147 -- | Find all locally-defined free Ids or type variables in several expressions
148 -- returning a non-deterministic set.
149 exprsFreeVars :: [CoreExpr] -> VarSet
150 exprsFreeVars = fvVarSet . exprsFVs
151
152 -- | Find all locally-defined free Ids or type variables in several expressions
153 -- returning a composable FV computation. See Note [FV naming coventions] in FV
154 -- for why export it.
155 exprsFVs :: [CoreExpr] -> FV
156 exprsFVs exprs = mapUnionFV exprFVs exprs
157
158 -- | Find all locally-defined free Ids or type variables in several expressions
159 -- returning a deterministically ordered list.
160 exprsFreeVarsList :: [CoreExpr] -> [Var]
161 exprsFreeVarsList = fvVarList . exprsFVs
162
163 -- | Find all locally defined free Ids in a binding group
164 bindFreeVars :: CoreBind -> VarSet
165 bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r)
166 bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $
167 addBndrs (map fst prs)
168 (mapUnionFV rhs_fvs prs)
169
170 -- | Finds free variables in an expression selected by a predicate
171 exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting
172 -> CoreExpr
173 -> VarSet
174 exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e
175
176 -- | Finds free variables in an expression selected by a predicate
177 -- returning a deterministically ordered list.
178 exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting
179 -> CoreExpr
180 -> [Var]
181 exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e
182
183 -- | Finds free variables in an expression selected by a predicate
184 -- returning a deterministic set.
185 exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting
186 -> CoreExpr
187 -> DVarSet
188 exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e
189
190 -- | Finds free variables in several expressions selected by a predicate
191 exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
192 -> [CoreExpr]
193 -> VarSet
194 exprsSomeFreeVars fv_cand es =
195 fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es
196
197 -- | Finds free variables in several expressions selected by a predicate
198 -- returning a deterministically ordered list.
199 exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting
200 -> [CoreExpr]
201 -> [Var]
202 exprsSomeFreeVarsList fv_cand es =
203 fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es
204
205 -- | Finds free variables in several expressions selected by a predicate
206 -- returning a deterministic set.
207 exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting
208 -> [CoreExpr]
209 -> DVarSet
210 exprsSomeFreeVarsDSet fv_cand e =
211 fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e
212
213 -- Comment about obselete code
214 -- We used to gather the free variables the RULES at a variable occurrence
215 -- with the following cryptic comment:
216 -- "At a variable occurrence, add in any free variables of its rule rhss
217 -- Curiously, we gather the Id's free *type* variables from its binding
218 -- site, but its free *rule-rhs* variables from its usage sites. This
219 -- is a little weird. The reason is that the former is more efficient,
220 -- but the latter is more fine grained, and a makes a difference when
221 -- a variable mentions itself one of its own rule RHSs"
222 -- Not only is this "weird", but it's also pretty bad because it can make
223 -- a function seem more recursive than it is. Suppose
224 -- f = ...g...
225 -- g = ...
226 -- RULE g x = ...f...
227 -- Then f is not mentioned in its own RHS, and needn't be a loop breaker
228 -- (though g may be). But if we collect the rule fvs from g's occurrence,
229 -- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB
230 -- code in GHC.Enum.)
231 --
232 -- Anyway, it seems plain wrong. The RULE is like an extra RHS for the
233 -- function, so its free variables belong at the definition site.
234 --
235 -- Deleted code looked like
236 -- foldVarSet add_rule_var var_itself_set (idRuleVars var)
237 -- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
238 -- | otherwise = set
239 -- SLPJ Feb06
240
241 addBndr :: CoreBndr -> FV -> FV
242 addBndr bndr fv fv_cand in_scope acc
243 = (varTypeTyCoFVs bndr `unionFV`
244 -- Include type variables in the binder's type
245 -- (not just Ids; coercion variables too!)
246 FV.delFV bndr fv) fv_cand in_scope acc
247
248 addBndrs :: [CoreBndr] -> FV -> FV
249 addBndrs bndrs fv = foldr addBndr fv bndrs
250
251 expr_fvs :: CoreExpr -> FV
252 expr_fvs (Type ty) fv_cand in_scope acc =
253 tyCoFVsOfType ty fv_cand in_scope acc
254 expr_fvs (Coercion co) fv_cand in_scope acc =
255 tyCoFVsOfCo co fv_cand in_scope acc
256 expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc
257 expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc
258 expr_fvs (Tick t expr) fv_cand in_scope acc =
259 (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc
260 expr_fvs (App fun arg) fv_cand in_scope acc =
261 (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc
262 expr_fvs (Lam bndr body) fv_cand in_scope acc =
263 addBndr bndr (expr_fvs body) fv_cand in_scope acc
264 expr_fvs (Cast expr co) fv_cand in_scope acc =
265 (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc
266
267 expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc
268 = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr
269 (mapUnionFV alt_fvs alts)) fv_cand in_scope acc
270 where
271 alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
272
273 expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc
274 = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))
275 fv_cand in_scope acc
276
277 expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc
278 = addBndrs (map fst pairs)
279 (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body)
280 fv_cand in_scope acc
281
282 ---------
283 rhs_fvs :: (Id, CoreExpr) -> FV
284 rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`
285 bndrRuleAndUnfoldingFVs bndr
286 -- Treat any RULES as extra RHSs of the binding
287
288 ---------
289 exprs_fvs :: [CoreExpr] -> FV
290 exprs_fvs exprs = mapUnionFV expr_fvs exprs
291
292 tickish_fvs :: Tickish Id -> FV
293 tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids
294 tickish_fvs _ = emptyFV
295
296 {-
297 ************************************************************************
298 * *
299 \section{Free names}
300 * *
301 ************************************************************************
302 -}
303
304 -- | Finds the free /external/ names of an expression, notably
305 -- including the names of type constructors (which of course do not show
306 -- up in 'exprFreeVars').
307 exprOrphNames :: CoreExpr -> NameSet
308 -- There's no need to delete local binders, because they will all
309 -- be /internal/ names.
310 exprOrphNames e
311 = go e
312 where
313 go (Var v)
314 | isExternalName n = unitNameSet n
315 | otherwise = emptyNameSet
316 where n = idName v
317 go (Lit _) = emptyNameSet
318 go (Type ty) = orphNamesOfType ty -- Don't need free tyvars
319 go (Coercion co) = orphNamesOfCo co
320 go (App e1 e2) = go e1 `unionNameSet` go e2
321 go (Lam v e) = go e `delFromNameSet` idName v
322 go (Tick _ e) = go e
323 go (Cast e co) = go e `unionNameSet` orphNamesOfCo co
324 go (Let (NonRec _ r) e) = go e `unionNameSet` go r
325 go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e
326 go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty
327 `unionNameSet` unionNameSets (map go_alt as)
328
329 go_alt (_,_,r) = go r
330
331 -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
332 exprsOrphNames :: [CoreExpr] -> NameSet
333 exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
334
335
336 {- **********************************************************************
337 %* *
338 orphNamesXXX
339
340 %* *
341 %********************************************************************* -}
342
343 orphNamesOfTyCon :: TyCon -> NameSet
344 orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of
345 Nothing -> emptyNameSet
346 Just cls -> unitNameSet (getName cls)
347
348 orphNamesOfType :: Type -> NameSet
349 orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'
350 -- Look through type synonyms (Trac #4912)
351 orphNamesOfType (TyVarTy _) = emptyNameSet
352 orphNamesOfType (LitTy {}) = emptyNameSet
353 orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
354 `unionNameSet` orphNamesOfTypes tys
355 orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
356 `unionNameSet` orphNamesOfType res
357 orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535
358 `unionNameSet` orphNamesOfType arg
359 `unionNameSet` orphNamesOfType res
360 orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
361 orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
362 orphNamesOfType (CoercionTy co) = orphNamesOfCo co
363
364 orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
365 orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
366
367 orphNamesOfTypes :: [Type] -> NameSet
368 orphNamesOfTypes = orphNamesOfThings orphNamesOfType
369
370 orphNamesOfCo :: Coercion -> NameSet
371 orphNamesOfCo (Refl _ ty) = orphNamesOfType ty
372 orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
373 orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
374 orphNamesOfCo (ForAllCo _ kind_co co)
375 = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
376 orphNamesOfCo (CoVarCo _) = emptyNameSet
377 orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
378 orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
379 orphNamesOfCo (SymCo co) = orphNamesOfCo co
380 orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
381 orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
382 orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
383 orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
384 orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
385 orphNamesOfCo (KindCo co) = orphNamesOfCo co
386 orphNamesOfCo (SubCo co) = orphNamesOfCo co
387 orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
388
389 orphNamesOfProv :: UnivCoProvenance -> NameSet
390 orphNamesOfProv UnsafeCoerceProv = emptyNameSet
391 orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
392 orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
393 orphNamesOfProv (PluginProv _) = emptyNameSet
394 orphNamesOfProv (HoleProv _) = emptyNameSet
395
396 orphNamesOfCos :: [Coercion] -> NameSet
397 orphNamesOfCos = orphNamesOfThings orphNamesOfCo
398
399 orphNamesOfCoCon :: CoAxiom br -> NameSet
400 orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
401 = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
402
403 orphNamesOfAxiom :: CoAxiom br -> NameSet
404 orphNamesOfAxiom axiom
405 = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
406 `extendNameSet` getName (coAxiomTyCon axiom)
407
408 orphNamesOfCoAxBranches :: Branches br -> NameSet
409 orphNamesOfCoAxBranches
410 = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches
411
412 orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
413 orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
414 = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
415
416 -- | orphNamesOfAxiom collects the names of the concrete types and
417 -- type constructors that make up the LHS of a type family instance,
418 -- including the family name itself.
419 --
420 -- For instance, given `type family Foo a b`:
421 -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]
422 --
423 -- Used in the implementation of ":info" in GHCi.
424 orphNamesOfFamInst :: FamInst -> NameSet
425 orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
426
427 {-
428 ************************************************************************
429 * *
430 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
431 * *
432 ************************************************************************
433 -}
434
435 -- | Those variables free in the right hand side of a rule returned as a
436 -- non-deterministic set
437 ruleRhsFreeVars :: CoreRule -> VarSet
438 ruleRhsFreeVars (BuiltinRule {}) = noFVs
439 ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
440 = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
441 -- See Note [Rule free var hack]
442
443 -- | Those variables free in the both the left right hand sides of a rule
444 -- returned as a non-deterministic set
445 ruleFreeVars :: CoreRule -> VarSet
446 ruleFreeVars = fvVarSet . ruleFVs
447
448 -- | Those variables free in the both the left right hand sides of a rule
449 -- returned as FV computation
450 ruleFVs :: CoreRule -> FV
451 ruleFVs (BuiltinRule {}) = emptyFV
452 ruleFVs (Rule { ru_fn = _do_not_include
453 -- See Note [Rule free var hack]
454 , ru_bndrs = bndrs
455 , ru_rhs = rhs, ru_args = args })
456 = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
457
458 -- | Those variables free in the both the left right hand sides of rules
459 -- returned as FV computation
460 rulesFVs :: [CoreRule] -> FV
461 rulesFVs = mapUnionFV ruleFVs
462
463 -- | Those variables free in the both the left right hand sides of rules
464 -- returned as a deterministic set
465 rulesFreeVarsDSet :: [CoreRule] -> DVarSet
466 rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
467
468 idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
469 -- Just the variables free on the *rhs* of a rule
470 idRuleRhsVars is_active id
471 = mapUnionVarSet get_fvs (idCoreRules id)
472 where
473 get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
474 , ru_rhs = rhs, ru_act = act })
475 | is_active act
476 -- See Note [Finding rule RHS free vars] in OccAnal.hs
477 = delFromUFM fvs fn -- Note [Rule free var hack]
478 where
479 fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
480 get_fvs _ = noFVs
481
482 -- | Those variables free in the right hand side of several rules
483 rulesFreeVars :: [CoreRule] -> VarSet
484 rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
485
486 ruleLhsFreeIds :: CoreRule -> VarSet
487 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
488 -- and returns them as a non-deterministic set
489 ruleLhsFreeIds = fvVarSet . ruleLhsFVIds
490
491 ruleLhsFreeIdsList :: CoreRule -> [Var]
492 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
493 -- and returns them as a determinisitcally ordered list
494 ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds
495
496 ruleLhsFVIds :: CoreRule -> FV
497 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
498 -- and returns an FV computation
499 ruleLhsFVIds (BuiltinRule {}) = emptyFV
500 ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
501 = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
502
503 {-
504 Note [Rule free var hack] (Not a hack any more)
505 ~~~~~~~~~~~~~~~~~~~~~~~~~
506 We used not to include the Id in its own rhs free-var set.
507 Otherwise the occurrence analyser makes bindings recursive:
508 f x y = x+y
509 RULE: f (f x y) z ==> f x (f y z)
510 However, the occurrence analyser distinguishes "non-rule loop breakers"
511 from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will
512 put this 'f' in a Rec block, but will mark the binding as a non-rule loop
513 breaker, which is perfectly inlinable.
514 -}
515
516 -- |Free variables of a vectorisation declaration
517 vectsFreeVars :: [CoreVect] -> VarSet
518 vectsFreeVars = mapUnionVarSet vectFreeVars
519 where
520 vectFreeVars (Vect _ rhs) = fvVarSet $ filterFV isLocalId $ expr_fvs rhs
521 vectFreeVars (NoVect _) = noFVs
522 vectFreeVars (VectType _ _ _) = noFVs
523 vectFreeVars (VectClass _) = noFVs
524 vectFreeVars (VectInst _) = noFVs
525 -- this function is only concerned with values, not types
526
527 {-
528 ************************************************************************
529 * *
530 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
531 * *
532 ************************************************************************
533
534 The free variable pass annotates every node in the expression with its
535 NON-GLOBAL free variables and type variables.
536 -}
537
538 data FVAnn = FVAnn { fva_fvs :: DVarSet -- free in expression
539 , fva_ty_fvs :: DVarSet -- free only in expression's type
540 , fva_ty :: Type -- expression's type
541 }
542
543 -- | Every node in a binding group annotated with its
544 -- (non-global) free variables, both Ids and TyVars, and type.
545 type CoreBindWithFVs = AnnBind Id FVAnn
546 -- | Every node in an expression annotated with its
547 -- (non-global) free variables, both Ids and TyVars, and type.
548 type CoreExprWithFVs = AnnExpr Id FVAnn
549 type CoreExprWithFVs' = AnnExpr' Id FVAnn
550
551 -- | Every node in an expression annotated with its
552 -- (non-global) free variables, both Ids and TyVars, and type.
553 type CoreAltWithFVs = AnnAlt Id FVAnn
554
555 freeVarsOf :: CoreExprWithFVs -> DIdSet
556 -- ^ Inverse function to 'freeVars'
557 freeVarsOf (FVAnn { fva_fvs = fvs }, _) = fvs
558
559 -- | Extract the vars free in an annotated expression's type
560 freeVarsOfType :: CoreExprWithFVs -> DTyCoVarSet
561 freeVarsOfType (FVAnn { fva_ty_fvs = ty_fvs }, _) = ty_fvs
562
563 -- | Extract the type of an annotated expression. (This is cheap.)
564 exprTypeFV :: CoreExprWithFVs -> Type
565 exprTypeFV (FVAnn { fva_ty = ty }, _) = ty
566
567 -- | Extract the vars reported in a FVAnn
568 freeVarsOfAnn :: FVAnn -> DIdSet
569 freeVarsOfAnn = fva_fvs
570
571 -- | Extract the type-level vars reported in a FVAnn
572 freeVarsOfTypeAnn :: FVAnn -> DTyCoVarSet
573 freeVarsOfTypeAnn = fva_ty_fvs
574
575 noFVs :: VarSet
576 noFVs = emptyVarSet
577
578 aFreeVar :: Var -> DVarSet
579 aFreeVar = unitDVarSet
580
581 unionFVs :: DVarSet -> DVarSet -> DVarSet
582 unionFVs = unionDVarSet
583
584 unionFVss :: [DVarSet] -> DVarSet
585 unionFVss = unionDVarSets
586
587 delBindersFV :: [Var] -> DVarSet -> DVarSet
588 delBindersFV bs fvs = foldr delBinderFV fvs bs
589
590 delBinderFV :: Var -> DVarSet -> DVarSet
591 -- This way round, so we can do it multiple times using foldr
592
593 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
594 -- but *adds* to s
595 --
596 -- the free variables of b's type
597 --
598 -- This is really important for some lambdas:
599 -- In (\x::a -> x) the only mention of "a" is in the binder.
600 --
601 -- Also in
602 -- let x::a = b in ...
603 -- we should really note that "a" is free in this expression.
604 -- It'll be pinned inside the /\a by the binding for b, but
605 -- it seems cleaner to make sure that a is in the free-var set
606 -- when it is mentioned.
607 --
608 -- This also shows up in recursive bindings. Consider:
609 -- /\a -> letrec x::a = x in E
610 -- Now, there are no explicit free type variables in the RHS of x,
611 -- but nevertheless "a" is free in its definition. So we add in
612 -- the free tyvars of the types of the binders, and include these in the
613 -- free vars of the group, attached to the top level of each RHS.
614 --
615 -- This actually happened in the defn of errorIO in IOBase.hs:
616 -- errorIO (ST io) = case (errorIO# io) of
617 -- _ -> bottom
618 -- where
619 -- bottom = bottom -- Never evaluated
620
621 delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b
622 -- Include coercion variables too!
623
624 varTypeTyCoVars :: Var -> TyCoVarSet
625 -- Find the type/kind variables free in the type of the id/tyvar
626 varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var
627
628 dVarTypeTyCoVars :: Var -> DTyCoVarSet
629 -- Find the type/kind/coercion variables free in the type of the id/tyvar
630 dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var
631
632 varTypeTyCoFVs :: Var -> FV
633 varTypeTyCoFVs var = tyCoFVsOfType (varType var)
634
635 idFreeVars :: Id -> VarSet
636 idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id
637
638 dIdFreeVars :: Id -> DVarSet
639 dIdFreeVars id = fvDVarSet $ idFVs id
640
641 idFVs :: Id -> FV
642 -- Type variables, rule variables, and inline variables
643 idFVs id = ASSERT( isId id)
644 varTypeTyCoFVs id `unionFV`
645 idRuleAndUnfoldingFVs id
646
647 bndrRuleAndUnfoldingFVs :: Var -> FV
648 bndrRuleAndUnfoldingFVs v | isTyVar v = emptyFV
649 | otherwise = idRuleAndUnfoldingFVs v
650
651 idRuleAndUnfoldingVars :: Id -> VarSet
652 idRuleAndUnfoldingVars id = fvVarSet $ idRuleAndUnfoldingFVs id
653
654 idRuleAndUnfoldingVarsDSet :: Id -> DVarSet
655 idRuleAndUnfoldingVarsDSet id = fvDVarSet $ idRuleAndUnfoldingFVs id
656
657 idRuleAndUnfoldingFVs :: Id -> FV
658 idRuleAndUnfoldingFVs id = ASSERT( isId id)
659 idRuleFVs id `unionFV` idUnfoldingFVs id
660
661
662 idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
663 idRuleVars id = fvVarSet $ idRuleFVs id
664
665 idRuleFVs :: Id -> FV
666 idRuleFVs id = ASSERT( isId id)
667 FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
668
669 idUnfoldingVars :: Id -> VarSet
670 -- Produce free vars for an unfolding, but NOT for an ordinary
671 -- (non-inline) unfolding, since it is a dup of the rhs
672 -- and we'll get exponential behaviour if we look at both unf and rhs!
673 -- But do look at the *real* unfolding, even for loop breakers, else
674 -- we might get out-of-scope variables
675 idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id
676
677 idUnfoldingFVs :: Id -> FV
678 idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV
679
680 stableUnfoldingVars :: Unfolding -> Maybe VarSet
681 stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf
682
683 stableUnfoldingFVs :: Unfolding -> Maybe FV
684 stableUnfoldingFVs unf
685 = case unf of
686 CoreUnfolding { uf_tmpl = rhs, uf_src = src }
687 | isStableSource src
688 -> Just (filterFV isLocalVar $ expr_fvs rhs)
689 DFunUnfolding { df_bndrs = bndrs, df_args = args }
690 -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)
691 -- DFuns are top level, so no fvs from types of bndrs
692 _other -> Nothing
693
694
695 {-
696 ************************************************************************
697 * *
698 \subsection{Free variables (and types)}
699 * *
700 ************************************************************************
701 -}
702
703 freeVars :: CoreExpr -> CoreExprWithFVs
704 -- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
705 freeVars = go
706 where
707 go :: CoreExpr -> CoreExprWithFVs
708 go (Var v)
709 = (FVAnn fvs ty_fvs (idType v), AnnVar v)
710 where
711 -- ToDo: insert motivating example for why we *need*
712 -- to include the idSpecVars in the FV list.
713 -- Actually [June 98] I don't think it's necessary
714 -- fvs = fvs_v `unionVarSet` idSpecVars v
715
716 (fvs, ty_fvs)
717 | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, dVarTypeTyCoVars v)
718 | otherwise = (emptyDVarSet, emptyDVarSet)
719
720 go (Lit lit) = (FVAnn emptyDVarSet emptyDVarSet (literalType lit), AnnLit lit)
721 go (Lam b body)
722 = ( FVAnn { fva_fvs = b_fvs `unionFVs` (b `delBinderFV` body_fvs)
723 , fva_ty_fvs = b_fvs `unionFVs` (b `delBinderFV` body_ty_fvs)
724 , fva_ty = mkFunTy b_ty body_ty }
725 , AnnLam b body' )
726 where
727 body'@(FVAnn { fva_fvs = body_fvs, fva_ty_fvs = body_ty_fvs
728 , fva_ty = body_ty }, _) = go body
729 b_ty = idType b
730 b_fvs = tyCoVarsOfTypeDSet b_ty
731
732 go (App fun arg)
733 = ( FVAnn { fva_fvs = freeVarsOf fun' `unionFVs` freeVarsOf arg'
734 , fva_ty_fvs = tyCoVarsOfTypeDSet res_ty
735 , fva_ty = res_ty }
736 , AnnApp fun' arg' )
737 where
738 fun' = go fun
739 fun_ty = exprTypeFV fun'
740 arg' = go arg
741 res_ty = applyTypeToArg fun_ty arg
742
743 go (Case scrut bndr ty alts)
744 = ( FVAnn { fva_fvs = (bndr `delBinderFV` alts_fvs)
745 `unionFVs` freeVarsOf scrut2
746 `unionFVs` tyCoVarsOfTypeDSet ty
747 -- don't need to look at (idType bndr)
748 -- b/c that's redundant with scrut
749 , fva_ty_fvs = tyCoVarsOfTypeDSet ty
750 , fva_ty = ty }
751 , AnnCase scrut2 bndr ty alts2 )
752 where
753 scrut2 = go scrut
754
755 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
756 alts_fvs = unionFVss alts_fvs_s
757
758 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
759 (con, args, rhs2))
760 where
761 rhs2 = go rhs
762
763 go (Let (NonRec binder rhs) body)
764 = ( FVAnn { fva_fvs = freeVarsOf rhs2
765 `unionFVs` body_fvs
766 `unionFVs` fvDVarSet
767 (bndrRuleAndUnfoldingFVs binder)
768 -- Remember any rules; cf rhs_fvs above
769 , fva_ty_fvs = freeVarsOfType body2
770 , fva_ty = exprTypeFV body2 }
771 , AnnLet (AnnNonRec binder rhs2) body2 )
772 where
773 rhs2 = go rhs
774 body2 = go body
775 body_fvs = binder `delBinderFV` freeVarsOf body2
776
777 go (Let (Rec binds) body)
778 = ( FVAnn { fva_fvs = delBindersFV binders all_fvs
779 , fva_ty_fvs = freeVarsOfType body2
780 , fva_ty = exprTypeFV body2 }
781 , AnnLet (AnnRec (binders `zip` rhss2)) body2 )
782 where
783 (binders, rhss) = unzip binds
784
785 rhss2 = map go rhss
786 rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
787 binders_fvs = fvDVarSet $ mapUnionFV idRuleAndUnfoldingFVs binders
788 all_fvs = rhs_body_fvs `unionFVs` binders_fvs
789 -- The "delBinderFV" happens after adding the idSpecVars,
790 -- since the latter may add some of the binders as fvs
791
792 body2 = go body
793 body_fvs = freeVarsOf body2
794
795 go (Cast expr co)
796 = ( FVAnn (freeVarsOf expr2 `unionFVs` cfvs) (tyCoVarsOfTypeDSet to_ty) to_ty
797 , AnnCast expr2 (c_ann, co) )
798 where
799 expr2 = go expr
800 cfvs = tyCoVarsOfCoDSet co
801 c_ann = FVAnn cfvs (tyCoVarsOfTypeDSet co_ki) co_ki
802 co_ki = coercionType co
803 Just (_, to_ty) = splitCoercionType_maybe co_ki
804
805
806 go (Tick tickish expr)
807 = ( FVAnn { fva_fvs = tickishFVs tickish `unionFVs` freeVarsOf expr2
808 , fva_ty_fvs = freeVarsOfType expr2
809 , fva_ty = exprTypeFV expr2 }
810 , AnnTick tickish expr2 )
811 where
812 expr2 = go expr
813 tickishFVs (Breakpoint _ ids) = mkDVarSet ids
814 tickishFVs _ = emptyDVarSet
815
816 go (Type ty) = ( FVAnn (tyCoVarsOfTypeDSet ty)
817 (tyCoVarsOfTypeDSet ki)
818 ki
819 , AnnType ty)
820 where
821 ki = typeKind ty
822
823 go (Coercion co) = ( FVAnn (tyCoVarsOfCoDSet co)
824 (tyCoVarsOfTypeDSet ki)
825 ki
826 , AnnCoercion co)
827 where
828 ki = coercionType co