{-# LANGUAGE CPP #-}---- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998------------------------------------------------------------------ Converting Core to STG Syntax---------------------------------------------------------------- And, as we have the info in hand, we may convert some lets to-- let-no-escapes.moduleCoreToStg(coreToStg,coreExprToStg)where#include "HsVersions.h"importCoreSynimportCoreUtils(exprType,findDefault)importCoreArity(manifestArity)importStgSynimportTypeimportTyConimportMkId(coercionTokenId)importIdimportIdInfoimportDataConimportCostCentre(noCCS)importVarSetimportVarEnvimportModuleimportName(getOccName,isExternalName,nameOccName)importOccName(occNameString,occNameFS)importBasicTypes(Arity)importTysWiredIn(unboxedUnitDataCon)importLiteralimportOutputableimportMonadUtilsimportFastStringimportUtilimportDynFlagsimportForeignCallimportDemand(isSingleUsed)importPrimOp(PrimCall(..))importData.Maybe(isJust)importControl.Monad(liftM,ap)-- Note [Live vs free]-- ~~~~~~~~~~~~~~~~~~~---- The actual Stg datatype is decorated with live variable information, as well-- as free variable information. The two are not the same. Liveness is an-- operational property rather than a semantic one. A variable is live at a-- particular execution point if it can be referred to directly again. In-- particular, a dead variable's stack slot (if it has one):---- - should be stubbed to avoid space leaks, and-- - may be reused for something else.---- There ought to be a better way to say this. Here are some examples:---- let v = [q] \[x] -> e-- in-- ...v... (but no q's)---- Just after the `in', v is live, but q is dead. If the whole of that-- let expression was enclosed in a case expression, thus:---- case (let v = [q] \[x] -> e in ...v...) of-- alts[...q...]---- (ie `alts' mention `q'), then `q' is live even after the `in'; because-- we'll return later to the `alts' and need it.---- Let-no-escapes make this a bit more interesting:---- let-no-escape v = [q] \ [x] -> e-- in-- ...v...---- Here, `q' is still live at the `in', because `v' is represented not by-- a closure but by the current stack state. In other words, if `v' is-- live then so is `q'. Furthermore, if `e' mentions an enclosing-- let-no-escaped variable, then its free variables are also live if `v' is.-- Note [Collecting live CAF info]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- In this pass we also collect information on which CAFs are live for-- constructing SRTs (see SRT.lhs).---- A top-level Id has CafInfo, which is---- - MayHaveCafRefs, if it may refer indirectly to-- one or more CAFs, or-- - NoCafRefs if it definitely doesn't---- The CafInfo has already been calculated during the CoreTidy pass.---- During CoreToStg, we then pin onto each binding and case expression, a-- list of Ids which represents the "live" CAFs at that point. The meaning-- of "live" here is the same as for live variables, see above (which is-- why it's convenient to collect CAF information here rather than elsewhere).---- The later SRT pass takes these lists of Ids and uses them to construct-- the actual nested SRTs, and replaces the lists of Ids with (offset,length)-- pairs.-- Note [Interaction of let-no-escape with SRTs]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- Consider---- let-no-escape x = ...caf1...caf2...-- in-- ...x...x...x...---- where caf1,caf2 are CAFs. Since x doesn't have a closure, we-- build SRTs just as if x's defn was inlined at each call site, and-- that means that x's CAF refs get duplicated in the overall SRT.---- This is unlike ordinary lets, in which the CAF refs are not duplicated.---- We could fix this loss of (static) sharing by making a sort of pseudo-closure-- for x, solely to put in the SRTs lower down.-- Note [What is a non-escaping let]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Consider:---- let x = fvs \ args -> e-- in-- if ... then x else-- if ... then x else ...---- `x' is used twice (so we probably can't unfold it), but when it is-- entered, the stack is deeper than it was when the definition of `x'-- happened. Specifically, if instead of allocating a closure for `x',-- we saved all `x's fvs on the stack, and remembered the stack depth at-- that moment, then whenever we enter `x' we can simply set the stack-- pointer(s) to these remembered (compile-time-fixed) values, and jump-- to the code for `x'.---- All of this is provided x is:-- 1. non-updatable - it must have at least one parameter (see Note-- [Join point abstraction]);-- 2. guaranteed to be entered before the stack retreats -- ie x is not-- buried in a heap-allocated closure, or passed as an argument to-- something;-- 3. all the enters have exactly the right number of arguments,-- no more no less;-- 4. all the enters are tail calls; that is, they return to the-- caller enclosing the definition of `x'.---- Under these circumstances we say that `x' is non-escaping.---- An example of when (4) does not hold:---- let x = ...-- in case x of ...alts...---- Here, `x' is certainly entered only when the stack is deeper than when-- `x' is defined, but here it must return to ...alts... So we can't just-- adjust the stack down to `x''s recalled points, because that would lost-- alts' context.---- Things can get a little more complicated. Consider:---- let y = ...-- in let x = fvs \ args -> ...y...-- in ...x...---- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a-- non-escaping way in ...y..., then `y' is non-escaping.---- `x' can even be recursive! Eg:---- letrec x = [y] \ [v] -> if v then x True else ...-- in-- ...(x b)...-- ---------------------------------------------------------------- Setting variable info: top-level, binds, RHSs-- --------------------------------------------------------------coreToStg::DynFlags->Module->CoreProgram->IO[StgBinding]coreToStgdflagsthis_modpgm=returnpgm'where(_,_,pgm')=coreTopBindsToStgdflagsthis_modemptyVarEnvpgmcoreExprToStg::CoreExpr->StgExprcoreExprToStgexpr=new_exprwhere(new_expr,_,_)=initLneemptyVarEnv(coreToStgExprexpr)coreTopBindsToStg::DynFlags->Module->IdEnvHowBound-- environment for the bindings->CoreProgram->(IdEnvHowBound,FreeVarsInfo,[StgBinding])coreTopBindsToStg__env[]=(env,emptyFVInfo,[])coreTopBindsToStgdflagsthis_modenv(b:bs)=(env2,fvs2,b':bs')where-- Notice the mutually-recursive "knot" here:-- env accumulates down the list of binds,-- fvs accumulates upwards(env1,fvs2,b')=coreTopBindToStgdflagsthis_modenvfvs1b(env2,fvs1,bs')=coreTopBindsToStgdflagsthis_modenv1bscoreTopBindToStg::DynFlags->Module->IdEnvHowBound->FreeVarsInfo-- Info about the body->CoreBind->(IdEnvHowBound,FreeVarsInfo,StgBinding)coreTopBindToStgdflagsthis_modenvbody_fvs(NonRecidrhs)=letenv'=extendVarEnvenvidhow_boundhow_bound=LetBoundTopLet$!manifestArityrhs(stg_rhs,fvs')=initLneenv$do(stg_rhs,fvs')<-coreToTopStgRhsdflagsthis_modbody_fvs(id,rhs)return(stg_rhs,fvs')bind=StgNonRecidstg_rhsinASSERT2(consistentCafInfoidbind,pprid)-- NB: previously the assertion printed 'rhs' and 'bind'-- as well as 'id', but that led to a black hole-- where printing the assertion error tripped the-- assertion again!(env',fvs'`unionFVInfo`body_fvs,bind)coreTopBindToStgdflagsthis_modenvbody_fvs(Recpairs)=ASSERT(not(nullpairs))letbinders=mapfstpairsextra_env'=[(b,LetBoundTopLet$!manifestArityrhs)|(b,rhs)<-pairs]env'=extendVarEnvListenvextra_env'(stg_rhss,fvs')=initLneenv'$do(stg_rhss,fvss')<-mapAndUnzipM(coreToTopStgRhsdflagsthis_modbody_fvs)pairsletfvs'=unionFVInfosfvss'return(stg_rhss,fvs')bind=StgRec(zipbindersstg_rhss)inASSERT2(consistentCafInfo(headbinders)bind,pprbinders)(env',fvs'`unionFVInfo`body_fvs,bind)-- Assertion helper: this checks that the CafInfo on the Id matches-- what CoreToStg has figured out about the binding's SRT. The-- CafInfo will be exact in all cases except when CorePrep has-- floated out a binding, in which case it will be approximate.consistentCafInfo::Id->GenStgBindingVarId->BoolconsistentCafInfoidbind=WARN(not(exact||is_sat_thing),pprid<+>pprid_marked_caffy<+>pprbinding_is_caffy)safewheresafe=id_marked_caffy||notbinding_is_caffyexact=id_marked_caffy==binding_is_caffyid_marked_caffy=mayHaveCafRefs(idCafInfoid)binding_is_caffy=stgBindHasCafRefsbindis_sat_thing=occNameFS(nameOccName(idNameid))==fsLit"sat"coreToTopStgRhs::DynFlags->Module->FreeVarsInfo-- Free var info for the scope of the binding->(Id,CoreExpr)->LneM(StgRhs,FreeVarsInfo)coreToTopStgRhsdflagsthis_modscope_fv_info(bndr,rhs)=do{(new_rhs,rhs_fvs,_)<-coreToStgExprrhs;lv_info<-freeVarsToLiveVarsrhs_fvs;letstg_rhs=mkTopStgRhsdflagsthis_modrhs_fvs(mkSRTlv_info)bndrbndr_infonew_rhsstg_arity=stgRhsAritystg_rhs;return(ASSERT2(arity_okstg_arity,mk_arity_msgstg_arity)stg_rhs,rhs_fvs)}wherebndr_info=lookupFVInfoscope_fv_infobndr-- It's vital that the arity on a top-level Id matches-- the arity of the generated STG binding, else an importing-- module will use the wrong calling convention-- (Trac #2844 was an example where this happened)-- NB1: we can't move the assertion further out without-- blocking the "knot" tied in coreTopBindsToStg-- NB2: the arity check is only needed for Ids with External-- Names, because they are externally visible. The CorePrep-- pass introduces "sat" things with Local Names and does-- not bother to set their Arity info, so don't fail for thosearity_okstg_arity|isExternalName(idNamebndr)=id_arity==stg_arity|otherwise=Trueid_arity=idAritybndrmk_arity_msgstg_arity=vcat[pprbndr,ptext(sLit"Id arity:")<+>pprid_arity,ptext(sLit"STG arity:")<+>pprstg_arity]mkTopStgRhs::DynFlags->Module->FreeVarsInfo->SRT->Id->StgBinderInfo->StgExpr->StgRhsmkTopStgRhsdflagsthis_mod=mkStgRhs'con_updateable-- Dynamic StgConApps are updatablewherecon_updateableconargs=isDllConAppdflagsthis_modconargs-- ----------------------------------------------------------------------------- Expressions-- ---------------------------------------------------------------------------coreToStgExpr::CoreExpr->LneM(StgExpr,-- Decorated STG exprFreeVarsInfo,-- Its free vars (NB free, not live)EscVarsSet)-- Its escapees, a subset of its free vars;-- also a subset of the domain of the envt-- because we are only interested in the escapees-- for vars which might be turned into-- let-no-escaped ones.-- The second and third components can be derived in a simple bottom up pass, not-- dependent on any decisions about which variables will be let-no-escaped or-- not. The first component, that is, the decorated expression, may then depend-- on these components, but it in turn is not scrutinised as the basis for any-- decisions. Hence no black holes.-- No LitInteger's should be left by the time this is called. CorePrep-- should have converted them all to a real core representation.coreToStgExpr(Lit(LitInteger{}))=panic"coreToStgExpr: LitInteger"coreToStgExpr(Litl)=return(StgLitl,emptyFVInfo,emptyVarSet)coreToStgExpr(Varv)=coreToStgAppNothingv[][]coreToStgExpr(Coercion_)=coreToStgAppNothingcoercionTokenId[][]coreToStgExprexpr@(App__)=coreToStgAppNothingfargstickswhere(f,args,ticks)=myCollectArgsexprcoreToStgExprexpr@(Lam__)=let(args,body)=myCollectBindersexprargs'=filterStgBindersargsinextendVarEnvLne[(a,LambdaBound)|a<-args']$do(body,body_fvs,body_escs)<-coreToStgExprbodyletfvs=args'`minusFVBinders`body_fvsescs=body_escs`delVarSetList`args'result_expr|nullargs'=body|otherwise=StgLamargs'bodyreturn(result_expr,fvs,escs)coreToStgExpr(Ticktickexpr)=docasetickofHpcTick{}->return()ProfNote{}->return()SourceNote{}->return()Breakpoint{}->panic"coreToStgExpr: breakpoint should not happen"(expr2,fvs,escs)<-coreToStgExprexprreturn(StgTicktickexpr2,fvs,escs)coreToStgExpr(Castexpr_)=coreToStgExprexpr-- Cases require a little more real work.coreToStgExpr(Casescrut__[])=coreToStgExprscrut-- See Note [Empty case alternatives] in CoreSyn If the case-- alternatives are empty, the scrutinee must diverge or raise an-- exception, so we can just dive into it.---- Of course this may seg-fault if the scrutinee *does* return. A-- belt-and-braces approach would be to move this case into the-- code generator, and put a return point anyway that calls a-- runtime system error function.coreToStgExpr(Casescrutbndr_alts)=do(alts2,alts_fvs,alts_escs)<-extendVarEnvLne[(bndr,LambdaBound)]$do(alts2,fvs_s,escs_s)<-mapAndUnzip3Mvars_altaltsreturn(alts2,unionFVInfosfvs_s,unionVarSetsescs_s)let-- Determine whether the default binder is dead or not-- This helps the code generator to avoid generating an assignment-- for the case binder (is extremely rare cases) ToDo: remove.bndr'|bndr`elementOfFVInfo`alts_fvs=bndr|otherwise=bndr`setIdOccInfo`IAmDead-- Don't consider the default binder as being 'live in alts',-- since this is from the point of view of the case expr, where-- the default binder is not free.alts_fvs_wo_bndr=bndr`minusFVBinder`alts_fvsalts_escs_wo_bndr=alts_escs`delVarSet`bndralts_lv_info<-freeVarsToLiveVarsalts_fvs_wo_bndr-- We tell the scrutinee that everything-- live in the alts is live in it, too.(scrut2,scrut_fvs,_scrut_escs,scrut_lv_info)<-setVarsLiveInContalts_lv_info$do(scrut2,scrut_fvs,scrut_escs)<-coreToStgExprscrutscrut_lv_info<-freeVarsToLiveVarsscrut_fvsreturn(scrut2,scrut_fvs,scrut_escs,scrut_lv_info)return(StgCasescrut2(getLiveVarsscrut_lv_info)(getLiveVarsalts_lv_info)bndr'(mkSRTalts_lv_info)(mkStgAltTypebndralts)alts2,scrut_fvs`unionFVInfo`alts_fvs_wo_bndr,alts_escs_wo_bndr`unionVarSet`getFVSetscrut_fvs-- You might think we should have scrut_escs, not-- (getFVSet scrut_fvs), but actually we can't call, and-- then return from, a let-no-escape thing.)wherevars_alt(con,binders,rhs)|DataAltc<-con,c==unboxedUnitDataCon=-- This case is a bit smelly.-- See Note [Nullary unboxed tuple] in Type.lhs-- where a nullary tuple is mapped to (State# World#)ASSERT(nullbinders)do{(rhs2,rhs_fvs,rhs_escs)<-coreToStgExprrhs;return((DEFAULT,[],[],rhs2),rhs_fvs,rhs_escs)}|otherwise=let-- Remove type variablesbinders'=filterStgBindersbindersinextendVarEnvLne[(b,LambdaBound)|b<-binders']$do(rhs2,rhs_fvs,rhs_escs)<-coreToStgExprrhslet-- Records whether each param is used in the RHSgood_use_mask=[b`elementOfFVInfo`rhs_fvs|b<-binders']return((con,binders',good_use_mask,rhs2),binders'`minusFVBinders`rhs_fvs,rhs_escs`delVarSetList`binders')-- ToDo: remove the delVarSet;-- since escs won't include any of these binders-- Lets not only take quite a bit of work, but this is where we convert-- then to let-no-escapes, if we wish.-- (Meanwhile, we don't expect to see let-no-escapes...)coreToStgExpr(Letbindbody)=do(new_let,fvs,escs,_)<-mfix(\~(_,_,_,no_binder_escapes)->coreToStgLetno_binder_escapesbindbody)return(new_let,fvs,escs)coreToStgExpre=pprPanic"coreToStgExpr"(ppre)mkStgAltType::Id->[CoreAlt]->AltTypemkStgAltTypebndralts=caserepType(idTypebndr)ofUnaryReprep_ty->casetyConAppTyCon_mayberep_tyofJusttc|isUnLiftedTyContc->PrimAlttc|isAbstractTyContc->look_for_better_tycon|isAlgTyContc->AlgAlttc|otherwise->ASSERT2(_is_poly_alt_tycontc,pprtc)PolyAltNothing->PolyAltUbxTupleReprep_tys->UbxTupAlt(lengthrep_tys)-- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAltwhere_is_poly_alt_tycontc=isFunTyContc||isPrimTyContc-- "Any" is lifted but primitive||isFamilyTyContc-- Type family; e.g. Any, or arising from strict-- function application where argument has a-- type-family type-- Sometimes, the TyCon is a AbstractTyCon which may not have any-- constructors inside it. Then we may get a better TyCon by-- grabbing the one from a constructor alternative-- if one exists.look_for_better_tycon|((DataAltcon,_,_):_)<-data_alts=AlgAlt(dataConTyConcon)|otherwise=ASSERT(nulldata_alts)PolyAltwhere(data_alts,_deflt)=findDefaultalts-- ----------------------------------------------------------------------------- Applications-- ---------------------------------------------------------------------------coreToStgApp::MaybeUpdateFlag-- Just upd <=> this application is-- the rhs of a thunk binding-- x = [...] \upd [] -> the_app-- with specified update flag->Id-- Function->[CoreArg]-- Arguments->[TickishId]-- Debug ticks->LneM(StgExpr,FreeVarsInfo,EscVarsSet)coreToStgApp_fargsticks=do(args',args_fvs,ticks')<-coreToStgArgsargshow_bound<-lookupVarLnefletn_val_args=valArgCountargsnot_letrec_bound=not(isLetBoundhow_bound)fun_fvs=singletonFVInfofhow_boundfun_occ-- e.g. (f :: a -> int) (x :: a)-- Here the free variables are "f", "x" AND the type variable "a"-- coreToStgArgs will deal with the arguments recursively-- Mostly, the arity info of a function is in the fn's IdInfo-- But new bindings introduced by CoreSat may not have no-- arity info; it would do us no good anyway. For example:-- let f = \ab -> e in f-- No point in having correct arity info for f!-- Hence the hasArity stuff below.-- NB: f_arity is only consulted for LetBound thingsf_arity=stgArityfhow_boundsaturated=f_arity<=n_val_argsfun_occ|not_letrec_bound=noBinderInfo-- Uninteresting variable|f_arity>0&&saturated=stgSatOcc-- Saturated or over-saturated function call|otherwise=stgUnsatOcc-- Unsaturated function or thunkfun_escs|not_letrec_bound=emptyVarSet-- Only letrec-bound escapees are interesting|f_arity==n_val_args=emptyVarSet-- A function *or thunk* with an exactly-- saturated call doesn't escape-- (let-no-escape applies to 'thunks' too)|otherwise=unitVarSetf-- Inexact application; it does escape-- At the moment of the call:-- either the function is *not* let-no-escaped, in which case-- nothing is live except live_in_cont-- or the function *is* let-no-escaped in which case the-- variables it uses are live, but still the function-- itself is not. PS. In this case, the function's-- live vars should already include those of the-- continuation, but it does no harm to just union the-- two regardless.res_ty=exprType(mkApps(Varf)args)app=caseidDetailsfofDataConWorkIddc|saturated->StgConAppdcargs'-- Some primitive operator that might be implemented as a library call.PrimOpIdop->ASSERT(saturated)StgOpApp(StgPrimOpop)args'res_ty-- A call to some primitive Cmm function.FCallId(CCall(CCallSpec(StaticTargetlbl(JustpkgId)True)PrimCallConv_))->ASSERT(saturated)StgOpApp(StgPrimCallOp(PrimCalllblpkgId))args'res_ty-- A regular foreign call.FCallIdcall->ASSERT(saturated)StgOpApp(StgFCallOpcall(idUniquef))args'res_tyTickBoxOpId{}->pprPanic"coreToStg TickBox"$ppr(f,args')_other->StgAppfargs'fvs=fun_fvs`unionFVInfo`args_fvsvars=fun_escs`unionVarSet`(getFVSetargs_fvs)-- All the free vars of the args are disqualified-- from being let-no-escaped.tapp=foldrStgTickapp(ticks++ticks')-- Forcing these fixes a leak in the code generator, noticed while-- profiling for trac #4367app`seq`fvs`seq`seqVarSetvars`seq`return(tapp,fvs,vars)-- ----------------------------------------------------------------------------- Argument lists-- This is the guy that turns applications into A-normal form-- ---------------------------------------------------------------------------coreToStgArgs::[CoreArg]->LneM([StgArg],FreeVarsInfo,[TickishId])coreToStgArgs[]=return([],emptyFVInfo,[])coreToStgArgs(Type_:args)=do-- Type argument(args',fvs,ts)<-coreToStgArgsargsreturn(args',fvs,ts)coreToStgArgs(Coercion_:args)-- Coercion argument; replace with place holder=do{(args',fvs,ts)<-coreToStgArgsargs;return(StgVarArgcoercionTokenId:args',fvs,ts)}coreToStgArgs(Tickte:args)=ASSERT(not(tickishIsCodet))do{(args',fvs,ts)<-coreToStgArgs(e:args);return(args',fvs,t:ts)}coreToStgArgs(arg:args)=do-- Non-type argument(stg_args,args_fvs,ticks)<-coreToStgArgsargs(arg',arg_fvs,_escs)<-coreToStgExprargletfvs=args_fvs`unionFVInfo`arg_fvs(aticks,arg'')=stripStgTicksToptickishFloatablearg'stg_arg=casearg''ofStgAppv[]->StgVarArgvStgConAppcon[]->StgVarArg(dataConWorkIdcon)StgLitlit->StgLitArglit_->pprPanic"coreToStgArgs"(pprarg)-- WARNING: what if we have an argument like (v `cast` co)-- where 'co' changes the representation type?-- (This really only happens if co is unsafe.)-- Then all the getArgAmode stuff in CgBindery will set the-- cg_rep of the CgIdInfo based on the type of v, rather-- than the type of 'co'.-- This matters particularly when the function is a primop-- or foreign call.-- Wanted: a better solution than this hacky warningletarg_ty=exprTypeargstg_arg_ty=stgArgTypestg_argbad_args=(isUnLiftedTypearg_ty&&not(isUnLiftedTypestg_arg_ty))||(maptypePrimRep(flattenRepType(repTypearg_ty))/=maptypePrimRep(flattenRepType(repTypestg_arg_ty)))-- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),-- and pass it to a function expecting an HValue (arg_ty). This is ok because-- we can treat an unlifted value as lifted. But the other way round-- we complain.-- We also want to check if a pointer is cast to a non-ptr etcWARN(bad_args,ptext(sLit"Dangerous-looking argument. Probable cause: bad unsafeCoerce#")$$pprarg)return(stg_arg:stg_args,fvs,ticks++aticks)-- ----------------------------------------------------------------------------- The magic for lets:-- ---------------------------------------------------------------------------coreToStgLet::Bool-- True <=> yes, we are let-no-escaping this let->CoreBind-- bindings->CoreExpr-- body->LneM(StgExpr,-- new letFreeVarsInfo,-- variables free in the whole letEscVarsSet,-- variables that escape from the whole letBool)-- True <=> none of the binders in the bindings-- is among the escaping varscoreToStgLetlet_no_escapebindbody=do(bind2,bind_fvs,bind_escs,bind_lvs,body2,body_fvs,body_escs,body_lvs)<-mfix$\~(_,_,_,_,_,rec_body_fvs,_,_)->do-- Do the bindings, setting live_in_cont to empty if-- we ain't in a let-no-escape worldlive_in_cont<-getVarsLiveInCont(bind2,bind_fvs,bind_escs,bind_lv_info,env_ext)<-setVarsLiveInCont(iflet_no_escapethenlive_in_contelseemptyLiveInfo)(vars_bindrec_body_fvsbind)-- Do the bodyextendVarEnvLneenv_ext$do(body2,body_fvs,body_escs)<-coreToStgExprbodybody_lv_info<-freeVarsToLiveVarsbody_fvsreturn(bind2,bind_fvs,bind_escs,getLiveVarsbind_lv_info,body2,body_fvs,body_escs,getLiveVarsbody_lv_info)-- Compute the new let-expressionletnew_let|let_no_escape=StgLetNoEscapelive_in_whole_letbind_lvsbind2body2|otherwise=StgLetbind2body2free_in_whole_let=binders`minusFVBinders`(bind_fvs`unionFVInfo`body_fvs)live_in_whole_let=bind_lvs`unionVarSet`(body_lvs`delVarSetList`binders)real_bind_escs=iflet_no_escapethenbind_escselsegetFVSetbind_fvs-- Everything escapes which is free in the bindingslet_escs=(real_bind_escs`unionVarSet`body_escs)`delVarSetList`bindersall_escs=bind_escs`unionVarSet`body_escs-- Still includes binders of-- this let(rec)no_binder_escapes=isEmptyVarSet(set_of_binders`intersectVarSet`all_escs)-- Debugging code as requested by Andrew Kennedychecked_no_binder_escapes|debugIsOn&&notno_binder_escapes&&anyis_join_varbinders=pprTrace"Interesting! A join var that isn't let-no-escaped"(pprbinders)False|otherwise=no_binder_escapes-- Mustn't depend on the passed-in let_no_escape flag, since-- no_binder_escapes is used by the caller to derive the flag!return(new_let,free_in_whole_let,let_escs,checked_no_binder_escapes)whereset_of_binders=mkVarSetbindersbinders=bindersOfbindmk_bindingbind_lv_infobinderrhs=(binder,LetBound(NestedLetlive_vars)(manifestArityrhs))wherelive_vars|let_no_escape=addLiveVarbind_lv_infobinder|otherwise=unitLiveVarbinder-- c.f. the invariant on NestedLetvars_bind::FreeVarsInfo-- Free var info for body of binding->CoreBind->LneM(StgBinding,FreeVarsInfo,EscVarsSet,-- free vars; escapee varsLiveInfo,-- Vars and CAFs live in binding[(Id,HowBound)])-- extension to environmentvars_bindbody_fvs(NonRecbinderrhs)=do(rhs2,bind_fvs,bind_lv_info,escs)<-coreToStgRhsbody_fvs[](binder,rhs)letenv_ext_item=mk_bindingbind_lv_infobinderrhsreturn(StgNonRecbinderrhs2,bind_fvs,escs,bind_lv_info,[env_ext_item])vars_bindbody_fvs(Recpairs)=mfix$\~(_,rec_rhs_fvs,_,bind_lv_info,_)->letrec_scope_fvs=unionFVInfobody_fvsrec_rhs_fvsbinders=mapfstpairsenv_ext=[mk_bindingbind_lv_infobrhs|(b,rhs)<-pairs]inextendVarEnvLneenv_ext$do(rhss2,fvss,lv_infos,escss)<-mapAndUnzip4M(coreToStgRhsrec_scope_fvsbinders)pairsletbind_fvs=unionFVInfosfvssbind_lv_info=foldrunionLiveInfoemptyLiveInfolv_infosescs=unionVarSetsescssreturn(StgRec(binders`zip`rhss2),bind_fvs,escs,bind_lv_info,env_ext)is_join_var::Id->Bool-- A hack (used only for compiler debuggging) to tell if-- a variable started life as a join point ($j)is_join_varj=occNameString(getOccNamej)=="$j"coreToStgRhs::FreeVarsInfo-- Free var info for the scope of the binding->[Id]->(Id,CoreExpr)->LneM(StgRhs,FreeVarsInfo,LiveInfo,EscVarsSet)coreToStgRhsscope_fv_infobinders(bndr,rhs)=do(new_rhs,rhs_fvs,rhs_escs)<-coreToStgExprrhslv_info<-freeVarsToLiveVars(binders`minusFVBinders`rhs_fvs)return(mkStgRhsrhs_fvs(mkSRTlv_info)bndrbndr_infonew_rhs,rhs_fvs,lv_info,rhs_escs)wherebndr_info=lookupFVInfoscope_fv_infobndrmkStgRhs::FreeVarsInfo->SRT->Id->StgBinderInfo->StgExpr->StgRhsmkStgRhs=mkStgRhs'con_updateablewherecon_updateable__=FalsemkStgRhs'::(DataCon->[StgArg]->Bool)->FreeVarsInfo->SRT->Id->StgBinderInfo->StgExpr->StgRhsmkStgRhs'con_updateablerhs_fvssrtbndrbinder_inforhs|StgLambndrsbody<-rhs=StgRhsClosurenoCCSbinder_info(getFVsrhs_fvs)ReEntrantsrtbndrsbody|StgConAppconargs<-unticked_rhs,not(con_updateableconargs)=StgRhsConnoCCSconargs|otherwise=StgRhsClosurenoCCSbinder_info(getFVsrhs_fvs)upd_flagsrt[]rhswhere(_,unticked_rhs)=stripStgTicksTop(not.tickishIsCode)rhsupd_flag|isSingleUsed(idDemandInfobndr)=SingleEntry|otherwise=Updatable{-
SDM: disabled. Eval/Apply can't handle functions with arity zero very
well; and making these into simple non-updatable thunks breaks other
assumptions (namely that they will be entered only once).
upd_flag | isPAP env rhs = ReEntrant
| otherwise = Updatable
-- Detect thunks which will reduce immediately to PAPs, and make them
-- non-updatable. This has several advantages:
--
-- - the non-updatable thunk behaves exactly like the PAP,
--
-- - the thunk is more efficient to enter, because it is
-- specialised to the task.
--
-- - we save one update frame, one stg_update_PAP, one update
-- and lots of PAP_enters.
--
-- - in the case where the thunk is top-level, we save building
-- a black hole and futhermore the thunk isn't considered to
-- be a CAF any more, so it doesn't appear in any SRTs.
--
-- We do it here, because the arity information is accurate, and we need
-- to do it before the SRT pass to save the SRT entries associated with
-- any top-level PAPs.
isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
where
arity = stgArity f (lookupBinding env f)
isPAP env _ = False
-}{- ToDo:
upd = if isOnceDem dem
then (if isNotTop toplev
then SingleEntry -- HA! Paydirt for "dem"
else
(if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
Updatable)
else Updatable
-- For now we forbid SingleEntry CAFs; they tickle the
-- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
-- and I don't understand why. There's only one SE_CAF (well,
-- only one that tickled a great gaping bug in an earlier attempt
-- at ClosureInfo.getEntryConvention) in the whole of nofib,
-- specifically Main.lvl6 in spectral/cryptarithm2.
-- So no great loss. KSW 2000-07.
-}-- ----------------------------------------------------------------------------- A little monad for this let-no-escaping pass-- ----------------------------------------------------------------------------- There's a lot of stuff to pass around, so we use this LneM monad to-- help. All the stuff here is only passed *down*.newtypeLneMa=LneM{unLneM::IdEnvHowBound->LiveInfo-- Vars and CAFs live in continuation->a}typeLiveInfo=(StgLiveVars,-- Dynamic live variables;-- i.e. ones with a nested (non-top-level) bindingCafSet)-- Static live variables;-- i.e. top-level variables that are CAFs or refer to themtypeEscVarsSet=IdSettypeCafSet=IdSetdataHowBound=ImportBound-- Used only as a response to lookupBinding; never-- exists in the range of the (IdEnv HowBound)|LetBound-- A let(rec) in this moduleLetInfo-- Whether top level or nestedArity-- Its arity (local Ids don't have arity info at this point)|LambdaBound-- Used for both lambda and casedataLetInfo=TopLet-- top level things|NestedLetLiveInfo-- For nested things, what is live if this-- thing is live? Invariant: the binder-- itself is always a member of-- the dynamic set of its own LiveInfoisLetBound::HowBound->BoolisLetBound(LetBound__)=TrueisLetBound_=FalsetopLevelBound::HowBound->BooltopLevelBoundImportBound=TruetopLevelBound(LetBoundTopLet_)=TruetopLevelBound_=False-- For a let(rec)-bound variable, x, we record LiveInfo, the set of-- variables that are live if x is live. This LiveInfo comprises-- (a) dynamic live variables (ones with a non-top-level binding)-- (b) static live variabes (CAFs or things that refer to CAFs)---- For "normal" variables (a) is just x alone. If x is a let-no-escaped-- variable then x is represented by a code pointer and a stack pointer-- (well, one for each stack). So all of the variables needed in the-- execution of x are live if x is, and are therefore recorded in the-- LetBound constructor; x itself *is* included.---- The set of dynamic live variables is guaranteed ot have no further-- let-no-escaped variables in it.emptyLiveInfo::LiveInfoemptyLiveInfo=(emptyVarSet,emptyVarSet)unitLiveVar::Id->LiveInfounitLiveVarlv=(unitVarSetlv,emptyVarSet)unitLiveCaf::Id->LiveInfounitLiveCafcaf=(emptyVarSet,unitVarSetcaf)addLiveVar::LiveInfo->Id->LiveInfoaddLiveVar(lvs,cafs)id=(lvs`extendVarSet`id,cafs)unionLiveInfo::LiveInfo->LiveInfo->LiveInfounionLiveInfo(lv1,caf1)(lv2,caf2)=(lv1`unionVarSet`lv2,caf1`unionVarSet`caf2)mkSRT::LiveInfo->SRTmkSRT(_,cafs)=SRTEntriescafsgetLiveVars::LiveInfo->StgLiveVarsgetLiveVars(lvs,_)=lvs-- The std monad functions:initLne::IdEnvHowBound->LneMa->ainitLneenvm=unLneMmenvemptyLiveInfo{-# INLINE thenLne #-}{-# INLINE returnLne #-}returnLne::a->LneMareturnLnee=LneM$\__->ethenLne::LneMa->(a->LneMb)->LneMbthenLnemk=LneM$\envlvs_cont->unLneM(k(unLneMmenvlvs_cont))envlvs_continstanceFunctorLneMwherefmap=liftMinstanceApplicativeLneMwherepure=return(<*>)=apinstanceMonadLneMwherereturn=returnLne(>>=)=thenLneinstanceMonadFixLneMwheremfixexpr=LneM$\envlvs_cont->letresult=unLneM(exprresult)envlvs_continresult-- Functions specific to this monad:getVarsLiveInCont::LneMLiveInfogetVarsLiveInCont=LneM$\_envlvs_cont->lvs_contsetVarsLiveInCont::LiveInfo->LneMa->LneMasetVarsLiveInContnew_lvs_contexpr=LneM$\env_lvs_cont->unLneMexprenvnew_lvs_contextendVarEnvLne::[(Id,HowBound)]->LneMa->LneMaextendVarEnvLneids_w_howboundexpr=LneM$\envlvs_cont->unLneMexpr(extendVarEnvListenvids_w_howbound)lvs_contlookupVarLne::Id->LneMHowBoundlookupVarLnev=LneM$\env_lvs_cont->lookupBindingenvvlookupBinding::IdEnvHowBound->Id->HowBoundlookupBindingenvv=caselookupVarEnvenvvofJustxx->xxNothing->ASSERT2(isGlobalIdv,pprv)ImportBound-- The result of lookupLiveVarsForSet, a set of live variables, is-- only ever tacked onto a decorated expression. It is never used as-- the basis of a control decision, which might give a black hole.freeVarsToLiveVars::FreeVarsInfo->LneMLiveInfofreeVarsToLiveVarsfvs=LneMfreeVarsToLiveVars'wherefreeVarsToLiveVars'_envlive_in_cont=live_infowherelive_info=foldrunionLiveInfolive_in_contlvs_from_fvslvs_from_fvs=mapdo_one(allFreeIdsfvs)do_one(v,how_bound)=casehow_boundofImportBound->unitLiveCafv-- Only CAF imports are-- recorded in fvsLetBoundTopLet_|mayHaveCafRefs(idCafInfov)->unitLiveCafv|otherwise->emptyLiveInfoLetBound(NestedLetlvs)_->lvs-- lvs already contains v-- (see the invariant on NestedLet)_lambda_or_case_binding->unitLiveVarv-- Bound by lambda or case-- ----------------------------------------------------------------------------- Free variable information-- ---------------------------------------------------------------------------typeFreeVarsInfo=VarEnv(Var,HowBound,StgBinderInfo)-- The Var is so we can gather up the free variables-- as a set.---- The HowBound info just saves repeated lookups;-- we look up just once when we encounter the occurrence.-- INVARIANT: Any ImportBound Ids are HaveCafRef Ids-- Imported Ids without CAF refs are simply-- not put in the FreeVarsInfo for an expression.-- See singletonFVInfo and freeVarsToLiveVars---- StgBinderInfo records how it occurs; notably, we-- are interested in whether it only occurs in saturated-- applications, because then we don't need to build a-- curried version.-- If f is mapped to noBinderInfo, that means-- that f *is* mentioned (else it wouldn't be in the-- IdEnv at all), but perhaps in an unsaturated applications.---- All case/lambda-bound things are also mapped to-- noBinderInfo, since we aren't interested in their-- occurrence info.---- For ILX we track free var info for type variables too;-- hence VarEnv not IdEnvemptyFVInfo::FreeVarsInfoemptyFVInfo=emptyVarEnvsingletonFVInfo::Id->HowBound->StgBinderInfo->FreeVarsInfo-- Don't record non-CAF imports at all, to keep free-var sets smallsingletonFVInfoidImportBoundinfo|mayHaveCafRefs(idCafInfoid)=unitVarEnvid(id,ImportBound,info)|otherwise=emptyVarEnvsingletonFVInfoidhow_boundinfo=unitVarEnvid(id,how_bound,info)unionFVInfo::FreeVarsInfo->FreeVarsInfo->FreeVarsInfounionFVInfofv1fv2=plusVarEnv_CplusFVInfofv1fv2unionFVInfos::[FreeVarsInfo]->FreeVarsInfounionFVInfosfvs=foldrunionFVInfoemptyFVInfofvsminusFVBinders::[Id]->FreeVarsInfo->FreeVarsInfominusFVBindersvsfv=foldrminusFVBinderfvvsminusFVBinder::Id->FreeVarsInfo->FreeVarsInfominusFVBindervfv=fv`delVarEnv`v-- When removing a binder, remember to add its type variables-- c.f. CoreFVs.delBinderFVelementOfFVInfo::Id->FreeVarsInfo->BoolelementOfFVInfoidfvs=isJust(lookupVarEnvfvsid)lookupFVInfo::FreeVarsInfo->Id->StgBinderInfo-- Find how the given Id is used.-- Externally visible things may be used any old howlookupFVInfofvsid|isExternalName(idNameid)=noBinderInfo|otherwise=caselookupVarEnvfvsidofNothing->noBinderInfoJust(_,_,info)->infoallFreeIds::FreeVarsInfo->[(Id,HowBound)]-- Both top level and non-top-level IdsallFreeIdsfvs=ASSERT(all(isId.fst)ids)idswhereids=[(id,how_bound)|(id,how_bound,_)<-varEnvEltsfvs]-- Non-top-level things only, both type variables and idsgetFVs::FreeVarsInfo->[Var]getFVsfvs=[id|(id,how_bound,_)<-varEnvEltsfvs,not(topLevelBoundhow_bound)]getFVSet::FreeVarsInfo->VarSetgetFVSetfvs=mkVarSet(getFVsfvs)plusFVInfo::(Var,HowBound,StgBinderInfo)->(Var,HowBound,StgBinderInfo)->(Var,HowBound,StgBinderInfo)plusFVInfo(id1,hb1,info1)(id2,hb2,info2)=ASSERT(id1==id2&&hb1`check_eq_how_bound`hb2)(id1,hb1,combineStgBinderInfoinfo1info2)-- The HowBound info for a variable in the FVInfo should be consistentcheck_eq_how_bound::HowBound->HowBound->Boolcheck_eq_how_boundImportBoundImportBound=Truecheck_eq_how_boundLambdaBoundLambdaBound=Truecheck_eq_how_bound(LetBoundli1ar1)(LetBoundli2ar2)=ar1==ar2&&check_eq_lili1li2check_eq_how_bound__=Falsecheck_eq_li::LetInfo->LetInfo->Boolcheck_eq_li(NestedLet_)(NestedLet_)=Truecheck_eq_liTopLetTopLet=Truecheck_eq_li__=False-- Misc.filterStgBinders::[Var]->[Var]filterStgBindersbndrs=filterisIdbndrsmyCollectBinders::ExprVar->([Var],ExprVar)myCollectBindersexpr=go[]exprwheregobs(Lambe)=go(b:bs)egobs(Caste_)=gobsegobse=(reversebs,e)myCollectArgs::CoreExpr->(Id,[CoreArg],[TickishId])-- We assume that we only have variables-- in the function position by nowmyCollectArgsexpr=goexpr[][]wherego(Varv)asts=(v,as,ts)go(Appfa)asts=gof(a:as)tsgo(Tickte)asts=ASSERT(allisTypeArgas)goeas(t:ts)-- ticks can appear in type appsgo(Caste_)asts=goeastsgo(Lambe)asts|isTyVarb=goeasts-- Note [Collect args]go___=pprPanic"CoreToStg.myCollectArgs"(pprexpr)-- Note [Collect args]-- ~~~~~~~~~~~~~~~~~~~---- This big-lambda case occurred following a rather obscure eta expansion.-- It all seems a bit yukky to me.stgArity::Id->HowBound->AritystgArity_(LetBound_arity)=aritystgArityfImportBound=idArityfstgArity_LambdaBound=0