1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
module CoreFVs (
exprFreeVars, exprsFreeVars,
exprSomeFreeVars, exprsSomeFreeVars,
idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars,
CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
) where
#include "HsVersions.h"
import CoreSyn
import Id ( Id, idFreeTyVars, getIdSpecialisation )
import VarSet
import Var ( IdOrTyVar, isId )
import Name ( isLocallyDefined )
import Type ( tyVarsOfType, Type )
import Util ( mapAndUnzip )
\end{code}
%************************************************************************
%* *
\section{Finding the free variables of an expression}
%* *
%************************************************************************
This function simply finds the free variables of an expression.
So far as type variables are concerned, it only finds tyvars that are
* free in type arguments,
* free in the type of a binder,
but not those that are free in the type of variable occurrence.
\begin{code}
exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars
exprFreeVars = exprSomeFreeVars isLocallyDefined
exprsFreeVars :: [CoreExpr] -> IdOrTyVarSet
exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
-> CoreExpr
-> IdOrTyVarSet
exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
-> [CoreExpr]
-> IdOrTyVarSet
exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
\end{code}
\begin{code}
type FV = InterestingVarFun
-> IdOrTyVarSet -- In scope
-> IdOrTyVarSet -- Free vars
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
noVars :: FV
noVars fv_cand in_scope = emptyVarSet
-- At a variable occurrence, add in any free variables of its rule rhss
-- Curiously, we gather the Id's free *type* variables from its binding
-- site, but its free *rule-rhs* variables from its usage sites. This
-- is a little weird. The reason is that the former is more efficient,
-- but the latter is more fine grained, and a makes a difference when
-- a variable mentions itself one of its own rule RHSs
oneVar :: IdOrTyVar -> FV
oneVar var fv_cand in_scope
= foldVarSet add_rule_var var_itself_set (idRuleVars var)
where
var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
| otherwise = emptyVarSet
add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
| otherwise = set
someVars :: IdOrTyVarSet -> FV
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
| otherwise = False
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope
| isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
| otherwise = inside_fvs
where
inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs
\end{code}
\begin{code}
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
expr_fvs (Var var) = oneVar var
expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args
expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
expr_fvs (Case scrut bndr alts)
= expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
where
alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
expr_fvs (Let (NonRec bndr rhs) body)
= expr_fvs rhs `union` addBndr bndr (expr_fvs body)
expr_fvs (Let (Rec pairs) body)
= addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
where
(bndrs,rhss) = unzip pairs
\end{code}
\begin{code}
idRuleVars ::Id -> IdOrTyVarSet
idRuleVars id = rulesRhsFreeVars (getIdSpecialisation id)
idFreeVars :: Id -> IdOrTyVarSet
idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id
rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> IdOrTyVarSet
rulesSomeFreeVars interesting (Rules rules _)
= foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
= rule_fvs interesting emptyVarSet
where
rule_fvs = addBndrs tpl_vars $
foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
\end{code}
%************************************************************************
%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%************************************************************************
The free variable pass annotates every node in the expression with its
NON-GLOBAL free variables and type variables.
\begin{code}
type CoreBindWithFVs = AnnBind Id IdOrTyVarSet
type CoreExprWithFVs = AnnExpr Id IdOrTyVarSet
-- Every node annotated with its free variables,
-- both Ids and TyVars
freeVarsOf :: CoreExprWithFVs -> IdSet
freeVarsOf (free_vars, _) = free_vars
noFVs = emptyVarSet
aFreeVar = unitVarSet
unionFVs = unionVarSet
filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet
-- (b `filters` s) removes the binder b from the free variable set s,
-- but *adds* to s
-- (a) the free variables of b's type
-- (b) the idSpecVars of b
--
-- This is really important for some lambdas:
-- In (\x::a -> x) the only mention of "a" is in the binder.
--
-- Also in
-- let x::a = b in ...
-- we should really note that "a" is free in this expression.
-- It'll be pinned inside the /\a by the binding for b, but
-- it seems cleaner to make sure that a is in the free-var set
-- when it is mentioned.
--
-- This also shows up in recursive bindings. Consider:
-- /\a -> letrec x::a = x in E
-- Now, there are no explicit free type variables in the RHS of x,
-- but nevertheless "a" is free in its definition. So we add in
-- the free tyvars of the types of the binders, and include these in the
-- free vars of the group, attached to the top level of each RHS.
--
-- This actually happened in the defn of errorIO in IOBase.lhs:
-- errorIO (ST io) = case (errorIO# io) of
-- _ -> bottom
-- where
-- bottom = bottom -- Never evaluated
filters b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
| otherwise = s `delVarSet` b
\end{code}
%************************************************************************
%* *
\subsection{Free variables (and types)}
%* *
%************************************************************************
\begin{code}
freeVars :: CoreExpr -> CoreExprWithFVs
freeVars (Var v)
= (fvs, AnnVar v)
where
-- ToDo: insert motivating example for why we *need*
-- to include the idSpecVars in the FV list.
-- Actually [June 98] I don't think it's necessary
-- fvs = fvs_v `unionVarSet` idSpecVars v
fvs | isLocallyDefined v = aFreeVar v
| otherwise = noFVs
freeVars (Con con args)
= (foldr (unionFVs . freeVarsOf) noFVs args2, AnnCon con args2)
where
args2 = map freeVars args
freeVars (Lam b body)
= (b `filters` freeVarsOf body', AnnLam b body')
where
body' = freeVars body
freeVars (App fun arg)
= (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
where
fun2 = freeVars fun
arg2 = freeVars arg
freeVars (Case scrut bndr alts)
= ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2,
AnnCase scrut2 bndr alts2)
where
scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr1 unionFVs alts_fvs_s
fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args,
(con, args, rhs2))
where
rhs2 = freeVars rhs
freeVars (Let (NonRec binder rhs) body)
= (freeVarsOf rhs2 `unionFVs` body_fvs,
AnnLet (AnnNonRec binder rhs2) body2)
where
rhs2 = freeVars rhs
body2 = freeVars body
body_fvs = binder `filters` freeVarsOf body2
freeVars (Let (Rec binds) body)
= (foldl delVarSet group_fvs binders,
-- The "filters" part may have added one of the binders
-- via the idSpecVars part, so we must delete it again
AnnLet (AnnRec (binders `zip` rhss2)) body2)
where
(binders, rhss) = unzip binds
rhss2 = map freeVars rhss
all_fvs = foldr (unionFVs . fst) body_fvs rhss2
group_fvs = foldr filters all_fvs binders
body2 = freeVars body
body_fvs = freeVarsOf body2
freeVars (Note (Coerce to_ty from_ty) expr)
= (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
AnnNote (Coerce to_ty from_ty) expr2)
where
expr2 = freeVars expr
tfvs1 = tyVarsOfType from_ty
tfvs2 = tyVarsOfType to_ty
freeVars (Note other_note expr)
= (freeVarsOf expr2, AnnNote other_note expr2)
where
expr2 = freeVars expr
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
\end{code}
|