-- | Simple code motion transformation performing common sub-expression-- elimination and variable hoisting. Note that the implementation is very-- inefficient.---- The code is based on an implementation by Gergely Dévai.moduleLanguage.Syntactic.Sharing.SimpleCodeMotion(BindDict(..),codeMotion,defaultBindDict,reifySmart,reifySmartDefault)whereimportControl.Monad.StateimportData.SetasSetimportData.TypeableimportLanguage.SyntacticimportLanguage.Syntactic.Constructs.BindingimportLanguage.Syntactic.Constructs.Binding.HigherOrder-- | Interface for binding constructsdataBindDictdom=BindDict{prjVariable::foralla.doma->MaybeVarId,prjLambda::foralla.doma->MaybeVarId,injVariable::foralla.ASTFdoma->VarId->dom(Fulla),injLambda::forallab.ASTFdoma->ASTFdomb->VarId->dom(b:->Full(a->b)),injLet::forallab.ASTFdomb->dom(a:->(a->b):->Fullb)}-- | Substituting a sub-expression. Assumes no variable capturing in the-- expressions involved.substitute::foralldomab.(ConstrainedBydomTypeable,AlphaEqdomdomdom[(VarId,VarId)])=>ASTFdoma-- ^ Sub-expression to be replaced->ASTFdoma-- ^ Replacing sub-expression->ASTFdomb-- ^ Whole expression->ASTFdombsubstitutexya|Dict::Dict(Typeablea)<-exprDictSuby,Dict::Dict(Typeableb)<-exprDictSuba,Justy'<-gcasty,alphaEqxa=y'|otherwise=substawheresubst::ASTdomc->ASTdomcsubst(f:$a)=substf:$substitutexyasubsta=a-- | Count the number of occurrences of a sub-expressioncount::foralldomab.AlphaEqdomdomdom[(VarId,VarId)]=>ASTFdoma-- ^ Expression to count->ASTFdomb-- ^ Expression to count in->Intcountab|alphaEqab=1|otherwise=cntbwherecnt::ASTdomc->Intcnt(f:$b)=cntf+countabcnt_=0nonTerminal::ASTdoma->BoolnonTerminal(_:$_)=TruenonTerminal_=False-- | Environment for the expression in the 'choose' functiondataEnvdom=Env{inLambda::Bool-- ^ Whether the current expression is inside a lambda,canShare::foralla.doma->Bool-- ^ Whether a given symbol can be shared,counter::ASTEdom->Int-- ^ Counting the number of occurrences of an expression in the-- environment,dependencies::SetVarId-- ^ The set of variables that are not allowed to occur in the chosen-- expression}independent::BindDictdom->Envdom->ASTdoma->BoolindependentbindDictenv(Sym(prjVariablebindDict->Justv))=not(v`member`dependenciesenv)independentbindDictenv(f:$a)=independentbindDictenvf&&independentbindDictenvaindependent___=True-- | Checks whether a sub-expression in a given environment can be lifted outliftable::BindDictdom->Envdom->ASTFdoma->BoolliftablebindDictenva=independentbindDictenva&&heuristic-- Lifting dependent expressions is semantically incorrectwhereheuristic=simpleMatch(const.canShareenv)a&&nonTerminala&&(inLambdaenv||(counterenv(ASTEa)>1))-- | Choose a sub-expression to sharechoose::AlphaEqdomdomdom[(VarId,VarId)]=>BindDictdom->(foralla.doma->Bool)->ASTFdoma->Maybe(ASTEdom)choosebindDictcanShra=chooseEnvbindDictenvawhereenv=Env{inLambda=False,canShare=canShr,counter=\(ASTEb)->countba,dependencies=empty}-- | Choose a sub-expression to share in an 'Env' environmentchooseEnv::BindDictdom->Envdom->ASTFdoma->Maybe(ASTEdom)chooseEnvbindDictenva|liftablebindDictenva=Just(ASTEa)|otherwise=chooseEnvSubbindDictenva-- | Like 'chooseEnv', but does not consider the top expression for sharingchooseEnvSub::BindDictdom->Envdom->ASTdoma->Maybe(ASTEdom)chooseEnvSubbindDictenv(Sym(prjLambdabindDict->Justv):$a)=chooseEnvbindDictenv'awhereenv'=env{inLambda=True,dependencies=insertv(dependenciesenv)}chooseEnvSubbindDictenv(f:$a)=chooseEnvSubbindDictenvf`mplus`chooseEnvbindDictenvachooseEnvSub___=Nothing-- | Perform common sub-expression elimination and variable hoistingcodeMotion::foralldoma.(ConstrainedBydomTypeable,AlphaEqdomdomdom[(VarId,VarId)])=>BindDictdom->(foralla.doma->Bool)->ASTFdoma->StateVarId(ASTFdoma)codeMotionbindDictcanShra|Justb<-choosebindDictcanShra=shareb|otherwise=descendawhereshare(ASTEb)=dob'<-codeMotionbindDictcanShrbv<-get;put(v+1)letx=Sym(injVariablebindDictbv)body<-codeMotionbindDictcanShr$substitutebxareturn$Sym(injLetbindDictbody):$b':$(Sym(injLambdabindDictb'bodyv):$body)descend::ASTdomb->StateVarId(ASTdomb)descend(f:$a)=liftM2(:$)(descendf)(codeMotionbindDictcanShra)descenda=returnadefaultBindDict::(Variable:<:dom,Lambda:<:dom,Let:<:dom,Constraineddom)=>BindDict(dom:||Typeable)defaultBindDict=BindDict{prjVariable=\a->doVariablev<-prjareturnv,prjLambda=\a->doLambdav<-prjareturnv,injVariable=\refv->caseexprDictrefofDict->C'$inj(Variablev),injLambda=\refarefbv->case(exprDictrefa,exprDictrefb)of(Dict,Dict)->C'$inj(Lambdav),injLet=\ref->caseexprDictrefofDict->C'$injLet}-- TODO Abstract away from Typeable?-- | Like 'reify' but with common sub-expression elimination and variable-- hoistingreifySmart::(AlphaEqdomdom((Lambda:+:Variable:+:dom):||Typeable)[(VarId,VarId)],Syntactica(HODomaindomTypeable))=>BindDict((Lambda:+:Variable:+:dom):||Typeable)->(foralla.((Lambda:+:Variable:+:dom):||Typeable)a->Bool)->a->ASTF((Lambda:+:Variable:+:dom):||Typeable)(Internala)reifySmartdictcanShr=flipevalState0.(codeMotiondictcanShr<=<reifyM.desugar)reifySmartDefault::(Let:<:dom,AlphaEqdomdom((Lambda:+:Variable:+:dom):||Typeable)[(VarId,VarId)],Syntactica(HODomaindomTypeable))=>(foralla.((Lambda:+:Variable:+:dom):||Typeable)a->Bool)->a->ASTF((Lambda:+:Variable:+:dom):||Typeable)(Internala)reifySmartDefault=reifySmartdefaultBindDict