moduleDDC.Core.Flow.Transform.Rates.SeriesOfVector(seriesOfVectorModule,seriesOfVectorFunction)whereimportDDC.Core.CollectimportDDC.Core.Flow.CompoundsimportDDC.Core.Flow.PrimimportDDC.Core.Flow.ExpimportDDC.Core.Flow.Transform.Rates.ConstraintsimportDDC.Core.Flow.Transform.Rates.FailimportDDC.Core.Flow.Transform.Rates.GraphimportDDC.Core.ModuleimportDDC.Core.Transform.AnnotateimportDDC.Core.Transform.DeannotateimportqualifiedDDC.Type.EnvasEnvimportControl.ApplicativeimportControl.MonadimportData.List(intersect,nub)importqualifiedData.MapasMapimportData.Maybe(catMaybes)importqualifiedData.SetasSetseriesOfVectorModule::ModuleF->(ModuleF,[(Name,Fail)])seriesOfVectorModulemm=letbody=deannotate(constNothing)$moduleBodymm(lets,xx)=splitXLetsbodyletsErrs=mapseriesOfVectorLetsletslets'=mapfstletsErrserrs=concatMapsndletsErrsbody'=annotate()$xLetslets'xxin-- trace ("ORIGINAL:"++ show (ppr $ moduleBody mm))-- trace ("MODULE:" ++ show (ppr body'))(mm{moduleBody=body'},errs)seriesOfVectorLets::LetsF->(LetsF,[(Name,Fail)])seriesOfVectorLetsll|LLetb@(BNamen_)x<-ll,(x',errs)<-seriesOfVectorFunctionx=(LLetbx',map(\f->(n,f))errs)|LRecbxs<-ll,(bs,xs)<-unzipbxs,(xs',_errs)<-unzip$mapseriesOfVectorFunctionxs=(LRec(bs`zip`xs'),[])-- We still need to produce errors if this doesn't work.|otherwise=(ll,[])-- | Takes a single function body. Function body must be in a-normal form.seriesOfVectorFunction::ExpF->(ExpF,[Fail])seriesOfVectorFunctionfun=run$do-- Peel off the lambdaslet(lams,body)=takeXLamFlags_safefun-- This assumes the body is already in a-normal form.(lets,xx)=splitXLetsbody-- Split into name and values and warn for recursive bindingsbinds<-takeLetsletslettymap=takeTypes(concatMapvalwitBindsOfLetslets++mapsndlams)-- Assumes the binds only use vector primitives,-- OR if not vector primitives, do not refer to bound vectorsletnames=mapfstbinds-- Make sure names are uniquewhen(lengthnames/=length(nubnames))$warnFailNamesNotUnique(constrs,equivs)<-checkBindConstraintsbindsletextras=catMaybes$map(takeNameOfBind.snd)lamsletgraph=graphOfBindsbindsextrasletrets=catMaybes$maptakeNameOfBound$Set.toList$freeXEnv.emptyxxloops<-schedulegraphequivsretsbinds'<-orderBindsbindsloops-- True <- trace ("TYMAP:" ++ show tymap) return True-- True <- trace ("NAMES,LOOPS,NAMES':" ++ show (names, loops, map (map fst) binds')) -- return Trueletoutputs=maplOutputsloopsletinputs=maplInputsloopsletgetMax=getMaxSizeconstrsequivsextrasreturn$constructgetMaxlams(zip3binds'outputsinputs)equivstymapxx-- | Peel the lambdas off, or const if there are nonetakeXLamFlags_safex|Just(binds,body)<-takeXLamFlagsx=(binds,body)|otherwise=([],x)-- | Split into name and values and warn for recursive bindingstakeLets::[LetsF]->LogFailures[(Name,ExpF)]takeLetslets=concat<$>mapMgetletswhereget(LLet(BNamen_)x)=return[(n,x)]get(LLet(BNone_)_)=return[]get(LLet(BAnon_)_)=wFailNoDeBruijnAllowedget(LRec_)=wFailRecursiveBindingsget(LPrivate___)=wFailLetRegionNotHandledget(LWithRegion_)=wFailLetRegionNotHandledwerr=warnerr>>return[]-- | Split into name and values and warn for recursive bindingstakeTypes::[BindName]->Map.MapNameTypeFtakeTypesbinds=Map.fromList$concatMapgetbindswhereget(BNament)=[(n,t)]get_=[]dataLoop=Loop{lBindings::[Name],lOutputs::[Name],lInputs::[Name]}deriving(Eq,Show)schedule::Graph->EquivClass->[Name]->LogFailures[Loop]schedulegraphequivsrets=lettype_order=map(canonNameequivs.Set.findMin)equivs-- minimumBy length $ map scheduleTypes $ permutations type_order(wts,graph')=scheduleTypesgraphequivstype_orderloops=scheduleAll(mapsndwts)graphgraph'-- Use the original graph to find vars that cross loop boundariesoutputs=scheduleOutputsloopsgraphretsinputs=scheduleInputsloopsgraphin-- trace ("GRAPH,GRAPH',WTS,EQUIVS:" ++ show (graph, graph', wts, equivs)) return$zipWith3LooploopsoutputsinputsscheduleTypes::Graph->EquivClass->[Name]->([(Name,Map.MapNameInt)],Graph)scheduleTypesgraphtypestype_order=foldlgo([],graph)type_orderwherego(w,g)ty=letw'=typedTraversalgtypestyg'=mergeWeightsgw'in((ty,w'):w,g')scheduleAll::[Map.MapNameInt]->Graph->Graph->[[Name]]scheduleAllweightsgraphgraph'=loopswhereweights'=mapinvertMapweightstopo=graphTopoOrdergraph'loops=mapgetNamestopogetNamesn=sort$findn(weights`zip`weights')original_order=graphTopoOrdergraph-- Cheesy hack to get ns in same order as the original graph's topo:-- filter topo to only those elements in nssortns=filter(flipelemns)original_orderfind_[]=[]findn((w,w'):rest)|Justi<-n`Map.lookup`w,Justns<-i`Map.lookup`w'=ns|otherwise=findnrest-- Find any variables that cross loop boundaries - they must be reifiedscheduleOutputs::[[Name]]->Graph->[Name]->[[Name]]scheduleOutputsloopsgraphrets=mapoutputloopswhereoutputns=graphOutsns++filter(`elem`ns)retsgraphOutsns=concatMap(\(k,es)->ifk`elem`nsthen[]elsens`intersect`mapfstes)$Map.toListgraph-- Find any variables that cross loop boundaries - they must be reifiedscheduleInputs::[[Name]]->Graph->[[Name]]scheduleInputsloopsgraph=mapinputloopswhereinputns=filter(\n->not(n`elem`ns))$graphInsnsgraphInsns=nub$concatMap(mapfst.mlookup"graphIns"graph)nstypedTraversal::Graph->EquivClass->Name->Map.MapNameInttypedTraversalgraphtypescurrent_type=restrictTypestypescurrent_type$traversalgraphwwherewuv=ifw'uvthen1else0w'(u,fusible)v|canonNametypesu==current_type=canonNametypesv/=current_type||notfusible|otherwise=FalserestrictTypes::EquivClass->Name->Map.MapNameInt->Map.MapNameIntrestrictTypestypescurrent_typeweights=Map.filterWithKeyrestrictweightswhererestrictn_=canonNametypesn==current_typeorderBinds::[(Name,ExpF)]->[Loop]->LogFailures[[(Name,ExpF)]]orderBindsbindsloops=letbindsM=Map.fromListbindsorder=maplBindingsloopsgetk|Justv<-Map.lookupkbindsM=[(k,v)]|otherwise=[]inreturn$map(\o->concatMapgeto)orderconstruct::(Name->Name)->[(Bool,BindF)]->[([(Name,ExpF)],[Name],[Name])]->EquivClass->Map.MapNameTypeF->ExpF->ExpFconstructgetMaxlamsloopsequivstysxx=letlets=concatMapconvertloopsinmakeXLamFlagslams$xLetslets$xxwhereconvert(binds,outputs,inputs)=convertToSeriesgetMaxbindsoutputsinputsequivstys-- We still need to join procs,-- split output procs into separate functionsconvertToSeries::(Name->Name)->[(Name,ExpF)]->[Name]->[Name]->EquivClass->Map.MapNameTypeF->[LetsF]convertToSeriesgetMaxbindsoutputsinputsequivstys=concatsetups++[LLet(BNonetBool)(runprocsinputs'processes)]++concatreadrefswhererunprocs::[(Name,TypeF)]->ExpF->ExpFrunprocsvecs@((cn,_):_)body=letcnn=canonNameequivscnkN=NameVarModcnn"k"kFlags=[(True,BNamekNkRate),(False,BNone$tRateNat$TVar$UNamekN)]vFlags=map(\(n,t)->(False,BName(NameVarModn"s")(tSeries(TVar(UNamekN))t)))vecsinxApps(xVarOpSeries(OpSeriesRunProcess$lengthvecs))(map(XType.snd)vecs++map(XVar.UName.fst)vecs++[(makeXLamFlags(kFlags++vFlags)body)])-- Should we introduce a rate parameter for generates?runprocs[]body=bodyinputs'::[(Name,TypeF)]inputs'=concatMapfilterInputsinputsfilterInputsinp|tyI<-mlookup"collectKloks"tysinp,Just(_tcVec,[tyA])<-takeTyConAppstyI,tyI==tVectortyA=[(inp,tyA)]|otherwise=[]processes=foldrwrapjoinsbindswrap(n,x)body=wrapSeriesXequivsoutputsn(mlookup"wrap"tysn)xbodyjoins|not$nulloutputs=foldl1mkJoin$map(\n->XVar$UName$NameVarModn"proc")outputs|otherwise=xUnit-- ???mkJoinpq=xApps(xVarOpSeriesOpSeriesJoin)[p,q]-- fill vectors and read references(setups,readrefs)=unzip$mapsetread$filter(flipelemoutputs.fst)bindssetread(n,x)=setreadSeriesXgetMaxtysn(mlookup"setread"tysn)xsetreadSeriesX::(Name->Name)->Map.MapNameTypeF->Name->TypeF->ExpF->([LetsF],[LetsF])setreadSeriesXgetMaxtysnametyxx|Just(f,args)<-takeXAppsxx,XVar(UPrim(NameOpVectorov)_)<-f=caseovof-- any folds MUST be known as outputs, so this is safeOpVectorReduce|[_tA,_f,z,_vA]<-args->([LLet(BName(nm"ref")(tRefty))(xNewtyz)],[LLet(BNamenamety)(xReadty(vr$nm"ref"))])_|[_vec,tyR]<-takeTAppsty,v<-getMaxname-- canonName equivs name,[_vec,tyCR]<-takeTApps$mlookup"setreadSeriesX"tysv->letvl=xApps(xVarOpVectorOpVectorLength)[XTypetyCR,XVar$UNamev]in([LLet(BNamename$tBotkData)$xNewVectortyRvl],[])_->([],[])|otherwise=([],[])wherenms=NameVarModnamesvrn=XVar$UNamenwrapSeriesX::EquivClass->[Name]->Name->TypeF->ExpF->ExpF->ExpFwrapSeriesXequivsoutputsnametyxxwrap|Just(op,args)<-takeXAppsxx,XVar(UPrim(NameOpVectorov)_)<-op=caseovofOpVectorReduce|[_tA,f,z,vA]<-args,XVar(UNamenvA)<-vA,kA<-kloknvA->XLet(LLet(BNamename'proctProcess)$xApps(xVarOpSeriesOpSeriesReduce)[kA,XTypety,XVar(UNamename'ref),f,z,modNameX"s"vA])wrapOpVectorMapn|(tys,f:rest)<-splitAt(n+1)args,lengthrest==n,kT<-klokname,rest'<-map(modNameX"s")rest->XLet(LLet(BNamename's$tBotkData)$xApps(xVarOpSeries(OpSeriesMapn))([kT]++tys++[f]++rest'))wrap'fillOpVectorFilter|[tA,p,vA]<-args,XVar(UNamenvA)<-vA,tkA<-klokTnvA,kA<-kloknvA,TVar(UNamenkT)<-klokTname,tkT<-klokTname->XLet(LLet(BNamename'flags(tBotkData))$xApps(xVarOpSeries(OpSeriesMap1))([kA,tA,XTypetBool,p,modNameX"s"vA]))$xApps(xVarOpSeries(OpSeriesMkSel1))([kA,XVar(UNamename'flags),XLAM(BNamenkTkRate)$XLam(BNamename'sel(tSel1tkAtkT))$XLet(LLet(BNamename's(tBotkData))$xApps(xVarOpSeriesOpSeriesPack)([kA,XTypetkT,tA,XVar(UNamename'sel),modNameX"s"vA]))wrap'fill])_->xx|otherwise=xxwherename'flags=NameVarModname"flags"name'proc=NameVarModname"proc"name'ref=NameVarModname"ref"name's=NameVarModname"s"name'sel=NameVarModname"sel"klokTn=letn'=canonNameequivsnkN=NameVarModn'"k"inTVar$UNamekNklokn=XType$klokTntyR|[_vec,tyR']<-takeTAppsty=JusttyR'|otherwise=Nothingwrap'fill|name`elem`outputs,JusttyR'<-tyR=XLet(LLet(BNamename'proctProcess)$xAppsfillV[klokname,XTypetyR',vrname,vrname's])wrap|otherwise=wrapfillV=xVarOpSeriesOpSeriesFillvrn=XVar$UNamen-- tySeries-- | Vector nxVarOpSeriesn=XVar(UPrim(NameOpSeriesn)(typeOpSeriesn))xVarOpVectorn=XVar(UPrim(NameOpVectorn)(typeOpVectorn))modNameX::String->ExpF->ExpFmodNameXsxx=casexxofXVar(UNamen)->XVar(UName(NameVarModns))_->xx{-
\as,bs...
cs = map as
ds = filter as
n = fold ds
es = map3 bs cs
return es
==>
schedule graph equivs [es]
==>
[ [ds, n]
, [cs, es] ]
-}