2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[StgVarInfo]{Sets free/live variable info in STG syntax}
6 And, as we have the info in hand, we may convert some lets to
10 module StgVarInfo ( setStgVarInfo ) where
12 #include "HsVersions.h"
16 import Id ( isLocalId, setIdArityInfo, idArity, setIdOccInfo, Id )
20 import IdInfo ( ArityInfo(..), OccInfo(..) )
21 import PrimOp ( PrimOp(..), ccallMayGC )
22 import TysWiredIn ( isForeignObjTy )
23 import Maybes ( maybeToBool, orElse )
24 import Name ( isLocalName, getOccName )
25 import OccName ( occNameUserString )
26 import BasicTypes ( Arity )
29 infixr 9 `thenLne`, `thenLne_`
32 %************************************************************************
34 \subsection[live-vs-free-doc]{Documentation}
36 %************************************************************************
38 (There is other relevant documentation in codeGen/CgLetNoEscape.)
40 March 97: setStgVarInfo guarantees to leave every variable's arity correctly
41 set. The lambda lifter makes some let-bound variables (which have arities)
42 and turns them into lambda-bound ones (which should not, else we get Vap trouble),
43 so this guarantee is necessary, as well as desirable.
45 The arity information is used in the code generator, when deciding if
46 a right-hand side is a saturated application so we can generate a VAP
49 The actual Stg datatype is decorated with {\em live variable}
50 information, as well as {\em free variable} information. The two are
51 {\em not} the same. Liveness is an operational property rather than a
52 semantic one. A variable is live at a particular execution point if
53 it can be referred to {\em directly} again. In particular, a dead
54 variable's stack slot (if it has one):
57 should be stubbed to avoid space leaks, and
59 may be reused for something else.
62 There ought to be a better way to say this. Here are some examples:
69 Just after the `in', v is live, but q is dead. If the whole of that
70 let expression was enclosed in a case expression, thus:
72 case (let v = [q] \[x] -> e in ...v...) of
75 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
76 we'll return later to the @alts@ and need it.
78 Let-no-escapes make this a bit more interesting:
80 let-no-escape v = [q] \ [x] -> e
84 Here, @q@ is still live at the `in', because @v@ is represented not by
85 a closure but by the current stack state. In other words, if @v@ is
86 live then so is @q@. Furthermore, if @e@ mentions an enclosing
87 let-no-escaped variable, then {\em its} free variables are also live
90 %************************************************************************
92 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
94 %************************************************************************
98 setStgVarInfo :: Bool -- True <=> do let-no-escapes
99 -> [StgBinding] -- input
100 -> [StgBinding] -- result
102 setStgVarInfo want_LNEs pgm
105 (pgm', _) = initLne want_LNEs (varsTopBinds pgm)
109 For top-level guys, we basically aren't worried about this
110 live-variable stuff; we do need to keep adding to the environment
111 as we step through the bindings (using @extendVarEnv@).
114 varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo)
116 varsTopBinds [] = returnLne ([], emptyFVInfo)
117 varsTopBinds (bind:binds)
118 = extendVarEnvLne env_extension (
119 varsTopBinds binds `thenLne` \ (binds', fv_binds) ->
120 varsTopBind binders' fv_binds bind `thenLne` \ (bind', fv_bind) ->
121 returnLne ((bind' : binds'),
122 (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders'
128 StgNonRec binder rhs -> [(binder,rhs)]
129 StgRec pairs -> pairs
131 binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs)
132 | (binder, rhs) <- pairs
135 env_extension = binders' `zip` repeat how_bound
137 how_bound = LetrecBound
142 varsTopBind :: [Id] -- New binders (with correct arity)
143 -> FreeVarsInfo -- Info about the body
145 -> LneM (StgBinding, FreeVarsInfo)
147 varsTopBind [binder'] body_fvs (StgNonRec binder rhs)
148 = varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
149 returnLne (StgNonRec binder' rhs2, fvs)
151 varsTopBind binders' body_fvs (StgRec pairs)
152 = fixLne (\ ~(_, rec_rhs_fvs) ->
154 scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
156 mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
158 fvs = unionFVInfos fvss
160 returnLne (StgRec (binders' `zip` rhss2), fvs)
166 varsRhs :: FreeVarsInfo -- Free var info for the scope of the binding
168 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
170 varsRhs scope_fv_info (binder, StgRhsCon cc con args)
171 = varsAtoms args `thenLne` \ (args', fvs) ->
172 returnLne (StgRhsCon cc con args', fvs, getFVSet fvs)
174 varsRhs scope_fv_info (binder, StgRhsClosure cc _ srt _ upd args body)
175 = extendVarEnvLne [ (zapArity a, LambdaBound) | a <- args ] (
176 do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
178 set_of_args = mkVarSet args
179 rhs_fvs = body_fvs `minusFVBinders` args
180 rhs_escs = body_escs `minusVarSet` set_of_args
181 binder_info = lookupFVInfo scope_fv_info binder
182 upd' | null args && isPAP body2 = ReEntrant
185 returnLne (StgRhsClosure cc binder_info srt (getFVs rhs_fvs) upd'
186 args body2, rhs_fvs, rhs_escs)
189 -- Pick out special case of application in body of thunk
190 do_body [] (StgApp f args) = varsApp (Just upd) f args
191 do_body _ other_body = varsExpr other_body
194 Detect thunks which will reduce immediately to PAPs, and make them
195 non-updatable. This has several advantages:
197 - the non-updatable thunk behaves exactly like the PAP,
199 - the thunk is more efficient to enter, because it is
200 specialised to the task.
202 - we save one update frame, one stg_update_PAP, one update
203 and lots of PAP_enters.
205 - in the case where the thunk is top-level, we save building
206 a black hole and futhermore the thunk isn't considered to
207 be a CAF any more, so it doesn't appear in any SRTs.
209 We do it here, because the arity information is accurate, and we need
210 to do it before the SRT pass to save the SRT entries associated with
214 isPAP (StgApp f args) = idArity f > length args
219 varsAtoms :: [StgArg]
220 -> LneM ([StgArg], FreeVarsInfo)
221 -- It's not *really* necessary to return fresh arguments,
222 -- because the only difference is that the argument variable
223 -- arities are correct. But it seems safer to do so.
226 = mapAndUnzipLne var_atom atoms `thenLne` \ (args', fvs_lists) ->
227 returnLne (args', unionFVInfos fvs_lists)
229 var_atom a@(StgVarArg v)
230 = lookupVarLne v `thenLne` \ (v', how_bound) ->
231 returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc)
232 var_atom a = returnLne (a, emptyFVInfo)
235 %************************************************************************
237 \subsection[expr-StgVarInfo]{Setting variable info on expressions}
239 %************************************************************************
241 @varsExpr@ carries in a monad-ised environment, which binds each
242 let(rec) variable (ie non top level, not imported, not lambda bound,
243 not case-alternative bound) to:
245 - its set of live vars.
246 For normal variables the set of live vars is just the variable
247 itself. For let-no-escaped variables, the set of live vars is the set
248 live at the moment the variable is entered. The set is guaranteed to
249 have no further let-no-escaped vars in it.
253 -> LneM (StgExpr, -- Decorated expr
254 FreeVarsInfo, -- Its free vars (NB free, not live)
255 EscVarsSet) -- Its escapees, a subset of its free vars;
256 -- also a subset of the domain of the envt
257 -- because we are only interested in the escapees
258 -- for vars which might be turned into
259 -- let-no-escaped ones.
262 The second and third components can be derived in a simple bottom up pass, not
263 dependent on any decisions about which variables will be let-no-escaped or
264 not. The first component, that is, the decorated expression, may then depend
265 on these components, but it in turn is not scrutinised as the basis for any
266 decisions. Hence no black holes.
269 varsExpr (StgLit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
271 varsExpr (StgApp f args) = varsApp Nothing f args
273 varsExpr (StgConApp con args)
274 = varsAtoms args `thenLne` \ (args', args_fvs) ->
275 returnLne (StgConApp con args', args_fvs, getFVSet args_fvs)
277 varsExpr (StgPrimApp op args res_ty)
278 = varsAtoms args `thenLne` \ (args', args_fvs) ->
279 returnLne (StgPrimApp op args' res_ty, args_fvs, getFVSet args_fvs)
281 varsExpr (StgSCC cc expr)
282 = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
283 returnLne (StgSCC cc expr2, fvs, escs) )
286 Cases require a little more real work.
288 varsExpr (StgCase scrut _ _ bndr srt alts)
289 = getVarsLiveInCont `thenLne` \ live_in_cont ->
290 extendVarEnvLne [(zapArity bndr, CaseBound)] (
291 vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
292 lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
294 -- determine whether the default binder is dead or not
295 bndr'= if (bndr `elementOfFVInfo` alts_fvs)
296 then bndr `setIdOccInfo` NoOccInfo
297 else bndr `setIdOccInfo` IAmDead
299 -- for a _ccall_GC_, some of the *arguments* need to live across the
300 -- call (see findLiveArgs comments.), so we annotate them as being live
301 -- in the alts to achieve the desired effect.
302 mb_live_across_case =
304 StgPrimApp (CCallOp ccall) args _
306 -> Just (foldl findLiveArgs emptyVarSet args)
309 -- don't consider the default binder as being 'live in alts',
310 -- since this is from the point of view of the case expr, where
311 -- the default binder is not free.
312 live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
313 live_in_cont `unionVarSet`
314 (alts_lvs `minusVarSet` unitVarSet bndr)
316 -- we tell the scrutinee that everything live in the alts
317 -- is live in it, too.
318 setVarsLiveInCont live_in_alts (
320 ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
321 lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
323 live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
326 StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
327 (scrut_fvs `unionFVInfo` alts_fvs)
328 `minusFVBinders` [bndr],
329 (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
330 -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
331 -- but actually we can't call, and then return from, a let-no-escape thing.
335 vars_alts (StgAlgAlts tycon alts deflt)
336 = mapAndUnzip3Lne vars_alg_alt alts
337 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
339 alts_fvs = unionFVInfos alts_fvs_list
340 alts_escs = unionVarSets alts_escs_list
342 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
344 StgAlgAlts tycon alts2 deflt2,
345 alts_fvs `unionFVInfo` deflt_fvs,
346 alts_escs `unionVarSet` deflt_escs
349 vars_alg_alt (con, binders, worthless_use_mask, rhs)
350 = extendVarEnvLne [(zapArity b, CaseBound) | b <- binders] (
351 varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
353 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
354 -- records whether each param is used in the RHS
357 (con, binders, good_use_mask, rhs2),
358 rhs_fvs `minusFVBinders` binders,
359 rhs_escs `minusVarSet` mkVarSet binders -- ToDo: remove the minusVarSet;
360 -- since escs won't include
361 -- any of these binders
364 vars_alts (StgPrimAlts tycon alts deflt)
365 = mapAndUnzip3Lne vars_prim_alt alts
366 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
368 alts_fvs = unionFVInfos alts_fvs_list
369 alts_escs = unionVarSets alts_escs_list
371 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
373 StgPrimAlts tycon alts2 deflt2,
374 alts_fvs `unionFVInfo` deflt_fvs,
375 alts_escs `unionVarSet` deflt_escs
378 vars_prim_alt (lit, rhs)
379 = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
380 returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
382 vars_deflt StgNoDefault
383 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
385 vars_deflt (StgBindDefault rhs)
386 = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
387 returnLne ( StgBindDefault rhs2, rhs_fvs, rhs_escs )
390 Lets not only take quite a bit of work, but this is where we convert
391 then to let-no-escapes, if we wish.
393 (Meanwhile, we don't expect to see let-no-escapes...)
395 varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
397 varsExpr (StgLet bind body)
398 = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
400 (fixLne (\ ~(_, _, _, no_binder_escapes) ->
402 non_escaping_let = want_LNEs && no_binder_escapes
404 vars_let non_escaping_let bind body
405 )) `thenLne` \ (new_let, fvs, escs, _) ->
407 returnLne (new_let, fvs, escs)
410 If we've got a case containing a _ccall_GC_ primop, we need to
411 ensure that the arguments are kept live for the duration of the
412 call. This only an issue
415 findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars
416 findLiveArgs lvs (StgVarArg x)
417 | isForeignObjTy (idType x) = extendVarSet lvs x
419 findLiveArgs lvs arg = lvs
425 varsApp :: Maybe UpdateFlag -- Just upd <=> this application is
426 -- the rhs of a thunk binding
427 -- x = [...] \upd [] -> the_app
428 -- with specified update flag
430 -> [StgArg] -- Arguments
431 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
433 varsApp maybe_thunk_body f args
434 = getVarsLiveInCont `thenLne` \ live_in_cont ->
436 varsAtoms args `thenLne` \ (args', args_fvs) ->
438 lookupVarLne f `thenLne` \ (f', how_bound) ->
442 not_letrec_bound = not (isLetrecBound how_bound)
443 f_arity = idArity f' -- Will have an exact arity by now
444 fun_fvs = singletonFVInfo f' how_bound fun_occ
447 | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
449 -- Otherwise it is letrec bound; must have its arity
450 | n_args == 0 = stgFakeFunAppOcc -- Function Application
451 -- with no arguments.
452 -- used by the lambda lifter.
453 | f_arity > n_args = stgUnsatOcc -- Unsaturated
456 | f_arity == n_args &&
457 maybeToBool maybe_thunk_body -- Exactly saturated,
459 = case maybe_thunk_body of
460 Just Updatable -> stgStdHeapOcc
461 Just SingleEntry -> stgNoUpdHeapOcc
462 other -> panic "varsApp"
464 | otherwise = stgNormalOcc
465 -- Record only that it occurs free
467 myself = unitVarSet f'
469 fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
470 | f_arity == n_args = emptyVarSet -- Function doesn't escape
471 | otherwise = myself -- Inexact application; it does escape
473 -- At the moment of the call:
475 -- either the function is *not* let-no-escaped, in which case
476 -- nothing is live except live_in_cont
477 -- or the function *is* let-no-escaped in which case the
478 -- variables it uses are live, but still the function
479 -- itself is not. PS. In this case, the function's
480 -- live vars should already include those of the
481 -- continuation, but it does no harm to just union the
486 -- = live_in_cont `unionVarSet` case how_bound of
487 -- LetrecBound _ lvs -> lvs `minusVarSet` myself
488 -- other -> emptyVarSet
492 fun_fvs `unionFVInfo` args_fvs,
493 fun_escs `unionVarSet` (getFVSet args_fvs)
494 -- All the free vars of the args are disqualified
495 -- from being let-no-escaped.
501 vars_let :: Bool -- True <=> yes, we are let-no-escaping this let
502 -> StgBinding -- bindings
504 -> LneM (StgExpr, -- new let
505 FreeVarsInfo, -- variables free in the whole let
506 EscVarsSet, -- variables that escape from the whole let
507 Bool) -- True <=> none of the binders in the bindings
508 -- is among the escaping vars
510 vars_let let_no_escape bind body
511 = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
513 -- Do the bindings, setting live_in_cont to empty if
514 -- we ain't in a let-no-escape world
515 getVarsLiveInCont `thenLne` \ live_in_cont ->
517 (if let_no_escape then live_in_cont else emptyVarSet)
518 (vars_bind rec_bind_lvs rec_body_fvs bind)
519 `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
521 -- The live variables of this binding are the ones which are live
522 -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
523 -- together with the live_in_cont ones
524 lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs ->
526 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
529 -- bind_fvs and bind_escs still include the binders of the let(rec)
530 -- but bind_lvs does not
533 extendVarEnvLne env_ext (
534 varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
535 lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
537 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
538 body2, body_fvs, body_escs, body_lvs)
540 )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
541 body2, body_fvs, body_escs, body_lvs) ->
544 -- Compute the new let-expression
546 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
547 | otherwise = StgLet bind2 body2
550 = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
553 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
555 real_bind_escs = if let_no_escape then
559 -- Everything escapes which is free in the bindings
561 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
563 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
566 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
569 -- Debugging code as requested by Andrew Kennedy
570 checked_no_binder_escapes
571 | not no_binder_escapes && any is_join_var binders
572 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
574 | otherwise = no_binder_escapes
576 checked_no_binder_escapes = no_binder_escapes
579 -- Mustn't depend on the passed-in let_no_escape flag, since
580 -- no_binder_escapes is used by the caller to derive the flag!
586 checked_no_binder_escapes
589 set_of_binders = mkVarSet binders
590 binders = case bind of
591 StgNonRec binder rhs -> [binder]
592 StgRec pairs -> map fst pairs
594 mk_binding bind_lvs (binder,rhs)
595 = (binder `setIdArityInfo` ArityExactly (stgArity rhs),
596 LetrecBound False -- Not top level
600 live_vars = if let_no_escape then
601 extendVarSet bind_lvs binder
605 vars_bind :: StgLiveVars
606 -> FreeVarsInfo -- Free var info for body of binding
609 FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
611 -- extension to environment
613 vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs)
614 = varsRhs rec_body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, escs) ->
616 env_ext_item@(binder', _) = mk_binding rec_bind_lvs (binder,rhs)
618 returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
620 vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs)
622 env_ext = map (mk_binding rec_bind_lvs) pairs
623 binders' = map fst env_ext
625 extendVarEnvLne env_ext (
626 fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
628 rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
630 mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
632 fvs = unionFVInfos fvss
633 escs = unionVarSets escss
635 returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
638 is_join_var :: Id -> Bool
639 -- A hack (used only for compiler debuggging) to tell if
640 -- a variable started life as a join point ($j)
641 is_join_var j = occNameUserString (getOccName j) == "$j"
644 %************************************************************************
646 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
648 %************************************************************************
650 There's a lot of stuff to pass around, so we use this @LneM@ monad to
651 help. All the stuff here is only passed {\em down}.
654 type LneM a = Bool -- True <=> do let-no-escapes
655 -> IdEnv (Id, HowBound) -- Use the Id at all occurrences; it has correct
656 -- arity information inside it.
657 -> StgLiveVars -- vars live in continuation
665 Bool -- True <=> bound at top level
666 StgLiveVars -- Live vars... see notes below
668 isLetrecBound (LetrecBound _ _) = True
669 isLetrecBound other = False
672 For a let(rec)-bound variable, x, we record what varibles are live if
673 x is live. For "normal" variables that is just x alone. If x is
674 a let-no-escaped variable then x is represented by a code pointer and
675 a stack pointer (well, one for each stack). So all of the variables
676 needed in the execution of x are live if x is, and are therefore recorded
677 in the LetrecBound constructor; x itself *is* included.
679 The std monad functions:
681 initLne :: Bool -> LneM a -> a
682 initLne want_LNEs m = m want_LNEs emptyVarEnv emptyVarSet
684 {-# INLINE thenLne #-}
685 {-# INLINE thenLne_ #-}
686 {-# INLINE returnLne #-}
688 returnLne :: a -> LneM a
689 returnLne e sw env lvs_cont = e
691 thenLne :: LneM a -> (a -> LneM b) -> LneM b
692 thenLne m k sw env lvs_cont
693 = case (m sw env lvs_cont) of
694 m_result -> k m_result sw env lvs_cont
696 thenLne_ :: LneM a -> LneM b -> LneM b
697 thenLne_ m k sw env lvs_cont
698 = case (m sw env lvs_cont) of
699 _ -> k sw env lvs_cont
701 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
702 mapLne f [] = returnLne []
704 = f x `thenLne` \ r ->
705 mapLne f xs `thenLne` \ rs ->
708 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
710 mapAndUnzipLne f [] = returnLne ([],[])
711 mapAndUnzipLne f (x:xs)
712 = f x `thenLne` \ (r1, r2) ->
713 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
714 returnLne (r1:rs1, r2:rs2)
716 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
718 mapAndUnzip3Lne f [] = returnLne ([],[],[])
719 mapAndUnzip3Lne f (x:xs)
720 = f x `thenLne` \ (r1, r2, r3) ->
721 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
722 returnLne (r1:rs1, r2:rs2, r3:rs3)
724 fixLne :: (a -> LneM a) -> LneM a
725 fixLne expr sw env lvs_cont = result
727 result = expr result sw env lvs_cont
728 -- ^^^^^^ ------ ^^^^^^
731 Functions specific to this monad:
733 isSwitchSetLne :: LneM Bool
734 isSwitchSetLne want_LNEs env lvs_cont
737 getVarsLiveInCont :: LneM StgLiveVars
738 getVarsLiveInCont sw env lvs_cont = lvs_cont
740 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
741 setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
742 = expr sw env new_lvs_cont
744 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
745 extendVarEnvLne ids_w_howbound expr sw env lvs_cont
746 = expr sw (extendVarEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
749 lookupVarLne :: Id -> LneM (Id, HowBound)
750 lookupVarLne v sw env lvs_cont
752 case (lookupVarEnv env v) of
754 Nothing -> --false:ASSERT(not (isLocallyDefined v))
758 -- The result of lookupLiveVarsForSet, a set of live variables, is
759 -- only ever tacked onto a decorated expression. It is never used as
760 -- the basis of a control decision, which might give a black hole.
762 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
764 lookupLiveVarsForSet fvs sw env lvs_cont
765 = returnLne (unionVarSets (map do_one (getFVs fvs)))
769 = if isLocalId v then
770 case (lookupVarEnv env v) of
771 Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
772 Just _ -> unitVarSet v
773 Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
779 %************************************************************************
781 \subsection[Free-var info]{Free variable information}
783 %************************************************************************
786 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
787 -- If f is mapped to NoStgBinderInfo, that means
788 -- that f *is* mentioned (else it wouldn't be in the
789 -- IdEnv at all), but only in a saturated applications.
791 -- All case/lambda-bound things are also mapped to
792 -- NoStgBinderInfo, since we aren't interested in their
795 -- The Bool is True <=> the Id is top level letrec bound
797 type EscVarsSet = IdSet
801 emptyFVInfo :: FreeVarsInfo
802 emptyFVInfo = emptyVarEnv
804 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
805 singletonFVInfo id ImportBound info = emptyVarEnv
806 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
807 singletonFVInfo id other info = unitVarEnv id (id, False, info)
809 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
810 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
812 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
813 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
815 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
816 minusFVBinders fv ids = fv `delVarEnvList` ids
818 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
819 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
821 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
822 lookupFVInfo fvs id = case lookupVarEnv fvs id of
823 Nothing -> NoStgBinderInfo
824 Just (_,_,info) -> info
826 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
827 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
829 getFVSet :: FreeVarsInfo -> IdSet
830 getFVSet fvs = mkVarSet (getFVs fvs)
832 plusFVInfo (id1,top1,info1) (id2,top2,info2)
833 = ASSERT (id1 == id2 && top1 == top2)
834 (id1, top1, combineStgBinderInfo info1 info2)
838 rhsArity :: StgRhs -> Arity
839 rhsArity (StgRhsCon _ _ _) = 0
840 rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
843 zapArity id = id `setIdArityInfo` UnknownArity