module DDC.Build.Pipeline.Core
( PipeCore (..)
, pipeCore
, pipeCores
, PipeTetra (..)
, pipeTetra
, 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.Base.Name
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.Forward 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.Flow.Convert as Flow
import qualified DDC.Core.Tetra.Transform.Curry as Tetra
import qualified DDC.Core.Tetra.Transform.Boxing as Tetra
import qualified DDC.Core.Tetra as Tetra
import qualified DDC.Core.Babel.PHP as PHP
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.Unshare as C
import qualified DDC.Core.Transform.Reannotate as C
import qualified DDC.Core.Transform.Namify as C
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.Transform.Beta as Beta
import qualified DDC.Core.Transform.Lambdas as Lambdas
import qualified DDC.Core.Transform.Forward as Forward
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.Annot 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
:: (Pretty a, CompoundName n)
=> !(Fragment n err)
-> !s
-> !(Simplifier s a n)
-> ![PipeCore () n]
-> PipeCore a n
PipeCoreAsTetra
:: ![PipeTetra a]
-> PipeCore a Tetra.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
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
PipeTetraCurry
:: (NFData a, Show a)
=> ![PipeCore () Tetra.Name]
-> PipeTetra (C.AnTEC a Tetra.Name)
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)
PipeTetraToPHP
:: (NFData a, Show a)
=> !Sink
-> PipeTetra a
pipeTetra
:: C.Module a Tetra.Name
-> PipeTetra a
-> IO [Error]
pipeTetra !mm !pp
= case pp of
PipeTetraOutput !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeTetraCurry !pipes
->
case Tetra.curryModule (C.unshareModule mm) of
Left err -> return [ErrorTetraConvert err]
Right mm' -> pipeCores mm' pipes
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
PipeTetraToPHP !sink
->
let
mm_snip = Flatten.flatten
$ Snip.snip (Snip.configZero) mm
namifierT = C.makeNamifier Tetra.freshT Env.empty
namifierX = C.makeNamifier Tetra.freshX Env.empty
mm_namified = S.evalState (C.namify namifierT namifierX mm_snip) 0
doc = PHP.phpOfModule mm_namified
in pipeSink (renderIndent doc) sink
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)
PipeFlowToTetra
:: [PipeCore () Salt.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
mm_float = Flow.forwardProcesses 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
floatControl l
= case l of
C.LLet _ x
| Just _ <- C.takeXLamFlags x
-> Forward.FloatForceUsedOnce
_ -> Forward.FloatDeny
mm_float = C.result
$ Forward.forwardModule Flow.profile
(Forward.Config floatControl False)
$ C.reannotate (const ()) 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.Synth 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
PipeFlowToTetra !pipes
->
let
mm_beta = C.result $ Beta.betaReduce Flow.profile
(Beta.configZero { Beta.configBindRedexes = True})
mm
mm_eta = C.result $ Eta.etaModule Flow.profile
(Eta.configZero { Eta.configExpand = True})
mm_beta
mm_lift = Lambdas.lambdasModule Flow.profile mm_eta
mm_snip = Flatten.flatten
$ Snip.snip
Snip.configZero
mm_lift
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
in case Flow.tetraOfFlowModule mm_namified of
Left err -> return [ErrorFlowConvert err]
Right mm' ->
case C.checkModule (C.configOfProfile Salt.profile) mm' C.Recon of
(Left err, _ct)
-> return [ErrorCoreTransform err]
(Right mm_check', _ct)
-> let mm_reannot' = C.reannotate (const ()) mm_check'
floatControl l
= case l of
C.LLet b _
| Just _ <- C.takeTFun $ C.typeOfBind b
-> Forward.FloatForce
_ -> Forward.FloatAllow
mm_float = C.result
$ Forward.forwardModule Salt.profile
(Forward.Config floatControl True)
$ C.reannotate (const ()) mm_reannot'
in pipeCores mm_float 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