module DDC.Build.Pipeline
(
Error(..)
, PipeText (..)
, pipeText
, PipeCore (..)
, pipeCore
, PipeLite (..)
, pipeLite
, PipeSalt (..)
, pipeSalt
, PipeLlvm (..)
, pipeLlvm
, Sink (..)
, pipeSink)
where
import DDC.Build.Language
import DDC.Build.Builder
import DDC.Core.Simplifier
import DDC.Base.Pretty
import DDC.Data.Canned
import DDC.Llvm.Pretty ()
import DDC.Core.Check (AnTEC)
import qualified DDC.Core.Transform.Reannotate 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.Load as CL
import qualified DDC.Core.Llvm.Convert as Llvm
import qualified DDC.Core.Salt.Transfer as Salt
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.Lite as Lite
import qualified DDC.Llvm.Syntax as Llvm
import qualified Control.Monad.State.Strict as S
import Control.Monad
import Control.DeepSeq
import System.Directory
data Error
= ErrorSaltLoad (CL.Error Salt.Name)
| forall err. Pretty err => ErrorSaltConvert !err
| forall err. Pretty err => ErrorLiteConvert !err
| forall err. Pretty err => ErrorLoad !err
| forall err. Pretty err => ErrorLint !err
instance Pretty Error where
ppr err
= case err of
ErrorSaltLoad err'
-> vcat [ text "Type error when loading Salt module."
, indent 2 (ppr err') ]
ErrorSaltConvert err'
-> vcat [ text "Fragment violation when converting Salt module to C code."
, indent 2 (ppr err') ]
ErrorLiteConvert err'
-> vcat [ text "Fragment violation when converting Lite module to Salt module."
, indent 2 (ppr err') ]
ErrorLoad err'
-> vcat [ text "Error loading module"
, indent 2 (ppr err') ]
ErrorLint err'
-> vcat [ text "Error in transformed module."
, indent 2 (ppr err') ]
instance NFData Error
data PipeText n (err :: * -> *) where
PipeTextOutput
:: !Sink
-> PipeText n err
PipeTextLoadCore
:: (Ord n, Show n, Pretty n)
=> !(Fragment n err)
-> ![PipeCore (C.AnTEC () n) n]
-> PipeText n err
pipeText
:: NFData n
=> String
-> Int
-> String
-> PipeText n err
-> IO [Error]
pipeText !srcName !srcLine !str !pp
= case pp of
PipeTextOutput !sink
->
pipeSink str sink
PipeTextLoadCore !frag !pipes
->
let toks = fragmentLexModule frag srcName srcLine str
in case CL.loadModuleFromTokens (fragmentProfile frag) srcName toks of
Left err -> return $ [ErrorLoad err]
Right mm -> pipeCores mm pipes
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
PipeCoreStrip
:: ![PipeCore () 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
PipeCoreAsSalt
:: Pretty a
=> ![PipeSalt a]
-> PipeCore a Salt.Name
PipeCoreHacks
:: Canned (C.Module a n -> IO (C.Module a n))
-> ![PipeCore a 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
PipeCoreStrip !pipes
->
let mm' = (C.reannotate (const ()) 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
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 PipeSalt a where
PipeSaltId
:: ![PipeSalt a]
-> PipeSalt a
PipeSaltOutput
:: !Sink
-> PipeSalt a
PipeSaltTransfer
:: ![PipeSalt (AnTEC a Salt.Name)]
-> PipeSalt (AnTEC a Salt.Name)
PipeSaltPrint
:: !Bool
-> !Salt.Platform
-> !Sink
-> PipeSalt a
PipeSaltToLlvm
:: !Salt.Platform
-> ![PipeLlvm]
-> PipeSalt a
PipeSaltCompile
:: !Salt.Platform
-> !Builder
-> !FilePath
-> !FilePath
-> !(Maybe FilePath)
-> !Bool
-> PipeSalt a
deriving instance Show a => Show (PipeSalt a)
pipeSalt :: (Show a, Pretty a, NFData a)
=> C.Module a Salt.Name
-> PipeSalt a
-> IO [Error]
pipeSalt !mm !pp
= case pp of
PipeSaltId !pipes
->
liftM concat $ mapM (pipeSalt mm) pipes
PipeSaltOutput !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeSaltTransfer !pipes
->
case Salt.transferModule mm of
Left err -> return [ErrorSaltConvert err]
Right mm' -> liftM concat $ mapM (pipeSalt mm') pipes
PipeSaltPrint !withPrelude !platform !sink
->
case Salt.seaOfSaltModule withPrelude platform mm of
Left err
-> return $ [ErrorSaltConvert err]
Right doc
-> pipeSink (renderIndent doc) sink
PipeSaltToLlvm !platform !more
->
do let !mm_cut = C.reannotate (const ()) mm
let !mm' = Llvm.convertModule platform mm_cut
results <- mapM (pipeLlvm mm') more
return $ concat results
PipeSaltCompile
!platform !builder !cPath !oPath !mExePath
!keepSeaFiles
->
case Salt.seaOfSaltModule True platform mm of
Left errs
-> error $ show errs
Right cDoc
-> do let cSrc = renderIndent cDoc
writeFile cPath cSrc
buildCC builder cPath oPath
(case mExePath of
Nothing -> return ()
Just exePath
-> do buildLdExe builder oPath exePath
return ())
when (not keepSeaFiles)
$ removeFile cPath
return []
data PipeLlvm
= PipeLlvmPrint Sink
| PipeLlvmCompile
{ pipeBuilder :: Builder
, pipeFileLlvm :: FilePath
, pipeFileAsm :: FilePath
, pipeFileObject :: FilePath
, pipeFileExe :: Maybe FilePath
, pipeKeepLlvmFiles :: Bool
, pipeKeepAsmFiles :: Bool }
deriving (Show)
pipeLlvm
:: Llvm.Module
-> PipeLlvm
-> IO [Error]
pipeLlvm !mm !pp
= case pp of
PipeLlvmPrint !sink
->
pipeSink (renderIndent $ ppr mm) sink
PipeLlvmCompile
!builder !llPath !sPath !oPath !mExePath
!keepLlvmFiles !keepAsmFiles
->
do
let llSrc = renderIndent $ ppr mm
writeFile llPath llSrc
buildLlc builder llPath sPath
buildAs builder sPath oPath
(case mExePath of
Nothing
-> return ()
Just exePath
-> do buildLdExe builder oPath exePath
return ())
when (not keepLlvmFiles)
$ removeFile llPath
when (not keepAsmFiles)
$ removeFile sPath
return []
data Sink
= SinkDiscard
| SinkStdout
| SinkFile FilePath
deriving (Show)
pipeSink :: String -> Sink -> IO [Error]
pipeSink !str !tg
= case tg of
SinkDiscard
-> do return []
SinkStdout
-> do putStrLn str
return []
SinkFile path
-> do writeFile path str
return []