module DDC.Build.Pipeline.Core
( PipeCore (..)
, pipeCore
, pipeCores
, 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.Prep as Flow
import qualified DDC.Core.Flow.Transform.Slurp as Flow
import qualified DDC.Core.Flow.Transform.Schedule as Flow
import qualified DDC.Core.Flow.Transform.Extract as Flow
import qualified DDC.Core.Flow.Transform.Wind as Flow
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.Forward as Forward
import qualified DDC.Core.Transform.Namify as C
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.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 qualified Data.Map as Map
import Control.Monad
import Control.DeepSeq
data PipeCore a n where
PipeCoreId
:: ![PipeCore a n]
-> PipeCore a n
PipeCoreOutput
:: !Sink
-> PipeCore a n
PipeCoreCheck
:: !(Fragment n err)
-> ![PipeCore (C.AnTEC a n) n]
-> PipeCore a n
PipeCoreReCheck
:: (Show a, NFData a)
=> !(Fragment n err)
-> ![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
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 !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeCoreCheck !fragment !pipes
->
let profile = fragmentProfile fragment
goCheck mm1
= case C.checkModule (C.configOfProfile profile) mm1 of
Left err -> return [ErrorLint err]
Right mm2 -> goComplies mm2
goComplies mm1
= case C.complies profile mm1 of
Just err -> return [ErrorLint err]
Nothing -> pipeCores mm1 pipes
in goCheck mm
PipeCoreReCheck !fragment !pipes
->
pipeCore (C.reannotate C.annotTail mm)
$ PipeCoreCheck fragment 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' = (flip S.evalState nameZero
$ applySimplifier profile primKindEnv primTypeEnv simpl mm)
!mm2 = C.reannotate (const ()) mm'
in mm2 `deepseq` pipeCores mm2 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 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
PipeFlowPrep
:: (NFData a, Show a)
=> [PipeCore a Flow.Name]
-> PipeFlow a
PipeFlowLower
:: [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
PipeFlowPrep !pipes
->
let
(mm_prep, nsWorker)
= Flow.prepModule mm
isFloatable lts
= case lts of
C.LLet (C.BName n _) _
| Just{} <- Map.lookup n nsWorker
-> Forward.FloatForce
_ -> Forward.FloatAllow
config = Forward.Config isFloatable False
mm_float
= C.result $ Forward.forwardModule Flow.profile
config mm_prep
namifierT = C.makeNamifier Flow.freshT Env.empty
namifierX = C.makeNamifier Flow.freshX Env.empty
mm_namified
= S.evalState (C.namify namifierT namifierX mm_float) 0
in pipeCores mm_namified pipes
PipeFlowLower !pipes
->
let mm_stripped = C.reannotate (const ()) mm
processes = Flow.slurpProcesses mm_stripped
procedures = map Flow.scheduleProcess processes
mm_lowered = Flow.extractModule mm_stripped procedures
in pipeCores mm_lowered pipes
PipeFlowWind !pipes
->
let mm_stripped = C.reannotate (const ()) mm
mm_wound = Flow.windModule mm_stripped
in pipeCores mm_wound pipes