module DDC.Core.Flow.Transform.Slurp
(slurpProcesses)
where
import DDC.Core.Flow.Transform.Slurp.Alloc
import DDC.Core.Flow.Transform.Slurp.Operator
import DDC.Core.Flow.Prim
import DDC.Core.Flow.Context
import DDC.Core.Flow.Process
import DDC.Core.Flow.Compounds
import DDC.Core.Flow.Exp
import DDC.Core.Transform.Deannotate
import DDC.Core.Module
import Data.Maybe
import Data.List
slurpProcesses :: Module () Name -> [Process]
slurpProcesses mm
= slurpProcessesX (deannotate (const Nothing) $ moduleBody mm)
slurpProcessesX :: Exp () Name -> [Process]
slurpProcessesX xx
= case xx of
XLet lts x'
-> slurpProcessesLts lts ++ slurpProcessesX x'
_ -> []
slurpProcessesLts :: Lets () Name -> [Process]
slurpProcessesLts (LRec binds)
= catMaybes [slurpProcessLet b x | (b, x) <- binds]
slurpProcessesLts (LLet b x)
= catMaybes [slurpProcessLet b x]
slurpProcessesLts _
= []
slurpProcessLet :: Bind Name -> Exp () Name -> Maybe Process
slurpProcessLet (BName n tProcess) xx
| Just (fbs, xBody) <- takeXLamFlags xx
= let
(fbts, fbvs) = partition fst fbs
bts = map snd fbts
tsRate = filter (\b -> typeOfBind b == kRate) bts
ctxParam = map (ContextRate . TVar . UName)
$ map (\(BName nRate _) -> nRate)
$ tsRate
bvs = map snd fbvs
(ctxLocal, ops, ltss, xResult)
= slurpProcessX xBody
ops_alloc = patchAllocRates ops
tResult = snd $ takeTFunAllArgResult tProcess
in Just $ Process
{ processName = n
, processParamTypes = bts
, processParamValues = bvs
, processContexts = ctxParam ++ ctxLocal
, processOperators = ops_alloc
, processStmts = ltss
, processResultType = tResult
, processResult = xResult }
slurpProcessLet _ _
= Nothing
slurpProcessX
:: ExpF
-> ( [Context]
, [Operator]
, [LetsF]
, ExpF)
slurpProcessX xx
| XLet (LLet b x) xMore <- xx
, (ctxHere, opsHere, ltsHere) <- slurpBindingX b x
, (ctxMore, opsMore, ltsMore, xResult) <- slurpProcessX xMore
= ( ctxHere ++ ctxMore
, opsHere ++ opsMore
, ltsHere ++ ltsMore
, xResult)
| XCase xScrut [AAlt (PData dc bs) x] <- xx
, bs' <- takeSubstBoundsOfBinds bs
, length bs == length bs'
, lets <- zipWith
(\b b' -> LLet b
(XCase xScrut
[AAlt (PData dc bs)
(XVar b')])) bs bs'
= slurpProcessX (xLets lets x)
| otherwise
= ([], [], [], xx)
slurpBindingX
:: BindF
-> ExpF
-> ( [Context]
, [Operator]
, [LetsF])
slurpBindingX b1 xx
| XLet (LLet b2 x2) xMore <- xx
, (ctxHere, opsHere, ltsHere) <- slurpBindingX b2 x2
, (ctxMore, opsMore, ltsMore) <- slurpBindingX b1 xMore
= ( ctxHere ++ ctxMore
, opsHere ++ opsMore
, ltsHere ++ ltsMore)
slurpBindingX b
( takeXPrimApps
-> Just ( NameOpFlow (OpFlowMkSel 1)
, [ XType tK1, XType _tA
, XVar uFlags
, XLAM (BName nR kR) (XLam bSel xBody)]))
| kR == kRate
= let
(ctxInner, osInner, ltsInner)
= slurpBindingX b xBody
UName nFlags = uFlags
nFlagsUse = NameVarMod nFlags "use"
uFlagsUse = UName nFlagsUse
bFlagsUse = BName nFlagsUse (tSeries tK1 tBool)
opId = OpId
{ opResultSeries = bFlagsUse
, opInputRate = tK1
, opInputSeries = uFlags
, opElemType = tBool }
context = ContextSelect
{ contextOuterRate = tK1
, contextInnerRate = TVar (UName nR)
, contextFlags = uFlagsUse
, contextSelector = bSel }
in (context : ctxInner, opId : osInner, ltsInner)
slurpBindingX b x
= case slurpOperator b x of
Just op -> ([], [op], [])
_ -> ([], [], [LLet b x])