[project @ 1996-06-05 06:44:31 by partain]
[ghc-hetmet.git] / ghc / compiler / coreSyn / FreeVars.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 Taken quite directly from the Peyton Jones/Lester paper.
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module FreeVars (
10         freeVars,
11
12         -- cheap and cheerful variant...
13         addTopBindsFVs,
14
15         freeVarsOf, freeTyVarsOf,
16         FVCoreExpr(..), FVCoreBinding(..),
17
18         CoreExprWithFVs(..),            -- For the above functions
19         AnnCoreExpr(..),                -- Dito
20         FVInfo(..), LeakInfo(..)
21     ) where
22
23 IMP_Ubiq(){-uitous-}
24
25 import AnnCoreSyn       -- output
26
27 import CoreSyn
28 import Id               ( idType, getIdArity, isBottomingId,
29                           emptyIdSet, unitIdSet, mkIdSet,
30                           elementOfIdSet, minusIdSet, unionManyIdSets,
31                           IdSet(..)
32                         )
33 import IdInfo           ( arityMaybe )
34 import PrimOp           ( PrimOp(..) )
35 import Type             ( tyVarsOfType )
36 import TyVar            ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
37                           intersectTyVarSets,
38                           TyVarSet(..)
39                         )
40 import UniqSet          ( unionUniqSets )
41 import Usage            ( UVar(..) )
42 import Util             ( panic, assertPanic )
43 \end{code}
44
45 %************************************************************************
46 %*                                                                      *
47 \section[freevars-everywhere]{Attaching free variables to every sub-expression
48 %*                                                                      *
49 %************************************************************************
50
51 The free variable pass annotates every node in the expression with its
52 NON-GLOBAL free variables and type variables.
53
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.
56
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)
60
61 \begin{code}
62 type CoreExprWithFVs =  AnnCoreExpr Id Id TyVar UVar FVInfo
63
64 type TyVarCands = TyVarSet  -- for when we carry around lists of
65 type IdCands    = IdSet     -- "candidate" TyVars/Ids.
66 noTyVarCands    = emptyTyVarSet
67 noIdCands       = emptyIdSet
68
69 data FVInfo
70   = FVInfo  IdSet       -- Free ids
71             TyVarSet    -- Free tyvars
72             LeakInfo
73
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
82
83 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
84   = FVInfo (fvs1  `combine` fvs2)
85            (tfvs1 `combine` tfvs2)
86            (leak1 `orLeak`  leak2)
87 \end{code}
88
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.
92
93 Applications of error gets (LeakFree bigArity) -- a hack!
94
95 \begin{code}
96 data LeakInfo
97   = MightLeak
98   | LeakFree Int    -- Leak free, and guarantees to absorb this # of
99                     -- args before becoming leaky.
100
101 lEAK_FREE_0   = LeakFree 0
102 lEAK_FREE_BIG = LeakFree bigArity
103               where
104                 bigArity = 1000::Int    -- NB: arbitrary
105
106 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
107 orLeak MightLeak     _           = MightLeak
108 orLeak _             MightLeak   = MightLeak
109 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
110 \end{code}
111
112 Main public interface:
113 \begin{code}
114 freeVars :: CoreExpr -> CoreExprWithFVs
115
116 freeVars expr = fvExpr noIdCands noTyVarCands expr
117 \end{code}
118
119 %************************************************************************
120 %*                                                                      *
121 \subsection{Free variables (and types)}
122 %*                                                                      *
123 %************************************************************************
124
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.
129
130 \begin{code}
131
132 fvExpr :: IdCands           -- In-scope Ids
133        -> TyVarCands        -- In-scope tyvars
134        -> CoreExpr
135        -> CoreExprWithFVs
136
137 fvExpr id_cands tyvar_cands (Var v)
138   = (FVInfo (if (v `is_among` id_cands)
139              then aFreeId v
140              else noFreeIds)
141             noFreeTyVars
142             leakiness,
143      AnnVar v)
144   where
145     leakiness
146       | isBottomingId v = lEAK_FREE_BIG -- Hack
147       | otherwise       = case arityMaybe (getIdArity v) of
148                             Nothing    -> lEAK_FREE_0
149                             Just arity -> LeakFree arity
150
151 fvExpr id_cands tyvar_cands (Lit k)
152   = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
153
154 fvExpr id_cands tyvar_cands (Con c args)
155   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
156   where
157     (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
158
159 fvExpr id_cands tyvar_cands (Prim op args)
160   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
161   where
162     (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
163     args_to_use
164       = case op of
165           CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
166           _                      -> args
167
168 -- this Lam stuff could probably be improved by rewriting (WDP 96/03)
169
170 fvExpr id_cands tyvar_cands (Lam (UsageBinder uvar) body)
171   = panic "fvExpr:Lam UsageBinder"
172
173 fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
174   = (FVInfo (freeVarsOf body2   `minusIdSet` unitIdSet binder)
175             (freeTyVarsOf body2 `combine`    munge_id_ty binder)
176             leakiness,
177      AnnLam b body2)
178   where
179         -- We need to collect free tyvars from the binders
180     body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
181
182     leakiness = case leakinessOf body2 of
183                   MightLeak  -> LeakFree 1
184                   LeakFree n -> LeakFree (n + 1)
185
186 fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
187   = (FVInfo (freeVarsOf body2)
188             (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
189             (leakinessOf body2),
190      AnnLam b body2)
191   where
192     body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
193
194 -- ditto on rewriting this App stuff (WDP 96/03)
195
196 fvExpr id_cands tyvar_cands (App fun arg)
197   = (FVInfo (freeVarsOf fun2   `combine` fvs_arg)
198             (freeTyVarsOf fun2 `combine` tfvs_arg)
199             leakiness,
200      AnnApp fun2 arg)
201   where
202     fun2 = fvExpr id_cands tyvar_cands fun
203     fun2_leakiness = leakinessOf fun2
204
205     (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
206
207     leakiness = if (notValArg arg) then
208                     fun2_leakiness
209                 else
210                     case fun2_leakiness of
211                        LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
212                        other            -> MightLeak
213
214 fvExpr id_cands tyvar_cands (Case expr alts)
215   = (combineFVInfo expr_fvinfo alts_fvinfo,
216      AnnCase expr2 alts')
217   where
218     expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
219     (alts_fvinfo, alts') = annotate_alts alts
220
221     annotate_alts (AlgAlts alts deflt)
222       = (fvinfo, AnnAlgAlts alts' deflt')
223       where
224         (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
225         (deflt_fvinfo, deflt') = annotate_default deflt
226         fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
227
228         ann_boxed_alt (con, params, rhs)
229           = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
230                     (freeTyVarsOf rhs' `combine` param_ftvs)
231                     (leakinessOf rhs'),
232              (con, params, rhs'))
233           where
234             rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
235             param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
236                 -- We need to collect free tyvars from the binders
237
238     annotate_alts (PrimAlts alts deflt)
239       = (fvinfo, AnnPrimAlts alts' deflt')
240       where
241         (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
242         (deflt_fvinfo, deflt') = annotate_default deflt
243         fvinfo  = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
244
245         ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
246           where
247             rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
248
249     annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
250                                     AnnNoDefault)
251
252     annotate_default (BindDefault binder rhs)
253       = (FVInfo (freeVarsOf   rhs' `minusIdSet` aFreeId binder)
254                 (freeTyVarsOf rhs' `combine` binder_ftvs)
255                 (leakinessOf rhs'),
256          AnnBindDefault binder rhs')
257       where
258         rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
259         binder_ftvs = munge_id_ty binder
260             -- We need to collect free tyvars from the binder
261
262 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
263   = (FVInfo (freeVarsOf rhs'   `combine` body_fvs)
264             (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
265             (leakinessOf rhs' `orLeak` leakinessOf body2),
266      AnnLet (AnnNonRec binder rhs') body2)
267   where
268     rhs'        = fvExpr id_cands tyvar_cands rhs
269     body2       = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
270     body_fvs    = freeVarsOf body2 `minusIdSet` aFreeId binder
271     binder_ftvs = munge_id_ty binder
272         -- We need to collect free tyvars from the binder
273
274 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
275   = (FVInfo (binds_fvs `combine` body_fvs)
276             (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
277             (leakiness_of_rhss `orLeak` leakinessOf body2),
278      AnnLet (AnnRec (binders `zip` rhss')) body2)
279   where
280     (binders, rhss)   = unzip binds
281     new_id_cands      = binders_set `combine` id_cands
282     binders_set       = mkIdSet binders
283     rhss'             = map (fvExpr new_id_cands tyvar_cands) rhss
284
285     FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
286         = foldr1 combineFVInfo [info | (info,_) <- rhss']
287
288     binds_fvs         = rhss_fvs `minusIdSet` binders_set
289     body2             = fvExpr new_id_cands tyvar_cands body
290     body_fvs          = freeVarsOf body2 `minusIdSet` binders_set
291     binders_ftvs      = foldr (combine . munge_id_ty) noFreeTyVars binders
292         -- We need to collect free tyvars from the binders
293
294 fvExpr id_cands tyvar_cands (SCC label expr)
295   = (fvinfo, AnnSCC label expr2)
296   where
297     expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
298
299 fvExpr id_cands tyvar_cands (Coerce c ty expr)
300   = (FVInfo (freeVarsOf   expr2)
301             (freeTyVarsOf expr2 `combine` tfvs)
302             (leakinessOf  expr2),
303      AnnCoerce c ty expr2)
304   where
305     expr2 = fvExpr id_cands tyvar_cands expr
306     tfvs  = freeTy tyvar_cands ty
307 \end{code}
308
309 \begin{code}
310 freeArgs :: IdCands -> TyVarCands
311          -> [CoreArg]
312          -> (IdSet, TyVarSet)
313
314 freeArgs icands tcands [] = noFreeAnything
315 freeArgs icands tcands (arg:args)
316   -- this code is written this funny way only for "efficiency" purposes
317   = let
318         free_first_arg@(arg_fvs, tfvs) = free_arg arg
319     in
320     if (null args) then
321         free_first_arg
322     else
323         case (freeArgs icands tcands args) of { (irest, trest) ->
324         (arg_fvs `combine` irest, tfvs `combine` trest) }
325   where
326     free_arg (LitArg   _) = noFreeAnything
327     free_arg (UsageArg _) = noFreeAnything
328     free_arg (TyArg   ty) = (noFreeIds, freeTy tcands ty)
329     free_arg (VarArg   v)
330       | v `is_among` icands = (aFreeId v, noFreeTyVars)
331       | otherwise           = noFreeAnything
332
333 ---------
334 freeTy :: TyVarCands -> Type -> TyVarSet
335
336 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
337
338 freeVarsOf :: CoreExprWithFVs -> IdSet
339 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
340
341 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
342 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
343
344 leakinessOf :: CoreExprWithFVs -> LeakInfo
345 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
346 \end{code}
347
348
349 %************************************************************************
350 %*                                                                      *
351 \section[freevars-binders]{Attaching free variables to binders
352 %*                                                                      *
353 %************************************************************************
354
355
356 Here's an variant of the free-variable pass, which pins free-variable
357 information on {\em binders} rather than every single jolly
358 expression!
359 \begin{itemize}
360 \item
361   The free vars attached to a lambda binder are the free vars of the
362   whole lambda abstraction.  If there are multiple binders, they are
363   each given the same free-var set.
364 \item
365   The free vars attached to a let(rec) binder are the free vars of the
366   rhs of the binding.  In the case of letrecs, this set excludes the
367   binders themselves.
368 \item
369   The free vars attached to a case alternative binder are the free
370   vars of the alternative, excluding the alternative's binders.
371 \end{itemize}
372
373 There's a predicate carried in which tells what is a free-var
374 candidate. It is passed the Id and a set of in-scope Ids.
375
376 (Global) constructors used on the rhs in a Con are also treated as
377 potential free-var candidates (though they will not be recorded in the
378 in-scope set). The predicate must decide if they are to be recorded as
379 free-vars.
380
381 As it happens this is only ever used by the Specialiser!
382
383 \begin{code}
384 type FVCoreBinder  = (Id, IdSet)
385 type FVCoreExpr    = GenCoreExpr    FVCoreBinder Id TyVar UVar
386 type FVCoreBinding = GenCoreBinding FVCoreBinder Id TyVar UVar
387
388 type InterestingIdFun
389   =  IdSet      -- Non-top-level in-scope variables
390   -> Id         -- The Id being looked at
391   -> Bool       -- True <=> interesting
392 \end{code}
393
394 \begin{code}
395 addExprFVs :: InterestingIdFun  -- "Interesting id" predicate
396            -> IdSet             -- In scope ids
397            -> CoreExpr
398            -> (FVCoreExpr, IdSet)
399
400 addExprFVs fv_cand in_scope (Var v)
401   = (Var v, if fv_cand in_scope v
402               then aFreeId v
403               else noFreeIds)
404
405 addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
406
407 addExprFVs fv_cand in_scope (Con con args)
408   = (Con con args,
409      if fv_cand in_scope con
410      then aFreeId con
411      else noFreeIds `combine` fvsOfArgs fv_cand in_scope args)
412
413 addExprFVs fv_cand in_scope (Prim op args)
414   = (Prim op args, fvsOfArgs fv_cand in_scope args)
415
416 addExprFVs fv_cand in_scope (Lam binder body)
417   = (Lam new_binder new_body, lam_fvs)
418   where
419     (new_binder, binder_set)
420       = case binder of
421           TyBinder    t -> (TyBinder t, emptyIdSet)
422           UsageBinder u -> (UsageBinder u, emptyIdSet)
423           ValBinder   b -> (ValBinder (b, lam_fvs),
424                             unitIdSet b)
425
426     new_in_scope         = in_scope `combine` binder_set
427     (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
428     lam_fvs              = body_fvs `minusIdSet` binder_set
429
430 addExprFVs fv_cand in_scope (App fun arg)
431   = (App fun2 arg, fun_fvs `combine` fvsOfArgs fv_cand in_scope [arg])
432   where
433     (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
434
435 addExprFVs fv_cand in_scope (Case scrut alts)
436   = (Case scrut' alts', scrut_fvs `combine` alts_fvs)
437   where
438     (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
439
440     (alts', alts_fvs)
441       = case alts of
442           AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
443             where
444               (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
445               (deflt', deflt_fvs) = do_deflt deflt
446               fvs = unionManyIdSets (deflt_fvs : alt_fvs)
447
448           PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
449             where
450               (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
451               (deflt', deflt_fvs) = do_deflt deflt
452               fvs = unionManyIdSets (deflt_fvs : alt_fvs)
453
454     do_alg_alt :: (Id, [Id], CoreExpr)
455                -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
456
457     do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
458       where
459         new_in_scope = in_scope `combine` arg_set
460         (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
461         fvs = rhs_fvs `minusIdSet` arg_set
462         arg_set = mkIdSet args
463
464     do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
465       where
466         (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
467
468     do_deflt NoDefault = (NoDefault, noFreeIds)
469     do_deflt (BindDefault var rhs)
470       = (BindDefault (var,fvs) rhs', fvs)
471       where
472         new_in_scope = in_scope `combine` var_set
473         (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
474         fvs = rhs_fvs `minusIdSet` var_set
475         var_set = aFreeId var
476
477 addExprFVs fv_cand in_scope (Let binds body)
478   = (Let binds' body2, fvs_binds `combine` (fvs_body `minusIdSet` binder_set))
479   where
480     (binds', fvs_binds, new_in_scope, binder_set)
481       = addBindingFVs fv_cand in_scope binds
482
483     (body2, fvs_body)  = addExprFVs fv_cand new_in_scope body
484
485 addExprFVs fv_cand in_scope (SCC label expr)
486   = (SCC label expr2, expr_fvs)
487   where
488     (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
489
490 addExprFVs fv_cand in_scope (Coerce c ty expr)
491   = (Coerce c ty expr2, expr_fvs)
492   where
493     (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
494 \end{code}
495
496 \begin{code}
497 addBindingFVs
498             :: InterestingIdFun -- "Interesting id" predicate
499             -> IdSet            -- In scope ids
500             -> CoreBinding
501             -> (FVCoreBinding,
502                 IdSet,          -- Free vars of binding group
503                 IdSet,          -- Augmented in-scope Ids
504                 IdSet)          -- Set of Ids bound by this binding
505
506 addBindingFVs fv_cand in_scope (NonRec binder rhs)
507   = (NonRec binder' rhs', fvs, new_in_scope, binder_set)
508   where
509     ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
510     new_in_scope = in_scope `combine` binder_set
511     binder_set = aFreeId binder
512
513 addBindingFVs fv_cand in_scope (Rec pairs)
514   = (Rec pairs', unionManyIdSets fvs_s, new_in_scope, binder_set)
515   where
516     binders = [binder | (binder,_) <- pairs]
517     binder_set = mkIdSet binders
518     new_in_scope = in_scope `combine` binder_set
519     (pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
520 \end{code}
521
522 \begin{code}
523 addTopBindsFVs
524             :: InterestingIdFun -- "Interesting id" predicate
525             -> [CoreBinding]
526             -> ([FVCoreBinding],
527                 IdSet)
528
529 addTopBindsFVs fv_cand [] = ([], noFreeIds)
530 addTopBindsFVs fv_cand (b:bs)
531   = let
532       (b',  fvs_b, _, _) = addBindingFVs fv_cand noFreeIds b
533       (bs', fvs_bs)      = addTopBindsFVs fv_cand bs
534     in
535     (b' : bs', fvs_b `combine` fvs_bs)
536 \end{code}
537
538 \begin{code}
539 fvsOfArgs   :: InterestingIdFun -- "Interesting id" predicate
540             -> IdSet            -- In scope ids
541             -> [CoreArg]
542             -> IdSet
543
544 fvsOfArgs _ _ [] = noFreeIds
545
546 fvsOfArgs fv_cand in_scope [VarArg v] -- this is only a short-cut...
547   = if (fv_cand in_scope v) then aFreeId v else noFreeIds
548 fvsOfArgs _       _        [ _ ] = noFreeIds
549
550 fvsOfArgs fv_cand in_scope args
551   = mkIdSet [ v | (VarArg v) <- args, fv_cand in_scope v ]
552     -- all other types of args are uninteresting here...
553
554 ----------
555 do_pair :: InterestingIdFun -- "Interesting id" predicate
556         -> IdSet            -- In scope ids
557         -> IdSet
558         -> (Id, CoreExpr)
559         -> ((FVCoreBinder, FVCoreExpr), IdSet)
560
561 do_pair fv_cand in_scope binder_set (binder,rhs)
562  = (((binder, fvs), rhs'), fvs)
563  where
564    (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
565    fvs = rhs_fvs `minusIdSet` binder_set
566 \end{code}