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