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 binders `minusFVBinders` (fv_binds `unionFVInfo` fv_bind)
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 = args' `minusFVBinders` body_fvs
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 StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
333 bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
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 binders' `minusFVBinders` rhs_fvs,
390 rhs_escs `minusVarSet` mkVarSet binders'
391 -- ToDo: remove the minusVarSet;
392 -- since escs won't include any of these binders
394 vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
397 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
399 vars_deflt (Just rhs)
400 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
401 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
404 Lets not only take quite a bit of work, but this is where we convert
405 then to let-no-escapes, if we wish.
407 (Meanwhile, we don't expect to see let-no-escapes...)
409 coreToStgExpr (Let bind body)
410 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
411 coreToStgLet no_binder_escapes bind body
412 ) `thenLne` \ (new_let, fvs, escs, _) ->
414 returnLne (new_let, fvs, escs)
417 If we've got a case containing a _ccall_GC_ primop, we need to
418 ensure that the arguments are kept live for the duration of the
419 call. This only an issue
422 isForeignObjArg :: Id -> Bool
423 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
425 isForeignObjPrimTy ty
426 = case splitTyConApp_maybe ty of
427 Just (tycon, _) -> tycon == foreignObjPrimTyCon
432 mkStgAlgAlts ty alts deflt
434 -- Get the tycon from the data con
435 (dc, _, _, _) : _rest
436 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
438 -- Otherwise just do your best
439 [] -> case splitTyConApp_maybe (repType ty) of
440 Just (tc,_) | isAlgTyCon tc
441 -> StgAlgAlts (Just tc) alts deflt
443 -> StgAlgAlts Nothing alts deflt
445 mkStgPrimAlts ty alts deflt
446 = StgPrimAlts (tyConAppTyCon ty) alts deflt
450 -- ---------------------------------------------------------------------------
452 -- ---------------------------------------------------------------------------
456 :: Maybe UpdateFlag -- Just upd <=> this application is
457 -- the rhs of a thunk binding
458 -- x = [...] \upd [] -> the_app
459 -- with specified update flag
461 -> [CoreArg] -- Arguments
462 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
464 coreToStgApp maybe_thunk_body f args
465 = getVarsLiveInCont `thenLne` \ live_in_cont ->
466 coreToStgArgs args `thenLne` \ (args', args_fvs) ->
467 lookupVarLne f `thenLne` \ how_bound ->
471 not_letrec_bound = not (isLetrecBound how_bound)
472 fun_fvs = singletonFVInfo f how_bound fun_occ
474 -- Mostly, the arity info of a function is in the fn's IdInfo
475 -- But new bindings introduced by CoreSat may not have no
476 -- arity info; it would do us no good anyway. For example:
477 -- let f = \ab -> e in f
478 -- No point in having correct arity info for f!
479 -- Hence the hasArity stuff below.
480 f_arity_info = idArityInfo f
481 f_arity = arityLowerBound f_arity_info -- Zero if no info
484 | not_letrec_bound = noBinderInfo -- Uninteresting variable
485 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
486 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
489 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
490 | hasArity f_arity_info &&
491 f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
492 -- saturated call doesn't escape
493 -- (let-no-escape applies to 'thunks' too)
495 | otherwise = unitVarSet f -- Inexact application; it does escape
497 -- At the moment of the call:
499 -- either the function is *not* let-no-escaped, in which case
500 -- nothing is live except live_in_cont
501 -- or the function *is* let-no-escaped in which case the
502 -- variables it uses are live, but still the function
503 -- itself is not. PS. In this case, the function's
504 -- live vars should already include those of the
505 -- continuation, but it does no harm to just union the
508 app = case idFlavour f of
509 DataConId dc -> StgConApp dc args'
510 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
511 _other -> StgApp f args'
516 fun_fvs `unionFVInfo` args_fvs,
517 fun_escs `unionVarSet` (getFVSet args_fvs)
518 -- All the free vars of the args are disqualified
519 -- from being let-no-escaped.
524 -- ---------------------------------------------------------------------------
526 -- This is the guy that turns applications into A-normal form
527 -- ---------------------------------------------------------------------------
529 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
531 = returnLne ([], emptyFVInfo)
533 coreToStgArgs (Type ty : args) -- Type argument
534 = coreToStgArgs args `thenLne` \ (args', fvs) ->
535 if opt_KeepStgTypes then
536 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
538 returnLne (args', fvs)
540 coreToStgArgs (arg : args) -- Non-type argument
541 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
542 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
544 fvs = args_fvs `unionFVInfo` arg_fvs
545 stg_arg = case arg' of
546 StgApp v [] -> StgVarArg v
547 StgConApp con [] -> StgVarArg (dataConWrapId con)
548 StgLit lit -> StgLitArg lit
549 _ -> pprPanic "coreToStgArgs" (ppr arg)
551 returnLne (stg_arg : stg_args, fvs)
554 -- ---------------------------------------------------------------------------
555 -- The magic for lets:
556 -- ---------------------------------------------------------------------------
559 :: Bool -- True <=> yes, we are let-no-escaping this let
560 -> CoreBind -- bindings
562 -> LneM (StgExpr, -- new let
563 FreeVarsInfo, -- variables free in the whole let
564 EscVarsSet, -- variables that escape from the whole let
565 Bool) -- True <=> none of the binders in the bindings
566 -- is among the escaping vars
568 coreToStgLet let_no_escape bind body
569 = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
571 -- Do the bindings, setting live_in_cont to empty if
572 -- we ain't in a let-no-escape world
573 getVarsLiveInCont `thenLne` \ live_in_cont ->
575 (if let_no_escape then live_in_cont else emptyVarSet)
576 (vars_bind rec_bind_lvs rec_body_fvs bind)
577 `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
579 -- The live variables of this binding are the ones which are live
580 -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
581 -- together with the live_in_cont ones
582 lookupLiveVarsForSet (binders `minusFVBinders` bind_fvs)
583 `thenLne` \ lvs_from_fvs ->
585 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
588 -- bind_fvs and bind_escs still include the binders of the let(rec)
589 -- but bind_lvs does not
592 extendVarEnvLne env_ext (
593 coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
594 lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
596 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
597 body2, body_fvs, body_escs, body_lvs)
599 )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
600 body2, body_fvs, body_escs, body_lvs) ->
603 -- Compute the new let-expression
605 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
606 | otherwise = StgLet bind2 body2
609 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
612 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
614 real_bind_escs = if let_no_escape then
618 -- Everything escapes which is free in the bindings
620 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
622 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
625 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
628 -- Debugging code as requested by Andrew Kennedy
629 checked_no_binder_escapes
630 | not no_binder_escapes && any is_join_var binders
631 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
633 | otherwise = no_binder_escapes
635 checked_no_binder_escapes = no_binder_escapes
638 -- Mustn't depend on the passed-in let_no_escape flag, since
639 -- no_binder_escapes is used by the caller to derive the flag!
645 checked_no_binder_escapes
648 set_of_binders = mkVarSet binders
649 binders = case bind of
650 NonRec binder rhs -> [binder]
651 Rec pairs -> map fst pairs
653 mk_binding bind_lvs binder
654 = (binder, LetrecBound False -- Not top level
658 live_vars = if let_no_escape then
659 extendVarSet bind_lvs binder
663 vars_bind :: StgLiveVars
664 -> FreeVarsInfo -- Free var info for body of binding
667 FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
669 -- extension to environment
671 vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
672 = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
673 `thenLne` \ (rhs2, fvs, escs) ->
675 env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
677 returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
679 vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
681 binders = map fst pairs
682 env_ext = map (mk_binding rec_bind_lvs) binders
684 extendVarEnvLne env_ext (
685 fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
687 rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
689 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
690 `thenLne` \ (rhss2, fvss, escss) ->
692 fvs = unionFVInfos fvss
693 escs = unionVarSets escss
695 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
698 is_join_var :: Id -> Bool
699 -- A hack (used only for compiler debuggging) to tell if
700 -- a variable started life as a join point ($j)
701 is_join_var j = occNameUserString (getOccName j) == "$j"
704 %************************************************************************
706 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
708 %************************************************************************
710 There's a lot of stuff to pass around, so we use this @LneM@ monad to
711 help. All the stuff here is only passed {\em down}.
714 type LneM a = IdEnv HowBound
715 -> StgLiveVars -- vars live in continuation
723 Bool -- True <=> bound at top level
724 StgLiveVars -- Live vars... see notes below
726 isLetrecBound (LetrecBound _ _) = True
727 isLetrecBound other = False
730 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
731 variables that are live if x is live. For "normal" variables that is
732 just x alone. If x is a let-no-escaped variable then x is represented
733 by a code pointer and a stack pointer (well, one for each stack). So
734 all of the variables needed in the execution of x are live if x is,
735 and are therefore recorded in the LetrecBound constructor; x itself
738 The set of live variables is guaranteed ot have no further let-no-escaped
741 The std monad functions:
743 initLne :: LneM a -> a
744 initLne m = m emptyVarEnv emptyVarSet
746 {-# INLINE thenLne #-}
747 {-# INLINE returnLne #-}
749 returnLne :: a -> LneM a
750 returnLne e env lvs_cont = e
752 thenLne :: LneM a -> (a -> LneM b) -> LneM b
753 thenLne m k env lvs_cont
754 = k (m env lvs_cont) env lvs_cont
756 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
757 mapLne f [] = returnLne []
759 = f x `thenLne` \ r ->
760 mapLne f xs `thenLne` \ rs ->
763 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
765 mapAndUnzipLne f [] = returnLne ([],[])
766 mapAndUnzipLne f (x:xs)
767 = f x `thenLne` \ (r1, r2) ->
768 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
769 returnLne (r1:rs1, r2:rs2)
771 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
773 mapAndUnzip3Lne f [] = returnLne ([],[],[])
774 mapAndUnzip3Lne f (x:xs)
775 = f x `thenLne` \ (r1, r2, r3) ->
776 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
777 returnLne (r1:rs1, r2:rs2, r3:rs3)
779 fixLne :: (a -> LneM a) -> LneM a
780 fixLne expr env lvs_cont
783 result = expr result env lvs_cont
786 Functions specific to this monad:
789 getVarsLiveInCont :: LneM StgLiveVars
790 getVarsLiveInCont env lvs_cont = lvs_cont
792 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
793 setVarsLiveInCont new_lvs_cont expr env lvs_cont
794 = expr env new_lvs_cont
796 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
797 extendVarEnvLne ids_w_howbound expr env lvs_cont
798 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
800 lookupVarLne :: Id -> LneM HowBound
801 lookupVarLne v env lvs_cont
803 case (lookupVarEnv env v) of
805 Nothing -> ImportBound
808 -- The result of lookupLiveVarsForSet, a set of live variables, is
809 -- only ever tacked onto a decorated expression. It is never used as
810 -- the basis of a control decision, which might give a black hole.
812 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
814 lookupLiveVarsForSet fvs env lvs_cont
815 = returnLne (unionVarSets (map do_one (getFVs fvs)))
819 = if isLocalId v then
820 case (lookupVarEnv env v) of
821 Just (LetrecBound _ lvs) -> extendVarSet lvs v
822 Just _ -> unitVarSet v
823 Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
829 %************************************************************************
831 \subsection[Free-var info]{Free variable information}
833 %************************************************************************
836 type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
837 -- If f is mapped to noBinderInfo, that means
838 -- that f *is* mentioned (else it wouldn't be in the
839 -- IdEnv at all), but perhaps in an unsaturated applications.
841 -- All case/lambda-bound things are also mapped to
842 -- noBinderInfo, since we aren't interested in their
845 -- The Bool is True <=> the Id is top level letrec bound
847 -- For ILX we track free var info for type variables too;
848 -- hence VarEnv not IdEnv
850 type EscVarsSet = IdSet
854 emptyFVInfo :: FreeVarsInfo
855 emptyFVInfo = emptyVarEnv
857 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
858 singletonFVInfo id ImportBound info = emptyVarEnv
859 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
860 singletonFVInfo id other info = unitVarEnv id (id, False, info)
862 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
863 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
865 add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo)
867 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
868 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
870 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
871 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
873 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
874 minusFVBinders vs fv = foldr minusFVBinder fv vs
876 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
877 minusFVBinder v fv | isId v && opt_KeepStgTypes
878 = (fv `delVarEnv` v) `unionFVInfo`
879 tyvarFVInfo (tyVarsOfType (idType v))
880 | otherwise = fv `delVarEnv` v
881 -- When removing a binder, remember to add its type variables
882 -- c.f. CoreFVs.delBinderFV
884 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
885 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
887 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
888 -- Find how the given Id is used.
889 -- Externally visible things may be used any old how
891 | isExternallyVisibleName (idName id) = noBinderInfo
892 | otherwise = case lookupVarEnv fvs id of
893 Nothing -> noBinderInfo
894 Just (_,_,info) -> info
896 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
897 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
899 getFVSet :: FreeVarsInfo -> IdSet
900 getFVSet fvs = mkVarSet (getFVs fvs)
902 plusFVInfo (id1,top1,info1) (id2,top2,info2)
903 = ASSERT (id1 == id2 && top1 == top2)
904 (id1, top1, combineStgBinderInfo info1 info2)
909 filterStgBinders :: [Var] -> [Var]
910 filterStgBinders bndrs
911 | opt_KeepStgTypes = bndrs
912 | otherwise = filter isId bndrs
917 -- Ignore all notes except SCC
918 myCollectBinders expr
921 go bs (Lam b e) = go (b:bs) e
922 go bs e@(Note (SCC _) _) = (reverse bs, e)
923 go bs (Note _ e) = go bs e
924 go bs e = (reverse bs, e)
926 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
927 -- We assume that we only have variables
928 -- in the function position by now
932 go (Var v) as = (v, as)
933 go (App f a) as = go f (a:as)
934 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
935 go (Note n e) as = go e as
936 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)