ddc-core-flow-0.4.1.1: DDC/Core/Flow/Transform/Slurp.hs
module DDC.Core.Flow.Transform.Slurp
( slurpProcesses
, slurpOperator
, isSeriesOperator
, isVectorOperator)
where
import DDC.Core.Flow.Transform.Slurp.Operator
import DDC.Core.Flow.Transform.Slurp.Error
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 qualified DDC.Type.Env as Env
import DDC.Type.Env (TypeEnv)
import Data.List
-- | Slurp stream processes from the top level of a module.
slurpProcesses :: Module () Name -> Either Error [Process]
slurpProcesses mm
= slurpProcessesX (deannotate (const Nothing) $ moduleBody mm)
-- | Slurp stream processes from a module body.
-- A module consists of some let-bindings wrapping a unit data constructor.
slurpProcessesX :: Exp () Name -> Either Error [Process]
slurpProcessesX xx
= case xx of
-- Slurp processes definitions from the let-bindings.
XLet lts x'
-> do ps1 <- slurpProcessesLts lts
ps2 <- slurpProcessesX x'
return $ ps1 ++ ps2
-- Ignore the unit data constructor at the end of the module.
_
| xx == xUnit -> Right []
| otherwise -> Left $ ErrorBadProcess xx
-- | Slurp stream processes from the top-level let expressions.
slurpProcessesLts :: Lets () Name -> Either Error [Process]
slurpProcessesLts (LRec binds)
= sequence [slurpProcessLet b x | (b, x) <- binds]
slurpProcessesLts (LLet b x)
= sequence [slurpProcessLet b x]
slurpProcessesLts _
= return []
-------------------------------------------------------------------------------
-- | Slurp stream operators from a top-level binding.
slurpProcessLet
:: Bind Name -- ^ Binder for the whole process.
-> Exp () Name -- ^ Expression of body.
-> Either Error Process
slurpProcessLet (BName n t) xx
-- We assume that all type params come before the value params.
| (snd $ takeTFunAllArgResult t) == tProcess
, Just (fbs, xBody) <- takeXLamFlags xx
= let
-- Split binders into type and value binders.
(fbts, fbvs) = partition fst fbs
-- Type binders.
bts = map snd fbts
tsRate = filter (\b -> typeOfBind b == kRate) bts
-- Create contexts for all the parameter rate variables.
ctxParam = map (ContextRate . TVar . UName)
$ map (\(BName nRate _) -> nRate)
$ tsRate
-- Value binders.
bvs = map snd fbvs
-- Slurp the body of the process.
in do
(ctxLocal, ops)
<- slurpProcessX Env.empty xBody
return $ Process
{ processName = n
, processParamTypes = bts
, processParamValues = bvs
-- Note that the parameter contexts needs to come first
-- so they are scheduled before the local contexts, which
-- are inside
, processContexts = ctxParam ++ ctxLocal
, processOperators = ops }
slurpProcessLet _ xx
= Left (ErrorBadProcess xx)
-------------------------------------------------------------------------------
-- | Slurp stream operators from the body of a function and add them to
-- the provided loop nest.
--
-- The process type environment records what process bindings are in scope,
-- so that we can check that the overall process is well formed.
-- This environment only needs to contain locally defined process variables,
-- not the global environment for the whole module.
--
slurpProcessX
:: TypeEnv Name -- ^ Process type environment.
-> ExpF -- ^ A sequence of non-recursive let-bindings.
-> Either Error
( [Context] -- Nested contexts created by this process.
, [Operator]) -- Series operators in this binding.
slurpProcessX tenv xx
| XLet (LLet b x) xMore <- xx
= do
-- Slurp operators from the binding.
(ctxHere, opsHere) <- slurpBindingX tenv b x
-- If this binding defined a process then add it do the environment.
let tenv'
| typeOfBind b == tProcess = Env.extend b tenv
| otherwise = tenv
-- Slurp the rest of the process using the new environment.
(ctxMore, opsMore) <- slurpProcessX tenv' xMore
return ( ctxHere ++ ctxMore
, opsHere ++ opsMore)
-- Slurp a process ending.
slurpProcessX tenv xx
-- The process ends with a variable that has Process# type.
| XVar u <- xx
, Just t <- Env.lookup u tenv
, t == tProcess
= return ([], [])
-- The process ends by joining two existing processes.
-- We assume that the overall expression is well typed.
| Just (NameOpSeries OpSeriesJoin, [_, _])
<- takeXPrimApps xx
= return ([], [])
-- Process finishes with some expression that doesn't look like it
-- actually defines a value of type Process#.
| otherwise
= Left (ErrorBadProcess xx)
-------------------------------------------------------------------------------
-- | Slurp stream operators from a let-binding.
slurpBindingX
:: TypeEnv Name -- ^ Process type environment.
-> BindF -- ^ Binder to assign result to.
-> ExpF -- ^ Right of the binding.
-> Either
Error
( [Context] -- Nested contexts created by this binding.
, [Operator]) -- Series operators in this binding.
-- Decend into more let bindings.
-- We get these when entering into a nested context.
slurpBindingX tenv b1 xx
| XLet (LLet b2 x2) xMore <- xx
= do
-- Slurp operators from the binding.
(ctxHere, opsHere) <- slurpBindingX tenv b2 x2
-- If this binding defined a process then add it to the environement.
let tenv'
| typeOfBind b2 == tProcess = Env.extend b2 tenv
| otherwise = tenv
-- Slurp the rest of the process using the new environment.
(ctxMore, opsMore) <- slurpBindingX tenv' b1 xMore
return ( ctxHere ++ ctxMore
, opsHere ++ opsMore)
-- Slurp a mkSel1#
-- This creates a nested selector context.
slurpBindingX tenv b
( takeXPrimApps
-> Just ( NameOpSeries (OpSeriesMkSel 1)
, [ XType tK1
, XVar uFlags
, XLAM (BName nR kR) (XLam bSel xBody)]))
| kR == kRate
= do
(ctxInner, osInner)
<- slurpBindingX tenv b xBody
-- Add an intermediate edge from the flags variable to its use.
-- This is needed for the case when the flags series is one of the
-- parameters to the process, because the intermediate OpId forces
-- the scheduler to add the flags_elem = next [k] flags_series
-- statement.
let UName nFlags = uFlags
let nFlagsUse = NameVarMod nFlags "use"
let uFlagsUse = UName nFlagsUse
let bFlagsUse = BName nFlagsUse (tSeries tK1 tBool)
let opId = OpId
{ opResultSeries = bFlagsUse
, opInputRate = tK1
, opInputSeries = uFlags
, opElemType = tBool }
let context = ContextSelect
{ contextOuterRate = tK1
, contextInnerRate = TVar (UName nR)
, contextFlags = uFlagsUse
, contextSelector = bSel }
return (context : ctxInner, opId : osInner)
-- Slurp a mkSegd#.
-- This creates a segmented context.
slurpBindingX tenv b
( takeXPrimApps
-> Just ( NameOpSeries OpSeriesMkSegd
, [ XType tK1
, XVar uLens
, XLAM (BName nK2 kR) (XLam bSegd xBody)]))
| kR == kRate
= do
(ctxInner, osInner)
<- slurpBindingX tenv b xBody
let UName nLens = uLens
let nLensUse = NameVarMod nLens "use"
let uLensUse = UName nLensUse
let bLensUse = BName nLensUse (tSeries tK1 tNat)
let opId = OpId
{ opResultSeries = bLensUse
, opInputRate = tK1
, opInputSeries = uLens
, opElemType = tNat }
let context = ContextSegment
{ contextOuterRate = tK1
, contextInnerRate = TVar (UName nK2)
, contextLens = uLensUse
, contextSegd = bSegd }
return (context : ctxInner, opId : osInner)
-- Slurp a series operator that doesn't introduce a new context.
slurpBindingX _ b xx
| Just op <- slurpOperator b xx
= return ([], [op])
-- Slurp a process ending.
slurpBindingX tenv _ xx
-- The process ends with a variable that has Process# type.
| XVar u <- xx
, Just t <- Env.lookup u tenv
, t == tProcess
= return ([], [])
-- The process ends by joining two existing processes.
-- We assume that the overall expression is well typed.
| Just (NameOpSeries OpSeriesJoin, [_, _])
<- takeXPrimApps xx
= return ([], [])
-- Process finishes with some expression that doesn't look like it
-- actually defines a value of type Process#.
| otherwise
= Left (ErrorBadOperator xx)