module DDC.Build.Pipeline.Core
( PipeCore (..)
, pipeCore
, pipeCores
, PipeTetra (..)
, pipeTetra
, PipeLite (..)
, pipeLite
, PipeFlow (..)
, pipeFlow)
where
import DDC.Build.Pipeline.Error
import DDC.Build.Pipeline.Sink
import DDC.Build.Pipeline.Salt
import DDC.Build.Language
import DDC.Core.Simplifier
import DDC.Base.Pretty
import DDC.Data.Canned
import DDC.Llvm.Pretty ()
import qualified DDC.Core.Flow as Flow
import qualified DDC.Core.Flow.Profile as Flow
import qualified DDC.Core.Flow.Transform.Slurp as Flow
import qualified DDC.Core.Flow.Transform.Melt as Flow
import qualified DDC.Core.Flow.Transform.Wind as Flow
import qualified DDC.Core.Flow.Transform.Rates.SeriesOfVector as Flow
import qualified DDC.Core.Tetra as Tetra
import qualified DDC.Core.Tetra.Transform.Boxing as Tetra
import qualified DDC.Core.Lite as Lite
import qualified DDC.Core.Salt.Platform as Salt
import qualified DDC.Core.Salt.Runtime as Salt
import qualified DDC.Core.Salt as Salt
import qualified DDC.Core.Transform.Reannotate as C
import qualified DDC.Core.Transform.Deannotate as C
import qualified DDC.Core.Transform.Namify as C
import qualified DDC.Core.Transform.Forward as Forward
import qualified DDC.Core.Transform.Snip as Snip
import qualified DDC.Core.Transform.Flatten as Flatten
import qualified DDC.Core.Transform.Eta as Eta
import qualified DDC.Core.Simplifier as C
import qualified DDC.Core.Fragment as C
import qualified DDC.Core.Check as C
import qualified DDC.Core.Pretty as C
import qualified DDC.Core.Module as C
import qualified DDC.Core.Exp as C
import qualified DDC.Type.Env as Env
import qualified Control.Monad.State.Strict as S
import Control.Monad
import Control.DeepSeq
data PipeCore a n where
PipeCoreId
:: ![PipeCore a n]
-> PipeCore a n
PipeCoreOutput
:: !(C.PrettyMode (C.Module a n))
-> !Sink
-> PipeCore a n
PipeCoreCheck
:: (Pretty a, Pretty (err (C.AnTEC a n)))
=> !(Fragment n err)
-> !(C.Mode n)
-> !Sink
-> ![PipeCore (C.AnTEC a n) n]
-> PipeCore a n
PipeCoreReCheck
:: (NFData a, Show a, Pretty a, Pretty (err (C.AnTEC a n)))
=> !(Fragment n err)
-> !(C.Mode n)
-> ![PipeCore (C.AnTEC a n) n]
-> PipeCore (C.AnTEC a n') n
PipeCoreReannotate
:: (NFData b, Show b)
=> (a -> b)
-> ![PipeCore b n]
-> PipeCore a n
PipeCoreSimplify
:: !(Fragment n err)
-> !s
-> !(Simplifier s a n)
-> ![PipeCore () n]
-> PipeCore a n
PipeCoreAsTetra
:: ![PipeTetra (C.AnTEC a Tetra.Name)]
-> PipeCore (C.AnTEC a Tetra.Name) Tetra.Name
PipeCoreAsLite
:: ![PipeLite]
-> PipeCore (C.AnTEC () Lite.Name) Lite.Name
PipeCoreAsFlow
:: Pretty a
=> ![PipeFlow a]
-> PipeCore a Flow.Name
PipeCoreAsSalt
:: Pretty a
=> ![PipeSalt a]
-> PipeCore a Salt.Name
PipeCoreHacks
:: (NFData a, Show b, NFData b)
=> Canned (C.Module a n -> IO (C.Module b n))
-> ![PipeCore b n]
-> PipeCore a n
pipeCore
:: (NFData a, Show a, NFData n, Eq n, Ord n, Show n, Pretty n)
=> C.Module a n
-> PipeCore a n
-> IO [Error]
pipeCore !mm !pp
= case pp of
PipeCoreId !pipes
->
pipeCores mm pipes
PipeCoreOutput !mode !sink
->
pipeSink (renderIndent $ pprModePrec mode 0 mm) sink
PipeCoreCheck !fragment !mode !sinkTrace !pipes
->
let profile = fragmentProfile fragment
goCheck mm1
= case C.checkModule (C.configOfProfile profile) mm1 mode of
(Left err, C.CheckTrace doc)
-> do pipeSink (renderIndent doc) sinkTrace
return [ErrorLint err]
(Right mm2, C.CheckTrace doc)
-> do pipeSink (renderIndent doc) sinkTrace
goComplies mm2
goComplies mm1
= case C.complies profile mm1 of
Just err -> return [ErrorLint err]
Nothing -> goFragment mm1
goFragment mm1
= case fragmentCheckModule fragment mm1 of
Just err -> return [ErrorLint err]
Nothing -> pipeCores mm1 pipes
in goCheck mm
PipeCoreReCheck !fragment !mode !pipes
->
pipeCore (C.reannotate C.annotTail mm)
$ PipeCoreCheck fragment mode SinkDiscard pipes
PipeCoreReannotate f !pipes
->
let mm' = (C.reannotate f mm)
in pipeCores mm' pipes
PipeCoreSimplify !fragment !nameZero !simpl !pipes
->
let profile = fragmentProfile fragment
primKindEnv = C.profilePrimKinds profile
primTypeEnv = C.profilePrimTypes profile
!mm' = (result . flip S.evalState nameZero
$ applySimplifier profile primKindEnv primTypeEnv simpl mm)
!mm2 = C.reannotate (const ()) mm'
in mm2 `deepseq` pipeCores mm2 pipes
PipeCoreAsTetra !pipes
->
liftM concat $ mapM (pipeTetra mm) pipes
PipeCoreAsLite !pipes
->
liftM concat $ mapM (pipeLite mm) pipes
PipeCoreAsFlow !pipes
->
liftM concat $ mapM (pipeFlow mm) pipes
PipeCoreAsSalt !pipes
->
liftM concat $ mapM (pipeSalt mm) pipes
PipeCoreHacks !(Canned f) !pipes
->
do mm' <- f mm
pipeCores mm' pipes
pipeCores :: (NFData a, Show a, NFData n, Eq n, Ord n, Show n, Pretty n)
=> C.Module a n -> [PipeCore a n] -> IO [Error]
pipeCores !mm !pipes
= go [] pipes
where go !errs []
= return errs
go !errs (pipe : rest)
= do !err <- pipeCore mm pipe
go (errs ++ err) rest
data PipeTetra a where
PipeTetraOutput
:: !Sink
-> PipeTetra a
PipeTetraBoxing
:: (NFData a, Show a)
=> ![PipeCore a Tetra.Name]
-> PipeTetra a
PipeTetraToSalt
:: (NFData a, Show a)
=> !Salt.Platform
-> !Salt.Config
-> ![PipeCore a Salt.Name]
-> PipeTetra (C.AnTEC a Tetra.Name)
pipeTetra
:: C.Module a Tetra.Name
-> PipeTetra a
-> IO [Error]
pipeTetra !mm !pp
= case pp of
PipeTetraOutput !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeTetraBoxing !pipes
->
pipeCores (Tetra.boxingModule mm) pipes
PipeTetraToSalt !platform !runConfig !pipes
->
case Tetra.saltOfTetraModule platform runConfig
(C.profilePrimDataDefs Tetra.profile)
(C.profilePrimKinds Tetra.profile)
(C.profilePrimTypes Tetra.profile)
mm
of Left err -> return [ErrorTetraConvert err]
Right mm' -> pipeCores mm' pipes
data PipeLite
= PipeLiteOutput !Sink
| PipeLiteToSalt !Salt.Platform
!Salt.Config
![PipeCore () Salt.Name]
pipeLite :: C.Module (C.AnTEC () Lite.Name) Lite.Name
-> PipeLite
-> IO [Error]
pipeLite !mm !pp
= case pp of
PipeLiteOutput !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeLiteToSalt !platform !runConfig !pipes
->
case Lite.saltOfLiteModule platform runConfig
(C.profilePrimDataDefs Lite.profile)
(C.profilePrimKinds Lite.profile)
(C.profilePrimTypes Lite.profile)
mm
of Left err -> return [ErrorLiteConvert err]
Right mm' -> pipeCores mm' pipes
data PipeFlow a where
PipeFlowOutput
:: Sink
-> PipeFlow a
PipeFlowHacks
:: (NFData a, Show b, NFData b)
=> Canned (C.Module a Flow.Name -> IO (C.Module b Flow.Name))
-> ![PipeFlow b]
-> PipeFlow a
PipeFlowPrep
:: [PipeCore () Flow.Name]
-> PipeFlow ()
PipeFlowRate
:: [PipeCore () Flow.Name]
-> PipeFlow ()
PipeFlowLower
:: Flow.Config
-> [PipeCore () Flow.Name]
-> PipeFlow (C.AnTEC () Flow.Name)
PipeFlowMelt
:: [PipeCore () Flow.Name]
-> PipeFlow (C.AnTEC () Flow.Name)
PipeFlowWind
:: [PipeCore () Flow.Name]
-> PipeFlow (C.AnTEC () Flow.Name)
pipeFlow :: C.Module a Flow.Name
-> PipeFlow a
-> IO [Error]
pipeFlow !mm !pp
= case pp of
PipeFlowOutput !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeFlowHacks !(Canned f) !pipes
->
do mm' <- f mm
pipeFlows mm' pipes
PipeFlowPrep !pipes
->
let
mm_eta = C.result $ Eta.etaModule Flow.profile
(Eta.configZero { Eta.configExpand = True})
mm
mm_snip = Flatten.flatten
$ Snip.snip
(Snip.configZero { Snip.configSnipLetBody = True })
mm_eta
namifierT = C.makeNamifier Flow.freshT Env.empty
namifierX = C.makeNamifier Flow.freshX Env.empty
mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0
isFloatable lts
= case lts of
C.LLet (C.BName _ _) x
| Flow.isSeriesOperator (C.deannotate (const Nothing) x)
-> Forward.FloatDeny
_ -> Forward.FloatForce
mm_float = C.result $ Forward.forwardModule Flow.profile
(Forward.Config isFloatable False)
mm_namified
in pipeCores mm_float pipes
PipeFlowRate !pipes
->
let
mm_eta = C.result $ Eta.etaModule Flow.profile
(Eta.configZero { Eta.configExpand = True})
mm
mm_snip = Flatten.flatten
$ Snip.snip
(Snip.configZero { Snip.configSnipLetBody = True })
mm_eta
namifierT = C.makeNamifier Flow.freshT Env.empty
namifierX = C.makeNamifier Flow.freshX Env.empty
mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0
isFloatable lts
= case lts of
C.LLet (C.BName _ _) x
| Flow.isVectorOperator (C.deannotate (const Nothing) x)
-> Forward.FloatDeny
_ -> Forward.FloatForce
mm_float = C.result $ Forward.forwardModule Flow.profile
(Forward.Config isFloatable False)
mm_namified
goRate
= case C.checkModule (C.configOfProfile Flow.profile) mm_float C.Recon of
(Left err, _)
-> return [ErrorCoreTransform err]
(Right mm', _)
-> let mm_stripped = C.reannotate (const ()) mm'
mm_flow = fst $ Flow.seriesOfVectorModule mm_stripped
in case C.checkModule (C.configOfProfile Flow.profile) mm_flow C.Recon of
(Left err, _ct)
-> return [ErrorCoreTransform err]
(Right mm_flow', _ct)
-> let mm_reannot' = C.reannotate (const ()) mm_flow'
in pipeCores mm_reannot' pipes
in goRate
PipeFlowLower !config !pipes
->
let mm_stripped = C.reannotate (const ()) mm
in case Flow.lowerModule config mm_stripped of
Right mm' -> pipeCores mm' pipes
Left err -> return [ErrorCoreTransform err]
PipeFlowMelt !pipes
->
let mm_stripped = C.reannotate (const ()) mm
(mm_melted, _info) = Flow.meltModule mm_stripped
in pipeCores mm_melted pipes
PipeFlowWind !pipes
->
let mm_stripped = C.reannotate (const ()) mm
mm_wound = Flow.windModule mm_stripped
in pipeCores mm_wound pipes
pipeFlows :: (NFData a, Show a)
=> C.Module a Flow.Name -> [PipeFlow a] -> IO [Error]
pipeFlows !mm !pipes
= go [] pipes
where go !errs []
= return errs
go !errs (pipe : rest)
= do !err <- pipeFlow mm pipe
go (errs ++ err) rest