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 )
26 import CostCentre ( noCCS )
29 import DataCon ( dataConWrapId )
30 import IdInfo ( OccInfo(..) )
31 import PrimOp ( PrimOp(..), ccallMayGC )
32 import TysPrim ( foreignObjPrimTyCon )
33 import Maybes ( maybeToBool, orElse )
34 import Name ( getOccName, isExternallyVisibleName )
35 import Module ( Module )
36 import OccName ( occNameUserString )
37 import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
38 import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
44 %************************************************************************
46 \subsection[live-vs-free-doc]{Documentation}
48 %************************************************************************
50 (There is other relevant documentation in codeGen/CgLetNoEscape.)
52 The actual Stg datatype is decorated with {\em live variable}
53 information, as well as {\em free variable} information. The two are
54 {\em not} the same. Liveness is an operational property rather than a
55 semantic one. A variable is live at a particular execution point if
56 it can be referred to {\em directly} again. In particular, a dead
57 variable's stack slot (if it has one):
60 should be stubbed to avoid space leaks, and
62 may be reused for something else.
65 There ought to be a better way to say this. Here are some examples:
72 Just after the `in', v is live, but q is dead. If the whole of that
73 let expression was enclosed in a case expression, thus:
75 case (let v = [q] \[x] -> e in ...v...) of
78 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
79 we'll return later to the @alts@ and need it.
81 Let-no-escapes make this a bit more interesting:
83 let-no-escape v = [q] \ [x] -> e
87 Here, @q@ is still live at the `in', because @v@ is represented not by
88 a closure but by the current stack state. In other words, if @v@ is
89 live then so is @q@. Furthermore, if @e@ mentions an enclosing
90 let-no-escaped variable, then {\em its} free variables are also live
93 %************************************************************************
95 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
97 %************************************************************************
100 coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
101 coreToStg dflags this_mod pgm
102 = return (fst (initLne (coreTopBindsToStg pgm)))
104 coreExprToStg :: CoreExpr -> StgExpr
106 = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr)
108 -- For top-level guys, we basically aren't worried about this
109 -- live-variable stuff; we do need to keep adding to the environment
110 -- as we step through the bindings (using @extendVarEnv@).
112 coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo)
114 coreTopBindsToStg [] = returnLne ([], emptyFVInfo)
115 coreTopBindsToStg (bind:binds)
117 binders = bindersOf bind
118 env_extension = binders `zip` repeat how_bound
119 how_bound = LetrecBound True {- top level -}
123 extendVarEnvLne env_extension (
124 coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) ->
125 coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) ->
128 (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
134 :: [Id] -- New binders (with correct arity)
135 -> FreeVarsInfo -- Info about the body
137 -> LneM (StgBinding, FreeVarsInfo)
139 coreTopBindToStg [binder] body_fvs (NonRec _ rhs)
140 = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
141 returnLne (StgNonRec binder rhs2, fvs)
143 coreTopBindToStg binders body_fvs (Rec pairs)
144 = fixLne (\ ~(_, rec_rhs_fvs) ->
145 let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
147 mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs
148 `thenLne` \ (rhss2, fvss, _) ->
149 let fvs = unionFVInfos fvss
151 returnLne (StgRec (binders `zip` rhss2), fvs)
157 :: FreeVarsInfo -- Free var info for the scope of the binding
160 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
162 coreToStgRhs scope_fv_info top (binder, rhs)
163 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
164 returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
167 binder_info = lookupFVInfo scope_fv_info binder
169 mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
172 mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
173 = StgRhsClosure noCCS binder_info noSRT
178 mkStgRhs top rhs_fvs binder_info (StgConApp con args)
179 | isNotTopLevel top || not (isDllConApp con args)
180 = StgRhsCon noCCS con args
182 mkStgRhs top rhs_fvs binder_info rhs
183 = StgRhsClosure noCCS binder_info noSRT
188 updatable args body | null args && isPAP body = ReEntrant
189 | otherwise = Updatable
191 upd = if isOnceDem dem
192 then (if isNotTop toplev
193 then SingleEntry -- HA! Paydirt for "dem"
196 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
200 -- For now we forbid SingleEntry CAFs; they tickle the
201 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
202 -- and I don't understand why. There's only one SE_CAF (well,
203 -- only one that tickled a great gaping bug in an earlier attempt
204 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
205 -- specifically Main.lvl6 in spectral/cryptarithm2.
206 -- So no great loss. KSW 2000-07.
210 Detect thunks which will reduce immediately to PAPs, and make them
211 non-updatable. This has several advantages:
213 - the non-updatable thunk behaves exactly like the PAP,
215 - the thunk is more efficient to enter, because it is
216 specialised to the task.
218 - we save one update frame, one stg_update_PAP, one update
219 and lots of PAP_enters.
221 - in the case where the thunk is top-level, we save building
222 a black hole and futhermore the thunk isn't considered to
223 be a CAF any more, so it doesn't appear in any SRTs.
225 We do it here, because the arity information is accurate, and we need
226 to do it before the SRT pass to save the SRT entries associated with
230 isPAP (StgApp f args) = idArity f > length args
235 -- ---------------------------------------------------------------------------
237 -- ---------------------------------------------------------------------------
242 -> LneM (StgExpr, -- Decorated STG expr
243 FreeVarsInfo, -- Its free vars (NB free, not live)
244 EscVarsSet) -- Its escapees, a subset of its free vars;
245 -- also a subset of the domain of the envt
246 -- because we are only interested in the escapees
247 -- for vars which might be turned into
248 -- let-no-escaped ones.
251 The second and third components can be derived in a simple bottom up pass, not
252 dependent on any decisions about which variables will be let-no-escaped or
253 not. The first component, that is, the decorated expression, may then depend
254 on these components, but it in turn is not scrutinised as the basis for any
255 decisions. Hence no black holes.
258 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
259 coreToStgExpr (Var v) = coreToStgApp Nothing v []
261 coreToStgExpr expr@(App _ _)
262 = coreToStgApp Nothing f args
264 (f, args) = myCollectArgs expr
266 coreToStgExpr expr@(Lam _ _)
267 = let (args, body) = myCollectBinders expr
268 args' = filterStgBinders args
270 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
271 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
273 set_of_args = mkVarSet args'
274 fvs = body_fvs `minusFVBinders` args'
275 escs = body_escs `minusVarSet` set_of_args
278 then returnLne (body, fvs, escs)
279 else returnLne (StgLam (exprType expr) args' body, fvs, escs)
281 coreToStgExpr (Note (SCC cc) expr)
282 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
283 returnLne (StgSCC cc expr2, fvs, escs) )
285 coreToStgExpr (Note other_note expr)
289 -- Cases require a little more real work.
291 coreToStgExpr (Case scrut bndr alts)
292 = getVarsLiveInCont `thenLne` \ live_in_cont ->
293 extendVarEnvLne [(bndr, CaseBound)] $
294 vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
295 lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
297 -- determine whether the default binder is dead or not
298 bndr' = bndr `setIdOccInfo` occ_info
299 occ_info | bndr `elementOfFVInfo` alts_fvs = NoOccInfo
300 | otherwise = IAmDead
302 -- for a _ccall_GC_, some of the *arguments* need to live across the
303 -- call (see findLiveArgs comments.), so we annotate them as being live
304 -- in the alts to achieve the desired effect.
305 mb_live_across_case =
308 e@(App _ _) | (v, args) <- myCollectArgs e,
309 PrimOpId (CCallOp ccall) <- idFlavour v,
311 -> Just (filterVarSet isForeignObjArg (exprFreeVars e))
314 -- Don't consider the default binder as being 'live in alts',
315 -- since this is from the point of view of the case expr, where
316 -- the default binder is not free.
317 live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
318 live_in_cont `unionVarSet`
319 (alts_lvs `minusVarSet` unitVarSet bndr)
321 -- we tell the scrutinee that everything live in the alts
322 -- is live in it, too.
323 setVarsLiveInCont live_in_alts (
325 ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
327 lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
329 live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
332 mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
333 (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
334 (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
335 -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
336 -- but actually we can't call, and then return from, a let-no-escape thing.
339 scrut_ty = idType bndr
340 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
342 vars_alts (alts,deflt)
344 = mapAndUnzip3Lne vars_prim_alt alts
345 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
347 alts_fvs = unionFVInfos alts_fvs_list
348 alts_escs = unionVarSets alts_escs_list
350 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
352 mkStgPrimAlts scrut_ty alts2 deflt2,
353 alts_fvs `unionFVInfo` deflt_fvs,
354 alts_escs `unionVarSet` deflt_escs
358 = mapAndUnzip3Lne vars_alg_alt alts
359 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
361 alts_fvs = unionFVInfos alts_fvs_list
362 alts_escs = unionVarSets alts_escs_list
364 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
366 mkStgAlgAlts scrut_ty alts2 deflt2,
367 alts_fvs `unionFVInfo` deflt_fvs,
368 alts_escs `unionVarSet` deflt_escs
372 vars_prim_alt (LitAlt lit, _, rhs)
373 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
374 returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
376 vars_alg_alt (DataAlt con, binders, rhs)
378 -- remove type variables
379 binders' = filterStgBinders binders
381 extendVarEnvLne [(b, CaseBound) | b <- binders'] $
382 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
384 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
385 -- records whether each param is used in the RHS
388 (con, binders', good_use_mask, rhs2),
389 rhs_fvs `minusFVBinders` binders',
390 rhs_escs `minusVarSet` mkVarSet binders'
391 -- ToDo: remove the minusVarSet;
392 -- since escs won't include any of these binders
396 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
398 vars_deflt (Just rhs)
399 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
400 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
403 Lets not only take quite a bit of work, but this is where we convert
404 then to let-no-escapes, if we wish.
406 (Meanwhile, we don't expect to see let-no-escapes...)
408 coreToStgExpr (Let bind body)
409 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
410 coreToStgLet no_binder_escapes bind body
411 ) `thenLne` \ (new_let, fvs, escs, _) ->
413 returnLne (new_let, fvs, escs)
416 If we've got a case containing a _ccall_GC_ primop, we need to
417 ensure that the arguments are kept live for the duration of the
418 call. This only an issue
421 isForeignObjArg :: Id -> Bool
422 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
424 isForeignObjPrimTy ty
425 = case splitTyConApp_maybe ty of
426 Just (tycon, _) -> tycon == foreignObjPrimTyCon
431 mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt
432 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
433 = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt)
435 mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt
436 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
437 = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts
440 | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" )
441 mkStgPrimAlts scrut_ty [] deflt
442 | otherwise = mkStgAlgAlts scrut_ty [] deflt
444 scrut_ty = stgArgType scrut
445 new_bndr = setIdType bndr scrut_ty
446 -- NB: SeqOp :: forall a. a -> Int#
447 -- So bndr has type Int#
448 -- But now we are going to scrutinise the SeqOp's argument directly,
449 -- so we must change the type of the case binder to match that
450 -- of the argument expression e.
452 scrut_expr = case scrut of
453 StgVarArg v -> StgApp v []
454 -- Others should not happen because
455 -- seq of a value should have disappeared
456 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
458 mkStgCase scrut lvs1 lvs2 bndr srt alts
459 = StgCase scrut lvs1 lvs2 bndr srt alts
462 mkStgAlgAlts ty alts deflt
464 -- Get the tycon from the data con
465 (dc, _, _, _) : _rest
466 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
468 -- Otherwise just do your best
469 [] -> case splitTyConApp_maybe (repType ty) of
470 Just (tc,_) | isAlgTyCon tc
471 -> StgAlgAlts (Just tc) alts deflt
473 -> StgAlgAlts Nothing alts deflt
475 mkStgPrimAlts ty alts deflt
476 = StgPrimAlts (tyConAppTyCon ty) alts deflt
480 -- ---------------------------------------------------------------------------
482 -- ---------------------------------------------------------------------------
486 :: Maybe UpdateFlag -- Just upd <=> this application is
487 -- the rhs of a thunk binding
488 -- x = [...] \upd [] -> the_app
489 -- with specified update flag
491 -> [CoreArg] -- Arguments
492 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
494 coreToStgApp maybe_thunk_body f args
495 = getVarsLiveInCont `thenLne` \ live_in_cont ->
496 coreToStgArgs args `thenLne` \ (args', args_fvs) ->
497 lookupVarLne f `thenLne` \ how_bound ->
501 not_letrec_bound = not (isLetrecBound how_bound)
502 fun_fvs = singletonFVInfo f how_bound fun_occ
504 -- Mostly, the arity info of a function is in the fn's IdInfo
505 -- But new bindings introduced by CoreSat may not have no
506 -- arity info; it would do us no good anyway. For example:
507 -- let f = \ab -> e in f
508 -- No point in having correct arity info for f!
509 -- Hence the hasArity stuff below.
510 f_arity_info = idArityInfo f
511 f_arity = arityLowerBound f_arity_info -- Zero if no info
514 | not_letrec_bound = noBinderInfo -- Uninteresting variable
515 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
516 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
519 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
520 | hasArity f_arity_info &&
521 f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
522 -- saturated call doesn't escape
523 -- (let-no-escape applies to 'thunks' too)
525 | otherwise = unitVarSet f -- Inexact application; it does escape
527 -- At the moment of the call:
529 -- either the function is *not* let-no-escaped, in which case
530 -- nothing is live except live_in_cont
531 -- or the function *is* let-no-escaped in which case the
532 -- variables it uses are live, but still the function
533 -- itself is not. PS. In this case, the function's
534 -- live vars should already include those of the
535 -- continuation, but it does no harm to just union the
538 app = case idFlavour f of
539 DataConId dc -> StgConApp dc args'
540 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
541 _other -> StgApp f args'
546 fun_fvs `unionFVInfo` args_fvs,
547 fun_escs `unionVarSet` (getFVSet args_fvs)
548 -- All the free vars of the args are disqualified
549 -- from being let-no-escaped.
554 -- ---------------------------------------------------------------------------
556 -- This is the guy that turns applications into A-normal form
557 -- ---------------------------------------------------------------------------
559 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
561 = returnLne ([], emptyFVInfo)
563 coreToStgArgs (Type ty : args) -- Type argument
564 = coreToStgArgs args `thenLne` \ (args', fvs) ->
565 if opt_KeepStgTypes then
566 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
568 returnLne (args', fvs)
570 coreToStgArgs (arg : args) -- Non-type argument
571 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
572 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
574 fvs = args_fvs `unionFVInfo` arg_fvs
575 stg_arg = case arg' of
576 StgApp v [] -> StgVarArg v
577 StgConApp con [] -> StgVarArg (dataConWrapId con)
578 StgLit lit -> StgLitArg lit
579 _ -> pprPanic "coreToStgArgs" (ppr arg)
581 returnLne (stg_arg : stg_args, fvs)
584 -- ---------------------------------------------------------------------------
585 -- The magic for lets:
586 -- ---------------------------------------------------------------------------
589 :: Bool -- True <=> yes, we are let-no-escaping this let
590 -> CoreBind -- bindings
592 -> LneM (StgExpr, -- new let
593 FreeVarsInfo, -- variables free in the whole let
594 EscVarsSet, -- variables that escape from the whole let
595 Bool) -- True <=> none of the binders in the bindings
596 -- is among the escaping vars
598 coreToStgLet let_no_escape bind body
599 = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
601 -- Do the bindings, setting live_in_cont to empty if
602 -- we ain't in a let-no-escape world
603 getVarsLiveInCont `thenLne` \ live_in_cont ->
605 (if let_no_escape then live_in_cont else emptyVarSet)
606 (vars_bind rec_bind_lvs rec_body_fvs bind)
607 `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
609 -- The live variables of this binding are the ones which are live
610 -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
611 -- together with the live_in_cont ones
612 lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
613 `thenLne` \ lvs_from_fvs ->
615 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
618 -- bind_fvs and bind_escs still include the binders of the let(rec)
619 -- but bind_lvs does not
622 extendVarEnvLne env_ext (
623 coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
624 lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
626 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
627 body2, body_fvs, body_escs, body_lvs)
629 )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
630 body2, body_fvs, body_escs, body_lvs) ->
633 -- Compute the new let-expression
635 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
636 | otherwise = StgLet bind2 body2
639 = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
642 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
644 real_bind_escs = if let_no_escape then
648 -- Everything escapes which is free in the bindings
650 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
652 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
655 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
658 -- Debugging code as requested by Andrew Kennedy
659 checked_no_binder_escapes
660 | not no_binder_escapes && any is_join_var binders
661 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
663 | otherwise = no_binder_escapes
665 checked_no_binder_escapes = no_binder_escapes
668 -- Mustn't depend on the passed-in let_no_escape flag, since
669 -- no_binder_escapes is used by the caller to derive the flag!
675 checked_no_binder_escapes
678 set_of_binders = mkVarSet binders
679 binders = case bind of
680 NonRec binder rhs -> [binder]
681 Rec pairs -> map fst pairs
683 mk_binding bind_lvs binder
684 = (binder, LetrecBound False -- Not top level
688 live_vars = if let_no_escape then
689 extendVarSet bind_lvs binder
693 vars_bind :: StgLiveVars
694 -> FreeVarsInfo -- Free var info for body of binding
697 FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
699 -- extension to environment
701 vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
702 = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
703 `thenLne` \ (rhs2, fvs, escs) ->
705 env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
707 returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
709 vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
711 binders = map fst pairs
712 env_ext = map (mk_binding rec_bind_lvs) binders
714 extendVarEnvLne env_ext (
715 fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
717 rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
719 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
720 `thenLne` \ (rhss2, fvss, escss) ->
722 fvs = unionFVInfos fvss
723 escs = unionVarSets escss
725 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
728 is_join_var :: Id -> Bool
729 -- A hack (used only for compiler debuggging) to tell if
730 -- a variable started life as a join point ($j)
731 is_join_var j = occNameUserString (getOccName j) == "$j"
734 %************************************************************************
736 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
738 %************************************************************************
740 There's a lot of stuff to pass around, so we use this @LneM@ monad to
741 help. All the stuff here is only passed {\em down}.
744 type LneM a = IdEnv HowBound
745 -> StgLiveVars -- vars live in continuation
753 Bool -- True <=> bound at top level
754 StgLiveVars -- Live vars... see notes below
756 isLetrecBound (LetrecBound _ _) = True
757 isLetrecBound other = False
760 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
761 variables that are live if x is live. For "normal" variables that is
762 just x alone. If x is a let-no-escaped variable then x is represented
763 by a code pointer and a stack pointer (well, one for each stack). So
764 all of the variables needed in the execution of x are live if x is,
765 and are therefore recorded in the LetrecBound constructor; x itself
768 The set of live variables is guaranteed ot have no further let-no-escaped
771 The std monad functions:
773 initLne :: LneM a -> a
774 initLne m = m emptyVarEnv emptyVarSet
776 {-# INLINE thenLne #-}
777 {-# INLINE returnLne #-}
779 returnLne :: a -> LneM a
780 returnLne e env lvs_cont = e
782 thenLne :: LneM a -> (a -> LneM b) -> LneM b
783 thenLne m k env lvs_cont
784 = k (m env lvs_cont) env lvs_cont
786 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
787 mapLne f [] = returnLne []
789 = f x `thenLne` \ r ->
790 mapLne f xs `thenLne` \ rs ->
793 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
795 mapAndUnzipLne f [] = returnLne ([],[])
796 mapAndUnzipLne f (x:xs)
797 = f x `thenLne` \ (r1, r2) ->
798 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
799 returnLne (r1:rs1, r2:rs2)
801 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
803 mapAndUnzip3Lne f [] = returnLne ([],[],[])
804 mapAndUnzip3Lne f (x:xs)
805 = f x `thenLne` \ (r1, r2, r3) ->
806 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
807 returnLne (r1:rs1, r2:rs2, r3:rs3)
809 fixLne :: (a -> LneM a) -> LneM a
810 fixLne expr env lvs_cont
813 result = expr result env lvs_cont
816 Functions specific to this monad:
819 getVarsLiveInCont :: LneM StgLiveVars
820 getVarsLiveInCont env lvs_cont = lvs_cont
822 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
823 setVarsLiveInCont new_lvs_cont expr env lvs_cont
824 = expr env new_lvs_cont
826 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
827 extendVarEnvLne ids_w_howbound expr env lvs_cont
828 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
830 lookupVarLne :: Id -> LneM HowBound
831 lookupVarLne v env lvs_cont
833 case (lookupVarEnv env v) of
835 Nothing -> ImportBound
838 -- The result of lookupLiveVarsForSet, a set of live variables, is
839 -- only ever tacked onto a decorated expression. It is never used as
840 -- the basis of a control decision, which might give a black hole.
842 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
844 lookupLiveVarsForSet fvs env lvs_cont
845 = returnLne (unionVarSets (map do_one (getFVs fvs)))
849 = if isLocalId v then
850 case (lookupVarEnv env v) of
851 Just (LetrecBound _ lvs) -> extendVarSet lvs v
852 Just _ -> unitVarSet v
853 Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
859 %************************************************************************
861 \subsection[Free-var info]{Free variable information}
863 %************************************************************************
866 type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
867 -- If f is mapped to noBinderInfo, that means
868 -- that f *is* mentioned (else it wouldn't be in the
869 -- IdEnv at all), but only in a saturated applications.
871 -- All case/lambda-bound things are also mapped to
872 -- noBinderInfo, since we aren't interested in their
875 -- The Bool is True <=> the Id is top level letrec bound
877 -- For ILX we track free var info for type variables too;
878 -- hence VarEnv not IdEnv
880 type EscVarsSet = IdSet
884 emptyFVInfo :: FreeVarsInfo
885 emptyFVInfo = emptyVarEnv
887 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
888 singletonFVInfo id ImportBound info = emptyVarEnv
889 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
890 singletonFVInfo id other info = unitVarEnv id (id, False, info)
892 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
893 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
895 add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo)
897 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
898 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
900 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
901 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
903 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
904 minusFVBinders fv ids = fv `delVarEnvList` ids
906 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
907 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
909 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
910 -- Find how the given Id is used.
911 -- Externally visible things may be used any old how
913 | isExternallyVisibleName (idName id) = noBinderInfo
914 | otherwise = case lookupVarEnv fvs id of
915 Nothing -> noBinderInfo
916 Just (_,_,info) -> info
918 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
919 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
921 getFVSet :: FreeVarsInfo -> IdSet
922 getFVSet fvs = mkVarSet (getFVs fvs)
924 plusFVInfo (id1,top1,info1) (id2,top2,info2)
925 = ASSERT (id1 == id2 && top1 == top2)
926 (id1, top1, combineStgBinderInfo info1 info2)
931 filterStgBinders :: [Var] -> [Var]
932 filterStgBinders bndrs
933 | opt_KeepStgTypes = bndrs
934 | otherwise = filter isId bndrs
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 :: CoreExpr -> (Id, [CoreArg])
949 -- We assume that we only have variables
950 -- in the function position by now
954 go (Var v) as = (v, as)
955 go (App f a) as = go f (a:as)
956 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
957 go (Note n e) as = go e as
958 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)