2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 Taken quite directly from the Peyton Jones/Lester paper.
7 #include "HsVersions.h"
12 -- cheap and cheerful variant...
13 addTopBindsFVs, addExprFVs,
15 freeVarsOf, freeTyVarsOf,
16 SYN_IE(FVCoreExpr), SYN_IE(FVCoreBinding),
18 SYN_IE(CoreExprWithFVs), -- For the above functions
19 SYN_IE(AnnCoreExpr), -- Dito
20 FVInfo(..), LeakInfo(..)
25 import AnnCoreSyn -- output
28 import Id ( idType, getIdArity, isBottomingId,
29 emptyIdSet, unitIdSet, mkIdSet,
30 elementOfIdSet, minusIdSet, unionManyIdSets,
31 SYN_IE(IdSet), SYN_IE(Id)
33 import IdInfo ( ArityInfo(..) )
34 import PrimOp ( PrimOp(..) )
35 import Type ( tyVarsOfType, SYN_IE(Type) )
36 import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
38 SYN_IE(TyVarSet), SYN_IE(TyVar)
40 import UniqSet ( unionUniqSets )
41 import Usage ( SYN_IE(UVar) )
42 import Util ( panic, assertPanic )
45 %************************************************************************
47 \section[freevars-everywhere]{Attaching free variables to every sub-expression
49 %************************************************************************
51 The free variable pass annotates every node in the expression with its
52 NON-GLOBAL free variables and type variables.
54 The ``free type variables'' are defined to be those which are mentioned
55 in type applications, {\em not} ones which lie buried in the types of Ids.
57 *** ALAS: we *do* need to collect tyvars from lambda-bound ids. ***
58 I've half-convinced myself we don't for case- and letrec bound ids
59 but I might be wrong. (SLPJ, date unknown)
62 type CoreExprWithFVs = AnnCoreExpr Id Id TyVar UVar FVInfo
64 type TyVarCands = TyVarSet -- for when we carry around lists of
65 type IdCands = IdSet -- "candidate" TyVars/Ids.
66 noTyVarCands = emptyTyVarSet
67 noIdCands = emptyIdSet
70 = FVInfo IdSet -- Free ids
71 TyVarSet -- Free tyvars
74 noFreeIds = emptyIdSet
75 noFreeTyVars = emptyTyVarSet
76 noFreeAnything = (noFreeIds, noFreeTyVars)
77 aFreeId i = unitIdSet i
78 aFreeTyVar t = unitTyVarSet t
79 is_among = elementOfIdSet
80 munge_id_ty i = tyVarsOfType (idType i)
81 combine = unionUniqSets -- used both for {Id,TyVar}Sets
83 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
84 = FVInfo (fvs1 `combine` fvs2)
85 (tfvs1 `combine` tfvs2)
86 (leak1 `orLeak` leak2)
89 Leak-free-ness is based only on the value, not the type. In
90 particular, nested collections of constructors are guaranteed leak
91 free. Function applications are not, except for PAPs.
93 Applications of error gets (LeakFree bigArity) -- a hack!
98 | LeakFree Int -- Leak free, and guarantees to absorb this # of
99 -- args before becoming leaky.
101 lEAK_FREE_0 = LeakFree 0
102 lEAK_FREE_BIG = LeakFree bigArity
104 bigArity = 1000::Int -- NB: arbitrary
106 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
107 orLeak MightLeak _ = MightLeak
108 orLeak _ MightLeak = MightLeak
109 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
112 Main public interface:
114 freeVars :: CoreExpr -> CoreExprWithFVs
116 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 (if (v `is_among` id_cands)
146 | isBottomingId v = lEAK_FREE_BIG -- Hack
147 | otherwise = case getIdArity v of
148 UnknownArity -> lEAK_FREE_0
149 ArityAtLeast arity -> LeakFree arity
150 ArityExactly arity -> LeakFree arity
152 fvExpr id_cands tyvar_cands (Lit k)
153 = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
155 fvExpr id_cands tyvar_cands (Con c args)
156 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
158 (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
160 fvExpr id_cands tyvar_cands (Prim op args)
161 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
163 (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
166 CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
169 -- this Lam stuff could probably be improved by rewriting (WDP 96/03)
171 fvExpr id_cands tyvar_cands (Lam (UsageBinder uvar) body)
172 = panic "fvExpr:Lam UsageBinder"
174 fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
175 = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder)
176 (freeTyVarsOf body2 `combine` munge_id_ty binder)
180 -- We need to collect free tyvars from the binders
181 body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
183 leakiness = case leakinessOf body2 of
184 MightLeak -> LeakFree 1
185 LeakFree n -> LeakFree (n + 1)
187 fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
188 = (FVInfo (freeVarsOf body2)
189 (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
193 body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
195 -- ditto on rewriting this App stuff (WDP 96/03)
197 fvExpr id_cands tyvar_cands (App fun arg)
198 = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
199 (freeTyVarsOf fun2 `combine` tfvs_arg)
203 fun2 = fvExpr id_cands tyvar_cands fun
204 fun2_leakiness = leakinessOf fun2
206 (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
208 leakiness = if (notValArg arg) then
211 case fun2_leakiness of
212 LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
215 fvExpr id_cands tyvar_cands (Case expr alts)
216 = (combineFVInfo expr_fvinfo alts_fvinfo,
219 expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
220 (alts_fvinfo, alts') = annotate_alts alts
222 annotate_alts (AlgAlts alts deflt)
223 = (fvinfo, AnnAlgAlts alts' deflt')
225 (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
226 (deflt_fvinfo, deflt') = annotate_default deflt
227 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
229 ann_boxed_alt (con, params, rhs)
230 = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
231 (freeTyVarsOf rhs' `combine` param_ftvs)
235 rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
236 param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
237 -- We need to collect free tyvars from the binders
239 annotate_alts (PrimAlts alts deflt)
240 = (fvinfo, AnnPrimAlts alts' deflt')
242 (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
243 (deflt_fvinfo, deflt') = annotate_default deflt
244 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
246 ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
248 rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
250 annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
253 annotate_default (BindDefault binder rhs)
254 = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder)
255 (freeTyVarsOf rhs' `combine` binder_ftvs)
257 AnnBindDefault binder rhs')
259 rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
260 binder_ftvs = munge_id_ty binder
261 -- We need to collect free tyvars from the binder
263 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
264 = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
265 (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
266 (leakinessOf rhs' `orLeak` leakinessOf body2),
267 AnnLet (AnnNonRec binder rhs') body2)
269 rhs' = fvExpr id_cands tyvar_cands rhs
270 body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
271 body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
272 binder_ftvs = munge_id_ty binder
273 -- We need to collect free tyvars from the binder
275 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
276 = (FVInfo (binds_fvs `combine` body_fvs)
277 (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
278 (leakiness_of_rhss `orLeak` leakinessOf body2),
279 AnnLet (AnnRec (binders `zip` rhss')) body2)
281 (binders, rhss) = unzip binds
282 new_id_cands = binders_set `combine` id_cands
283 binders_set = mkIdSet binders
284 rhss' = map (fvExpr new_id_cands tyvar_cands) rhss
286 FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
287 = foldr1 combineFVInfo [info | (info,_) <- rhss']
289 binds_fvs = rhss_fvs `minusIdSet` binders_set
290 body2 = fvExpr new_id_cands tyvar_cands body
291 body_fvs = freeVarsOf body2 `minusIdSet` binders_set
292 binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
293 -- We need to collect free tyvars from the binders
295 fvExpr id_cands tyvar_cands (SCC label expr)
296 = (fvinfo, AnnSCC label expr2)
298 expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
300 fvExpr id_cands tyvar_cands (Coerce c ty expr)
301 = (FVInfo (freeVarsOf expr2)
302 (freeTyVarsOf expr2 `combine` tfvs)
304 AnnCoerce c ty expr2)
306 expr2 = fvExpr id_cands tyvar_cands expr
307 tfvs = freeTy tyvar_cands ty
311 freeArgs :: IdCands -> TyVarCands
315 freeArgs icands tcands [] = noFreeAnything
316 freeArgs icands tcands (arg:args)
317 -- this code is written this funny way only for "efficiency" purposes
319 free_first_arg@(arg_fvs, tfvs) = free_arg arg
324 case (freeArgs icands tcands args) of { (irest, trest) ->
325 (arg_fvs `combine` irest, tfvs `combine` trest) }
327 free_arg (LitArg _) = noFreeAnything
328 free_arg (UsageArg _) = noFreeAnything
329 free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty)
331 | v `is_among` icands = (aFreeId v, noFreeTyVars)
332 | otherwise = noFreeAnything
335 freeTy :: TyVarCands -> Type -> TyVarSet
337 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
339 freeVarsOf :: CoreExprWithFVs -> IdSet
340 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
342 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
343 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
345 leakinessOf :: CoreExprWithFVs -> LeakInfo
346 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
350 %************************************************************************
352 \section[freevars-binders]{Attaching free variables to binders
354 %************************************************************************
357 Here's an variant of the free-variable pass, which pins free-variable
358 information on {\em binders} rather than every single jolly
362 The free vars attached to a lambda binder are the free vars of the
363 whole lambda abstraction. If there are multiple binders, they are
364 each given the same free-var set.
366 The free vars attached to a let(rec) binder are the free vars of the
367 rhs of the binding. In the case of letrecs, this set excludes the
370 The free vars attached to a case alternative binder are the free
371 vars of the alternative, excluding the alternative's binders.
374 There's a predicate carried in which tells what is a free-var
375 candidate. It is passed the Id and a set of in-scope Ids.
377 (Global) constructors used on the rhs in a Con are also treated as
378 potential free-var candidates (though they will not be recorded in the
379 in-scope set). The predicate must decide if they are to be recorded as
382 As it happens this is only ever used by the Specialiser!
385 type FVCoreBinder = (Id, IdSet)
386 type FVCoreExpr = GenCoreExpr FVCoreBinder Id TyVar UVar
387 type FVCoreBinding = GenCoreBinding FVCoreBinder Id TyVar UVar
389 type InterestingIdFun
390 = IdSet -- Non-top-level in-scope variables
391 -> Id -- The Id being looked at
392 -> Bool -- True <=> interesting
396 addExprFVs :: InterestingIdFun -- "Interesting id" predicate
397 -> IdSet -- In scope ids
399 -> (FVCoreExpr, IdSet)
401 addExprFVs fv_cand in_scope (Var v)
402 = (Var v, if fv_cand in_scope v
406 addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
408 addExprFVs fv_cand in_scope (Con con args)
410 if fv_cand in_scope con
412 else noFreeIds `combine` fvsOfArgs fv_cand in_scope args)
414 addExprFVs fv_cand in_scope (Prim op args)
415 = (Prim op args, fvsOfArgs fv_cand in_scope args)
417 addExprFVs fv_cand in_scope (Lam binder body)
418 = (Lam new_binder new_body, lam_fvs)
420 (new_binder, binder_set)
422 TyBinder t -> (TyBinder t, emptyIdSet)
423 UsageBinder u -> (UsageBinder u, emptyIdSet)
424 ValBinder b -> (ValBinder (b, lam_fvs),
427 new_in_scope = in_scope `combine` binder_set
428 (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
429 lam_fvs = body_fvs `minusIdSet` binder_set
431 addExprFVs fv_cand in_scope (App fun arg)
432 = (App fun2 arg, fun_fvs `combine` fvsOfArgs fv_cand in_scope [arg])
434 (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
436 addExprFVs fv_cand in_scope (Case scrut alts)
437 = (Case scrut' alts', scrut_fvs `combine` alts_fvs)
439 (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
443 AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
445 (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
446 (deflt', deflt_fvs) = do_deflt deflt
447 fvs = unionManyIdSets (deflt_fvs : alt_fvs)
449 PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
451 (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
452 (deflt', deflt_fvs) = do_deflt deflt
453 fvs = unionManyIdSets (deflt_fvs : alt_fvs)
455 do_alg_alt :: (Id, [Id], CoreExpr)
456 -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
458 do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
460 new_in_scope = in_scope `combine` arg_set
461 (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
462 fvs = rhs_fvs `minusIdSet` arg_set
463 arg_set = mkIdSet args
465 do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
467 (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
469 do_deflt NoDefault = (NoDefault, noFreeIds)
470 do_deflt (BindDefault var rhs)
471 = (BindDefault (var,fvs) rhs', fvs)
473 new_in_scope = in_scope `combine` var_set
474 (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
475 fvs = rhs_fvs `minusIdSet` var_set
476 var_set = aFreeId var
478 addExprFVs fv_cand in_scope (Let binds body)
479 = (Let binds' body2, fvs_binds `combine` (fvs_body `minusIdSet` binder_set))
481 (binds', fvs_binds, new_in_scope, binder_set)
482 = addBindingFVs fv_cand in_scope binds
484 (body2, fvs_body) = addExprFVs fv_cand new_in_scope body
486 addExprFVs fv_cand in_scope (SCC label expr)
487 = (SCC label expr2, expr_fvs)
489 (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
491 addExprFVs fv_cand in_scope (Coerce c ty expr)
492 = (Coerce c ty expr2, expr_fvs)
494 (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
499 :: InterestingIdFun -- "Interesting id" predicate
500 -> IdSet -- In scope ids
503 IdSet, -- Free vars of binding group
504 IdSet, -- Augmented in-scope Ids
505 IdSet) -- Set of Ids bound by this binding
507 addBindingFVs fv_cand in_scope (NonRec binder rhs)
508 = (NonRec binder' rhs', fvs, new_in_scope, binder_set)
510 ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
511 new_in_scope = in_scope `combine` binder_set
512 binder_set = aFreeId binder
514 addBindingFVs fv_cand in_scope (Rec pairs)
515 = (Rec pairs', unionManyIdSets fvs_s, new_in_scope, binder_set)
517 binders = [binder | (binder,_) <- pairs]
518 binder_set = mkIdSet binders
519 new_in_scope = in_scope `combine` binder_set
520 (pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
525 :: InterestingIdFun -- "Interesting id" predicate
530 addTopBindsFVs fv_cand [] = ([], noFreeIds)
531 addTopBindsFVs fv_cand (b:bs)
533 (b', fvs_b, _, _) = addBindingFVs fv_cand noFreeIds b
534 (bs', fvs_bs) = addTopBindsFVs fv_cand bs
536 (b' : bs', fvs_b `combine` fvs_bs)
540 fvsOfArgs :: InterestingIdFun -- "Interesting id" predicate
541 -> IdSet -- In scope ids
545 fvsOfArgs _ _ [] = noFreeIds
547 fvsOfArgs fv_cand in_scope [VarArg v] -- this is only a short-cut...
548 = if (fv_cand in_scope v) then aFreeId v else noFreeIds
549 fvsOfArgs _ _ [ _ ] = noFreeIds
551 fvsOfArgs fv_cand in_scope args
552 = mkIdSet [ v | (VarArg v) <- args, fv_cand in_scope v ]
553 -- all other types of args are uninteresting here...
556 do_pair :: InterestingIdFun -- "Interesting id" predicate
557 -> IdSet -- In scope ids
560 -> ((FVCoreBinder, FVCoreExpr), IdSet)
562 do_pair fv_cand in_scope binder_set (binder,rhs)
563 = (((binder, fvs), rhs'), fvs)
565 (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
566 fvs = rhs_fvs `minusIdSet` binder_set