2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 Taken quite directly from the Peyton Jones/Lester paper.
8 -- Cheap and cheerful variant...
11 -- Complicated and expensive variant for float-out
13 freeVarsOf, freeTyVarsOf,
14 CoreExprWithFVs, -- For the above functions
16 FVInfo(..), LeakInfo(..)
19 #include "HsVersions.h"
21 import AnnCoreSyn -- output
24 import Id ( idType, getIdArity, isBottomingId,
25 emptyIdSet, unitIdSet, mkIdSet,
26 elementOfIdSet, minusIdSet, unionManyIdSets,
29 import IdInfo ( ArityInfo(..) )
30 import PrimOp ( PrimOp(..) )
31 import Type ( tyVarsOfType, Type )
32 import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
36 import BasicTypes ( Unused )
37 import UniqSet ( unionUniqSets, addOneToUniqSet )
38 import Util ( panic, assertPanic )
41 %************************************************************************
43 \section[freevars-everywhere]{Attaching free variables to every sub-expression
45 %************************************************************************
47 The free variable pass annotates every node in the expression with its
48 NON-GLOBAL free variables and type variables.
50 The ``free type variables'' are defined to be those which are mentioned
51 in type applications, {\em not} ones which lie buried in the types of Ids.
53 *** ALAS: we *do* need to collect tyvars from lambda-bound ids. ***
54 I've half-convinced myself we don't for case- and letrec bound ids
55 but I might be wrong. (SLPJ, date unknown)
58 type CoreExprWithFVs = AnnCoreExpr Id Id Unused FVInfo
60 type TyVarCands = TyVarSet -- for when we carry around lists of
61 type IdCands = IdSet -- "candidate" TyVars/Ids.
62 noTyVarCands = emptyTyVarSet
63 noIdCands = emptyIdSet
66 = FVInfo IdSet -- Free ids
67 TyVarSet -- Free tyvars
70 noFreeIds = emptyIdSet
71 noFreeTyVars = emptyTyVarSet
72 noFreeAnything = (noFreeIds, noFreeTyVars)
73 aFreeId i = unitIdSet i
74 aFreeTyVar t = unitTyVarSet t
75 is_among = elementOfIdSet
76 munge_id_ty i = tyVarsOfType (idType i)
77 combine = unionUniqSets -- used both for {Id,TyVar}Sets
80 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
81 = FVInfo (fvs1 `combine` fvs2)
82 (tfvs1 `combine` tfvs2)
83 (leak1 `orLeak` leak2)
86 Leak-free-ness is based only on the value, not the type. In
87 particular, nested collections of constructors are guaranteed leak
88 free. Function applications are not, except for PAPs.
90 Applications of error gets (LeakFree bigArity) -- a hack!
95 | LeakFree Int -- Leak free, and guarantees to absorb this # of
96 -- args before becoming leaky.
98 lEAK_FREE_0 = LeakFree 0
99 lEAK_FREE_BIG = LeakFree bigArity
101 bigArity = 1000::Int -- NB: arbitrary
103 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
104 orLeak MightLeak _ = MightLeak
105 orLeak _ MightLeak = MightLeak
106 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
109 Main public interface:
111 freeVars :: CoreExpr -> CoreExprWithFVs
113 freeVars expr = fvExpr noIdCands noTyVarCands expr
116 %************************************************************************
118 \subsection{Free variables (and types)}
120 %************************************************************************
122 We do the free-variable stuff by passing around ``candidates lists''
123 of @Ids@ and @TyVars@ that may be considered free. This is useful,
124 e.g., to avoid considering top-level binders as free variables---don't
125 put them on the candidates list.
129 fvExpr :: IdCands -- In-scope Ids
130 -> TyVarCands -- In-scope tyvars
134 fvExpr id_cands tyvar_cands (Var v)
135 = (FVInfo (if (v `is_among` id_cands)
143 | isBottomingId v = lEAK_FREE_BIG -- Hack
144 | otherwise = case getIdArity v of
145 UnknownArity -> lEAK_FREE_0
146 ArityAtLeast arity -> LeakFree arity
147 ArityExactly arity -> LeakFree arity
149 fvExpr id_cands tyvar_cands (Lit k)
150 = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
152 fvExpr id_cands tyvar_cands (Con c args)
153 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
155 (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
157 fvExpr id_cands tyvar_cands (Prim op args)
158 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
160 (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
163 CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
166 -- this Lam stuff could probably be improved by rewriting (WDP 96/03)
168 fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
169 = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder)
170 (freeTyVarsOf body2 `combine` munge_id_ty binder)
174 -- We need to collect free tyvars from the binders
175 body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
177 leakiness = case leakinessOf body2 of
178 MightLeak -> LeakFree 1
179 LeakFree n -> LeakFree (n + 1)
181 fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
182 = (FVInfo (freeVarsOf body2)
183 (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
187 body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
189 -- ditto on rewriting this App stuff (WDP 96/03)
191 fvExpr id_cands tyvar_cands (App fun arg)
192 = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
193 (freeTyVarsOf fun2 `combine` tfvs_arg)
197 fun2 = fvExpr id_cands tyvar_cands fun
198 fun2_leakiness = leakinessOf fun2
200 (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
202 leakiness = if (notValArg arg) then
205 case fun2_leakiness of
206 LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
209 fvExpr id_cands tyvar_cands (Case expr alts)
210 = (combineFVInfo expr_fvinfo alts_fvinfo,
213 expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
214 (alts_fvinfo, alts') = annotate_alts alts
216 annotate_alts (AlgAlts alts deflt)
217 = (fvinfo, AnnAlgAlts alts' deflt')
219 (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
220 (deflt_fvinfo, deflt') = annotate_default deflt
221 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
223 ann_boxed_alt (con, params, rhs)
224 = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
225 (freeTyVarsOf rhs' `combine` param_ftvs)
229 rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
230 param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
231 -- We need to collect free tyvars from the binders
233 annotate_alts (PrimAlts alts deflt)
234 = (fvinfo, AnnPrimAlts alts' deflt')
236 (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
237 (deflt_fvinfo, deflt') = annotate_default deflt
238 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
240 ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
242 rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
244 annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
247 annotate_default (BindDefault binder rhs)
248 = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder)
249 (freeTyVarsOf rhs' `combine` binder_ftvs)
251 AnnBindDefault binder rhs')
253 rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
254 binder_ftvs = munge_id_ty binder
255 -- We need to collect free tyvars from the binder
257 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
258 = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
259 (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
260 (leakinessOf rhs' `orLeak` leakinessOf body2),
261 AnnLet (AnnNonRec binder rhs') body2)
263 rhs' = fvRhs id_cands tyvar_cands (binder, rhs)
264 body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
265 body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
266 binder_ftvs = munge_id_ty binder
267 -- We need to collect free tyvars from the binder
269 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
270 = (FVInfo (binds_fvs `combine` body_fvs)
271 (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
272 (leakiness_of_rhss `orLeak` leakinessOf body2),
273 AnnLet (AnnRec (binders `zip` rhss')) body2)
275 (binders, rhss) = unzip binds
276 new_id_cands = binders_set `combine` id_cands
277 binders_set = mkIdSet binders
278 rhss' = map (fvRhs new_id_cands tyvar_cands) binds
280 FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
281 = foldr1 combineFVInfo [info | (info,_) <- rhss']
283 binds_fvs = rhss_fvs `minusIdSet` binders_set
284 body2 = fvExpr new_id_cands tyvar_cands body
285 body_fvs = freeVarsOf body2 `minusIdSet` binders_set
286 binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
287 -- We need to collect free tyvars from the binders
289 fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
290 = (FVInfo (freeVarsOf expr2)
291 (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
293 AnnNote (Coerce to_ty from_ty) expr2)
295 expr2 = fvExpr id_cands tyvar_cands expr
296 tfvs1 = freeTy tyvar_cands from_ty
297 tfvs2 = freeTy tyvar_cands to_ty
299 fvExpr id_cands tyvar_cands (Note other_note expr)
300 = (fvinfo, AnnNote other_note expr2)
302 expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
304 -- fvRhs returns the annotated RHS, but it adds to the
305 -- free vars of the RHS the idSpecVars of the binder,
306 -- since those are, in truth, free in the definition.
307 fvRhs id_cands tyvar_cands (bndr,rhs)
308 = (FVInfo (fvs `unionIdSets` idSpecVars bndr) ftvs leak, rhs')
310 (FVInfo fvs ftvs leak, rhs') = fvExpr id_cands tyvar_cands rhs
314 freeArgs :: IdCands -> TyVarCands
318 freeArgs icands tcands [] = noFreeAnything
319 freeArgs icands tcands (arg:args)
320 -- this code is written this funny way only for "efficiency" purposes
322 free_first_arg@(arg_fvs, tfvs) = free_arg arg
327 case (freeArgs icands tcands args) of { (irest, trest) ->
328 (arg_fvs `combine` irest, tfvs `combine` trest) }
330 free_arg (LitArg _) = noFreeAnything
331 free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty)
333 | v `is_among` icands = (aFreeId v, noFreeTyVars)
334 | otherwise = noFreeAnything
337 freeTy :: TyVarCands -> Type -> TyVarSet
339 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
341 freeVarsOf :: CoreExprWithFVs -> IdSet
342 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
344 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
345 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
347 leakinessOf :: CoreExprWithFVs -> LeakInfo
348 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
352 %************************************************************************
354 \section{Finding the free variables of an expression}
356 %************************************************************************
358 This function simply finds the free variables of an expression.
361 type InterestingIdFun
362 = Id -- The Id being looked at
363 -> Bool -- True <=> interesting
365 exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
366 exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
371 expr_fvs :: InterestingIdFun -- "Interesting id" predicate
372 -> IdSet -- In scope ids
376 expr_fvs fv_cand in_scope (Var v) = id_fvs fv_cand in_scope v
377 expr_fvs fv_cand in_scope (Lit lit) = noFreeIds
378 expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
379 expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
380 expr_fvs fv_cand in_scope (Note _ expr) = expr_fvs fv_cand in_scope expr
381 expr_fvs fv_cand in_scope (App fun arg) = expr_fvs fv_cand in_scope fun `combine`
382 arg_fvs fv_cand in_scope arg
385 expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
386 = (expr_fvs fv_cand (in_scope `add` b) body)
387 expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
388 = expr_fvs fv_cand in_scope body
390 expr_fvs fv_cand in_scope (Case scrut alts)
391 = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
395 AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
397 alt_fvs = map do_alg_alt alg_alts
398 deflt_fvs = do_deflt deflt
400 PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
402 alt_fvs = map do_prim_alt prim_alts
403 deflt_fvs = do_deflt deflt
405 do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
406 do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
408 new_in_scope = in_scope `combine` mkIdSet args
410 do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
412 do_deflt NoDefault = noFreeIds
413 do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
415 expr_fvs fv_cand in_scope (Let (NonRec b r) body)
416 = expr_fvs fv_cand in_scope r `combine`
417 expr_fvs fv_cand (in_scope `add` b) body
419 expr_fvs fv_cand in_scope (Let (Rec pairs) body)
420 = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
421 expr_fvs fv_cand in_scope' body
423 in_scope' = in_scope `combine` mkIdSet (map fst pairs)
428 --------------------------------------
429 arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
430 arg_fvs fv_cand in_scope other_arg = noFreeIds
432 --------------------------------------
433 args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
436 --------------------------------------
437 id_fvs fv_cand in_scope v
438 | v `elementOfIdSet` in_scope = noFreeIds
439 | fv_cand v = aFreeId v
440 | otherwise = noFreeIds