18e109a74577ec9c0f3bf8df60aba19c632e4b07
[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 bndrRuleAndUnfoldingVarsDSet,
35 idFVs,
36 idRuleVars, idRuleRhsVars, stableUnfoldingVars,
37 ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
38 rulesFreeVarsDSet,
39 ruleLhsFreeIds, ruleLhsFreeIdsList,
40
41 expr_fvs,
42
43 -- * Orphan names
44 orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
45 orphNamesOfTypes, orphNamesOfCoCon,
46 exprsOrphNames, orphNamesOfFamInst,
47
48 -- * Core syntax tree annotation with free variables
49 FVAnn, -- annotation, abstract
50 CoreExprWithFVs, -- = AnnExpr Id FVAnn
51 CoreExprWithFVs', -- = AnnExpr' Id FVAnn
52 CoreBindWithFVs, -- = AnnBind Id FVAnn
53 CoreAltWithFVs, -- = AnnAlt Id FVAnn
54 freeVars, -- CoreExpr -> CoreExprWithFVs
55 freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs)
56 freeVarsOf, -- CoreExprWithFVs -> DIdSet
57 freeVarsOfAnn
58 ) where
59
60 #include "HsVersions.h"
61
62 import GhcPrelude
63
64 import CoreSyn
65 import Id
66 import IdInfo
67 import NameSet
68 import UniqSet
69 import Unique (Uniquable (..))
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 Maybes( orElse )
80 import Util
81 import BasicTypes( Activation )
82 import Outputable
83 import FV
84
85 {-
86 ************************************************************************
87 * *
88 \section{Finding the free variables of an expression}
89 * *
90 ************************************************************************
91
92 This function simply finds the free variables of an expression.
93 So far as type variables are concerned, it only finds tyvars that are
94
95 * free in type arguments,
96 * free in the type of a binder,
97
98 but not those that are free in the type of variable occurrence.
99 -}
100
101 -- | Find all locally-defined free Ids or type variables in an expression
102 -- returning a non-deterministic set.
103 exprFreeVars :: CoreExpr -> VarSet
104 exprFreeVars = fvVarSet . exprFVs
105
106 -- | Find all locally-defined free Ids or type variables in an expression
107 -- returning a composable FV computation. See Note [FV naming conventions] in FV
108 -- for why export it.
109 exprFVs :: CoreExpr -> FV
110 exprFVs = filterFV isLocalVar . expr_fvs
111
112 -- | Find all locally-defined free Ids or type variables in an expression
113 -- returning a deterministic set.
114 exprFreeVarsDSet :: CoreExpr -> DVarSet
115 exprFreeVarsDSet = fvDVarSet . exprFVs
116
117 -- | Find all locally-defined free Ids or type variables in an expression
118 -- returning a deterministically ordered list.
119 exprFreeVarsList :: CoreExpr -> [Var]
120 exprFreeVarsList = fvVarList . exprFVs
121
122 -- | Find all locally-defined free Ids in an expression
123 exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
124 exprFreeIds = exprSomeFreeVars 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 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 obselete 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 (_, 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 :: Tickish Id -> 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 (_,_,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 (Trac #4912)
350 orphNamesOfType (TyVarTy _) = emptyNameSet
351 orphNamesOfType (LitTy {}) = emptyNameSet
352 orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
353 `unionNameSet` orphNamesOfTypes tys
354 orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
355 `unionNameSet` orphNamesOfType res
356 orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See Trac #8535
357 `unionNameSet` orphNamesOfType arg
358 `unionNameSet` orphNamesOfType res
359 orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
360 orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
361 orphNamesOfType (CoercionTy co) = orphNamesOfCo co
362
363 orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
364 orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
365
366 orphNamesOfTypes :: [Type] -> NameSet
367 orphNamesOfTypes = orphNamesOfThings orphNamesOfType
368
369 orphNamesOfMCo :: MCoercion -> NameSet
370 orphNamesOfMCo MRefl = emptyNameSet
371 orphNamesOfMCo (MCo co) = orphNamesOfCo co
372
373 orphNamesOfCo :: Coercion -> NameSet
374 orphNamesOfCo (Refl ty) = orphNamesOfType ty
375 orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco
376 orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
377 orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
378 orphNamesOfCo (ForAllCo _ kind_co co)
379 = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
380 orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
381 orphNamesOfCo (CoVarCo _) = emptyNameSet
382 orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
383 orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
384 orphNamesOfCo (SymCo co) = orphNamesOfCo co
385 orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
386 orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co
387 orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
388 orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
389 orphNamesOfCo (KindCo co) = orphNamesOfCo co
390 orphNamesOfCo (SubCo co) = orphNamesOfCo co
391 orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
392 orphNamesOfCo (HoleCo _) = emptyNameSet
393
394 orphNamesOfProv :: UnivCoProvenance -> NameSet
395 orphNamesOfProv UnsafeCoerceProv = emptyNameSet
396 orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
397 orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
398 orphNamesOfProv (PluginProv _) = emptyNameSet
399
400 orphNamesOfCos :: [Coercion] -> NameSet
401 orphNamesOfCos = orphNamesOfThings orphNamesOfCo
402
403 orphNamesOfCoCon :: CoAxiom br -> NameSet
404 orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
405 = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
406
407 orphNamesOfAxiom :: CoAxiom br -> NameSet
408 orphNamesOfAxiom axiom
409 = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
410 `extendNameSet` getName (coAxiomTyCon axiom)
411
412 orphNamesOfCoAxBranches :: Branches br -> NameSet
413 orphNamesOfCoAxBranches
414 = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches
415
416 orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
417 orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
418 = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
419
420 -- | orphNamesOfAxiom collects the names of the concrete types and
421 -- type constructors that make up the LHS of a type family instance,
422 -- including the family name itself.
423 --
424 -- For instance, given `type family Foo a b`:
425 -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]
426 --
427 -- Used in the implementation of ":info" in GHCi.
428 orphNamesOfFamInst :: FamInst -> NameSet
429 orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
430
431 {-
432 ************************************************************************
433 * *
434 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
435 * *
436 ************************************************************************
437 -}
438
439 -- | Those variables free in the right hand side of a rule returned as a
440 -- non-deterministic set
441 ruleRhsFreeVars :: CoreRule -> VarSet
442 ruleRhsFreeVars (BuiltinRule {}) = noFVs
443 ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
444 = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
445 -- See Note [Rule free var hack]
446
447 -- | Those variables free in the both the left right hand sides of a rule
448 -- returned as a non-deterministic set
449 ruleFreeVars :: CoreRule -> VarSet
450 ruleFreeVars = fvVarSet . ruleFVs
451
452 -- | Those variables free in the both the left right hand sides of a rule
453 -- returned as FV computation
454 ruleFVs :: CoreRule -> FV
455 ruleFVs (BuiltinRule {}) = emptyFV
456 ruleFVs (Rule { ru_fn = _do_not_include
457 -- See Note [Rule free var hack]
458 , ru_bndrs = bndrs
459 , ru_rhs = rhs, ru_args = args })
460 = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
461
462 -- | Those variables free in the both the left right hand sides of rules
463 -- returned as FV computation
464 rulesFVs :: [CoreRule] -> FV
465 rulesFVs = mapUnionFV ruleFVs
466
467 -- | Those variables free in the both the left right hand sides of rules
468 -- returned as a deterministic set
469 rulesFreeVarsDSet :: [CoreRule] -> DVarSet
470 rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
471
472 idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
473 -- Just the variables free on the *rhs* of a rule
474 idRuleRhsVars is_active id
475 = mapUnionVarSet get_fvs (idCoreRules id)
476 where
477 get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
478 , ru_rhs = rhs, ru_act = act })
479 | is_active act
480 -- See Note [Finding rule RHS free vars] in OccAnal.hs
481 = delOneFromUniqSet_Directly fvs (getUnique fn)
482 -- Note [Rule free var hack]
483 where
484 fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
485 get_fvs _ = noFVs
486
487 -- | Those variables free in the right hand side of several rules
488 rulesFreeVars :: [CoreRule] -> VarSet
489 rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
490
491 ruleLhsFreeIds :: CoreRule -> VarSet
492 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
493 -- and returns them as a non-deterministic set
494 ruleLhsFreeIds = fvVarSet . ruleLhsFVIds
495
496 ruleLhsFreeIdsList :: CoreRule -> [Var]
497 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
498 -- and returns them as a determinisitcally ordered list
499 ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds
500
501 ruleLhsFVIds :: CoreRule -> FV
502 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
503 -- and returns an FV computation
504 ruleLhsFVIds (BuiltinRule {}) = emptyFV
505 ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
506 = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
507
508 {-
509 Note [Rule free var hack] (Not a hack any more)
510 ~~~~~~~~~~~~~~~~~~~~~~~~~
511 We used not to include the Id in its own rhs free-var set.
512 Otherwise the occurrence analyser makes bindings recursive:
513 f x y = x+y
514 RULE: f (f x y) z ==> f x (f y z)
515 However, the occurrence analyser distinguishes "non-rule loop breakers"
516 from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will
517 put this 'f' in a Rec block, but will mark the binding as a non-rule loop
518 breaker, which is perfectly inlinable.
519 -}
520
521 {-
522 ************************************************************************
523 * *
524 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
525 * *
526 ************************************************************************
527
528 The free variable pass annotates every node in the expression with its
529 NON-GLOBAL free variables and type variables.
530 -}
531
532 type FVAnn = DVarSet -- See Note [The FVAnn invariant]
533
534 {- Note [The FVAnn invariant]
535 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
536 Invariant: a FVAnn, say S, is closed:
537 That is: if v is in S,
538 then freevars( v's type/kind ) is also in S
539 -}
540
541 -- | Every node in a binding group annotated with its
542 -- (non-global) free variables, both Ids and TyVars, and type.
543 type CoreBindWithFVs = AnnBind Id FVAnn
544
545 -- | Every node in an expression annotated with its
546 -- (non-global) free variables, both Ids and TyVars, and type.
547 -- NB: see Note [The FVAnn invariant]
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 (fvs, _) = fvs
558
559 -- | Extract the vars reported in a FVAnn
560 freeVarsOfAnn :: FVAnn -> DIdSet
561 freeVarsOfAnn fvs = fvs
562
563 noFVs :: VarSet
564 noFVs = emptyVarSet
565
566 aFreeVar :: Var -> DVarSet
567 aFreeVar = unitDVarSet
568
569 unionFVs :: DVarSet -> DVarSet -> DVarSet
570 unionFVs = unionDVarSet
571
572 unionFVss :: [DVarSet] -> DVarSet
573 unionFVss = unionDVarSets
574
575 delBindersFV :: [Var] -> DVarSet -> DVarSet
576 delBindersFV bs fvs = foldr delBinderFV fvs bs
577
578 delBinderFV :: Var -> DVarSet -> DVarSet
579 -- This way round, so we can do it multiple times using foldr
580
581 -- (b `delBinderFV` s)
582 -- * removes the binder b from the free variable set s,
583 -- * AND *adds* to s the free variables of b's type
584 --
585 -- This is really important for some lambdas:
586 -- In (\x::a -> x) the only mention of "a" is in the binder.
587 --
588 -- Also in
589 -- let x::a = b in ...
590 -- we should really note that "a" is free in this expression.
591 -- It'll be pinned inside the /\a by the binding for b, but
592 -- it seems cleaner to make sure that a is in the free-var set
593 -- when it is mentioned.
594 --
595 -- This also shows up in recursive bindings. Consider:
596 -- /\a -> letrec x::a = x in E
597 -- Now, there are no explicit free type variables in the RHS of x,
598 -- but nevertheless "a" is free in its definition. So we add in
599 -- the free tyvars of the types of the binders, and include these in the
600 -- free vars of the group, attached to the top level of each RHS.
601 --
602 -- This actually happened in the defn of errorIO in IOBase.hs:
603 -- errorIO (ST io) = case (errorIO# io) of
604 -- _ -> bottom
605 -- where
606 -- bottom = bottom -- Never evaluated
607
608 delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b
609 -- Include coercion variables too!
610
611 varTypeTyCoVars :: Var -> TyCoVarSet
612 -- Find the type/kind variables free in the type of the id/tyvar
613 varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var
614
615 dVarTypeTyCoVars :: Var -> DTyCoVarSet
616 -- Find the type/kind/coercion variables free in the type of the id/tyvar
617 dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var
618
619 varTypeTyCoFVs :: Var -> FV
620 varTypeTyCoFVs var = tyCoFVsOfType (varType var)
621
622 idFreeVars :: Id -> VarSet
623 idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id
624
625 dIdFreeVars :: Id -> DVarSet
626 dIdFreeVars id = fvDVarSet $ idFVs id
627
628 idFVs :: Id -> FV
629 -- Type variables, rule variables, and inline variables
630 idFVs id = ASSERT( isId id)
631 varTypeTyCoFVs id `unionFV`
632 bndrRuleAndUnfoldingFVs id
633
634 bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet
635 bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id
636
637 bndrRuleAndUnfoldingFVs :: Id -> FV
638 bndrRuleAndUnfoldingFVs id
639 | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id
640 | otherwise = emptyFV
641
642 idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
643 idRuleVars id = fvVarSet $ idRuleFVs id
644
645 idRuleFVs :: Id -> FV
646 idRuleFVs id = ASSERT( isId id)
647 FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
648
649 idUnfoldingVars :: Id -> VarSet
650 -- Produce free vars for an unfolding, but NOT for an ordinary
651 -- (non-inline) unfolding, since it is a dup of the rhs
652 -- and we'll get exponential behaviour if we look at both unf and rhs!
653 -- But do look at the *real* unfolding, even for loop breakers, else
654 -- we might get out-of-scope variables
655 idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id
656
657 idUnfoldingFVs :: Id -> FV
658 idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV
659
660 stableUnfoldingVars :: Unfolding -> Maybe VarSet
661 stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf
662
663 stableUnfoldingFVs :: Unfolding -> Maybe FV
664 stableUnfoldingFVs unf
665 = case unf of
666 CoreUnfolding { uf_tmpl = rhs, uf_src = src }
667 | isStableSource src
668 -> Just (filterFV isLocalVar $ expr_fvs rhs)
669 DFunUnfolding { df_bndrs = bndrs, df_args = args }
670 -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)
671 -- DFuns are top level, so no fvs from types of bndrs
672 _other -> Nothing
673
674
675 {-
676 ************************************************************************
677 * *
678 \subsection{Free variables (and types)}
679 * *
680 ************************************************************************
681 -}
682
683 freeVarsBind :: CoreBind
684 -> DVarSet -- Free vars of scope of binding
685 -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope
686 freeVarsBind (NonRec binder rhs) body_fvs
687 = ( AnnNonRec binder rhs2
688 , freeVarsOf rhs2 `unionFVs` body_fvs2
689 `unionFVs` bndrRuleAndUnfoldingVarsDSet binder )
690 where
691 rhs2 = freeVars rhs
692 body_fvs2 = binder `delBinderFV` body_fvs
693
694 freeVarsBind (Rec binds) body_fvs
695 = ( AnnRec (binders `zip` rhss2)
696 , delBindersFV binders all_fvs )
697 where
698 (binders, rhss) = unzip binds
699 rhss2 = map freeVars rhss
700 rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
701 binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders
702 -- See Note [The FVAnn invariant]
703 all_fvs = rhs_body_fvs `unionFVs` binders_fvs
704 -- The "delBinderFV" happens after adding the idSpecVars,
705 -- since the latter may add some of the binders as fvs
706
707 freeVars :: CoreExpr -> CoreExprWithFVs
708 -- ^ Annotate a 'CoreExpr' with its (non-global) free type
709 -- and value variables at every tree node.
710 freeVars = go
711 where
712 go :: CoreExpr -> CoreExprWithFVs
713 go (Var v)
714 | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v)
715 | otherwise = (emptyDVarSet, AnnVar v)
716 where
717 ty_fvs = dVarTypeTyCoVars v
718 -- See Note [The FVAnn invariant]
719
720 go (Lit lit) = (emptyDVarSet, AnnLit lit)
721 go (Lam b body)
722 = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs)
723 , AnnLam b body' )
724 where
725 body'@(body_fvs, _) = go body
726 b_ty = idType b
727 b_fvs = tyCoVarsOfTypeDSet b_ty
728 -- See Note [The FVAnn invariant]
729
730 go (App fun arg)
731 = ( freeVarsOf fun' `unionFVs` freeVarsOf arg'
732 , AnnApp fun' arg' )
733 where
734 fun' = go fun
735 arg' = go arg
736
737 go (Case scrut bndr ty alts)
738 = ( (bndr `delBinderFV` alts_fvs)
739 `unionFVs` freeVarsOf scrut2
740 `unionFVs` tyCoVarsOfTypeDSet ty
741 -- Don't need to look at (idType bndr)
742 -- because that's redundant with scrut
743 , AnnCase scrut2 bndr ty alts2 )
744 where
745 scrut2 = go scrut
746
747 (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
748 alts_fvs = unionFVss alts_fvs_s
749
750 fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
751 (con, args, rhs2))
752 where
753 rhs2 = go rhs
754
755 go (Let bind body)
756 = (bind_fvs, AnnLet bind2 body2)
757 where
758 (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2)
759 body2 = go body
760
761 go (Cast expr co)
762 = ( freeVarsOf expr2 `unionFVs` cfvs
763 , AnnCast expr2 (cfvs, co) )
764 where
765 expr2 = go expr
766 cfvs = tyCoVarsOfCoDSet co
767
768 go (Tick tickish expr)
769 = ( tickishFVs tickish `unionFVs` freeVarsOf expr2
770 , AnnTick tickish expr2 )
771 where
772 expr2 = go expr
773 tickishFVs (Breakpoint _ ids) = mkDVarSet ids
774 tickishFVs _ = emptyDVarSet
775
776 go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty)
777 go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)