[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / simplStg / StgVarInfo.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
3 %
4 \section[StgVarInfo]{Sets free/live variable info in STG syntax}
5
6 And, as we have the info in hand, we may convert some lets to
7 let-no-escapes.
8
9 \begin{code}
10 #include "HsVersions.h"
11
12 module StgVarInfo ( setStgVarInfo ) where
13
14 IMPORT_Trace            -- ToDo: rm (debugging only)
15 import Pretty
16 import Outputable
17
18 import StgSyn
19
20 import Id               ( getIdArity, externallyVisibleId )
21 import IdInfo           -- ( arityMaybe, ArityInfo )
22
23 import IdEnv
24 import Maybes           ( maybeToBool, Maybe(..) )
25 import UniqSet
26 import Util
27
28 infixr 9 `thenLne`, `thenLne_`
29 \end{code}
30
31 %************************************************************************
32 %*                                                                      *
33 \subsection[live-vs-free-doc]{Documentation}
34 %*                                                                      *
35 %************************************************************************
36
37 (There is other relevant documentation in codeGen/CgLetNoEscape.)
38
39 The actual Stg datatype is decorated with {\em live variable}
40 information, as well as {\em free variable} information.  The two are
41 {\em not} the same.  Liveness is an operational property rather than a
42 semantic one.  A variable is live at a particular execution point if
43 it can be referred to {\em directly} again.  In particular, a dead
44 variable's stack slot (if it has one):
45 \begin{enumerate}
46 \item
47 should be stubbed to avoid space leaks, and 
48 \item
49 may be reused for something else.
50 \end{enumerate}
51
52 There ought to be a better way to say this.  Here are some examples:
53 \begin{verbatim}
54         let v = [q] \[x] -> e
55         in 
56         ...v...  (but no q's)
57 \end{verbatim}
58
59 Just after the `in', v is live, but q is dead.  If the whole of that
60 let expression was enclosed in a case expression, thus:
61 \begin{verbatim}
62         case (let v = [q] \[x] -> e in ...v...) of 
63                 alts[...q...]
64 \end{verbatim}
65 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
66 we'll return later to the @alts@ and need it.
67
68 Let-no-escapes make this a bit more interesting:
69 \begin{verbatim}
70         let-no-escape v = [q] \ [x] -> e
71         in 
72         ...v...
73 \end{verbatim}
74 Here, @q@ is still live at the `in', because @v@ is represented not by
75 a closure but by the current stack state.  In other words, if @v@ is
76 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
77 let-no-escaped variable, then {\em its} free variables are also live
78 if @v@ is.
79
80 %************************************************************************
81 %*                                                                      *
82 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
83 %*                                                                      *
84 %************************************************************************
85
86 Top-level:
87 \begin{code}
88 setStgVarInfo   :: Bool                 -- True <=> do let-no-escapes
89                 -> [PlainStgBinding]    -- input
90                 -> [PlainStgBinding]    -- result
91
92 setStgVarInfo want_LNEs pgm 
93   = pgm' 
94   where
95     (pgm', _) = initLne want_LNEs (varsTopBinds pgm)
96     
97 \end{code}
98
99 For top-level guys, we basically aren't worried about this
100 live-variable stuff; we do need to keep adding to the environment
101 as we step through the bindings (using @extendVarEnv@).
102
103 \begin{code}
104 varsTopBinds :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo)
105
106 varsTopBinds [] = returnLne ([], emptyFVInfo)
107 varsTopBinds (bind:binds)
108   = extendVarEnv env_extension (
109         varsTopBinds binds              `thenLne` \ (binds', fv_binds) ->
110         varsTopBind fv_binds bind       `thenLne` \ (bind',  fv_bind) ->
111         returnLne ((bind' : binds'),
112                    (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
113                   )
114                    
115     )
116   where
117     env_extension = [(b, LetrecBound 
118                                 True {- top level -}
119                                 (rhsArity rhs)
120                                 emptyUniqSet)
121                     | (b,rhs) <- pairs]
122
123     pairs         = case bind of
124                         StgNonRec binder rhs -> [(binder,rhs)]
125                         StgRec pairs         -> pairs
126
127     binders = [b | (b,_) <- pairs]
128
129
130 varsTopBind :: FreeVarsInfo             -- Info about the body
131             -> PlainStgBinding
132             -> LneM (PlainStgBinding, FreeVarsInfo)
133
134 varsTopBind body_fvs (StgNonRec binder rhs)
135   = varsRhs body_fvs (binder,rhs)               `thenLne` \ (rhs2, fvs, _) ->
136     returnLne (StgNonRec binder rhs2, fvs)
137
138 varsTopBind body_fvs (StgRec pairs)
139   = let
140         (binders, rhss) = unzip pairs
141     in
142     fixLne (\ ~(_, rec_rhs_fvs) ->
143         let 
144                 scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
145         in
146         mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
147         let
148                 fvs = unionFVInfos fvss
149         in
150         returnLne (StgRec (binders `zip` rhss2), fvs)
151     )
152
153 \end{code}
154
155 \begin{code}
156 varsRhs :: FreeVarsInfo         -- Free var info for the scope of the binding
157         -> (Id,PlainStgRhs)
158         -> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet)
159
160 varsRhs scope_fv_info (binder, StgRhsCon cc con args)
161   = varsAtoms args      `thenLne` \ fvs ->
162     returnLne (StgRhsCon cc con args, fvs, getFVSet fvs)
163
164 varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body) 
165   = extendVarEnv [ (a, LambdaBound) | a <- args ] (
166     do_body args body   `thenLne` \ (body2, body_fvs, body_escs) ->
167     let
168         set_of_args     = mkUniqSet args
169         rhs_fvs         = body_fvs  `minusFVBinders` args
170         rhs_escs        = body_escs `minusUniqSet`   set_of_args
171         binder_info     = lookupFVInfo scope_fv_info binder
172     in
173     returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, 
174                rhs_fvs, rhs_escs)
175     )
176   where
177         -- Pick out special case of application in body of thunk
178     do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args
179     do_body _ other_body                      = varsExpr other_body
180 \end{code}
181
182 \begin{code}
183 varsAtoms :: [PlainStgAtom]
184           -> LneM FreeVarsInfo
185
186 varsAtoms atoms
187   = mapLne var_atom atoms       `thenLne` \ fvs_lists ->
188     returnLne (unionFVInfos fvs_lists)
189   where
190     var_atom a@(StgLitAtom         _) = returnLne emptyFVInfo
191     var_atom a@(StgVarAtom v)
192       = lookupVarEnv v  `thenLne` \ how_bound ->
193         returnLne (singletonFVInfo v how_bound stgArgOcc)
194 \end{code}
195
196 %************************************************************************
197 %*                                                                      *
198 \subsection[expr-StgVarInfo]{Setting variable info on expressions}
199 %*                                                                      *
200 %************************************************************************
201
202 @varsExpr@ carries in a monad-ised environment, which binds each
203 let(rec) variable (ie non top level, not imported, not lambda bound,
204 not case-alternative bound) to:
205         - its STG arity, and 
206         - its set of live vars.  
207 For normal variables the set of live vars is just the variable
208 itself.  For let-no-escaped variables, the set of live vars is the set
209 live at the moment the variable is entered.  The set is guaranteed to
210 have no further let-no-escaped vars in it.
211
212 \begin{code}
213 varsExpr :: PlainStgExpr
214          -> LneM (PlainStgExpr, -- Decorated expr
215                   FreeVarsInfo, -- Its free vars (NB free, not live)
216                   EscVarsSet)   -- Its escapees, a subset of its free vars;
217                                 -- also a subset of the domain of the envt
218                                 -- because we are only interested in the escapees
219                                 -- for vars which might be turned into 
220                                 -- let-no-escaped ones.
221 \end{code}
222
223 The second and third components can be derived in a simple bottom up pass, not
224 dependent on any decisions about which variables will be let-no-escaped or
225 not.  The first component, that is, the decorated expression, may then depend
226 on these components, but it in turn is not scrutinised as the basis for any
227 decisions.  Hence no black holes.
228
229 \begin{code}
230 varsExpr (StgApp lit@(StgLitAtom _) args _)
231   = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) (
232     returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet)
233     --)
234
235 varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args
236
237 varsExpr (StgConApp con args _) 
238   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
239     varsAtoms args              `thenLne` \ args_fvs ->
240
241     returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs)
242
243 varsExpr (StgPrimApp op args _) 
244   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
245     varsAtoms args              `thenLne` \ args_fvs ->
246
247     returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs)
248
249 varsExpr (StgSCC ty label expr)
250   = varsExpr expr               `thenLne` ( \ (expr2, fvs, escs) ->
251     returnLne (StgSCC ty label expr2, fvs, escs) )
252 \end{code}
253
254 Cases require a little more real work.
255 \begin{code}
256 varsExpr (StgCase scrut _ _ uniq alts)
257   = getVarsLiveInCont             `thenLne` \ live_in_cont ->
258     vars_alts alts                `thenLne` \ (alts2, alts_fvs, alts_escs) ->
259     lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
260     let
261         live_in_alts = live_in_cont `unionUniqSets` alts_lvs
262     in
263         -- we tell the scrutinee that everything live in the alts
264         -- is live in it, too.
265     setVarsLiveInCont live_in_alts (
266         varsExpr scrut
267     )                              `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
268     lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
269     let
270         live_in_whole_case = live_in_alts `unionUniqSets` scrut_lvs
271     in
272     returnLne (
273       StgCase scrut2 live_in_whole_case live_in_alts uniq alts2,
274       scrut_fvs `unionFVInfo` alts_fvs,
275       alts_escs `unionUniqSets` (getFVSet scrut_fvs)   -- All free vars in the scrutinee escape
276     )
277   where
278     vars_alts (StgAlgAlts ty alts deflt)
279       = mapAndUnzip3Lne vars_alg_alt alts
280                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
281         let
282             alts_fvs  = unionFVInfos alts_fvs_list
283             alts_escs = unionManyUniqSets alts_escs_list
284         in
285         vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
286         returnLne (
287             StgAlgAlts ty alts2 deflt2,
288             alts_fvs  `unionFVInfo`   deflt_fvs,
289             alts_escs `unionUniqSets` deflt_escs
290         )
291       where
292         vars_alg_alt (con, binders, worthless_use_mask, rhs)
293           = extendVarEnv [(b, CaseBound) | b <- binders] (
294             varsExpr rhs        `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
295             let
296                 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
297                 -- records whether each param is used in the RHS
298             in
299             returnLne (
300                 (con, binders, good_use_mask, rhs2),
301                 rhs_fvs  `minusFVBinders` binders,
302                 rhs_escs `minusUniqSet`   mkUniqSet binders     -- ToDo: remove the minusUniqSet;
303                                                         -- since escs won't include
304                                                         -- any of these binders
305             ))
306
307     vars_alts (StgPrimAlts ty alts deflt)
308       = mapAndUnzip3Lne vars_prim_alt alts
309                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
310         let
311             alts_fvs  = unionFVInfos alts_fvs_list
312             alts_escs = unionManyUniqSets alts_escs_list
313         in
314         vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
315         returnLne (
316             StgPrimAlts ty alts2 deflt2,
317             alts_fvs  `unionFVInfo`   deflt_fvs,
318             alts_escs `unionUniqSets` deflt_escs
319         )
320       where
321         vars_prim_alt (lit, rhs)
322           = varsExpr rhs        `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
323             returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
324
325     vars_deflt StgNoDefault
326       = returnLne (StgNoDefault, emptyFVInfo, emptyUniqSet)
327
328     vars_deflt (StgBindDefault binder _ rhs)
329       = extendVarEnv [(binder, CaseBound)] (
330         varsExpr rhs    `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
331         let
332             used_in_rhs = binder `elementOfFVInfo` rhs_fvs
333         in
334         returnLne (
335             StgBindDefault binder used_in_rhs rhs2,
336             rhs_fvs  `minusFVBinders` [binder],
337             rhs_escs `minusUniqSet`   singletonUniqSet binder
338         ))
339 \end{code}
340
341 Lets not only take quite a bit of work, but this is where we convert
342 then to let-no-escapes, if we wish.
343
344 (Meanwhile, we don't expect to see let-no-escapes...)
345 \begin{code}
346 varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
347
348 varsExpr (StgLet bind body) 
349   = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
350
351     (fixLne (\ ~(_, _, _, no_binder_escapes) ->
352         let 
353             non_escaping_let = want_LNEs && no_binder_escapes
354         in
355         vars_let non_escaping_let bind body 
356     ))                                  `thenLne` \ (new_let, fvs, escs, _) ->
357
358     returnLne (new_let, fvs, escs)
359 \end{code}
360
361 \begin{code}
362 #ifdef DPH
363 -- rest of varsExpr goes here
364
365 #endif {- Data Parallel Haskell -}
366 \end{code}
367
368 Applications:
369 \begin{code}
370 varsApp :: Maybe UpdateFlag             -- Just upd <=> this application is
371                                         -- the rhs of a thunk binding
372                                         --      x = [...] \upd [] -> the_app
373                                         -- with specified update flag
374         -> Id                           -- Function
375         -> [PlainStgAtom]               -- Arguments
376         -> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet)
377
378 varsApp maybe_thunk_body f args
379   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
380
381     varsAtoms args              `thenLne` \ args_fvs ->
382   
383     lookupVarEnv f              `thenLne` \ how_bound ->
384    
385     let
386         n_args = length args
387
388         fun_fvs = singletonFVInfo f how_bound fun_occ
389
390         fun_occ =
391           case how_bound of 
392             LetrecBound _ arity _ 
393                 | n_args == 0 -> stgFakeFunAppOcc   -- Function Application
394                                                     -- with no arguments.
395                                                     -- used by the lambda lifter.
396                 | arity > n_args -> stgUnsatOcc     -- Unsaturated
397
398
399                 | arity == n_args &&
400                   maybeToBool maybe_thunk_body ->   -- Exactly saturated,
401                                                     -- and rhs of thunk
402                         case maybe_thunk_body of
403                                 Just Updatable   -> stgStdHeapOcc
404                                 Just SingleEntry -> stgNoUpdHeapOcc
405                                 other            -> panic "varsApp"
406
407                 | otherwise ->  stgNormalOcc
408                                 -- record only that it occurs free
409
410             other ->    NoStgBinderInfo
411                 -- uninteresting variable
412
413         myself = singletonUniqSet f
414
415         fun_escs = case how_bound of
416
417                      LetrecBound _ arity lvs -> 
418                        if arity == n_args then
419                           emptyUniqSet -- Function doesn't escape
420                        else
421                           myself -- Inexact application; it does escape
422
423                      other -> emptyUniqSet      -- Only letrec-bound escapees 
424                                                 -- are interesting
425
426         -- At the moment of the call:
427
428         --  either the function is *not* let-no-escaped, in which case
429         --         nothing is live except live_in_cont
430         --      or the function *is* let-no-escaped in which case the
431         --         variables it uses are live, but still the function
432         --         itself is not.  PS.  In this case, the function's
433         --         live vars should already include those of the
434         --         continuation, but it does no harm to just union the
435         --         two regardless.
436
437         live_at_call
438           = live_in_cont `unionUniqSets` case how_bound of
439                                    LetrecBound _ _ lvs -> lvs `minusUniqSet` myself
440                                    other               -> emptyUniqSet
441     in
442     returnLne (
443         StgApp (StgVarAtom f) args live_at_call,
444         fun_fvs  `unionFVInfo` args_fvs,
445         fun_escs `unionUniqSets` (getFVSet args_fvs)    
446                                 -- All the free vars of the args are disqualified
447                                 -- from being let-no-escaped.
448     )
449 \end{code}
450
451 The magic for lets:
452 \begin{code}
453 vars_let :: Bool                -- True <=> yes, we are let-no-escaping this let
454          -> PlainStgBinding     -- bindings
455          -> PlainStgExpr        -- body
456          -> LneM (PlainStgExpr, -- new let
457                   FreeVarsInfo, -- variables free in the whole let
458                   EscVarsSet,   -- variables that escape from the whole let
459                   Bool)         -- True <=> none of the binders in the bindings
460                                 -- is among the escaping vars
461
462 vars_let let_no_escape bind body
463   = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
464
465         -- Do the bindings, setting live_in_cont to empty if
466         -- we ain't in a let-no-escape world
467         getVarsLiveInCont               `thenLne` \ live_in_cont ->
468         setVarsLiveInCont
469                 (if let_no_escape then live_in_cont else emptyUniqSet)
470                 (vars_bind rec_bind_lvs rec_body_fvs bind)
471                                         `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
472
473         -- The live variables of this binding are the ones which are live
474         -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
475         -- together with the live_in_cont ones
476         lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)        `thenLne` \ lvs_from_fvs ->
477         let 
478                 bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont
479         in
480
481         -- bind_fvs and bind_escs still include the binders of the let(rec)
482         -- but bind_lvs does not
483
484         -- Do the body
485         extendVarEnv env_ext (
486                 varsExpr body                   `thenLne` \ (body2, body_fvs, body_escs) ->
487                 lookupLiveVarsForSet body_fvs   `thenLne` \ body_lvs ->
488
489                 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
490                            body2, body_fvs, body_escs, body_lvs)
491
492     )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
493                      body2, body_fvs, body_escs, body_lvs) ->
494
495
496         -- Compute the new let-expression
497     let 
498         new_let = if let_no_escape then
499                      -- trace "StgLetNoEscape!" (
500                      StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
501                      -- )
502                   else
503                      StgLet bind2 body2
504
505         free_in_whole_let
506           = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
507
508         live_in_whole_let
509           = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders)
510
511         real_bind_escs = if let_no_escape then 
512                             bind_escs
513                          else
514                             getFVSet bind_fvs
515                             -- Everything escapes which is free in the bindings
516
517         let_escs = (real_bind_escs `unionUniqSets` body_escs) `minusUniqSet` set_of_binders
518
519         all_escs = bind_escs `unionUniqSets` body_escs  -- Still includes binders of
520                                                 -- this let(rec)
521
522         no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs)
523                 -- Mustn't depend on the passed-in let_no_escape flag, since 
524                 -- no_binder_escapes is used by the caller to derive the flag!
525     in
526     returnLne (
527         new_let,
528         free_in_whole_let,
529         let_escs,
530         no_binder_escapes
531     ))
532   where
533     binders             = case bind of
534                             StgNonRec binder rhs -> [binder]
535                             StgRec pairs         -> map fst pairs
536     set_of_binders      = mkUniqSet binders
537
538     mk_binding bind_lvs (binder,rhs)
539         = (binder,
540            LetrecBound  False           -- Not top level
541                         (stgArity rhs)
542                         live_vars
543           )
544         where
545            live_vars = if let_no_escape then 
546                             bind_lvs `unionUniqSets` singletonUniqSet binder
547                        else 
548                             singletonUniqSet binder
549
550     vars_bind :: PlainStgLiveVars
551               -> FreeVarsInfo                   -- Free var info for body of binding
552               -> PlainStgBinding
553               -> LneM (PlainStgBinding,
554                        FreeVarsInfo, EscVarsSet,        -- free vars; escapee vars
555                        [(Id, HowBound)])
556                                          -- extension to environment
557
558     vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs)
559       = varsRhs rec_body_fvs (binder,rhs)       `thenLne` \ (rhs2, fvs, escs) ->
560         let
561             env_ext = [mk_binding rec_bind_lvs (binder,rhs)]
562         in
563         returnLne (StgNonRec binder rhs2, fvs, escs, env_ext)
564
565     vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs)
566       = let
567             (binders, rhss) = unzip pairs
568             env_ext = map (mk_binding rec_bind_lvs) pairs
569         in
570         extendVarEnv env_ext              (
571         fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
572                 let 
573                         rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
574                 in
575                 mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
576                 let
577                         fvs  = unionFVInfos      fvss
578                         escs = unionManyUniqSets escss
579                 in
580                 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
581         ))
582 \end{code}
583
584 %************************************************************************
585 %*                                                                      *
586 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
587 %*                                                                      *
588 %************************************************************************
589
590 There's a lot of stuff to pass around, so we use this @LneM@ monad to
591 help.  All the stuff here is only passed {\em down}.
592
593 \begin{code}
594 type LneM a =  Bool                     -- True <=> do let-no-escapes
595             -> IdEnv HowBound
596             -> PlainStgLiveVars         -- vars live in continuation
597             -> a
598
599 type Arity = Int
600
601 data HowBound
602   = ImportBound
603   | CaseBound
604   | LambdaBound
605   | LetrecBound 
606         Bool                    -- True <=> bound at top level
607         Arity                   -- Arity
608         PlainStgLiveVars        -- Live vars... see notes below
609 \end{code}
610
611 For a let(rec)-bound variable, x,  we record what varibles are live if 
612 x is live.  For "normal" variables that is just x alone.  If x is 
613 a let-no-escaped variable then x is represented by a code pointer and
614 a stack pointer (well, one for each stack).  So all of the variables
615 needed in the execution of x are live if x is, and are therefore recorded
616 in the LetrecBound constructor; x itself *is* included.
617
618 The std monad functions:
619 \begin{code}
620 initLne :: Bool -> LneM a -> a
621 initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet
622
623 #ifdef __GLASGOW_HASKELL__
624 {-# INLINE thenLne #-}
625 {-# INLINE thenLne_ #-}
626 {-# INLINE returnLne #-}
627 #endif
628
629 returnLne :: a -> LneM a
630 returnLne e sw env lvs_cont = e
631
632 thenLne :: LneM a -> (a -> LneM b) -> LneM b
633 (m `thenLne` k) sw env lvs_cont
634   = case (m sw env lvs_cont) of
635       m_result -> k m_result sw env lvs_cont
636
637 thenLne_ :: LneM a -> LneM b -> LneM b
638 (m `thenLne_` k) sw env lvs_cont
639   = case (m sw env lvs_cont) of
640       _ -> k sw env lvs_cont
641
642 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
643 mapLne f [] = returnLne []
644 mapLne f (x:xs)
645   = f x         `thenLne` \ r  ->
646     mapLne f xs `thenLne` \ rs ->
647     returnLne (r:rs)
648
649 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
650
651 mapAndUnzipLne f [] = returnLne ([],[])
652 mapAndUnzipLne f (x:xs)
653   = f x                 `thenLne` \ (r1,  r2)  ->
654     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
655     returnLne (r1:rs1, r2:rs2)
656
657 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
658
659 mapAndUnzip3Lne f []    = returnLne ([],[],[])
660 mapAndUnzip3Lne f (x:xs)
661   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
662     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
663     returnLne (r1:rs1, r2:rs2, r3:rs3)
664
665 fixLne :: (a -> LneM a) -> LneM a
666 fixLne expr sw env lvs_cont = result
667   where
668     result = expr result sw env lvs_cont
669 --  ^^^^^^ ------ ^^^^^^
670 \end{code}
671
672 Functions specific to this monad:
673 \begin{code}
674 {- NOT USED:
675 ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a
676 ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont
677   = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont
678 -}
679
680 isSwitchSetLne :: LneM Bool
681 isSwitchSetLne want_LNEs env lvs_cont
682   = want_LNEs
683
684 getVarsLiveInCont :: LneM PlainStgLiveVars
685 getVarsLiveInCont sw env lvs_cont = lvs_cont
686
687 setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a
688 setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
689   = expr sw env new_lvs_cont
690
691 extendVarEnv :: [(Id, HowBound)] -> LneM a -> LneM a
692 extendVarEnv extension expr sw env lvs_cont
693   = expr sw (growIdEnvList env extension) lvs_cont
694
695 lookupVarEnv :: Id -> LneM HowBound
696 lookupVarEnv v sw env lvs_cont
697   = returnLne (
698       case (lookupIdEnv env v) of
699         Just xx -> xx
700         Nothing -> --false:ASSERT(not (isLocallyDefined v))
701                    ImportBound
702     ) sw env lvs_cont
703
704 -- The result of lookupLiveVarsForSet, a set of live variables, is
705 -- only ever tacked onto a decorated expression. It is never used as
706 -- the basis of a control decision, which might give a black hole.
707
708 lookupLiveVarsForSet :: FreeVarsInfo -> LneM PlainStgLiveVars
709
710 lookupLiveVarsForSet fvs sw env lvs_cont
711   = returnLne (unionManyUniqSets (map do_one (getFVs fvs)))
712               sw env lvs_cont
713   where
714     do_one v
715       = if isLocallyDefined v then
716             case (lookupIdEnv env v) of
717               Just (LetrecBound _ _ lvs) -> lvs `unionUniqSets` singletonUniqSet v
718               Just _                     -> singletonUniqSet v
719               Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v)
720         else
721             emptyUniqSet
722 \end{code}
723
724
725 %************************************************************************
726 %*                                                                      *
727 \subsection[Free-var info]{Free variable information}
728 %*                                                                      *
729 %************************************************************************
730
731 \begin{code}
732 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)     
733                         -- If f is mapped to NoStgBinderInfo, that means
734                         -- that f *is* mentioned (else it wouldn't be in the
735                         -- IdEnv at all), but only in a saturated applications.
736                         -- 
737                         -- All case/lambda-bound things are also mapped to
738                         -- NoStgBinderInfo, since we aren't interested in their
739                         -- occurence info.
740                         --
741                         -- The Bool is True <=> the Id is top level letrec bound
742
743 type EscVarsSet   = UniqSet Id
744 \end{code}
745
746 \begin{code}
747 emptyFVInfo :: FreeVarsInfo
748 emptyFVInfo = nullIdEnv
749
750 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
751 singletonFVInfo id ImportBound                 info = nullIdEnv
752 singletonFVInfo id (LetrecBound top_level _ _) info = unitIdEnv id (id, top_level, info)
753 singletonFVInfo id other                       info = unitIdEnv id (id, False,     info)
754
755 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
756 unionFVInfo fv1 fv2 = combineIdEnvs plusFVInfo fv1 fv2
757
758 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
759 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
760
761 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
762 minusFVBinders fv ids = fv `delManyFromIdEnv` ids
763
764 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
765 elementOfFVInfo id fvs = maybeToBool (lookupIdEnv fvs id)
766
767 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
768 lookupFVInfo fvs id = case lookupIdEnv fvs id of
769                         Nothing         -> NoStgBinderInfo
770                         Just (_,_,info) -> info
771
772 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
773 getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs]
774
775 getFVSet :: FreeVarsInfo -> UniqSet Id
776 getFVSet fvs = mkUniqSet (getFVs fvs)
777
778 plusFVInfo (id1,top1,info1) (id2,top2,info2)
779   = ASSERT (id1 == id2 && top1 == top2)
780     (id1, top1, combineStgBinderInfo info1 info2)
781 \end{code}
782
783 \begin{code}
784 rhsArity :: PlainStgRhs -> Arity
785 rhsArity (StgRhsCon _ _ _)              = 0
786 rhsArity (StgRhsClosure _ _ _ _ args _) = length args
787 \end{code}
788
789
790