{-# LANGUAGE OverlappingInstances, PatternGuards, UndecidableInstances #-}moduleFeldspar.Compiler.Imperative.FromCore(Compilable(..),numArgs,fromCore)whereimportControl.Monad.StateimportControl.Monad.WriterimportData.ListimportData.StringimportData.BitsimportqualifiedFeldspar.DSL.ExpressionasLangimportqualifiedFeldspar.DSL.LambdaasLangimportFeldspar.DSL.Lambdahiding(Value,Variable)importFeldspar.DSL.NetworkimportFeldspar.Set(universal)importqualifiedFeldspar.Core.TypesasLangimportFeldspar.Core.Representationhiding(variable)importqualifiedFeldspar.Core.RepresentationasLangimportqualifiedFeldspar.Core.Functions.ArrayasLangimportqualifiedFeldspar.Core.Functions.TupleasLangimportFeldspar.Core.Functions.Num()importFeldspar.Range(Range(..),BoundedInt)importData.Typeable(Typeable,typeOf)importFeldspar.Compiler.Imperative.Representationhiding(blockProgram)importFeldspar.Compiler.Imperative.FrontendimportFeldspar.Compiler.Backend.C.CodeGenerationimportFeldspar.Compiler.ErrorimportFeldspar.Compiler.Backend.C.LibrarytypeTransformera=StateTInteger(Writer[Definition()])a-- | Path of a matching variabletypePath=[Int]typeMultiVar=[(Path,Lang.TypeRep)]indexType::TypeindexType=NumTypeUnsignedS32-- | Where to place the result of a single-edgedataSingleLoca=Shifted(Expression(),FeldNetwork(Out())Lang.Length)(SingleLoca)-- ^ A shifted location|SingleLoc{singleLV::Expression(),feedback::FeldNetwork(Out())a}-- ^ A location represented by a 'LeftValue ()' and a corresponding-- expression. The expression is used for feedback.-- | Container of a SingleLocgetSingleLV::SingleLoca->Expression()getSingleLV(SingleLoclv_)=lvgetSingleLV(Shifted_sl)=getSingleLVsl-- | Where to place the result of a general programdataLocationraawhereS::{single::SingleLoca}->Location(Out())aM::{multi::Ident}->Locationraa-- | Append a path to an identifierpathIdent::Ident->Path->IdentpathIdentidentpath=concat$intersperse"_"$(ident:)$mapshowpathtoSingle::Type->Location(Out())a->SingleLocatoSingletyp(Sloc)=loctoSingletyp(Mident)=SingleLocexprfbwhereexpr=varExpr$variableidenttypfb=Lang.VariableidentgetIx::Lang.Typea=>FeldNetwork(Out())[a]->FeldNetwork(Out())Lang.Index->FeldNetwork(Out())agetIxaix=undoEdge$unData$Lang.getIx(fromOutEdgeuniversala)(fromOutEdgeuniversalix)-- TODO Think about sizeaddExpr::FeldNetwork(Out())Lang.DefaultWord->FeldNetwork(Out())Lang.DefaultWord->FeldNetwork(Out())Lang.DefaultWordaddExprab=undoEdge$unData(fromOutEdgeuniversala+fromOutEdgeuniversalb)-- TODO Think about sizeadd::Expression()->Expression()->Expression()addab=FunctionCall"(+)"indexTypeInfixOp[a,b]()()indexLocSingle::Lang.Typea=>[(Expression(),FeldNetwork(Out())Lang.Length)]-- ^ Accumulated shifts->SingleLoc[a]-- ^ Original location->Expression()-- ^ Index variable->FeldNetwork(Out())Lang.Index-- ^ Index expression->SingleLocaindexLocSinglels(Shiftedlloc)ixVarixExpr=indexLocSingle(l:ls)locixVarixExprindexLocSinglels(SingleLoclvfb)ixVarixExpr=SingleLoclv'fb'wherelv'=arrayElemlv$foldladdixVar(mapfstls)ixExpr'=foldladdExprixExpr(mapsndls)fb'=getIxfbixExpr'-- | Sum the shifts of a shifted locationsumShifts::SingleLoca->Expression()sumShifts(SingleLoc__)=createConstantExpression$intConst0sumShifts(Shifted(e,_)l)=adde$sumShiftsl-- | Indexing into a locationindexLoc::Lang.Typea=>SingleLoc[a]-- ^ Original location->Expression()-- ^ Index variable->FeldNetwork(Out())Lang.Index-- ^ Index expression->SingleLocaindexLoclocixVarixExpr=indexLocSingle[]locixVarixExprselectFst::(Lang.Typea,Lang.Typeb)=>SingleLoc(a,b)->SingleLocaselectFst(SingleLocefb)=SingleLoc(StructFieldemember()())fb'wheremember=fst$head$s(StructTypes)=typeofefb'=undoEdge$unData$Lang.getFst$fromOutEdgeuniversalfbselectSnd::(Lang.Typea,Lang.Typeb)=>SingleLoc(a,b)->SingleLocbselectSnd(SingleLocefb)=SingleLoc(StructFieldemember()())fb'wheremember=fst$head$tail$s(StructTypes)=typeofefb'=undoEdge$unData$Lang.getSnd$fromOutEdgeuniversalfblocToNode::Location(Outra)a->FeldNetwork(Outra)alocToNode(S(SingleLoc_fb))=fblocToNode(Mident)=Lang.Variableident-- TODO Ingoring shiftmultiVarIn::FeldNetwork(Inra)a->MultiVarmultiVarIn=listEdge$\patha->(path,edgeType(edgeInfoa))simpleExpr::Expression()->Transformer([Program()],Expression())simpleExprexpr=return([],expr)isComplex::FeldNetwork(Outra)a->BoolisComplex(Inject(NodeCondition):$:_:$:_:$:_)=TrueisComplex(Inject(NodeParallel):$:_:$:_:$:_)=TrueisComplex(Inject(NodeSequential):$:_:$:_:$:_:$:_)=TrueisComplex(Inject(NodeForLoop):$:_:$:_:$:_)=TrueisComplex(Inject(Node(NoInline_)):$:_:$:_)=TrueisComplex(Inject(NodeSetLength):$:_:$:_)=TrueisComplex(Inject(NodePair):$:_:$:_)=TrueisComplex(Inject(NodeSetIx):$:_:$:_:$:_)=TrueisComplexa=isArrayLitagenLiteralExpression::Lang.Typea=>a->Transformer([Program()],Expression())genLiteralExpression=simpleExpr.flipConstExpr().compileDataRep.Lang.dataRepgenVarExpression::Type->FeldNetwork(Out())a->Transformer([Program()],Expression())genVarExpressiontypa=simpleExpr(varExprvar)whereJustident=traceVaravar=variable(pathIdentident$matchPatha)typgenApplyExpression::Type->String->FeldNetwork(Inra)a->Transformer([Program()],Expression())genApplyExpressiontypfuna=do(progs,exprs)<-liftMunzip$sequence$listEdge(constgenExpressionIn)areturn(concatprogs,FunctionCallfuntypSimpleFunexprs()())-- | Generate an expression that is not a literal, function call or a variablegenComplexExpression::Type->FeldNetwork(Out())a->Transformer([Program()],Expression())genComplexExpressiontypa=doident<-newName"w"letvar=variableidenttypdecl=DeclarationvarNothing()prog<-genNode(Mident)areturn([BlockProgram(block[decl]prog)()],VarExprvar())genExpressionIn::FeldNetwork(In())a->Transformer([Program()],Expression())genExpressionIna=genExpressiontyp(undoEdgea)wheretyp=compileTypeRep$edgeType$edgeInfoa-- | Generate an expression plus support codegenExpression::Type->FeldNetwork(Out())a->Transformer([Program()],Expression())genExpression_a@(Inject(Node(Literallit)))|not(isArrayLita)=genLiteralExpressionlitgenExpressiontyp(Inject(Node(Functionfun_)):$:a)=genApplyExpressiontypfunagenExpressiontypa|Just_<-traceVara=genVarExpressiontypagenExpressiontyp(Injectm:$:_)|isMatchm=localErrorInvariantViolation"matching on non-variable"genExpressiontypa=genComplexExpressiontypagenDeclarations::Ident->MultiVar->[Declaration()]-- TODO Would be nice to have (Out ra)genDeclarationsidentvars=[DeclarationvarNothing()|(path,typ)<-vars,letident'=pathIdentidentpath,letvar=variableident'$compileTypeReptyp]genMultiCopy::MultiVar->Locationraa->Locationrba->[Program()]genMultiCopy[(_,typ)](S(SingleLoclv_))(MrIdent)=[copyProglvrhs]whererhs=varExpr$variablerIdent$compileTypeReptypgenMultiCopy_(S(SingleLoclhs_))(S(SingleLocrhs_))=[copyProglhsrhs]genMultiCopyvars(Mident)(MrIdent)=[copyProg(varExprlVar)(varExprrVar)|(path,typ)<-vars,letident'=pathIdentidentpath,letrIdent'=pathIdentrIdentpath,lettyp'=compileTypeReptyp,letlVar=variableident'typ',letrVar=variablerIdent'typ']-- TODO Ingoring shiftgenMultiCopy[(_,typ)](Mident)(S(SingleLocrhs_))=[copyProglhsrhs]wherelhs=varExpr$variableident$compileTypeReptyp-- | Generate code for a 'Let' expressiongenLet::([Program()]->FeldNetworkraa->Transformerb)-- ^ Generator for the body->FeldNetworkraa->TransformerbgenLetgen(Letbase:$:a:$:Lambdaf)=doaIdent<-newNamebaseaProg<-genNode(MaIdent)aletaBlock=block(genDeclarationsaIdent(resTypesa))aProgletProg=f(Lang.VariableaIdent)gen[BlockProgramaBlock()]letProggenNodeExpression::SingleLoca->Type->FeldNetwork(Out())a->Transformer[Program()]genNodeExpressionloctypa=do(prog,rhs)<-genExpressiontypareturn$prog++caselocofSingleLocl_->[copyProglrhs]l@(Shifted__)->[copyProgPos(getSingleLVl)(sumShiftsl)rhs]genNodeSingle::SingleLoca->Type->FeldNetwork(Out())a->Transformer[Program()]genNodeSingleloc_a|isComplexa=genNode(Sloc)agenNodeSingleloctypa=genNodeExpressionloctypa-- | TODO network must be a 'Node' or a (nested) 'Let' resulting in a 'Node'genNode::forallraa.Locationraa->FeldNetworkraa-- TODO Would be nice to have (Out ra)->Transformer[Program()]genNodeloca|isLeta=genLetgenBodyawheregenBodyletProgbody=liftM(letProg++)$genNodelocbodygenNodeloc(Inject(NodeCondition):$:cond:$:t:$:e)=do(condProg,condExpr)<-genExpressionIncondthenProg<-genEdgeloctelseProg<-genEdgeloceletbranchProg=BranchcondExpr(block[]thenProg)(block[]elseProg)()()return(condProg++[branchProg])genNodeloca@(Inject(NodeParallel):$:len:$:Lambdaixf:$:cont)=do(lenProg,lenExpr)<-genExpressionInlenixIdent<-newName"i"letbodyExpr=ixf(Lang.VariableixIdent)ixVar=variableixIdentindexTypeixExpr=Lang.VariableixIdentloc'=toSingletyploclocBody=indexLocloc'(varExprixVar)ixExprlocCont=Shifted(lenExpr,undoEdgelen)loc'setLen=caseloc'ofSingleLoc__->setLength(singleLVloc')lenExprShifted_l->increaseLength(getSingleLVl)lenExprbodyProg<-genEdge(SlocBody)bodyExprcontProg<-genEdge(SlocCont)contreturn(lenProg++[setLen,ParLoopixVarlenExpr1(block[]bodyProg)()()]++contProg)-- TODO Should use \"default size\" for index typewhere[(_,Lang.ArrayType_t)]=resTypesatyp=compileTypeReptgenNodeloca@(Inject(NodeSequential):$:len:$:init:$:Lambdastep:$:Lambdacont)=do(lenProg,lenExpr)<-genExpressionInlenstepIdent<-newName"x"letstIdent=stepIdent++"_2"tempIdent<-newName"temp"ixIdent<-newName"i"initProg<-genEdge(MstIdent)initletstep'=step(Lang.VariableixIdent)stepExpr=shallowApplystep'(Lang.VariablestIdent)tempVarElem=variable(tempIdent++"_1")elemTypixVar=variableixIdentindexTypeixExpr=Lang.VariableixIdentloc'=toSinglearrTyploclocElem=indexLocloc'(varExprixVar)ixExprlocCont=Shifted(lenExpr,undoEdgelen)loc'tempDeclElem=genDeclarationstempIdent[([1],tElem)]tempDeclsSt=genDeclarations(tempIdent++"_2")(multiVarIninit)stDecls=genDeclarationsstIdent(multiVarIninit)elemCopy=copyProg(singleLVlocElem)(varExprtempVarElem)stCopy=genMultiCopy(multiVarIninit)(MstIdent)(M$tempIdent++"_2")apa=cont(Lang.VariablestIdent)setLen=setLength(singleLVloc')lenExprstepProg<-genEdge(MtempIdent)stepExprcontProg<-genEdge(SlocCont)apareturn$[BlockProgram(blockstDecls(initProg++lenProg++[setLen,ParLoopixVarlenExpr1(block(tempDeclElem++tempDeclsSt)(stepProg++stCopy++[elemCopy]))()()]++contProg))()]where[(_,tArr@(Lang.ArrayType_tElem))]=resTypesaarrTyp=compileTypeReptArrelemTyp=compileTypeReptElemgenNodeloca@(Inject(NodeForLoop):$:len:$:init:$:Lambdabody)=do(lenProg,lenExpr)<-genExpressionInlentempIdent<-newName"temp"ixIdent<-newName"i"initProg<-genEdgelocinitletbody'=body(Lang.VariableixIdent)bodyExpr=shallowApplybody'(locToNodeloc)ixVar=variableixIdentindexTypetempDecls=genDeclarationstempIdent(resTypesa)bodyProg<-genEdge(MtempIdent)bodyExprletcopyProg=genMultiCopy(resTypesa)loc(MtempIdent)return[BlockProgram(blocktempDecls(lenProg++initProg++[ParLoopixVarlenExpr1(block[](bodyProg++copyProg))()()]))()]genNode(S(Shifted__))a@(Inject(Node(Literal_)))|isArrayLita&&isEmptya=return[]genNodeloca@(Inject(Node(Literalb)))|isArrayLita=return[initialize(getSingleLVl)(sumShiftsl)v]wherel=toSingletyplocv=compileDataRep$Lang.dataRepbtyp=compileTypeRep$Lang.typeRep'bgenNodeloca@(Inject(Node(NoInlinename)):$:Lambdabody:$:x)=doparam<-newName"in"result<-newName"out"prolog<-sequence$listEdge(constgenExpressionIn)xletprologProgs=concatMapfstprologprologArgs=map(flipIn().snd)prologargVars=genVarsparamxresVars=genVarsresult(body$Lang.Variableparam)outArgs=map(flipOut())$genLocExprslocaprog<-genEdge(Mresult)(body$Lang.Variableparam)tell[procedurenameargVarsresVars(block[]prog)]return$prologProgs++[procedureCallnameprologArgsoutArgs]wheretyp=undefinednodeType=compileTypeRep.snd.head.resTypesgenNode(Sloc)(Inject(NodeSetLength):$:len:$:(Inject(Edgeedge):$:a))|not(isComplexa),Justname<-traceVara=do(lenProg,lenExpr)<-genExpressionInlenlettyp=compileTypeRep$edgeTypeedgeletarrProg=[copyProgLen(singleLVloc)(varExpr$createVariablenametyp)lenExpr]return$lenProg++arrProggenNode(Sloc)a@(Inject(NodeSetLength):$:len:$:arr)=do(lenProg,lenExpr)<-genExpressionInlenarrProg<-genEdge(Sloc)arrreturn$lenProg++arrProg++[setLength(singleLVloc)lenExpr]genNodeloca@(Inject(NodeSetIx):$:ix:$:val:$:e)=do(ixProg,ixExpr)<-genExpressionInixcopy<-genEdgeloceletupdLoc=indexLoc(toSingleelemTypeloc)ixExpr$undoEdgeixupdate<-genEdge(SupdLoc)valreturn$copy++ixProg++updatewhere[(_,(Lang.ArrayType_tElem))]=resTypesaelemType=compileTypeReptElemgenNodeloca@(Inject(NodePair):$:x:$:y)=doprog1<-genEdge(S$selectFst$toSingle(nodeTypea)loc)xprog2<-genEdge(S$selectSnd$toSingle(nodeTypea)loc)yreturn$prog1++prog2wherenodeType=compileTypeRep.snd.head.resTypesgenNodeloca@(Inject(Node(Literal_)))=genNodeSingle(toSingle(nodeTypea)loc)(nodeTypea)awherenodeType=compileTypeRep.snd.head.resTypesgenNodeloca@(Inject(Node(Function__)):$:_)=genNodeSingle(toSingle(nodeTypea)loc)(nodeTypea)awherenodeType=compileTypeRep.snd.head.resTypesgenLocExprs::Locationraa->FeldNetworkraa->[Expression()]genLocExprs(Sloc)_=[singleLVloc]genLocExprs(Mident)a=[varExpr$variable(pathIdentidentpath)(compileTypeReptyp)|(path,typ)<-resTypesa]viewGroup2::FeldNetwork(In(ra,rb))(a,b)->(FeldNetwork(Inra)a,FeldNetwork(Inrb)b)viewGroup2(InjectGroup2:$:a:$:b)=(a,b)-- TODO: Move somewhere elsegenEdgeSingle::Ident->Path->FeldNetwork(In())a->Transformer[Program()]genEdgeSingleidentpatha=genNodeSingle(toSingletyp$Mident')typ(undoEdgea)whereident'=pathIdentidentpathtyp=compileTypeRep$edgeType$edgeInfoa-- | Generate code for a multi-edgegenEdge::Location(Outra)a->FeldNetwork(Inra)a->Transformer[Program()]genEdgeloca|isLeta=genLetgenBodyawheregenBodyletProgbody=liftM(letProg++)$genEdgelocbodygenEdgeloc(Inject(Edgeedge):$:a)=genNodeSingle(toSingletyploc)typawheretyp=compileTypeRep$edgeTypeedgegenEdge(Mident)a=liftMconcat$sequence$listEdge(genEdgeSingleident)a-- | Generate a variable of the same type as the given single-edgegenVar::Ident->Path->FeldNetwork(In())a->Variable()genVaridentpatha=variable(pathIdentidentpath)typwheretyp=compileTypeRep$edgeType$edgeInfoagenVars::Ident->FeldNetwork(Inra)a->[Variable()]genVarsident(Let_:$:a:$:Lambdaf)=genVarsident(f(Lang.Variable"TODO"))genVarsidenta=listEdge(genVarident)aclassCompilabletwheretoImperativeM::String-- ^ Name of procedure->[Variable()]-- ^ Free variables->t-- ^ Program to compile->Transformer()-- | Returns a list containing the number of edges in each curried argumentbuildInParamDescriptor::t->[Int]instanceSyntactica=>CompilableawheretoImperativeMprocNamefreeVarsprog=doident<-newName"out"body<-genEdge(Mident)prog'letresVars=genVarsidentprog'tell[ProcedureprocNamefreeVarsresVars(block[]body)()()]whereprog'=feldSharing(toEdgeprog)buildInParamDescriptor_=[]instance(Syntactica,Compilablet)=>Compilable(a->t)wheretoImperativeMprocNamefreeVarsprog=doident<-newName"in"letarg=Lang.variableuniversalidentletvars=genVarsident(toEdgearg)toImperativeMprocName(freeVars++vars)(progarg)buildInParamDescriptorprog=countEdges(toEdgearg):buildInParamDescriptor(progarg)wherearg=Lang.variableuniversal"argument"numArgs::Compilablea=>a->IntnumArgs=length.buildInParamDescriptorfromCore::Compilablet=>String->t->Module()fromCoreprocNameprog=Module(execWriter$evalStateT(toImperativeMprocName[]prog)0)()initialize::Expression()->Expression()->Constant()->Program()initializelocshift(ArrayConstvs__)=createProgramSequence$(setLengthloc$shift`add`intConstExpr(toInteger$lengthvs)):(map(\(v,i)->initialize(arrayElemloc$shift`add`i)(intConstExpr0)v)$zipvs$mapintConstExpr[0..])initializeloc_v=copyProgloc$createConstantExpressionv-- | Compilation of a data representation to an imperative constantcompileDataRep::Lang.DataRep->Constant()compileDataRep(Lang.BoolDatax)=BoolConstx()()compileDataRep(Lang.IntDatax)=IntConstx()()compileDataRep(Lang.FloatDatax)=FloatConst(fromRational$toRationalx)()()compileDataRep(Lang.ComplexDatari)=ComplexConst(compileDataRepr)(compileDataRepi)()()compileDataRep(Lang.ArrayDataxs)=ArrayConst(mapcompileDataRepxs)()()compileDataRep(Lang.StructDatasd)=localErrorInternalError"Struct constants not supported yet."-- | Compilation of a type representation to an imperative typecompileTypeRep::Lang.TypeRep->TypecompileTypeReptyp=casetypofLang.BoolType->BoolTypeLang.IntTyper->compileNumericTyperLang.FloatType->FloatTypeLang.ComplexTypetyp->ComplexType(compileTypeReptyp)Lang.UserTypeuserTypeName->UserTypeuserTypeNameLang.ArrayTypedimelemTyp->ArrayType(getLengthdim)$compileTypeRepelemTypLang.StructTypememberTypes->StructType$zip(map((defaultMemberName++).show)[1..])$mapcompileTypeRepmemberTypes-- | Numeric type based on a rangecompileNumericType::(BoundedInta,Typeablea)=>Rangea->TypecompileNumericTyper=NumType(intSignr)(intSizer)-- | Sign based on a rangeintSign::BoundedInta=>Rangea->SignednessintSignr|isSigned(upperBoundr)=Signed|otherwise=Unsigned-- | Size based on a rangeintSize::(BoundedInta,Typeablea)=>Rangea->SizeintSizer=casebitSizeiof8->S816->S1632->S3264->S64_->localErrorInvariantViolation$"unknown integer type: "++show(typeOfi)wherei=upperBoundr-- | Compilation of a lengthgetLength::RangeLang.Length->LengthgetLengthl|u==maxBound=UndefinedLen|otherwise=LiteralLen(fromIntegralu)whereu=upperBoundl-- | Customized error functionlocalError=handleError"Backends :: C :: ConstTransformation"