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 CoreUtils ( idSpecVars )
25 import Id ( idType, getIdArity, isBottomingId,
26 emptyIdSet, unitIdSet, mkIdSet, unionIdSets,
27 elementOfIdSet, minusIdSet, unionManyIdSets,
30 import IdInfo ( ArityInfo(..) )
31 import PrimOp ( PrimOp(..) )
32 import Type ( tyVarsOfType, Type )
33 import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
37 import BasicTypes ( Unused )
38 import UniqSet ( unionUniqSets, addOneToUniqSet )
39 import Util ( panic, assertPanic )
43 %************************************************************************
45 \section[freevars-everywhere]{Attaching free variables to every sub-expression
47 %************************************************************************
49 The free variable pass annotates every node in the expression with its
50 NON-GLOBAL free variables and type variables.
52 The ``free type variables'' are defined to be those which are mentioned
53 in type applications, {\em not} ones which lie buried in the types of Ids.
55 *** ALAS: we *do* need to collect tyvars from lambda-bound ids. ***
56 I've half-convinced myself we don't for case- and letrec bound ids
57 but I might be wrong. (SLPJ, date unknown)
60 type CoreExprWithFVs = AnnCoreExpr Id Id Unused FVInfo
62 type TyVarCands = TyVarSet -- for when we carry around lists of
63 type IdCands = IdSet -- "candidate" TyVars/Ids.
64 noTyVarCands = emptyTyVarSet
65 noIdCands = emptyIdSet
68 = FVInfo IdSet -- Free ids
69 TyVarSet -- Free tyvars
72 noFreeIds = emptyIdSet
73 noFreeTyVars = emptyTyVarSet
74 noFreeAnything = (noFreeIds, noFreeTyVars)
75 aFreeId i = unitIdSet i
76 aFreeTyVar t = unitTyVarSet t
77 is_among = elementOfIdSet
78 munge_id_ty i = tyVarsOfType (idType i)
79 combine = unionUniqSets -- used both for {Id,TyVar}Sets
82 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
83 = FVInfo (fvs1 `combine` fvs2)
84 (tfvs1 `combine` tfvs2)
85 (leak1 `orLeak` leak2)
88 Leak-free-ness is based only on the value, not the type. In
89 particular, nested collections of constructors are guaranteed leak
90 free. Function applications are not, except for PAPs.
92 Applications of error gets (LeakFree bigArity) -- a hack!
97 | LeakFree Int -- Leak free, and guarantees to absorb this # of
98 -- args before becoming leaky.
100 lEAK_FREE_0 = LeakFree 0
101 lEAK_FREE_BIG = LeakFree bigArity
103 bigArity = 1000::Int -- NB: arbitrary
105 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
106 orLeak MightLeak _ = MightLeak
107 orLeak _ MightLeak = MightLeak
108 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
111 Main public interface:
113 freeVars :: CoreExpr -> CoreExprWithFVs
115 freeVars expr = fvExpr noIdCands noTyVarCands expr
119 %************************************************************************
121 \subsection{Free variables (and types)}
123 %************************************************************************
125 We do the free-variable stuff by passing around ``candidates lists''
126 of @Ids@ and @TyVars@ that may be considered free. This is useful,
127 e.g., to avoid considering top-level binders as free variables---don't
128 put them on the candidates list.
132 fvExpr :: IdCands -- In-scope Ids
133 -> TyVarCands -- In-scope tyvars
137 fvExpr id_cands tyvar_cands (Var v)
138 = (FVInfo fvs noFreeTyVars leakiness, AnnVar v)
141 ToDo: insert motivating example for why we *need*
142 to include the idSpecVars in the FV list.
144 fvs = fvs_v `unionIdSets` mkIdSet (idSpecVars v)
147 | v `is_among` id_cands = aFreeId v
148 | otherwise = noFreeIds
151 | isBottomingId v = lEAK_FREE_BIG -- Hack
152 | otherwise = case getIdArity v of
153 UnknownArity -> lEAK_FREE_0
154 ArityAtLeast arity -> LeakFree arity
155 ArityExactly arity -> LeakFree arity
157 fvExpr id_cands tyvar_cands (Lit k)
158 = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
160 fvExpr id_cands tyvar_cands (Con c args)
161 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
163 (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
165 fvExpr id_cands tyvar_cands (Prim op args)
166 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
168 (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
171 CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
174 -- this Lam stuff could probably be improved by rewriting (WDP 96/03)
176 fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
177 = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder)
178 (freeTyVarsOf body2 `combine` munge_id_ty binder)
182 -- We need to collect free tyvars from the binders
183 body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
185 leakiness = case leakinessOf body2 of
186 MightLeak -> LeakFree 1
187 LeakFree n -> LeakFree (n + 1)
189 fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
190 = (FVInfo (freeVarsOf body2)
191 (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
195 body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
197 -- ditto on rewriting this App stuff (WDP 96/03)
199 fvExpr id_cands tyvar_cands (App fun arg)
200 = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
201 (freeTyVarsOf fun2 `combine` tfvs_arg)
205 fun2 = fvExpr id_cands tyvar_cands fun
206 fun2_leakiness = leakinessOf fun2
208 (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
210 leakiness = if (notValArg arg) then
213 case fun2_leakiness of
214 LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
217 fvExpr id_cands tyvar_cands (Case expr alts)
218 = (combineFVInfo expr_fvinfo alts_fvinfo,
221 expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
222 (alts_fvinfo, alts') = annotate_alts alts
224 annotate_alts (AlgAlts alts deflt)
225 = (fvinfo, AnnAlgAlts alts' deflt')
227 (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
228 (deflt_fvinfo, deflt') = annotate_default deflt
229 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
231 ann_boxed_alt (con, params, rhs)
232 = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
233 (freeTyVarsOf rhs' `combine` param_ftvs)
237 rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
238 param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
239 -- We need to collect free tyvars from the binders
241 annotate_alts (PrimAlts alts deflt)
242 = (fvinfo, AnnPrimAlts alts' deflt')
244 (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
245 (deflt_fvinfo, deflt') = annotate_default deflt
246 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
248 ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
250 rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
252 annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
255 annotate_default (BindDefault binder rhs)
256 = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder)
257 (freeTyVarsOf rhs' `combine` binder_ftvs)
259 AnnBindDefault binder rhs')
261 rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
262 binder_ftvs = munge_id_ty binder
263 -- We need to collect free tyvars from the binder
265 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
266 = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
267 (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
268 (leakinessOf rhs' `orLeak` leakinessOf body2),
269 AnnLet (AnnNonRec binder rhs') body2)
271 rhs' = fvRhs id_cands tyvar_cands (binder, rhs)
272 body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
273 body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
274 binder_ftvs = munge_id_ty binder
275 -- We need to collect free tyvars from the binder
277 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
278 = (FVInfo (binds_fvs `combine` body_fvs)
279 (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
280 (leakiness_of_rhss `orLeak` leakinessOf body2),
281 AnnLet (AnnRec (binders `zip` rhss')) body2)
283 (binders, rhss) = unzip binds
284 new_id_cands = binders_set `combine` id_cands
285 binders_set = mkIdSet binders
286 rhss' = map (fvRhs new_id_cands tyvar_cands) binds
288 FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
289 = foldr1 combineFVInfo [info | (info,_) <- rhss']
291 binds_fvs = rhss_fvs `minusIdSet` binders_set
292 body2 = fvExpr new_id_cands tyvar_cands body
293 body_fvs = freeVarsOf body2 `minusIdSet` binders_set
294 binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
295 -- We need to collect free tyvars from the binders
297 fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
298 = (FVInfo (freeVarsOf expr2)
299 (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
301 AnnNote (Coerce to_ty from_ty) expr2)
303 expr2 = fvExpr id_cands tyvar_cands expr
304 tfvs1 = freeTy tyvar_cands from_ty
305 tfvs2 = freeTy tyvar_cands to_ty
307 fvExpr id_cands tyvar_cands (Note other_note expr)
308 = (fvinfo, AnnNote other_note expr2)
310 expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
312 -- fvRhs returns the annotated RHS, but it adds to the
313 -- free vars of the RHS the idSpecVars of the binder,
314 -- since those are, in truth, free in the definition.
315 fvRhs id_cands tyvar_cands (bndr,rhs)
316 = (FVInfo fvs' ftvs leak, rhs')
318 (FVInfo fvs ftvs leak, rhs') = fvExpr id_cands tyvar_cands rhs
319 fvs' = fvs `unionIdSets` mkIdSet (idSpecVars bndr)
324 freeArgs :: IdCands -> TyVarCands
328 freeArgs icands tcands [] = noFreeAnything
329 freeArgs icands tcands (arg:args)
330 -- this code is written this funny way only for "efficiency" purposes
332 free_first_arg@(arg_fvs, tfvs) = free_arg arg
337 case (freeArgs icands tcands args) of { (irest, trest) ->
338 (arg_fvs `combine` irest, tfvs `combine` trest) }
340 free_arg (LitArg _) = noFreeAnything
341 free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty)
343 | v `is_among` icands = (aFreeId v, noFreeTyVars)
344 | otherwise = noFreeAnything
347 freeTy :: TyVarCands -> Type -> TyVarSet
349 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
351 freeVarsOf :: CoreExprWithFVs -> IdSet
352 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
354 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
355 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
357 leakinessOf :: CoreExprWithFVs -> LeakInfo
358 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
362 %************************************************************************
364 \section{Finding the free variables of an expression}
366 %************************************************************************
368 This function simply finds the free variables of an expression.
371 type InterestingIdFun
372 = Id -- The Id being looked at
373 -> Bool -- True <=> interesting
375 exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
376 exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
381 expr_fvs :: InterestingIdFun -- "Interesting id" predicate
382 -> IdSet -- In scope ids
386 expr_fvs fv_cand in_scope (Var v) = id_fvs fv_cand in_scope v
387 expr_fvs fv_cand in_scope (Lit lit) = noFreeIds
388 expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
389 expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
390 expr_fvs fv_cand in_scope (Note _ expr) = expr_fvs fv_cand in_scope expr
391 expr_fvs fv_cand in_scope (App fun arg) = expr_fvs fv_cand in_scope fun `combine`
392 arg_fvs fv_cand in_scope arg
395 expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
396 = (expr_fvs fv_cand (in_scope `add` b) body)
397 expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
398 = expr_fvs fv_cand in_scope body
400 expr_fvs fv_cand in_scope (Case scrut alts)
401 = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
405 AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
407 alt_fvs = map do_alg_alt alg_alts
408 deflt_fvs = do_deflt deflt
410 PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
412 alt_fvs = map do_prim_alt prim_alts
413 deflt_fvs = do_deflt deflt
415 do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
416 do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
418 new_in_scope = in_scope `combine` mkIdSet args
420 do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
422 do_deflt NoDefault = noFreeIds
423 do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
425 expr_fvs fv_cand in_scope (Let (NonRec b r) body)
426 = expr_fvs fv_cand in_scope r `combine`
427 expr_fvs fv_cand (in_scope `add` b) body
429 expr_fvs fv_cand in_scope (Let (Rec pairs) body)
430 = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
431 expr_fvs fv_cand in_scope' body
433 in_scope' = in_scope `combine` mkIdSet (map fst pairs)
438 --------------------------------------
439 arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
440 arg_fvs fv_cand in_scope other_arg = noFreeIds
442 --------------------------------------
443 args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
446 --------------------------------------
447 id_fvs fv_cand in_scope v
448 | v `elementOfIdSet` in_scope = noFreeIds
449 | fv_cand v = aFreeId v
450 | otherwise = noFreeIds