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