2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[CoreToStg]{Converts Core to STG Syntax}
6 And, as we have the info in hand, we may convert some lets to
10 module CoreToStg ( coreToStg, coreExprToStg ) where
12 #include "HsVersions.h"
21 import TyCon ( isAlgTyCon )
25 import CostCentre ( noCCS )
28 import DataCon ( dataConWrapId )
29 import IdInfo ( OccInfo(..) )
30 import PrimOp ( PrimOp(..), ccallMayGC )
31 import TysPrim ( foreignObjPrimTyCon )
32 import Maybes ( maybeToBool, orElse )
33 import Name ( getOccName )
34 import Module ( Module )
35 import OccName ( occNameUserString )
36 import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
37 import CmdLineOpts ( DynFlags )
40 infixr 9 `thenLne`, `thenLne_`
43 %************************************************************************
45 \subsection[live-vs-free-doc]{Documentation}
47 %************************************************************************
49 (There is other relevant documentation in codeGen/CgLetNoEscape.)
51 The actual Stg datatype is decorated with {\em live variable}
52 information, as well as {\em free variable} information. The two are
53 {\em not} the same. Liveness is an operational property rather than a
54 semantic one. A variable is live at a particular execution point if
55 it can be referred to {\em directly} again. In particular, a dead
56 variable's stack slot (if it has one):
59 should be stubbed to avoid space leaks, and
61 may be reused for something else.
64 There ought to be a better way to say this. Here are some examples:
71 Just after the `in', v is live, but q is dead. If the whole of that
72 let expression was enclosed in a case expression, thus:
74 case (let v = [q] \[x] -> e in ...v...) of
77 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
78 we'll return later to the @alts@ and need it.
80 Let-no-escapes make this a bit more interesting:
82 let-no-escape v = [q] \ [x] -> e
86 Here, @q@ is still live at the `in', because @v@ is represented not by
87 a closure but by the current stack state. In other words, if @v@ is
88 live then so is @q@. Furthermore, if @e@ mentions an enclosing
89 let-no-escaped variable, then {\em its} free variables are also live
92 %************************************************************************
94 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
96 %************************************************************************
99 coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
100 coreToStg dflags this_mod pgm
101 = return (fst (initLne (coreTopBindsToStg pgm)))
103 coreExprToStg :: CoreExpr -> StgExpr
105 = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr)
107 -- For top-level guys, we basically aren't worried about this
108 -- live-variable stuff; we do need to keep adding to the environment
109 -- as we step through the bindings (using @extendVarEnv@).
111 coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo)
113 coreTopBindsToStg [] = returnLne ([], emptyFVInfo)
114 coreTopBindsToStg (bind:binds)
116 binders = bindersOf bind
117 env_extension = binders `zip` repeat how_bound
118 how_bound = LetrecBound True {- top level -}
122 extendVarEnvLne env_extension (
123 coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) ->
124 coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) ->
127 (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
133 :: [Id] -- New binders (with correct arity)
134 -> FreeVarsInfo -- Info about the body
136 -> LneM (StgBinding, FreeVarsInfo)
138 coreTopBindToStg [binder] body_fvs (NonRec _ rhs)
139 = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
140 returnLne (StgNonRec binder rhs2, fvs)
142 coreTopBindToStg binders body_fvs (Rec pairs)
143 = fixLne (\ ~(_, rec_rhs_fvs) ->
144 let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
146 mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs
147 `thenLne` \ (rhss2, fvss, _) ->
148 let fvs = unionFVInfos fvss
150 returnLne (StgRec (binders `zip` rhss2), fvs)
156 :: FreeVarsInfo -- Free var info for the scope of the binding
159 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
161 coreToStgRhs scope_fv_info top (binder, rhs)
162 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
166 -> let binder_info = lookupFVInfo scope_fv_info binder
167 in returnLne (StgRhsClosure noCCS
177 | isNotTopLevel top || not (isDllConApp con args)
178 -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs)
181 -> let binder_info = lookupFVInfo scope_fv_info binder
182 in returnLne (StgRhsClosure noCCS
186 (updatable [] new_rhs)
192 updatable args body | null args && isPAP body = ReEntrant
193 | otherwise = Updatable
195 upd = if isOnceDem dem
196 then (if isNotTop toplev
197 then SingleEntry -- HA! Paydirt for "dem"
200 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
204 -- For now we forbid SingleEntry CAFs; they tickle the
205 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
206 -- and I don't understand why. There's only one SE_CAF (well,
207 -- only one that tickled a great gaping bug in an earlier attempt
208 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
209 -- specifically Main.lvl6 in spectral/cryptarithm2.
210 -- So no great loss. KSW 2000-07.
214 Detect thunks which will reduce immediately to PAPs, and make them
215 non-updatable. This has several advantages:
217 - the non-updatable thunk behaves exactly like the PAP,
219 - the thunk is more efficient to enter, because it is
220 specialised to the task.
222 - we save one update frame, one stg_update_PAP, one update
223 and lots of PAP_enters.
225 - in the case where the thunk is top-level, we save building
226 a black hole and futhermore the thunk isn't considered to
227 be a CAF any more, so it doesn't appear in any SRTs.
229 We do it here, because the arity information is accurate, and we need
230 to do it before the SRT pass to save the SRT entries associated with
234 isPAP (StgApp f args) = idArity f > length args
237 -- ---------------------------------------------------------------------------
239 -- ---------------------------------------------------------------------------
241 coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
243 = let val_atoms = filter isValArg atoms in
244 mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) ->
245 returnLne (args', unionFVInfos fvs_lists)
248 = coreToStgExpr e `thenLne` \ (expr, fvs, escs) ->
250 StgApp v [] -> returnLne (StgVarArg v, fvs)
251 StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs)
252 StgLit lit -> returnLne (StgLitArg lit, fvs)
253 _ -> pprPanic "coreToStgAtom" (ppr expr)
255 -- ---------------------------------------------------------------------------
257 -- ---------------------------------------------------------------------------
260 @varsExpr@ carries in a monad-ised environment, which binds each
261 let(rec) variable (ie non top level, not imported, not lambda bound,
262 not case-alternative bound) to:
264 - its set of live vars.
265 For normal variables the set of live vars is just the variable
266 itself. For let-no-escaped variables, the set of live vars is the set
267 live at the moment the variable is entered. The set is guaranteed to
268 have no further let-no-escaped vars in it.
273 -> LneM (StgExpr, -- Decorated STG expr
274 FreeVarsInfo, -- Its free vars (NB free, not live)
275 EscVarsSet) -- Its escapees, a subset of its free vars;
276 -- also a subset of the domain of the envt
277 -- because we are only interested in the escapees
278 -- for vars which might be turned into
279 -- let-no-escaped ones.
282 The second and third components can be derived in a simple bottom up pass, not
283 dependent on any decisions about which variables will be let-no-escaped or
284 not. The first component, that is, the decorated expression, may then depend
285 on these components, but it in turn is not scrutinised as the basis for any
286 decisions. Hence no black holes.
289 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
291 coreToStgExpr (Var v)
292 = coreToStgApp Nothing v []
294 coreToStgExpr expr@(App _ _)
295 = let (f, args) = myCollectArgs expr
297 coreToStgApp Nothing (shouldBeVar f) args
299 coreToStgExpr expr@(Lam _ _)
300 = let (args, body) = myCollectBinders expr
301 args' = filter isId args
303 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
304 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
306 set_of_args = mkVarSet args'
307 fvs = body_fvs `minusFVBinders` args'
308 escs = body_escs `minusVarSet` set_of_args
311 then returnLne (body, fvs, escs)
312 else returnLne (StgLam (exprType expr) args' body, fvs, escs)
314 coreToStgExpr (Note (SCC cc) expr)
315 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
316 returnLne (StgSCC cc expr2, fvs, escs) )
318 coreToStgExpr (Note other_note expr)
322 -- Cases require a little more real work.
324 coreToStgExpr (Case scrut bndr alts)
325 = getVarsLiveInCont `thenLne` \ live_in_cont ->
326 extendVarEnvLne [(bndr, CaseBound)] $
327 vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
328 lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
330 -- determine whether the default binder is dead or not
331 bndr'= if (bndr `elementOfFVInfo` alts_fvs)
332 then bndr `setIdOccInfo` NoOccInfo
333 else bndr `setIdOccInfo` IAmDead
335 -- for a _ccall_GC_, some of the *arguments* need to live across the
336 -- call (see findLiveArgs comments.), so we annotate them as being live
337 -- in the alts to achieve the desired effect.
338 mb_live_across_case =
341 e@(App _ _) | (Var v, args) <- myCollectArgs e,
342 PrimOpId (CCallOp ccall) <- idFlavour v,
344 -> Just (filterVarSet isForeignObjArg (exprFreeVars e))
347 -- Don't consider the default binder as being 'live in alts',
348 -- since this is from the point of view of the case expr, where
349 -- the default binder is not free.
350 live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
351 live_in_cont `unionVarSet`
352 (alts_lvs `minusVarSet` unitVarSet bndr)
354 -- we tell the scrutinee that everything live in the alts
355 -- is live in it, too.
356 setVarsLiveInCont live_in_alts (
358 ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
360 lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
362 live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
365 mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
366 (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
367 (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
368 -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
369 -- but actually we can't call, and then return from, a let-no-escape thing.
372 scrut_ty = idType bndr
373 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
375 vars_alts (alts,deflt)
377 = mapAndUnzip3Lne vars_prim_alt alts
378 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
380 alts_fvs = unionFVInfos alts_fvs_list
381 alts_escs = unionVarSets alts_escs_list
383 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
385 mkStgPrimAlts scrut_ty alts2 deflt2,
386 alts_fvs `unionFVInfo` deflt_fvs,
387 alts_escs `unionVarSet` deflt_escs
391 = mapAndUnzip3Lne vars_alg_alt alts
392 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
394 alts_fvs = unionFVInfos alts_fvs_list
395 alts_escs = unionVarSets alts_escs_list
397 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
399 mkStgAlgAlts scrut_ty alts2 deflt2,
400 alts_fvs `unionFVInfo` deflt_fvs,
401 alts_escs `unionVarSet` deflt_escs
405 vars_prim_alt (LitAlt lit, _, rhs)
406 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
407 returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
409 vars_alg_alt (DataAlt con, binders, rhs)
411 -- remove type variables
412 binders' = filter isId binders
414 extendVarEnvLne [(b, CaseBound) | b <- binders'] $
415 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
417 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
418 -- records whether each param is used in the RHS
421 (con, binders', good_use_mask, rhs2),
422 rhs_fvs `minusFVBinders` binders',
423 rhs_escs `minusVarSet` mkVarSet binders'
424 -- ToDo: remove the minusVarSet;
425 -- since escs won't include any of these binders
429 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
431 vars_deflt (Just rhs)
432 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
433 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
437 Lets not only take quite a bit of work, but this is where we convert
438 then to let-no-escapes, if we wish.
440 (Meanwhile, we don't expect to see let-no-escapes...)
442 coreToStgExpr (Let bind body)
443 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
444 coreToStgLet no_binder_escapes bind body
445 ) `thenLne` \ (new_let, fvs, escs, _) ->
447 returnLne (new_let, fvs, escs)
450 If we've got a case containing a _ccall_GC_ primop, we need to
451 ensure that the arguments are kept live for the duration of the
452 call. This only an issue
455 isForeignObjArg :: Id -> Bool
456 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
458 isForeignObjPrimTy ty
459 = case splitTyConApp_maybe ty of
460 Just (tycon, _) -> tycon == foreignObjPrimTyCon
465 mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt
466 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
467 = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt)
469 mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt
470 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
471 = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts
474 | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" )
475 mkStgPrimAlts scrut_ty [] deflt
476 | otherwise = mkStgAlgAlts scrut_ty [] deflt
478 scrut_ty = stgArgType scrut
479 new_bndr = setIdType bndr scrut_ty
480 -- NB: SeqOp :: forall a. a -> Int#
481 -- So bndr has type Int#
482 -- But now we are going to scrutinise the SeqOp's argument directly,
483 -- so we must change the type of the case binder to match that
484 -- of the argument expression e.
486 scrut_expr = case scrut of
487 StgVarArg v -> StgApp v []
488 -- Others should not happen because
489 -- seq of a value should have disappeared
490 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
492 mkStgCase scrut lvs1 lvs2 bndr srt alts
493 = StgCase scrut lvs1 lvs2 bndr srt alts
496 mkStgAlgAlts ty alts deflt
498 -- Get the tycon from the data con
499 (dc, _, _, _) : _rest
500 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
502 -- Otherwise just do your best
503 [] -> case splitTyConApp_maybe (repType ty) of
504 Just (tc,_) | isAlgTyCon tc
505 -> StgAlgAlts (Just tc) alts deflt
507 -> StgAlgAlts Nothing alts deflt
509 mkStgPrimAlts ty alts deflt
510 = StgPrimAlts (tyConAppTyCon ty) alts deflt
517 :: Maybe UpdateFlag -- Just upd <=> this application is
518 -- the rhs of a thunk binding
519 -- x = [...] \upd [] -> the_app
520 -- with specified update flag
522 -> [CoreArg] -- Arguments
523 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
525 coreToStgApp maybe_thunk_body f args
526 = getVarsLiveInCont `thenLne` \ live_in_cont ->
527 coreToStgAtoms args `thenLne` \ (args', args_fvs) ->
528 lookupVarLne f `thenLne` \ how_bound ->
532 not_letrec_bound = not (isLetrecBound how_bound)
534 fun_fvs = singletonFVInfo f how_bound fun_occ
537 | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
539 -- Otherwise it is letrec bound; must have its arity
540 | n_args == 0 = stgFakeFunAppOcc -- Function Application
541 -- with no arguments.
542 -- used by the lambda lifter.
543 | f_arity > n_args = stgUnsatOcc -- Unsaturated
545 | f_arity == n_args &&
546 maybeToBool maybe_thunk_body -- Exactly saturated,
548 = case maybe_thunk_body of
549 Just Updatable -> stgStdHeapOcc
550 Just SingleEntry -> stgNoUpdHeapOcc
551 other -> panic "coreToStgApp"
553 | otherwise = stgNormalOcc
554 -- Record only that it occurs free
556 myself = unitVarSet f
558 fun_escs | not_letrec_bound = emptyVarSet
559 -- Only letrec-bound escapees are interesting
560 | f_arity == n_args = emptyVarSet
561 -- Function doesn't escape
563 -- Inexact application; it does escape
565 -- At the moment of the call:
567 -- either the function is *not* let-no-escaped, in which case
568 -- nothing is live except live_in_cont
569 -- or the function *is* let-no-escaped in which case the
570 -- variables it uses are live, but still the function
571 -- itself is not. PS. In this case, the function's
572 -- live vars should already include those of the
573 -- continuation, but it does no harm to just union the
578 -- = live_in_cont `unionVarSet` case how_bound of
579 -- LetrecBound _ lvs -> lvs `minusVarSet` myself
580 -- other -> emptyVarSet
582 app = case idFlavour f of
583 DataConId dc -> StgConApp dc args'
584 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
585 _other -> StgApp f args'
590 fun_fvs `unionFVInfo` args_fvs,
591 fun_escs `unionVarSet` (getFVSet args_fvs)
592 -- All the free vars of the args are disqualified
593 -- from being let-no-escaped.
597 -- ---------------------------------------------------------------------------
598 -- The magic for lets:
599 -- ---------------------------------------------------------------------------
602 :: Bool -- True <=> yes, we are let-no-escaping this let
603 -> CoreBind -- bindings
605 -> LneM (StgExpr, -- new let
606 FreeVarsInfo, -- variables free in the whole let
607 EscVarsSet, -- variables that escape from the whole let
608 Bool) -- True <=> none of the binders in the bindings
609 -- is among the escaping vars
611 coreToStgLet let_no_escape bind body
612 = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
614 -- Do the bindings, setting live_in_cont to empty if
615 -- we ain't in a let-no-escape world
616 getVarsLiveInCont `thenLne` \ live_in_cont ->
618 (if let_no_escape then live_in_cont else emptyVarSet)
619 (vars_bind rec_bind_lvs rec_body_fvs bind)
620 `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
622 -- The live variables of this binding are the ones which are live
623 -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
624 -- together with the live_in_cont ones
625 lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
626 `thenLne` \ lvs_from_fvs ->
628 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
631 -- bind_fvs and bind_escs still include the binders of the let(rec)
632 -- but bind_lvs does not
635 extendVarEnvLne env_ext (
636 coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
637 lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
639 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
640 body2, body_fvs, body_escs, body_lvs)
642 )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
643 body2, body_fvs, body_escs, body_lvs) ->
646 -- Compute the new let-expression
648 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
649 | otherwise = StgLet bind2 body2
652 = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
655 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
657 real_bind_escs = if let_no_escape then
661 -- Everything escapes which is free in the bindings
663 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
665 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
668 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
671 -- Debugging code as requested by Andrew Kennedy
672 checked_no_binder_escapes
673 | not no_binder_escapes && any is_join_var binders
674 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
676 | otherwise = no_binder_escapes
678 checked_no_binder_escapes = no_binder_escapes
681 -- Mustn't depend on the passed-in let_no_escape flag, since
682 -- no_binder_escapes is used by the caller to derive the flag!
688 checked_no_binder_escapes
691 set_of_binders = mkVarSet binders
692 binders = case bind of
693 NonRec binder rhs -> [binder]
694 Rec pairs -> map fst pairs
696 mk_binding bind_lvs binder
697 = (binder, LetrecBound False -- Not top level
701 live_vars = if let_no_escape then
702 extendVarSet bind_lvs binder
706 vars_bind :: StgLiveVars
707 -> FreeVarsInfo -- Free var info for body of binding
710 FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
712 -- extension to environment
714 vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
715 = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
716 `thenLne` \ (rhs2, fvs, escs) ->
718 env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
720 returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
722 vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
724 binders = map fst pairs
725 env_ext = map (mk_binding rec_bind_lvs) binders
727 extendVarEnvLne env_ext (
728 fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
730 rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
732 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
733 `thenLne` \ (rhss2, fvss, escss) ->
735 fvs = unionFVInfos fvss
736 escs = unionVarSets escss
738 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
741 is_join_var :: Id -> Bool
742 -- A hack (used only for compiler debuggging) to tell if
743 -- a variable started life as a join point ($j)
744 is_join_var j = occNameUserString (getOccName j) == "$j"
747 %************************************************************************
749 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
751 %************************************************************************
753 There's a lot of stuff to pass around, so we use this @LneM@ monad to
754 help. All the stuff here is only passed {\em down}.
757 type LneM a = IdEnv HowBound
758 -> StgLiveVars -- vars live in continuation
766 Bool -- True <=> bound at top level
767 StgLiveVars -- Live vars... see notes below
769 isLetrecBound (LetrecBound _ _) = True
770 isLetrecBound other = False
773 For a let(rec)-bound variable, x, we record what varibles are live if
774 x is live. For "normal" variables that is just x alone. If x is
775 a let-no-escaped variable then x is represented by a code pointer and
776 a stack pointer (well, one for each stack). So all of the variables
777 needed in the execution of x are live if x is, and are therefore recorded
778 in the LetrecBound constructor; x itself *is* included.
780 The std monad functions:
782 initLne :: LneM a -> a
783 initLne m = m emptyVarEnv emptyVarSet
785 {-# INLINE thenLne #-}
786 {-# INLINE thenLne_ #-}
787 {-# INLINE returnLne #-}
789 returnLne :: a -> LneM a
790 returnLne e env lvs_cont = e
792 thenLne :: LneM a -> (a -> LneM b) -> LneM b
793 thenLne m k env lvs_cont
794 = case (m env lvs_cont) of
795 m_result -> k m_result env lvs_cont
797 thenLne_ :: LneM a -> LneM b -> LneM b
798 thenLne_ m k env lvs_cont
799 = case (m env lvs_cont) of
802 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
803 mapLne f [] = returnLne []
805 = f x `thenLne` \ r ->
806 mapLne f xs `thenLne` \ rs ->
809 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
811 mapAndUnzipLne f [] = returnLne ([],[])
812 mapAndUnzipLne f (x:xs)
813 = f x `thenLne` \ (r1, r2) ->
814 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
815 returnLne (r1:rs1, r2:rs2)
817 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
819 mapAndUnzip3Lne f [] = returnLne ([],[],[])
820 mapAndUnzip3Lne f (x:xs)
821 = f x `thenLne` \ (r1, r2, r3) ->
822 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
823 returnLne (r1:rs1, r2:rs2, r3:rs3)
825 fixLne :: (a -> LneM a) -> LneM a
826 fixLne expr env lvs_cont = result
828 result = expr result env lvs_cont
829 -- ^^^^^^ ------ ^^^^^^
832 Functions specific to this monad:
834 getVarsLiveInCont :: LneM StgLiveVars
835 getVarsLiveInCont env lvs_cont = lvs_cont
837 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
838 setVarsLiveInCont new_lvs_cont expr env lvs_cont
839 = expr env new_lvs_cont
841 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
842 extendVarEnvLne ids_w_howbound expr env lvs_cont
843 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
845 lookupVarLne :: Id -> LneM HowBound
846 lookupVarLne v env lvs_cont
848 case (lookupVarEnv env v) of
850 Nothing -> ImportBound
853 -- The result of lookupLiveVarsForSet, a set of live variables, is
854 -- only ever tacked onto a decorated expression. It is never used as
855 -- the basis of a control decision, which might give a black hole.
857 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
859 lookupLiveVarsForSet fvs env lvs_cont
860 = returnLne (unionVarSets (map do_one (getFVs fvs)))
864 = if isLocalId v then
865 case (lookupVarEnv env v) of
866 Just (LetrecBound _ lvs) -> extendVarSet lvs v
867 Just _ -> unitVarSet v
868 Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
874 %************************************************************************
876 \subsection[Free-var info]{Free variable information}
878 %************************************************************************
881 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
882 -- If f is mapped to NoStgBinderInfo, that means
883 -- that f *is* mentioned (else it wouldn't be in the
884 -- IdEnv at all), but only in a saturated applications.
886 -- All case/lambda-bound things are also mapped to
887 -- NoStgBinderInfo, since we aren't interested in their
890 -- The Bool is True <=> the Id is top level letrec bound
892 type EscVarsSet = IdSet
896 emptyFVInfo :: FreeVarsInfo
897 emptyFVInfo = emptyVarEnv
899 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
900 singletonFVInfo id ImportBound info = emptyVarEnv
901 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
902 singletonFVInfo id other info = unitVarEnv id (id, False, info)
904 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
905 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
907 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
908 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
910 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
911 minusFVBinders fv ids = fv `delVarEnvList` ids
913 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
914 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
916 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
917 lookupFVInfo fvs id = case lookupVarEnv fvs id of
918 Nothing -> NoStgBinderInfo
919 Just (_,_,info) -> info
921 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
922 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
924 getFVSet :: FreeVarsInfo -> IdSet
925 getFVSet fvs = mkVarSet (getFVs fvs)
927 plusFVInfo (id1,top1,info1) (id2,top2,info2)
928 = ASSERT (id1 == id2 && top1 == top2)
929 (id1, top1, combineStgBinderInfo info1 info2)
935 shouldBeVar (Note _ e) = shouldBeVar e
936 shouldBeVar (Var v) = v
937 shouldBeVar e = pprPanic "shouldBeVar" (ppr e)
939 -- ignore all notes except SCC
940 myCollectBinders expr
943 go bs (Lam b e) = go (b:bs) e
944 go bs e@(Note (SCC _) _) = (reverse bs, e)
945 go bs (Note _ e) = go bs e
946 go bs e = (reverse bs, e)
948 myCollectArgs :: Expr b -> (Expr b, [Arg b])
952 go (App f a) as = go f (a:as)
953 go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs"
954 go (Note n e) as = go e as