---------------------------------------------------------------------------------- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file -- is distributed under the terms of the BSD3 License. For more information, -- see the file "LICENSE.txt", which is included in the distribution.---------------------------------------------------------------------------------- $Id: Lift.hs 291 2012-11-08 11:27:33Z heere112 $------------------------------------------------------------------ Do "johnson" style lambda lifting-- After this pass, each binding has either no free variables or no arguments.-- maintains free variable information & normalised structure----------------------------------------------------------------moduleLvm.Core.Lift(coreLift)whereimportData.ListimportData.MaybeimportLvm.Common.IdimportLvm.Common.IdMapimportLvm.Common.IdSetimportLvm.Core.ExprimportLvm.Core.FreeVarimportLvm.Core.Utils------------------------------------------------------------------ The environment maps variables to variables that should-- be supplied as arguments at each call site----------------------------------------------------------------dataEnv=EnvIdSet(IdMap[Id])-- primitives && the free variables to be passed as argumentselemFree::Env->Id->BoolelemFree(Env_env)x=elemMapxenvlookupFree::Env->Id->[Id]lookupFree(Env_env)x=fromMaybe[](lookupMapxenv)isPrimitive::Env->Id->BoolisPrimitive(Envprim_)=(`elemSet`prim)extendFree::Env->Id->[Id]->EnvextendFree(Envprimenv)xfv=Envprim(extendMapxfvenv)------------------------------------------------------------------ coreLift-- pre: [coreFreeVar] each binding is annotated with free variables-- [coreNoShadow] there is no shadowing----------------------------------------------------------------coreLift::CoreModule->CoreModulecoreLiftm=fmap(liftExprglobals(EnvprimitivesemptyMap))mwhereprimitives=externNamesmglobals=globalNamesmliftExpr::IdSet->Env->Expr->ExprliftExprglobalsenvexpr=caseexprofLetbindse->let(binds',env')=liftBindsglobalsenvbindsinLetbinds'(liftExprglobalsenv'e)Matchxalts->Matchx(liftAltsglobalsenvalts)Lamxe->Lamx(liftExprglobalsenve)Apexpr1expr2->Ap(liftExprglobalsenvexpr1)(liftExprglobalsenvexpr2)Varx->foldl'(\ev->Ape(Varv))expr(lookupFreeenvx)Con(ConTagtagarity)->Con(ConTag(liftExprglobalsenvtag)arity)_->exprliftAlts::IdSet->Env->Alts->AltsliftAltsglobalsenv=mapAlts(\patexpr->Altpat(liftExprglobalsenvexpr))------------------------------------------------------------------ Lift binding groups----------------------------------------------------------------liftBinds::IdSet->Env->Binds->(Binds,Env)liftBindsglobalsenvbinds=casebindsofNonRecbind->let([bind'],env')=liftBindsRecglobalsenv[bind]in(NonRecbind',env')Recrecs->let(recs',env')=liftBindsRecglobalsenvrecsin(Recrecs',env')Strict(Bindxrhs)->(Strict(Bindx(liftExprglobalsenvrhs)),env)freeVar2::IdSet->Expr->IdSetfreeVar2globals=(`diffSet`globals).freeVarliftBindsRec::IdSet->Env->[Bind]->([Bind],Env)liftBindsRecglobalsenvrecs=let(ids,exprs)=unzipBindsrecs-- calculate the mutual free variablesfvmap=fixMutual(zipids(map(liftedFreeVarenv.freeVar2globals)exprs))-- note these recursive equations :-)fvs=map(removeLiftedenv'.listFromSet.snd)fvmapenv'=foldlinsertLiftedenv(ziprecsfvs)-- put the computed free variables back into the bindings as lambdasrecs'=zipWith(addLambdasenv)fvs(zipWithBindids(map(liftExprglobalsenv')exprs))in(recs',env')addLambdas::Env->[Id]->Bind->BindaddLambdasenvfvbind@(Bindxexpr)|isAtomExprenvexpr=bind|otherwise=Bindx(foldrLamexprfv)insertLifted::Env->(Bind,[Id])->EnvinsertLiftedenv(Bindxexpr,fv)=ifisAtomExprenvexpr-- || isValueExpr expr)thenenvelseextendFreeenvxfvremoveLifted::Env->[Id]->[Id]removeLiftedenv=filter(not.elemFreeenv)fixMutual::[(Id,IdSet)]->[(Id,IdSet)]fixMutualfvmap=letfvmap'=mapaddMutualfvmapinifsizefvmap'==sizefvmapthenfvmapelsefixMutualfvmap'whereaddMutual(x,fv)=(x,foldSetaddLocalFreefvfv)addLocalFreexfv0=caselookupxfvmapofJustfv1->unionSetfv0fv1Nothing->fv0sizexs=sum(map(sizeSet.snd)xs)liftedFreeVar::Env->IdSet->IdSetliftedFreeVarenvfv=unionSetfv(setFromList(concatMap(lookupFreeenv)(listFromSetfv)))------------------------------------------------------------------ is an expression atomic: i.e. can we generate code inplace----------------------------------------------------------------isAtomExpr::Env->Expr->BoolisAtomExprenvexpr=caseexprofApe1e2->isAtomExprenve1&&isAtomExprenve2Varx->not(isPrimitiveenvx)Con_->TrueLit_->TrueLetbindse->isAtomBindsenvbinds&&isAtomExprenve_->FalseisAtomBinds::Env->Binds->BoolisAtomBindsenvbinds=casebindsofStrict_->FalseNonRec(Bind_expr)->isAtomExprenvexprRecbindings->all(isAtomExprenv)(snd(unzipBindsbindings))