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
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 mkStgAlgAlts ty alts deflt
433 -- Get the tycon from the data con
434 (dc, _, _, _) : _rest
435 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
437 -- Otherwise just do your best
438 [] -> case splitTyConApp_maybe (repType ty) of
439 Just (tc,_) | isAlgTyCon tc
440 -> StgAlgAlts (Just tc) alts deflt
442 -> StgAlgAlts Nothing alts deflt
444 mkStgPrimAlts ty alts deflt
445 = StgPrimAlts (tyConAppTyCon ty) alts deflt
449 -- ---------------------------------------------------------------------------
451 -- ---------------------------------------------------------------------------
455 :: Maybe UpdateFlag -- Just upd <=> this application is
456 -- the rhs of a thunk binding
457 -- x = [...] \upd [] -> the_app
458 -- with specified update flag
460 -> [CoreArg] -- Arguments
461 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
463 coreToStgApp maybe_thunk_body f args
464 = getVarsLiveInCont `thenLne` \ live_in_cont ->
465 coreToStgArgs args `thenLne` \ (args', args_fvs) ->
466 lookupVarLne f `thenLne` \ how_bound ->
470 not_letrec_bound = not (isLetrecBound how_bound)
471 fun_fvs = singletonFVInfo f how_bound fun_occ
473 -- Mostly, the arity info of a function is in the fn's IdInfo
474 -- But new bindings introduced by CoreSat may not have no
475 -- arity info; it would do us no good anyway. For example:
476 -- let f = \ab -> e in f
477 -- No point in having correct arity info for f!
478 -- Hence the hasArity stuff below.
479 f_arity_info = idArityInfo f
480 f_arity = arityLowerBound f_arity_info -- Zero if no info
483 | not_letrec_bound = noBinderInfo -- Uninteresting variable
484 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
485 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
488 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
489 | hasArity f_arity_info &&
490 f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
491 -- saturated call doesn't escape
492 -- (let-no-escape applies to 'thunks' too)
494 | otherwise = unitVarSet f -- Inexact application; it does escape
496 -- At the moment of the call:
498 -- either the function is *not* let-no-escaped, in which case
499 -- nothing is live except live_in_cont
500 -- or the function *is* let-no-escaped in which case the
501 -- variables it uses are live, but still the function
502 -- itself is not. PS. In this case, the function's
503 -- live vars should already include those of the
504 -- continuation, but it does no harm to just union the
507 app = case idFlavour f of
508 DataConId dc -> StgConApp dc args'
509 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
510 _other -> StgApp f args'
515 fun_fvs `unionFVInfo` args_fvs,
516 fun_escs `unionVarSet` (getFVSet args_fvs)
517 -- All the free vars of the args are disqualified
518 -- from being let-no-escaped.
523 -- ---------------------------------------------------------------------------
525 -- This is the guy that turns applications into A-normal form
526 -- ---------------------------------------------------------------------------
528 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
530 = returnLne ([], emptyFVInfo)
532 coreToStgArgs (Type ty : args) -- Type argument
533 = coreToStgArgs args `thenLne` \ (args', fvs) ->
534 if opt_KeepStgTypes then
535 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
537 returnLne (args', fvs)
539 coreToStgArgs (arg : args) -- Non-type argument
540 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
541 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
543 fvs = args_fvs `unionFVInfo` arg_fvs
544 stg_arg = case arg' of
545 StgApp v [] -> StgVarArg v
546 StgConApp con [] -> StgVarArg (dataConWrapId con)
547 StgLit lit -> StgLitArg lit
548 _ -> pprPanic "coreToStgArgs" (ppr arg)
550 returnLne (stg_arg : stg_args, fvs)
553 -- ---------------------------------------------------------------------------
554 -- The magic for lets:
555 -- ---------------------------------------------------------------------------
558 :: Bool -- True <=> yes, we are let-no-escaping this let
559 -> CoreBind -- bindings
561 -> LneM (StgExpr, -- new let
562 FreeVarsInfo, -- variables free in the whole let
563 EscVarsSet, -- variables that escape from the whole let
564 Bool) -- True <=> none of the binders in the bindings
565 -- is among the escaping vars
567 coreToStgLet let_no_escape bind body
568 = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
570 -- Do the bindings, setting live_in_cont to empty if
571 -- we ain't in a let-no-escape world
572 getVarsLiveInCont `thenLne` \ live_in_cont ->
574 (if let_no_escape then live_in_cont else emptyVarSet)
575 (vars_bind rec_bind_lvs rec_body_fvs bind)
576 `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
578 -- The live variables of this binding are the ones which are live
579 -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
580 -- together with the live_in_cont ones
581 lookupLiveVarsForSet (binders `minusFVBinders` bind_fvs)
582 `thenLne` \ lvs_from_fvs ->
584 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
587 -- bind_fvs and bind_escs still include the binders of the let(rec)
588 -- but bind_lvs does not
591 extendVarEnvLne env_ext (
592 coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
593 lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
595 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
596 body2, body_fvs, body_escs, body_lvs)
598 )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
599 body2, body_fvs, body_escs, body_lvs) ->
602 -- Compute the new let-expression
604 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
605 | otherwise = StgLet bind2 body2
608 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
611 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
613 real_bind_escs = if let_no_escape then
617 -- Everything escapes which is free in the bindings
619 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
621 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
624 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
627 -- Debugging code as requested by Andrew Kennedy
628 checked_no_binder_escapes
629 | not no_binder_escapes && any is_join_var binders
630 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
632 | otherwise = no_binder_escapes
634 checked_no_binder_escapes = no_binder_escapes
637 -- Mustn't depend on the passed-in let_no_escape flag, since
638 -- no_binder_escapes is used by the caller to derive the flag!
644 checked_no_binder_escapes
647 set_of_binders = mkVarSet binders
648 binders = case bind of
649 NonRec binder rhs -> [binder]
650 Rec pairs -> map fst pairs
652 mk_binding bind_lvs binder
653 = (binder, LetrecBound False -- Not top level
657 live_vars = if let_no_escape then
658 extendVarSet bind_lvs binder
662 vars_bind :: StgLiveVars
663 -> FreeVarsInfo -- Free var info for body of binding
666 FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
668 -- extension to environment
670 vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
671 = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
672 `thenLne` \ (rhs2, fvs, escs) ->
674 env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
676 returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
678 vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
680 binders = map fst pairs
681 env_ext = map (mk_binding rec_bind_lvs) binders
683 extendVarEnvLne env_ext (
684 fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
686 rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
688 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
689 `thenLne` \ (rhss2, fvss, escss) ->
691 fvs = unionFVInfos fvss
692 escs = unionVarSets escss
694 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
697 is_join_var :: Id -> Bool
698 -- A hack (used only for compiler debuggging) to tell if
699 -- a variable started life as a join point ($j)
700 is_join_var j = occNameUserString (getOccName j) == "$j"
703 %************************************************************************
705 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
707 %************************************************************************
709 There's a lot of stuff to pass around, so we use this @LneM@ monad to
710 help. All the stuff here is only passed {\em down}.
713 type LneM a = IdEnv HowBound
714 -> StgLiveVars -- vars live in continuation
722 Bool -- True <=> bound at top level
723 StgLiveVars -- Live vars... see notes below
725 isLetrecBound (LetrecBound _ _) = True
726 isLetrecBound other = False
729 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
730 variables that are live if x is live. For "normal" variables that is
731 just x alone. If x is a let-no-escaped variable then x is represented
732 by a code pointer and a stack pointer (well, one for each stack). So
733 all of the variables needed in the execution of x are live if x is,
734 and are therefore recorded in the LetrecBound constructor; x itself
737 The set of live variables is guaranteed ot have no further let-no-escaped
740 The std monad functions:
742 initLne :: LneM a -> a
743 initLne m = m emptyVarEnv emptyVarSet
745 {-# INLINE thenLne #-}
746 {-# INLINE returnLne #-}
748 returnLne :: a -> LneM a
749 returnLne e env lvs_cont = e
751 thenLne :: LneM a -> (a -> LneM b) -> LneM b
752 thenLne m k env lvs_cont
753 = k (m env lvs_cont) env lvs_cont
755 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
756 mapLne f [] = returnLne []
758 = f x `thenLne` \ r ->
759 mapLne f xs `thenLne` \ rs ->
762 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
764 mapAndUnzipLne f [] = returnLne ([],[])
765 mapAndUnzipLne f (x:xs)
766 = f x `thenLne` \ (r1, r2) ->
767 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
768 returnLne (r1:rs1, r2:rs2)
770 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
772 mapAndUnzip3Lne f [] = returnLne ([],[],[])
773 mapAndUnzip3Lne f (x:xs)
774 = f x `thenLne` \ (r1, r2, r3) ->
775 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
776 returnLne (r1:rs1, r2:rs2, r3:rs3)
778 fixLne :: (a -> LneM a) -> LneM a
779 fixLne expr env lvs_cont
782 result = expr result env lvs_cont
785 Functions specific to this monad:
788 getVarsLiveInCont :: LneM StgLiveVars
789 getVarsLiveInCont env lvs_cont = lvs_cont
791 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
792 setVarsLiveInCont new_lvs_cont expr env lvs_cont
793 = expr env new_lvs_cont
795 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
796 extendVarEnvLne ids_w_howbound expr env lvs_cont
797 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
799 lookupVarLne :: Id -> LneM HowBound
800 lookupVarLne v env lvs_cont
802 case (lookupVarEnv env v) of
804 Nothing -> ImportBound
807 -- The result of lookupLiveVarsForSet, a set of live variables, is
808 -- only ever tacked onto a decorated expression. It is never used as
809 -- the basis of a control decision, which might give a black hole.
811 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
813 lookupLiveVarsForSet fvs env lvs_cont
814 = returnLne (unionVarSets (map do_one (getFVs fvs)))
818 = if isLocalId v then
819 case (lookupVarEnv env v) of
820 Just (LetrecBound _ lvs) -> extendVarSet lvs v
821 Just _ -> unitVarSet v
822 Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
828 %************************************************************************
830 \subsection[Free-var info]{Free variable information}
832 %************************************************************************
835 type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
836 -- If f is mapped to noBinderInfo, that means
837 -- that f *is* mentioned (else it wouldn't be in the
838 -- IdEnv at all), but perhaps in an unsaturated applications.
840 -- All case/lambda-bound things are also mapped to
841 -- noBinderInfo, since we aren't interested in their
844 -- The Bool is True <=> the Id is top level letrec bound
846 -- For ILX we track free var info for type variables too;
847 -- hence VarEnv not IdEnv
849 type EscVarsSet = IdSet
853 emptyFVInfo :: FreeVarsInfo
854 emptyFVInfo = emptyVarEnv
856 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
857 singletonFVInfo id ImportBound info = emptyVarEnv
858 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
859 singletonFVInfo id other info = unitVarEnv id (id, False, info)
861 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
862 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
864 add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo)
866 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
867 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
869 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
870 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
872 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
873 minusFVBinders vs fv = foldr minusFVBinder fv vs
875 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
876 minusFVBinder v fv | isId v = (fv `delVarEnv` v) `unionFVInfo`
877 tyvarFVInfo (tyVarsOfType (idType v))
878 | otherwise = fv `delVarEnv` v
879 -- When removing a binder, remember to add its type variables
880 -- c.f. CoreFVs.delBinderFV
882 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
883 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
885 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
886 -- Find how the given Id is used.
887 -- Externally visible things may be used any old how
889 | isExternallyVisibleName (idName id) = noBinderInfo
890 | otherwise = case lookupVarEnv fvs id of
891 Nothing -> noBinderInfo
892 Just (_,_,info) -> info
894 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
895 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
897 getFVSet :: FreeVarsInfo -> IdSet
898 getFVSet fvs = mkVarSet (getFVs fvs)
900 plusFVInfo (id1,top1,info1) (id2,top2,info2)
901 = ASSERT (id1 == id2 && top1 == top2)
902 (id1, top1, combineStgBinderInfo info1 info2)
907 filterStgBinders :: [Var] -> [Var]
908 filterStgBinders bndrs
909 | opt_KeepStgTypes = bndrs
910 | otherwise = filter isId bndrs
915 -- Ignore all notes except SCC
916 myCollectBinders expr
919 go bs (Lam b e) = go (b:bs) e
920 go bs e@(Note (SCC _) _) = (reverse bs, e)
921 go bs (Note _ e) = go bs e
922 go bs e = (reverse bs, e)
924 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
925 -- We assume that we only have variables
926 -- in the function position by now
930 go (Var v) as = (v, as)
931 go (App f a) as = go f (a:as)
932 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
933 go (Note n e) as = go e as
934 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)