module DDC.Core.Flow.Lower
( Config (..)
, defaultConfigScalar
, defaultConfigKernel
, defaultConfigVector
, Method (..)
, Lifting (..)
, lowerModule)
where
import DDC.Core.Flow.Transform.Slurp
import DDC.Core.Flow.Transform.Schedule
import DDC.Core.Flow.Transform.Schedule.Base
import DDC.Core.Flow.Transform.Extract
import DDC.Core.Flow.Process
import DDC.Core.Flow.Procedure
import DDC.Core.Flow.Compounds
import DDC.Core.Flow.Profile
import DDC.Core.Flow.Prim
import DDC.Core.Flow.Exp
import DDC.Core.Module
import DDC.Core.Transform.TransformUpX
import DDC.Core.Transform.Annotate
import DDC.Core.Transform.Deannotate
import qualified DDC.Core.Simplifier as C
import qualified DDC.Core.Simplifier.Recipe as C
import qualified DDC.Core.Transform.Namify as C
import qualified DDC.Core.Transform.Snip as Snip
import qualified DDC.Type.Env as Env
import qualified Control.Monad.State.Strict as S
import qualified Data.Monoid as M
import Control.Monad
data Config
= Config
{ configMethod :: Method }
deriving (Eq, Show)
data Method
= MethodScalar
| MethodKernel
{ methodLifting :: Lifting }
| MethodVector
{ methodLifting :: Lifting }
deriving (Eq, Show)
defaultConfigScalar :: Config
defaultConfigScalar
= Config
{ configMethod = MethodScalar }
defaultConfigKernel :: Config
defaultConfigKernel
= Config
{ configMethod = MethodKernel (Lifting 8)}
defaultConfigVector :: Config
defaultConfigVector
= Config
{ configMethod = MethodVector (Lifting 8)}
lowerModule :: Config -> ModuleF -> Either Error ModuleF
lowerModule config mm
= case slurpProcesses mm of
Left err
-> Left (ErrorSlurpError err)
Right procs
-> do
let procname (Left p) = [processName p]
procname (Right _) = []
procnames = concatMap procname procs
lets <- mapM (lowerEither config procnames) procs
let mm_lowered = mm
{ moduleBody = annotate ()
$ XLet (LRec lets) xUnit }
let mm_clean = cleanModule mm_lowered
return mm_clean
lowerEither :: Config -> [Name] -> (Either Process (Bind Name, Exp () Name)) -> Either Error (BindF, ExpF)
lowerEither config _ (Left process)
= lowerProcess config process
lowerEither _config _procnames (Right (b,xx))
= let xx' = deannotate (const Nothing)
$ transformSimpleUpX' replaceRunProc
$ annotate () xx
in return (b, xx')
where
replaceRunProc (XVar (UPrim (NameOpSeries OpSeriesRunProcess) _))
= Just
$ XVar
$ UPrim (NameOpSeries OpSeriesRunProcessUnit)
(typeOpSeries OpSeriesRunProcessUnit)
replaceRunProc (XType t)
= Just
$ XType (replaceProcTy t)
replaceRunProc (XLet (LLet bind x) e)
= Just
$ XLet (LLet (replaceProcTyB bind) x) e
replaceRunProc (XLet (LRec bxs) e)
| (bs,xs) <- unzip bxs
, bs' <- map replaceProcTyB bs
= Just
$ XLet (LRec (zip bs' xs)) e
replaceRunProc _
= Nothing
replaceProcTyB (BName n t) = BName n $ replaceProcTy t
replaceProcTyB (BAnon t) = BAnon $ replaceProcTy t
replaceProcTyB (BNone t) = BNone $ replaceProcTy t
replaceProcTy tt
= case tt of
TVar{} -> tt
TCon{} -> tt
TForall bind tt' -> TForall bind (replaceProcTy tt')
TApp l r
| Just (NameTyConFlow TyConFlowProcess, [_,_]) <- takePrimTyConApps tt
-> tUnit
| otherwise
-> TApp (replaceProcTy l) (replaceProcTy r)
TSum ts
-> TSum ts
lowerProcess :: Config -> Process -> Either Error (BindF, ExpF)
lowerProcess config process
| MethodScalar <- configMethod config
= do
proc <- scheduleScalar process
let (bProc, xProc) = extractProcedure proc
return (bProc, xProc)
| MethodVector lifting <- configMethod config
, [nRN] <- [ nRN | (flag, BName nRN tRN) <- processParamFlags process
, not flag
, isRateNatType tRN ]
, tK <- processLoopRate process
= do let c = liftingFactor lifting
let xRN = XVar (UName nRN)
let tProc = processProcType process
let _tLoopRate = processLoopRate process
procVec <- scheduleKernel lifting process
let (_, xProcVec) = extractProcedure procVec
let bxsDownSeries
= [ ( bS
, ( BName (NameVarMod n "down")
(tSeries tProc (tDown c tK) tE)
, xDown c tProc tK tE (XVar (UIx 0)) xS))
| (flag, bS@(BName n tS)) <- processParamFlags process
, not flag
, let Just tE = elemTypeOfSeriesType tS
, let Just uS = takeSubstBoundOfBind bS
, let xS = XVar uS
, isSeriesType tS ]
let getDownValArg b
| Just (b', _) <- lookup b bxsDownSeries
= liftM XVar $ takeSubstBoundOfBind b'
| otherwise
= liftM XVar $ takeSubstBoundOfBind b
let Just xsVecValArgs
= sequence
$ map getDownValArg
$ map snd
$ filter (not.fst)
$ processParamFlags process
let bRateDown
= BAnon (tRateNat (tDown c tK))
let xProcVec'
= XLam bRateDown
$ xLets [LLet b x | (_, (b, x)) <- bxsDownSeries]
$ xApps xProcVec
$ [XType tProc, XType tK] ++ xsVecValArgs
procTail <- scheduleScalar process
let (bProcTail, xProcTail) = extractProcedure procTail
let bxsTailSeries
= [ ( bS, ( BName (NameVarMod n "tail") (tSeries tProc (tTail c tK) tE)
, xTail c tProc tK tE (XVar (UIx 0)) xS))
| (flag, bS@(BName n tS)) <- processParamFlags process
, not flag
, let Just tE = elemTypeOfSeriesType tS
, let Just uS = takeSubstBoundOfBind bS
, let xS = XVar uS
, isSeriesType tS ]
let bxsTailVector
= [ ( bV, ( BName (NameVarMod n "tail") (tVector tE)
, xTailVector c tK tE (XVar (UIx 0)) xV))
| (flag, bV@(BName n tV)) <- processParamFlags process
, not flag
, let Just tE = elemTypeOfVectorType tV
, let Just uV = takeSubstBoundOfBind bV
, let xV = XVar uV
, isVectorType tV ]
let getTailValArg b
| Just (b', _) <- lookup b bxsTailSeries
= liftM XVar $ takeSubstBoundOfBind b'
| Just (b', _) <- lookup b bxsTailVector
= liftM XVar $ takeSubstBoundOfBind b'
| otherwise
= liftM XVar $ takeSubstBoundOfBind b
let Just xsTailValArgs
= sequence
$ map getTailValArg (map snd $ filter (not.fst) $ procedureParamFlags procTail)
let bRateTail
= BAnon (tRateNat (tTail c tK))
let xProcTail'
= XLam bRateTail
$ xLets [LLet b x | (_, (b, x)) <- bxsTailSeries]
$ xLets [LLet b x | (_, (b, x)) <- bxsTailVector]
$ xApps xProcTail
$ [XType tProc, XType (tTail c tK)] ++ xsTailValArgs
let xProc
= makeXLamFlags (processParamFlags process)
xBody
xBody
= XLet (LLet (BNone tUnit)
(xSplit c tK xRN xProcVec' xProcTail'))
xUnit
let bProc
= BName (processName process)
(typeOfBind bProcTail)
return (bProc, xProc)
| MethodKernel lifting <- configMethod config
= do
proc <- scheduleKernel lifting process
let (bProc, xProc) = extractProcedure proc
return (bProc, xProc)
| otherwise
= error $ "ddc-core-flow.lowerProcess: invalid lowering method"
cleanModule :: ModuleF -> ModuleF
cleanModule mm
= let
clean
= C.Trans (C.Namify (C.makeNamifier freshT)
(C.makeNamifier freshX))
M.<> C.Trans C.Forward
M.<> C.beta
M.<> C.Trans (C.Snip (Snip.configZero { Snip.configPreserveLambdas = True }))
M.<> C.Trans C.Flatten
mm_cleaned
= C.result $ S.evalState
(C.applySimplifier profile Env.empty Env.empty
(C.Fix 4 clean) mm)
0
in mm_cleaned