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)
410 = extendVarEnvLne [(b, CaseBound) | b <- binders] $
411 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
413 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
414 -- records whether each param is used in the RHS
417 (con, binders, good_use_mask, rhs2),
418 rhs_fvs `minusFVBinders` binders,
419 rhs_escs `minusVarSet` mkVarSet binders
420 -- ToDo: remove the minusVarSet;
421 -- since escs won't include any of these binders
425 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
427 vars_deflt (Just rhs)
428 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
429 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
433 Lets not only take quite a bit of work, but this is where we convert
434 then to let-no-escapes, if we wish.
436 (Meanwhile, we don't expect to see let-no-escapes...)
438 coreToStgExpr (Let bind body)
439 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
440 coreToStgLet no_binder_escapes bind body
441 ) `thenLne` \ (new_let, fvs, escs, _) ->
443 returnLne (new_let, fvs, escs)
446 If we've got a case containing a _ccall_GC_ primop, we need to
447 ensure that the arguments are kept live for the duration of the
448 call. This only an issue
451 isForeignObjArg :: Id -> Bool
452 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
454 isForeignObjPrimTy ty
455 = case splitTyConApp_maybe ty of
456 Just (tycon, _) -> tycon == foreignObjPrimTyCon
461 mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt
462 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
463 = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt)
465 mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt
466 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
467 = StgCase scrut_expr lvs1 lvs2 new_bndr srt new_alts
470 | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" )
471 mkStgPrimAlts scrut_ty [] deflt
472 | otherwise = mkStgAlgAlts scrut_ty [] deflt
474 scrut_ty = stgArgType scrut
475 new_bndr = setIdType bndr scrut_ty
476 -- NB: SeqOp :: forall a. a -> Int#
477 -- So bndr has type Int#
478 -- But now we are going to scrutinise the SeqOp's argument directly,
479 -- so we must change the type of the case binder to match that
480 -- of the argument expression e.
482 scrut_expr = case scrut of
483 StgVarArg v -> StgApp v []
484 -- Others should not happen because
485 -- seq of a value should have disappeared
486 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
488 mkStgCase scrut lvs1 lvs2 bndr srt alts
489 = StgCase scrut lvs1 lvs2 bndr srt alts
492 mkStgAlgAlts ty alts deflt
494 -- Get the tycon from the data con
495 (dc, _, _, _) : _rest
496 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
498 -- Otherwise just do your best
499 [] -> case splitTyConApp_maybe (repType ty) of
500 Just (tc,_) | isAlgTyCon tc
501 -> StgAlgAlts (Just tc) alts deflt
503 -> StgAlgAlts Nothing alts deflt
505 mkStgPrimAlts ty alts deflt
506 = StgPrimAlts (tyConAppTyCon ty) alts deflt
513 :: Maybe UpdateFlag -- Just upd <=> this application is
514 -- the rhs of a thunk binding
515 -- x = [...] \upd [] -> the_app
516 -- with specified update flag
518 -> [CoreArg] -- Arguments
519 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
521 coreToStgApp maybe_thunk_body f args
522 = getVarsLiveInCont `thenLne` \ live_in_cont ->
523 coreToStgAtoms args `thenLne` \ (args', args_fvs) ->
524 lookupVarLne f `thenLne` \ how_bound ->
528 not_letrec_bound = not (isLetrecBound how_bound)
530 fun_fvs = singletonFVInfo f how_bound fun_occ
533 | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
535 -- Otherwise it is letrec bound; must have its arity
536 | n_args == 0 = stgFakeFunAppOcc -- Function Application
537 -- with no arguments.
538 -- used by the lambda lifter.
539 | f_arity > n_args = stgUnsatOcc -- Unsaturated
541 | f_arity == n_args &&
542 maybeToBool maybe_thunk_body -- Exactly saturated,
544 = case maybe_thunk_body of
545 Just Updatable -> stgStdHeapOcc
546 Just SingleEntry -> stgNoUpdHeapOcc
547 other -> panic "coreToStgApp"
549 | otherwise = stgNormalOcc
550 -- Record only that it occurs free
552 myself = unitVarSet f
554 fun_escs | not_letrec_bound = emptyVarSet
555 -- Only letrec-bound escapees are interesting
556 | f_arity == n_args = emptyVarSet
557 -- Function doesn't escape
559 -- Inexact application; it does escape
561 -- At the moment of the call:
563 -- either the function is *not* let-no-escaped, in which case
564 -- nothing is live except live_in_cont
565 -- or the function *is* let-no-escaped in which case the
566 -- variables it uses are live, but still the function
567 -- itself is not. PS. In this case, the function's
568 -- live vars should already include those of the
569 -- continuation, but it does no harm to just union the
574 -- = live_in_cont `unionVarSet` case how_bound of
575 -- LetrecBound _ lvs -> lvs `minusVarSet` myself
576 -- other -> emptyVarSet
578 app = case idFlavour f of
579 DataConId dc -> StgConApp dc args'
580 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
581 _other -> StgApp f args'
586 fun_fvs `unionFVInfo` args_fvs,
587 fun_escs `unionVarSet` (getFVSet args_fvs)
588 -- All the free vars of the args are disqualified
589 -- from being let-no-escaped.
593 -- ---------------------------------------------------------------------------
594 -- The magic for lets:
595 -- ---------------------------------------------------------------------------
598 :: Bool -- True <=> yes, we are let-no-escaping this let
599 -> CoreBind -- bindings
601 -> LneM (StgExpr, -- new let
602 FreeVarsInfo, -- variables free in the whole let
603 EscVarsSet, -- variables that escape from the whole let
604 Bool) -- True <=> none of the binders in the bindings
605 -- is among the escaping vars
607 coreToStgLet let_no_escape bind body
608 = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
610 -- Do the bindings, setting live_in_cont to empty if
611 -- we ain't in a let-no-escape world
612 getVarsLiveInCont `thenLne` \ live_in_cont ->
614 (if let_no_escape then live_in_cont else emptyVarSet)
615 (vars_bind rec_bind_lvs rec_body_fvs bind)
616 `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
618 -- The live variables of this binding are the ones which are live
619 -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
620 -- together with the live_in_cont ones
621 lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
622 `thenLne` \ lvs_from_fvs ->
624 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
627 -- bind_fvs and bind_escs still include the binders of the let(rec)
628 -- but bind_lvs does not
631 extendVarEnvLne env_ext (
632 coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
633 lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
635 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
636 body2, body_fvs, body_escs, body_lvs)
638 )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
639 body2, body_fvs, body_escs, body_lvs) ->
642 -- Compute the new let-expression
644 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
645 | otherwise = StgLet bind2 body2
648 = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
651 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
653 real_bind_escs = if let_no_escape then
657 -- Everything escapes which is free in the bindings
659 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
661 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
664 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
667 -- Debugging code as requested by Andrew Kennedy
668 checked_no_binder_escapes
669 | not no_binder_escapes && any is_join_var binders
670 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
672 | otherwise = no_binder_escapes
674 checked_no_binder_escapes = no_binder_escapes
677 -- Mustn't depend on the passed-in let_no_escape flag, since
678 -- no_binder_escapes is used by the caller to derive the flag!
684 checked_no_binder_escapes
687 set_of_binders = mkVarSet binders
688 binders = case bind of
689 NonRec binder rhs -> [binder]
690 Rec pairs -> map fst pairs
692 mk_binding bind_lvs binder
693 = (binder, LetrecBound False -- Not top level
697 live_vars = if let_no_escape then
698 extendVarSet bind_lvs binder
702 vars_bind :: StgLiveVars
703 -> FreeVarsInfo -- Free var info for body of binding
706 FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
708 -- extension to environment
710 vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
711 = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
712 `thenLne` \ (rhs2, fvs, escs) ->
714 env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
716 returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
718 vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
720 binders = map fst pairs
721 env_ext = map (mk_binding rec_bind_lvs) binders
723 extendVarEnvLne env_ext (
724 fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
726 rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
728 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
729 `thenLne` \ (rhss2, fvss, escss) ->
731 fvs = unionFVInfos fvss
732 escs = unionVarSets escss
734 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
737 is_join_var :: Id -> Bool
738 -- A hack (used only for compiler debuggging) to tell if
739 -- a variable started life as a join point ($j)
740 is_join_var j = occNameUserString (getOccName j) == "$j"
743 %************************************************************************
745 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
747 %************************************************************************
749 There's a lot of stuff to pass around, so we use this @LneM@ monad to
750 help. All the stuff here is only passed {\em down}.
753 type LneM a = IdEnv HowBound
754 -> StgLiveVars -- vars live in continuation
762 Bool -- True <=> bound at top level
763 StgLiveVars -- Live vars... see notes below
765 isLetrecBound (LetrecBound _ _) = True
766 isLetrecBound other = False
769 For a let(rec)-bound variable, x, we record what varibles are live if
770 x is live. For "normal" variables that is just x alone. If x is
771 a let-no-escaped variable then x is represented by a code pointer and
772 a stack pointer (well, one for each stack). So all of the variables
773 needed in the execution of x are live if x is, and are therefore recorded
774 in the LetrecBound constructor; x itself *is* included.
776 The std monad functions:
778 initLne :: LneM a -> a
779 initLne m = m emptyVarEnv emptyVarSet
781 {-# INLINE thenLne #-}
782 {-# INLINE thenLne_ #-}
783 {-# INLINE returnLne #-}
785 returnLne :: a -> LneM a
786 returnLne e env lvs_cont = e
788 thenLne :: LneM a -> (a -> LneM b) -> LneM b
789 thenLne m k env lvs_cont
790 = case (m env lvs_cont) of
791 m_result -> k m_result env lvs_cont
793 thenLne_ :: LneM a -> LneM b -> LneM b
794 thenLne_ m k env lvs_cont
795 = case (m env lvs_cont) of
798 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
799 mapLne f [] = returnLne []
801 = f x `thenLne` \ r ->
802 mapLne f xs `thenLne` \ rs ->
805 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
807 mapAndUnzipLne f [] = returnLne ([],[])
808 mapAndUnzipLne f (x:xs)
809 = f x `thenLne` \ (r1, r2) ->
810 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
811 returnLne (r1:rs1, r2:rs2)
813 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
815 mapAndUnzip3Lne f [] = returnLne ([],[],[])
816 mapAndUnzip3Lne f (x:xs)
817 = f x `thenLne` \ (r1, r2, r3) ->
818 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
819 returnLne (r1:rs1, r2:rs2, r3:rs3)
821 fixLne :: (a -> LneM a) -> LneM a
822 fixLne expr env lvs_cont = result
824 result = expr result env lvs_cont
825 -- ^^^^^^ ------ ^^^^^^
828 Functions specific to this monad:
830 getVarsLiveInCont :: LneM StgLiveVars
831 getVarsLiveInCont env lvs_cont = lvs_cont
833 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
834 setVarsLiveInCont new_lvs_cont expr env lvs_cont
835 = expr env new_lvs_cont
837 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
838 extendVarEnvLne ids_w_howbound expr env lvs_cont
839 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
841 lookupVarLne :: Id -> LneM HowBound
842 lookupVarLne v env lvs_cont
844 case (lookupVarEnv env v) of
846 Nothing -> ImportBound
849 -- The result of lookupLiveVarsForSet, a set of live variables, is
850 -- only ever tacked onto a decorated expression. It is never used as
851 -- the basis of a control decision, which might give a black hole.
853 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
855 lookupLiveVarsForSet fvs env lvs_cont
856 = returnLne (unionVarSets (map do_one (getFVs fvs)))
860 = if isLocalId v then
861 case (lookupVarEnv env v) of
862 Just (LetrecBound _ lvs) -> extendVarSet lvs v
863 Just _ -> unitVarSet v
864 Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
870 %************************************************************************
872 \subsection[Free-var info]{Free variable information}
874 %************************************************************************
877 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
878 -- If f is mapped to NoStgBinderInfo, that means
879 -- that f *is* mentioned (else it wouldn't be in the
880 -- IdEnv at all), but only in a saturated applications.
882 -- All case/lambda-bound things are also mapped to
883 -- NoStgBinderInfo, since we aren't interested in their
886 -- The Bool is True <=> the Id is top level letrec bound
888 type EscVarsSet = IdSet
892 emptyFVInfo :: FreeVarsInfo
893 emptyFVInfo = emptyVarEnv
895 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
896 singletonFVInfo id ImportBound info = emptyVarEnv
897 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
898 singletonFVInfo id other info = unitVarEnv id (id, False, info)
900 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
901 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
903 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
904 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
906 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
907 minusFVBinders fv ids = fv `delVarEnvList` ids
909 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
910 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
912 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
913 lookupFVInfo fvs id = case lookupVarEnv fvs id of
914 Nothing -> NoStgBinderInfo
915 Just (_,_,info) -> info
917 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
918 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
920 getFVSet :: FreeVarsInfo -> IdSet
921 getFVSet fvs = mkVarSet (getFVs fvs)
923 plusFVInfo (id1,top1,info1) (id2,top2,info2)
924 = ASSERT (id1 == id2 && top1 == top2)
925 (id1, top1, combineStgBinderInfo info1 info2)
931 shouldBeVar (Note _ e) = shouldBeVar e
932 shouldBeVar (Var v) = v
933 shouldBeVar e = pprPanic "shouldBeVar" (ppr e)
935 -- ignore all notes except SCC
936 myCollectBinders expr
939 go bs (Lam b e) = go (b:bs) e
940 go bs e@(Note (SCC _) _) = (reverse bs, e)
941 go bs (Note _ e) = go bs e
942 go bs e = (reverse bs, e)
944 myCollectArgs :: Expr b -> (Expr b, [Arg b])
948 go (App f a) as = go f (a:as)
949 go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs"
950 go (Note n e) as = go e as