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