2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 Taken quite directly from the Peyton Jones/Lester paper.
7 #include "HsVersions.h"
12 -- cheap and cheerful variant...
15 freeVarsOf, freeTyVarsOf,
16 FVCoreExpr(..), FVCoreBinding(..),
18 CoreExprWithFVs(..), -- For the above functions
19 AnnCoreExpr(..), -- Dito
20 FVInfo(..), LeakInfo(..)
22 -- and to make the interface self-sufficient...
26 import AnnCoreSyn -- output
28 import PrelInfo ( PrimOp(..), PrimRep -- for CCallOp
29 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
30 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
32 import Type ( extractTyVarsFromTy )
33 import Id ( idType, getIdArity, toplevelishId, isBottomingId )
34 import IdInfo -- Wanted for arityMaybe, but it seems you have
35 -- to import it all... (Death to the Instance Virus!)
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 FVInfo
60 type TyVarCands = TyVarSet -- for when we carry around lists of
61 type IdCands = IdSet -- "candidate" TyVars/Ids.
62 noTyVarCands = emptyUniqSet
63 noIdCands = emptyUniqSet
67 TyVarSet -- Free tyvars
70 noFreeIds = emptyUniqSet
71 noFreeTyVars = emptyUniqSet
72 aFreeId i = singletonUniqSet i
73 aFreeTyVar t = singletonUniqSet t
74 is_among = elementOfUniqSet
75 combine = unionUniqSets
76 munge_id_ty i = mkUniqSet (extractTyVarsFromTy (idType i))
78 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
79 = FVInfo (fvs1 `combine` fvs2)
80 (tfvs1 `combine` tfvs2)
81 (leak1 `orLeak` leak2)
84 Leak-free-ness is based only on the value, not the type.
85 In particular, nested collections of constructors are guaranteed leak free.
86 Function applications are not, except for PAPs.
88 Applications of error gets (LeakFree bigArity) -- a hack!
93 | LeakFree Int -- Leak free, and guarantees to absorb this # of
94 -- args before becoming leaky.
96 lEAK_FREE_0 = LeakFree 0
97 lEAK_FREE_BIG = LeakFree bigArity
99 bigArity = 1000::Int -- NB: arbitrary
101 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
102 orLeak MightLeak _ = MightLeak
103 orLeak _ MightLeak = MightLeak
104 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
107 Main public interface:
109 freeVars :: CoreExpr -> CoreExprWithFVs
111 freeVars expr = fvExpr noIdCands noTyVarCands expr
114 \subsection{Free variables (and types)}
116 We do the free-variable stuff by passing around ``candidates lists''
117 of @Ids@ and @TyVars@ that may be considered free. This is useful,
118 e.g., to avoid considering top-level binders as free variables---don't
119 put them on the candidates list.
123 fvExpr :: IdCands -- In-scope Ids
124 -> TyVarCands -- In-scope tyvars
128 fvExpr id_cands tyvar_cands (Var v)
129 = (FVInfo (if (v `is_among` id_cands)
137 | isBottomingId v = lEAK_FREE_BIG -- Hack
138 | otherwise = case arityMaybe (getIdArity v) of
139 Nothing -> lEAK_FREE_0
140 Just arity -> LeakFree arity
142 fvExpr id_cands tyvar_cands (Lit k)
143 = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k)
145 fvExpr id_cands tyvar_cands (Con c tys args)
146 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args)
148 args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
149 tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
151 fvExpr id_cands tyvar_cands (Prim op@(CCallOp _ _ _ _ res_ty) tys args)
153 (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
155 args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
156 tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys)
158 fvExpr id_cands tyvar_cands (Prim op tys args)
159 = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
161 args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
162 tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
164 fvExpr id_cands tyvar_cands (Lam binder body)
165 = (FVInfo (freeVarsOf body2 `minusUniqSet` singletonUniqSet binder)
166 (freeTyVarsOf body2 `combine` munge_id_ty binder)
168 AnnCoLam binder body2)
170 -- We need to collect free tyvars from the binders
171 body2 = fvExpr (singletonUniqSet binder `combine` id_cands) tyvar_cands body
173 leakiness = case leakinessOf body2 of
174 MightLeak -> LeakFree 1
175 LeakFree n -> LeakFree (n + 1)
177 fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
178 = (FVInfo (freeVarsOf body2)
179 (freeTyVarsOf body2 `minusUniqSet` aFreeTyVar tyvar)
181 AnnCoTyLam tyvar body2)
183 body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
185 fvExpr id_cands tyvar_cands (App fun arg)
186 = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
191 fun2 = fvExpr id_cands tyvar_cands fun
192 fvs_arg = freeAtom id_cands arg
194 leakiness = case leakinessOf fun2 of
195 LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
198 fvExpr id_cands tyvar_cands (CoTyApp expr ty)
199 = (FVInfo (freeVarsOf expr2)
200 (freeTyVarsOf expr2 `combine` tfvs_arg)
204 expr2 = fvExpr id_cands tyvar_cands expr
205 tfvs_arg = freeTy tyvar_cands ty
207 fvExpr id_cands tyvar_cands (Case expr alts)
208 = (combineFVInfo expr_fvinfo alts_fvinfo,
209 AnnCoCase expr2 alts')
211 expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
212 (alts_fvinfo, alts') = annotate_alts alts
214 annotate_alts (AlgAlts alts deflt)
215 = (fvinfo, AnnCoAlgAlts alts' deflt')
217 (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
218 (deflt_fvinfo, deflt') = annotate_default deflt
219 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
221 ann_boxed_alt (con, params, rhs)
222 = (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params)
223 (freeTyVarsOf rhs' `combine` param_ftvs)
227 rhs' = fvExpr (mkUniqSet params `combine` id_cands) tyvar_cands rhs
228 param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
229 -- We need to collect free tyvars from the binders
231 annotate_alts (PrimAlts alts deflt)
232 = (fvinfo, AnnCoPrimAlts alts' deflt')
234 (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
235 (deflt_fvinfo, deflt') = annotate_default deflt
236 fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
238 ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
240 rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
242 annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
245 annotate_default (BindDefault binder rhs)
246 = (FVInfo (freeVarsOf rhs' `minusUniqSet` aFreeId binder)
247 (freeTyVarsOf rhs' `combine` binder_ftvs)
249 AnnCoBindDefault binder rhs')
251 rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
252 binder_ftvs = munge_id_ty binder
253 -- We need to collect free tyvars from the binder
255 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
256 = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
257 (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
258 (leakinessOf rhs' `orLeak` leakinessOf body2),
259 AnnCoLet (AnnCoNonRec binder rhs') body2)
261 rhs' = fvExpr id_cands tyvar_cands rhs
262 body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
263 body_fvs = freeVarsOf body2 `minusUniqSet` aFreeId binder
264 binder_ftvs = munge_id_ty binder
265 -- We need to collect free tyvars from the binder
267 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
268 = (FVInfo (binds_fvs `combine` body_fvs)
269 (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
270 (leakiness_of_rhss `orLeak` leakinessOf body2),
271 AnnCoLet (AnnCoRec (binders `zip` rhss')) body2)
273 (binders, rhss) = unzip binds
274 new_id_cands = binders_set `combine` id_cands
275 binders_set = mkUniqSet binders
276 rhss' = map (fvExpr new_id_cands tyvar_cands) rhss
278 FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
279 = foldr1 combineFVInfo [info | (info,_) <- rhss']
281 binds_fvs = rhss_fvs `minusUniqSet` binders_set
282 body2 = fvExpr new_id_cands tyvar_cands body
283 body_fvs = freeVarsOf body2 `minusUniqSet` binders_set
284 binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
285 -- We need to collect free tyvars from the binders
287 fvExpr id_cands tyvar_cands (SCC label expr)
288 = (fvinfo, AnnCoSCC label expr2)
290 expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
294 freeAtom :: IdCands -> CoreArg -> IdSet
296 freeAtom cands (LitArg k) = noFreeIds
297 freeAtom cands (VarArg v) | v `is_among` cands = aFreeId v
298 | otherwise = noFreeIds
300 freeTy :: TyVarCands -> Type -> TyVarSet
302 freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands
304 freeVarsOf :: CoreExprWithFVs -> IdSet
305 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
307 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
308 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
310 leakinessOf :: CoreExprWithFVs -> LeakInfo
311 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
315 %************************************************************************
317 \section[freevars-binders]{Attaching free variables to binders
319 %************************************************************************
322 Here's an variant of the free-variable pass, which pins free-variable
323 information on {\em binders} rather than every single jolly
327 The free vars attached to a lambda binder are the free vars of the
328 whole lambda abstraction. If there are multiple binders, they are
329 each given the same free-var set.
331 The free vars attached to a let(rec) binder are the free vars of the
332 rhs of the binding. In the case of letrecs, this set excludes the
335 The free vars attached to a case alternative binder are the free
336 vars of the alternative, excluding the alternative's binders.
339 There's a predicate carried in which tells what is a free-var
340 candidate. It is passed the Id and a set of in-scope Ids.
342 (Global) constructors used on the rhs in a Con are also treated as
343 potential free-var candidates (though they will not be recorded in the
344 in-scope set). The predicate must decide if they are to be recorded as
347 As it happens this is only ever used by the Specialiser!
350 type FVCoreBinder = (Id, IdSet)
351 type FVCoreExpr = GenCoreExpr FVCoreBinder Id
352 type FVCoreBinding = GenCoreBinding FVCoreBinder Id
354 type InterestingIdFun
355 = IdSet -- Non-top-level in-scope variables
356 -> Id -- The Id being looked at
357 -> Bool -- True <=> interesting
361 addExprFVs :: InterestingIdFun -- "Interesting id" predicate
362 -> IdSet -- In scope ids
364 -> (FVCoreExpr, IdSet)
366 addExprFVs fv_cand in_scope (Var v)
367 = (Var v, if fv_cand in_scope v
371 addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
373 addExprFVs fv_cand in_scope (Con con tys args)
375 if fv_cand in_scope con
379 unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
381 addExprFVs fv_cand in_scope (Prim op tys args)
383 unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
385 addExprFVs fv_cand in_scope (Lam binder body)
386 = (Lam (binder,lam_fvs) new_body, lam_fvs)
388 binder_set = singletonUniqSet binder
389 new_in_scope = in_scope `combine` binder_set
390 (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
391 lam_fvs = body_fvs `minusUniqSet` binder_set
393 addExprFVs fv_cand in_scope (CoTyLam tyvar body)
394 = (CoTyLam tyvar body2, body_fvs)
396 (body2, body_fvs) = addExprFVs fv_cand in_scope body
398 addExprFVs fv_cand in_scope (App fun arg)
399 = (App fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
401 (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
403 addExprFVs fv_cand in_scope (CoTyApp fun ty)
404 = (CoTyApp fun2 ty, fun_fvs)
406 (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
408 addExprFVs fv_cand in_scope (Case scrut alts)
409 = (Case scrut' alts', scrut_fvs `combine` alts_fvs)
411 (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
415 AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
417 (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
418 (deflt', deflt_fvs) = do_deflt deflt
419 fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
421 PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
423 (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
424 (deflt', deflt_fvs) = do_deflt deflt
425 fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
427 do_alg_alt :: (Id, [Id], CoreExpr)
428 -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
430 do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
432 new_in_scope = in_scope `combine` arg_set
433 (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
434 fvs = rhs_fvs `minusUniqSet` arg_set
435 arg_set = mkUniqSet args
437 do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
439 (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
441 do_deflt NoDefault = (NoDefault, noFreeIds)
442 do_deflt (BindDefault var rhs)
443 = (BindDefault (var,fvs) rhs', fvs)
445 new_in_scope = in_scope `combine` var_set
446 (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
447 fvs = rhs_fvs `minusUniqSet` var_set
448 var_set = aFreeId var
450 addExprFVs fv_cand in_scope (Let binds body)
451 = (Let binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
453 (binds', fvs_binds, new_in_scope, binder_set)
454 = addBindingFVs fv_cand in_scope binds
456 (body2, fvs_body) = addExprFVs fv_cand new_in_scope body
458 addExprFVs fv_cand in_scope (SCC label expr)
459 = (SCC label expr2, expr_fvs)
461 (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
466 :: InterestingIdFun -- "Interesting id" predicate
467 -> IdSet -- In scope ids
470 IdSet, -- Free vars of binding group
471 IdSet, -- Augmented in-scope Ids
472 IdSet) -- Set of Ids bound by this binding
474 addBindingFVs fv_cand in_scope (NonRec binder rhs)
475 = (NonRec binder' rhs', fvs, new_in_scope, binder_set)
477 ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
478 new_in_scope = in_scope `combine` binder_set
479 binder_set = aFreeId binder
481 addBindingFVs fv_cand in_scope (Rec pairs)
482 = (Rec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
484 binders = [binder | (binder,_) <- pairs]
485 binder_set = mkUniqSet binders
486 new_in_scope = in_scope `combine` binder_set
487 (pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
492 :: InterestingIdFun -- "Interesting id" predicate
497 addTopBindsFVs fv_cand [] = ([], noFreeIds)
498 addTopBindsFVs fv_cand (b:bs)
500 (b', fvs_b, _, _) = addBindingFVs fv_cand noFreeIds b
501 (bs', fvs_bs) = addTopBindsFVs fv_cand bs
503 (b' : bs', fvs_b `combine` fvs_bs)
507 fvsOfAtom :: InterestingIdFun -- "Interesting id" predicate
508 -> IdSet -- In scope ids
512 fvsOfAtom fv_cand in_scope (VarArg v)
513 = if fv_cand in_scope v
516 fvsOfAtom _ _ _ = noFreeIds -- if a literal...
518 do_pair :: InterestingIdFun -- "Interesting id" predicate
519 -> IdSet -- In scope ids
522 -> ((FVCoreBinder, FVCoreExpr), IdSet)
524 do_pair fv_cand in_scope binder_set (binder,rhs)
525 = (((binder, fvs), rhs'), fvs)
527 (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
528 fvs = rhs_fvs `minusUniqSet` binder_set