-- | Float let-bindings with a single use forward into their use-sites.moduleDDC.Core.Transform.Forward(ForwardInfo(..),FloatControl(..),Config(..),forwardModule,forwardX)whereimportDDC.Base.PrettyimportDDC.Core.Analysis.UsageimportDDC.Core.ExpimportDDC.Core.ModuleimportDDC.Core.Simplifier.BaseimportDDC.Core.Transform.ReannotateimportDDC.Core.FragmentimportDDC.Core.PredicatesimportDDC.Core.CompoundsimportData.Map(Map)importControl.MonadimportControl.Monad.Writer(Writer,runWriter,tell)importData.Monoid(Monoid,mempty,mappend)importData.TypeableimportqualifiedData.MapasMapimportqualifiedDDC.Core.Transform.SubstituteXXasS--------------------------------------------------------------------------------- | Summary of number of bindings floated.dataForwardInfo=ForwardInfo{-- | Number of bindings inspected.infoInspected::!Int-- | Number of trivial @v1 = v2@ bindings inlined.,infoSubsts::!Int-- | Number of bindings floated forwards.,infoBindings::!Int}derivingTypeableinstancePrettyForwardInfowhereppr(ForwardInfoinspectedsubstsbindings)=text"Forward:"<$>indent4(vcat[text"Total bindings inspected: "<>intinspected,text" Trivial substitutions made: "<>intsubsts,text" Bindings moved forward: "<>intbindings])instanceMonoidForwardInfowheremempty=ForwardInfo000mappend(ForwardInfoi1s1b1)(ForwardInfoi2s2b2)=ForwardInfo(i1+i2)(s1+s2)(b1+b2)--------------------------------------------------------------------------------- | Fine control over what should be floated.dataFloatControl=FloatAllow-- ^ Allow binding to be floated, but don't require it.|FloatDeny-- ^ Prevent a binding being floated, at all times.|FloatForce-- ^ Force a binding to be floated, at all times.deriving(Eq,Show)dataConfigan=Config{configFloatControl::Letsan->FloatControl,configFloatLetBody::Bool}--------------------------------------------------------------------------------- | Float let-bindings in a module with a single use forward into-- their use sites.forwardModule::Ordn=>Profilen-- ^ Language profile->Configan->Modulean->TransformResult(Modulean)forwardModuleprofileconfigmm=let(mm',info)=runWriter$forwardWithprofileconfigMap.empty$usageModulemmprogress(ForwardInfo_sf)=s+f>0inTransformResult{result=mm',resultProgress=progressinfo,resultAgain=False,resultInfo=TransformInfoinfo}-- | Float let-bindings in an expression with a single use forward into-- their use-sites.forwardX::Ordn=>Profilen-- ^ Language profile.->Configan->Expan->TransformResult(Expan)forwardXprofileconfigxx=let(x',info)=runWriter$forwardWithprofileconfigMap.empty$usageXxxprogress(ForwardInfo_sf)=s+f>0inTransformResult{result=x',resultProgress=progressinfo,resultAgain=False,resultInfo=TransformInfoinfo}-------------------------------------------------------------------------------classForward(c::*->*->*)where-- | Carry bindings forward and downward into their use-sites.forwardWith::Ordn=>Profilen-- ^ Language profile.->Configan->Mapn(Expan)-- ^ Bindings currently being carried forward.->c(UsedMapn,a)n->WriterForwardInfo(can)instanceForwardModulewhereforwardWithprofileconfigbindings(ModuleCore{moduleName=name,moduleExportTypes=exportTypes,moduleExportValues=exportValues,moduleImportTypes=importTypes,moduleImportValues=importValues,moduleDataDefsLocal=dataDefsLocal,moduleBody=body})=dobody'<-forwardWithprofileconfigbindingsbodyreturnModuleCore{moduleName=name,moduleExportTypes=exportTypes,moduleExportValues=exportValues,moduleImportTypes=importTypes,moduleImportValues=importValues,moduleDataDefsLocal=dataDefsLocal,moduleBody=body'}instanceForwardExpwhereforwardWithprofileconfigbindingsxx={-# SCC forwardWith #-}letdown=forwardWithprofileconfigbindingsincasexxofXVarau@(UNamen)->caseMap.lookupnbindingsofJustxx'->dotellmempty{infoSubsts=1}returnxx'Nothing->return$XVar(snda)uXVarau->return$XVar(snda)uXConau->return$XCon(snda)uXLAMabx->liftM(XLAM(snda)b)(downx)XLamabx->liftM(XLam(snda)b)(downx)XAppax1x2->liftM2(XApp(snda))(downx1)(downx2)-- Always float last let-binding into its use.-- let x = exp in x => expXLet_(LLetbx1)(XVar_u)|boundMatchesBindub,configFloatLetBodyconfig->downx1-- Always float atomic bindings (variables, constructors)XLet_(LLetbx1)x2|isAtomXx1->do-- Record that we've moved this binding.tellmempty{infoInspected=1,infoBindings=1}-- Slow, but handles anonymous binders and shadowingdown$S.substituteXXbx1x2XLet(UsedMapum,a')lts@(LLet(BNamen_)x1)x2->doletcontrol=configFloatControlconfig$reannotatesndltsletisFun=isXLamx1||isXLAMx1letisApplied|Justusage<-Map.lookupnum,[UsedFunction]<-filterUsedInCastsusage=True|otherwise=FalseletshouldFloat=casecontrolofFloatDeny->FalseFloatForce->TrueFloatAllow->isFun&&isAppliedifshouldFloatthendo-- Record that we've moved this binding.tellmempty{infoInspected=1,infoBindings=1}x1'<-downx1letbindings'=Map.insertnx1'bindingsforwardWithprofileconfigbindings'x2elsedotellmempty{infoInspected=1}liftM2(XLeta')(downlts)(downx2)XLet(_,a')ltsx->liftM2(XLeta')(downlts)(downx)XCaseaxalts->liftM2(XCase(snda))(downx)(mapMdownalts)XCastacx->liftM2(XCast(snda))(downc)(downx)XTypeat->return(XType(snda)t)XWitnessaw->return(XWitness(snda)(reannotatesndw))filterUsedInCasts::[Used]->[Used]filterUsedInCasts=filternotCastwherenotCastUsedInCast=FalsenotCast_=TrueinstanceForwardCastwhereforwardWithprofileconfigbindingsxx=letdown=forwardWithprofileconfigbindingsincasexxofCastWeakenEffecteff->return$CastWeakenEffecteffCastWeakenClosurexs->liftMCastWeakenClosure(mapMdownxs)CastPurifyw->return$CastPurify(reannotatesndw)CastForgetw->return$CastForget(reannotatesndw)CastBox->return$CastBoxCastRun->return$CastRuninstanceForwardLetswhereforwardWithprofileconfigbindingslts=letdown=forwardWithprofileconfigbindingsincaseltsofLLetbx->liftM(LLetb)(downx)LRecbxs->liftMLRec$mapM(\(b,x)->dox'<-downxreturn(b,x'))bxsLPrivatebmtbs->return$LPrivatebmtbsLWithRegionb->return$LWithRegionbinstanceForwardAltwhereforwardWithprofileconfigbindings(AAltpx)=liftM(AAltp)(forwardWithprofileconfigbindingsx)