%%(c)TheGRASP/AQUAProject,GlasgowUniversity,1993-1998%\section[WorkWrap]{Worker/wrapper-generatingback-endofstrictnessanalyser}\begin{code}moduleWorkWrap(wwTopBinds,mkWrapper)whereimportCoreSynimportCoreUnfold(certainlyWillInline)importCoreUtils(exprType,exprIsHNF,mkInlineMe)importCoreArity(exprArity)importVarimportIdimportType(Type)importIdInfoimportNewDemand(Demand(..),StrictSig(..),DmdType(..),DmdResult(..),Demands(..),mkTopDmdType,isBotRes,returnsCPR,topSig,isAbsent)importUniqSupplyimportBasicTypes(RecFlag(..),isNonRec,isNeverActive,Activation,inlinePragmaActivation)importVarEnv(isEmptyVarEnv)importMaybes(orElse)importWwLibimportUtil(lengthIs,notNull)importOutputableimportMonadUtils#include "HsVersions.h"\end{code}WetakeCorebindingswhosebindershave:\begin{enumerate}\itemStrictnessattached(bythefront-endofthestrictnessanalyser),and/or\itemConstructedProductResultinformationattachedbytheCPRanalysispass.\end{enumerate}andwereturnsome``plain''bindingswhichhavebeenworker/wrapper-ified,meaning:\begin{enumerate}\itemFunctionshavebeensplitintoworkersandwrapperswhereappropriate.IfafunctionhasbothstrictnessandCPRpropertiesthenonlyoneworker/wrapperdoingbothtransformationsisproduced;\itemBinders'@IdInfos@havebeenupdatedtoreflecttheexistenceoftheseworkers/wrappers(thisiswherewegetSTRICTNESSandCPRpragmainfoforexportedvalues).\end{enumerate}\begin{code}wwTopBinds::UniqSupply->[CoreBind]->[CoreBind]wwTopBindsustop_binds=initUs_us$dotop_binds'<-mapMwwBindtop_bindsreturn(concattop_binds')\end{code}%************************************************************************%**\subsection[wwBind-wwExpr]{@wwBind@and@wwExpr@}%**%************************************************************************@wwBind@worksonabinding,tryingeach\tr{(binder,expr)}pairinturn.Non-recursivecasefirst,thenrecursive...\begin{code}wwBind::CoreBind->UniqSM[CoreBind]-- returns a WwBinding intermediate form;-- the caller will convert to Expr/Binding,-- as appropriate.wwBind(NonRecbinderrhs)=donew_rhs<-wwExprrhsnew_pairs<-tryWWNonRecursivebindernew_rhsreturn[NonRecbe|(b,e)<-new_pairs]-- Generated bindings must be non-recursive-- because the original binding was.wwBind(Recpairs)=return.Rec<$>concatMapMdo_onepairswheredo_one(binder,rhs)=donew_rhs<-wwExprrhstryWWRecursivebindernew_rhs\end{code}@wwExpr@basicallyjustwalksthetree,lookingforappropriateannotationsthatcanbeused.Rememberitis@wwBind@thatdoesthematchingbylookingforstrictargumentsofthecorrecttype.@wwExpr@isaversionthatjustreturnsthe``Plain''Tree.\begin{code}wwExpr::CoreExpr->UniqSMCoreExprwwExpre@(Type{})=returnewwExpre@(Lit{})=returnewwExpre@(Var{})=returnewwExpre@(NoteInlineMe_)=returne-- Don't w/w inside InlineMe'swwExpr(Lambinderexpr)=Lambinder<$>wwExprexprwwExpr(Appfa)=App<$>wwExprf<*>wwExprawwExpr(Notenoteexpr)=Notenote<$>wwExprexprwwExpr(Castexprco)=donew_expr<-wwExprexprreturn(Castnew_exprco)wwExpr(Letbindexpr)=mkLets<$>wwBindbind<*>wwExprexprwwExpr(Caseexprbindertyalts)=donew_expr<-wwExprexprnew_alts<-mapMww_altaltsreturn(Casenew_exprbindertynew_alts)whereww_alt(con,binders,rhs)=donew_rhs<-wwExprrhsreturn(con,binders,new_rhs)\end{code}%************************************************************************%**\subsection[tryWW]{@tryWW@:attemptaworker/wrapperpair}%**%************************************************************************@tryWW@justaccumulatesarguments,convertsstrictnessinfofromthefront-endintotheproperform,thencalls@mkWwBodies@todothebusiness.WehavetoBECAREFULthatwedon'tworker-wrapperizeanIdthathasalreadybeenw-w'd!(Youcanendupwithseveralliked-namedIdsbouncingaroundatthesametime---absolute mischief.) So thecriterionweuseis:ifanIdalreadyhasanunfolding(forwhateverreason),thenwedon'tw-wit.Theonlyreasonthisismonadisedisfortheuniquesupply.Note[Don'tw/winlinethings(a)]~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~It'sveryimportanttorefrainfromw/w-inganINLINEfunctionIfwedosobymistakewetransformf=__inline(\x->E)intof=__inline(\x->casexof(a,b)->fwE)fw=\ab->(__inline(\x->E))(a,b)andtheoriginal__inlinenowvanishes,soEisnolongerinsideits__inlinewrapper.Death!Disaster!Furthermore,iftheprogrammerhasmarkedsomethingasINLINE,wemaylosebyw/w'ingit.Ifthestrictnessanalyserisruntwice,thistestalsopreventswrappers(whichareINLINEd)frombeingre-done.Noticethatwerefrainfromw/w'inganINLINEfunctionevenifitisinarecursivegroup.Itmightnotbetheloopbreaker.(Wecouldtestforloop-breaker-hood,butI'mnotsurethatevermatters.)Note[Don'tw/winlinethings(b)]~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~Ingeneral,therefore,werefrainfromw/w-ing*small*functions,becausethey'llinlineanyway.Butwemusttakecare:itmaylooksmallnow,butgettobebiglaterafterotherinlinghashappened.SowetaketheprecautionofaddinganINLINEpragmatoanysuchfunctions.ImadethischangewhenIobservedabigfunctionattheendofcompilationwithausefulstrictnesssignaturebutnow-w.WhenImeasureditonnofib,itdidn'tmakemuchdifference;justafewpercentimprovedallocationononebenchmark(bspt/Euclid.space).Butnothinggotworse.\begin{code}tryWW::RecFlag->Id-- The fn binder->CoreExpr-- The bound rhs; its innards-- are already ww'd->UniqSM[(Id,CoreExpr)]-- either *one* or *two* pairs;-- if one, then no worker (only-- the orig "wrapper" lives on);-- if two, then a worker and a-- wrapper.tryWWis_recfn_idrhs|isNeverActiveinline_act-- No point in worker/wrappering if the thing is never inlined!-- Because the no-inline prag will prevent the wrapper ever-- being inlined at a call site. -- -- Furthermore, don't even expose strictness info=return[(fn_id,rhs)]|is_thunk&&worthSplittingThunkmaybe_fn_dmdres_info=ASSERT2(isNonRecis_rec,pprnew_fn_id)-- The thunk must be non-recursivecheckSizenew_fn_idrhs$splitThunknew_fn_idrhs|is_fun&&worthSplittingFunwrap_dmdsres_info=checkSizenew_fn_idrhs$splitFunnew_fn_idfn_infowrap_dmdsres_infoinline_actrhs|otherwise=return[(new_fn_id,rhs)]wherefn_info=idInfofn_idmaybe_fn_dmd=newDemandInfofn_infoinline_act=inlinePragmaActivation(inlinePragInfofn_info)-- In practice it always will have a strictness -- signature, even if it's a uninformative onestrict_sig=newStrictnessInfofn_info`orElse`topSigStrictSig(DmdTypeenvwrap_dmdsres_info)=strict_sig-- new_fn_id has the DmdEnv zapped. -- (a) it is never used again-- (b) it wastes space-- (c) it becomes incorrect as things are cloned, because-- we don't push the substitution into itnew_fn_id|isEmptyVarEnvenv=fn_id|otherwise=fn_id`setIdNewStrictness`StrictSig(mkTopDmdTypewrap_dmdsres_info)is_fun=notNullwrap_dmdsis_thunk=notis_fun&&not(exprIsHNFrhs)---------------------checkSize::Id->CoreExpr->UniqSM[(Id,CoreExpr)]->UniqSM[(Id,CoreExpr)]-- See Note [Don't w/w inline things (a) and (b)]checkSizefn_idrhsthing_inside|certainlyWillInlineunfolding=return[(fn_id,mkInlineMerhs)]-- Note [Don't w/w inline things (b)]|otherwise=thing_insidewhereunfolding=idUnfoldingfn_id---------------------splitFun::Id->IdInfo->[Demand]->DmdResult->Activation->ExprVar->UniqSM[(Id,CoreExpr)]splitFunfn_idfn_infowrap_dmdsres_infoinline_actrhs=WARN(not(wrap_dmds`lengthIs`arity),pprfn_id<+>(pprarity$$pprwrap_dmds$$pprres_info))(do{-- The arity should match the signature(work_demands,wrap_fn,work_fn)<-mkWwBodiesfun_tywrap_dmdsres_infoone_shots;work_uniq<-getUniqueM;letwork_rhs=work_fnrhswork_id=mkWorkerIdwork_uniqfn_id(exprTypework_rhs)`setInlineActivation`inline_act-- Any inline activation (which sets when inlining is active) -- on the original function is duplicated on the worker and wrapper-- It *matters* that the pragma stays on the wrapper-- It seems sensible to have it on the worker too, although we-- can't think of a compelling reason. (In ptic, INLINE things are -- not w/wd). However, the RuleMatchInfo is not transferred since-- it does not make sense for workers to be constructorlike.`setIdNewStrictness`StrictSig(mkTopDmdTypework_demandswork_res_info)-- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv`setIdArity`(exprAritywork_rhs)-- Set the arity so that the Core Lint check that the -- arity is consistent with the demand type goes throughwrap_rhs=wrap_fnwork_idwrap_id=fn_id`setIdWorkerInfo`HasWorkerwork_idarity;return([(work_id,work_rhs),(wrap_id,wrap_rhs)])})-- Worker first, because wrapper mentions it-- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around itwherefun_ty=idTypefn_idarity=arityInfofn_info-- The arity is set by the simplifier using exprEtaExpandArity-- So it may be more than the number of top-level-visible lambdaswork_res_info|isBotResres_info=BotRes-- Cpr stuff done by wrapper|otherwise=TopResone_shots=get_one_shotsrhs-- If the original function has one-shot arguments, it is important to-- make the wrapper and worker have corresponding one-shot arguments too.-- Otherwise we spuriously float stuff out of case-expression join points,-- which is very annoying.get_one_shots::ExprVar->[Bool]get_one_shots(Lambe)|isIdb=isOneShotLambdab:get_one_shotse|otherwise=get_one_shotseget_one_shots(Note_e)=get_one_shotseget_one_shots_=noOneShotInfo\end{code}Thunksplitting~~~~~~~~~~~~~~~Supposexisusedstrictly(nevermindwhetherithastheCPRproperty).letx*=x-rhsinbodysplitThunktransformslikethis:letx*=casex-rhsof{I#a->I#a}inbodyNowsimplifierwilltransformtocasex-rhsofI#a->letx*=I#ainbodywhichiswhatwewant.Nowsupposex-rhsisitselfacase:x-rhs=caseeof{T->I#a;F->I#b}Thejoinpointwillabstractovera,ratherthanover(whichiswhatwouldhavehappenedbefore)whichisfine.NoticethatxcertainlyhastheCPRpropertynow!Infact,splitThunkusesthefunctionargumentw/wsplittingfunction,sothatifx'sdemandisdeeper(sayU(U(L,L),L))thenthesplittingwillgodeepertoo.\begin{code}-- splitThunk converts the *non-recursive* binding-- x = e-- into-- x = let x = e-- in case x of -- I# y -> let x = I# y in x }-- See comments above. Is it not beautifully short?splitThunk::Var->ExprVar->UniqSM[(Var,ExprVar)]splitThunkfn_idrhs=do(_,wrap_fn,work_fn)<-mkWWstr[fn_id]return[(fn_id,Let(NonRecfn_idrhs)(wrap_fn(work_fn(Varfn_id))))]\end{code}%************************************************************************%**\subsection{FunctionsoverDemands}%**%************************************************************************\begin{code}worthSplittingFun::[Demand]->DmdResult->Bool-- True <=> the wrapper would not be an identity functionworthSplittingFundsres=anyworth_itds||returnsCPRres-- worthSplitting returns False for an empty list of demands,-- and hence do_strict_ww is False if arity is zero and there is no CPR-- See Note [Worker-wrapper for bottoming functions]whereworth_itAbs=True-- Absent argworth_it(Eval(Prod_))=True-- Product arg to evaluateworth_it_=FalseworthSplittingThunk::MaybeDemand-- Demand on the thunk->DmdResult-- CPR info for the thunk->BoolworthSplittingThunkmaybe_dmdres=worth_itmaybe_dmd||returnsCPRreswhere-- Split if the thing is unpackedworth_it(Just(Eval(Prodds)))=not(allisAbsentds)worth_it_=False\end{code}Note[Worker-wrapperforbottomingfunctions]~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~Weusednottosplitiftheresultisbottom.[Justification:there'snoefficiencytobegained.]Butit'ssometimesbadnottomakeawrapper.Considerfw=\x#->letx=I#x#incaseeofp1->error_fnxp2->error_fnxp3->therealstuffThere-boxingcodewon'tgoawayunlesserror_fngetsawrappertoo.[Wedon'tdoreboxingnow,butingeneralit'sbettertopassanunboxedthingtof,andhaveitreboxedintheerrorcases....]%************************************************************************%**\subsection{Theworkerwrappercore}%**%************************************************************************@mkWrapper@iscalledwhenimportingafunction.Wehavethetypeofthefunctionandthenameofitsworker,andwewanttomakeitsbody(thewrapper).\begin{code}mkWrapper::Type-- Wrapper type->StrictSig-- Wrapper strictness info->UniqSM(Id->CoreExpr)-- Wrapper body, missing worker IdmkWrapperfun_ty(StrictSig(DmdType_demandsres_info))=do(_,wrap_fn,_)<-mkWwBodiesfun_tydemandsres_infonoOneShotInforeturnwrap_fnnoOneShotInfo::[Bool]noOneShotInfo=repeatFalse\end{code}