module DDC.Core.Flow.Transform.Schedule
(scheduleProcess)
where
import DDC.Core.Flow.Transform.Schedule.SeriesEnv
import DDC.Core.Flow.Transform.Schedule.Nest
import DDC.Core.Flow.Procedure
import DDC.Core.Flow.Process
import DDC.Core.Flow.Compounds
import DDC.Core.Flow.Prim
import DDC.Core.Flow.Exp
import DDC.Base.Pretty
import Control.Monad
scheduleProcess :: Process -> Procedure
scheduleProcess
(Process
{ processName = name
, processParamTypes = psType
, processParamValues = psValue
, processContexts = contexts
, processOperators = ops
, processStmts = stmts
, processResultType = tResult
, processResult = xResult})
= let
Just nest1 = foldM insertContext NestEmpty contexts
nest2 = scheduleOperators nest1 emptySeriesEnv ops
in Procedure
{ procedureName = name
, procedureParamTypes = psType
, procedureParamValues = psValue
, procedureNest = nest2
, procedureStmts = stmts
, procedureResultType = tResult
, procedureResult = xResult }
scheduleOperators
:: Nest
-> SeriesEnv
-> [Operator]
-> Nest
scheduleOperators nest0 env ops
= case ops of
[] -> nest0
op : ops'
-> let (env', nest') = scheduleOperator nest0 env op
in scheduleOperators nest' env' ops'
scheduleOperator
:: Nest
-> SeriesEnv
-> Operator
-> (SeriesEnv, Nest)
scheduleOperator nest0 env op
| OpId{} <- op
= let
Just nSeries
= takeNameOfBound (opInputSeries op)
(uInput, env1, nest1)
= bindNextElem nSeries
(opInputRate op) (opElemType op)
env nest0
Just bResultElem
= elemBindOfSeriesBind $ opResultSeries op
context = ContextRate (opInputRate op)
Just nest2 = insertBody nest1 context
$ [ BodyStmt bResultElem (XVar uInput) ]
in (env1, nest2)
| OpCreate{} <- op
= let
Just nSeries
= takeNameOfBound (opInputSeries op)
(uInput, env1, nest1)
= bindNextElem nSeries
(opInputRate op) (opElemType op)
env nest0
BName nVec _ = opResultVector op
context = ContextRate (opInputRate op)
Just tRateAlloc = opAllocRate op
Just nest2 = insertStarts nest1 context
$ [ StartVecNew
nVec
(opElemType op)
tRateAlloc ]
Just nest3 = insertBody nest2 context
$ [ BodyVecWrite
nVec
(opElemType op)
(XVar (UIx 0))
(XVar uInput) ]
Just nest4 = insertEnds nest3 context
$ [ EndVecSlice
nVec
(opElemType op)
(opInputRate op) ]
nest' = if opInputRate op == tRateAlloc
then nest3
else nest4
in (env1, nest')
| OpMap{} <- op
= let
Just nsSeries = sequence $ map takeNameOfBound $ opInputSeriess op
tsRate = repeat (opInputRate op)
tsElem = map typeOfBind $ opWorkerParams op
(usInputs, env1, nest1)
= bindNextElems (zip3 nsSeries tsRate tsElem) env nest0
xsInputs = map XVar usInputs
xBody = foldl (\x (b, p) -> XApp (XLam b x) p)
(opWorkerBody op)
(zip (opWorkerParams op) xsInputs)
Just nResultSeries = takeNameOfBind $ opResultSeries op
nResultElem = NameVarMod nResultSeries "elem"
uResultElem = UName nResultElem
Just bResultElem = elemBindOfSeriesBind (opResultSeries op)
context = ContextRate $ opInputRate op
Just nest2 = insertBody nest1 context
$ [ BodyStmt bResultElem xBody ]
env2 = insertElemForSeries nResultSeries uResultElem env1
in (env2, nest2)
| OpFold{} <- op
= let
Just nSeries = takeNameOfBound (opInputSeries op)
tRate = opInputRate op
tInputElem = typeOfBind (opWorkerParamElem op)
(uInput, env1, nest1)
= bindNextElem nSeries tRate tInputElem env nest0
BName nResult _ = opResultValue op
nAcc = NameVarMod nResult "acc"
tAcc = typeOfBind (opWorkerParamAcc op)
context = ContextRate $ opInputRate op
Just nest2 = insertStarts nest1 context
$ [ StartAcc nAcc tAcc (opZero op) ]
xBody = XApp (XApp ( XLam (opWorkerParamElem op)
$ XLam (opWorkerParamIndex op)
(opWorkerBody op))
(XVar uInput))
(XVar (UIx 0))
Just nest3 = insertBody nest2 context
$ [ BodyAccRead nAcc tAcc (opWorkerParamAcc op)
, BodyAccWrite nAcc tAcc xBody ]
Just nest4 = insertEnds nest3 context
$ [ EndAcc nResult tAcc nAcc ]
in (env1, nest4)
| OpPack{} <- op
= let
Just nSeries = takeNameOfBound (opInputSeries op)
tRate = opInputRate op
tInputElem = opElemType op
(uInput, env1, nest1)
= bindNextElem nSeries tRate tInputElem env nest0
Just nResultSeries = takeNameOfBind (opResultSeries op)
env2 = insertElemForSeries nResultSeries uInput env1
in (env2, nest1)
| otherwise
= error $ renderIndent
$ vcat [ text "ddc-core-flow.scheduleOperator"
, indent 4 $ text "Can't schedule operator."
, indent 4 $ ppr op ]