module DDC.Driver.Stage
( Config (..)
, ViaBackend (..)
, stageFlowLoad
, stageFlowPrep
, stageFlowLower
, stageFlowWind
, stageLiteLoad
, stageLiteOpt
, stageLiteToSalt
, stageSaltOpt
, stageSaltToC
, stageSaltToLLVM
, stageCompileSalt
, stageCompileLLVM)
where
import DDC.Interface.Source
import DDC.Build.Builder
import DDC.Build.Pipeline
import DDC.Core.Transform.Namify
import DDC.Core.Simplifier (Simplifier)
import System.FilePath
import Data.Monoid
import Data.Maybe
import qualified DDC.Core.Flow as Flow
import qualified DDC.Core.Flow.Profile as Flow
import qualified DDC.Build.Language.Flow as Flow
import qualified DDC.Build.Language.Salt as Salt
import qualified DDC.Core.Salt.Runtime as Salt
import qualified DDC.Core.Salt.Name as Salt
import qualified DDC.Build.Language.Lite as Lite
import qualified DDC.Core.Lite as Lite
import qualified DDC.Core.Check as C
import qualified DDC.Core.Simplifier as S
import qualified DDC.Core.Simplifier.Recipe as S
import qualified DDC.Core.Transform.Namify as S
import qualified DDC.Core.Transform.Snip as Snip
data Config
= Config
{
configDump :: Bool
, configSimplLite :: Simplifier Int () Lite.Name
, configSimplSalt :: Simplifier Int () Salt.Name
, configViaBackend :: ViaBackend
, configRuntime :: Salt.Config
, configBuilder :: Builder
, configSuppressCoreImports :: Bool
, configSuppressHashImports :: Bool
, configOutputFile :: Maybe FilePath
, configOutputDir :: Maybe FilePath
, configKeepLlvmFiles :: Bool
, configKeepSeaFiles :: Bool
, configKeepAsmFiles :: Bool
, configTaintAvoidTypeChecks :: Bool
}
data ViaBackend
= ViaC
| ViaLLVM
deriving Show
stageFlowLoad
:: Config -> Source
-> [PipeCore () Flow.Name]
-> PipeText Flow.Name Flow.Error
stageFlowLoad config source pipesFlow
= PipeTextLoadCore Flow.fragment
[ PipeCoreReannotate (const ())
( PipeCoreOutput (dump config source "dump.flow-load.dcf")
: pipesFlow ) ]
stageFlowPrep
:: Config -> Source
-> [PipeCore () Flow.Name]
-> PipeCore () Flow.Name
stageFlowPrep config source pipesFlow
= PipeCoreReannotate (const ())
[ PipeCoreSimplify Flow.fragment (0 :: Int) simplNorm
[ PipeCoreOutput (dump config source "dump.flow-prep-norm.dcf")
, PipeCoreAsFlow
[ PipeFlowPrep
( PipeCoreOutput (dump config source "dump.flow-prep-done.dcf")
: pipesFlow)]]]
where simplNamify
= S.Trans (S.Namify namifierT namifierX)
simplNorm
= S.Trans (S.Snip $ Snip.configZero { Snip.configSnipLetBody = True })
<> S.flatten
<> simplNamify
namifierT = S.makeNamifier Flow.freshT
namifierX = S.makeNamifier Flow.freshX
stageFlowLower
:: Config -> Source
-> [PipeCore () Flow.Name]
-> PipeCore (C.AnTEC () Flow.Name) Flow.Name
stageFlowLower config source pipesFlow
= PipeCoreAsFlow
[ PipeFlowLower
( PipeCoreOutput (dump config source "dump.flow-lower.dcf")
: pipesFlow ) ]
stageFlowWind
:: Config -> Source
-> [PipeCore () Flow.Name]
-> PipeCore (C.AnTEC () Flow.Name) Flow.Name
stageFlowWind config source pipesFlow
= PipeCoreAsFlow
[ PipeFlowWind
( PipeCoreOutput (dump config source "dump.flow-wind.dcf")
: pipesFlow ) ]
stageLiteLoad
:: Config -> Source
-> [PipeCore () Lite.Name]
-> PipeText Lite.Name Lite.Error
stageLiteLoad config source pipesLite
= PipeTextLoadCore Lite.fragment
[ PipeCoreReannotate (const ())
( PipeCoreOutput (dump config source "dump.lite.dcl")
: pipesLite ) ]
stageLiteOpt
:: Config -> Source
-> [PipeCore () Lite.Name]
-> PipeCore () Lite.Name
stageLiteOpt config source pipes
= PipeCoreSimplify
Lite.fragment
(0 :: Int)
(configSimplLite config)
( PipeCoreOutput (dump config source "dump.lite-opt.dcl")
: pipes)
stageSaltOpt
:: Config -> Source
-> [PipeCore () Salt.Name]
-> PipeCore () Salt.Name
stageSaltOpt config source pipes
= PipeCoreSimplify
Salt.fragment
(0 :: Int)
(configSimplSalt config)
( PipeCoreOutput (dump config source "dump.salt-opt.dcl")
: pipes )
stageLiteToSalt
:: Config -> Source
-> [PipeCore () Salt.Name]
-> PipeCore () Lite.Name
stageLiteToSalt config source pipesSalt
= PipeCoreSimplify Lite.fragment 0 normalizeLite
[ PipeCoreCheck Lite.fragment
[ PipeCoreOutput (dump config source "dump.lite-normalized.dcl")
, PipeCoreAsLite
[ PipeLiteToSalt (buildSpec $ configBuilder config)
(configRuntime config)
( PipeCoreOutput (dump config source "dump.salt.dcs")
: pipesSalt)]]]
where normalizeLite
= S.anormalize
(makeNamifier Lite.freshT)
(makeNamifier Lite.freshX)
stageSaltToC
:: Config -> Source
-> Sink
-> PipeCore () Salt.Name
stageSaltToC config source sink
= PipeCoreSimplify Salt.fragment 0 normalizeSalt
[ PipeCoreCheck Salt.fragment
[ PipeCoreOutput (dump config source "dump.salt-normalized.dcs")
, PipeCoreAsSalt
[ PipeSaltTransfer
[ PipeSaltOutput (dump config source "dump.salt-transfer.dcs")
, PipeSaltPrint
(not $ configSuppressHashImports config)
(buildSpec $ configBuilder config)
sink ]]]]
where normalizeSalt
= S.anormalize (makeNamifier Salt.freshT)
(makeNamifier Salt.freshX)
stageCompileSalt
:: Config -> Source
-> FilePath
-> Bool
-> PipeCore () Salt.Name
stageCompileSalt config source filePath shouldLinkExe
= let
outputDir = fromMaybe (takeDirectory filePath) (configOutputDir config)
outputDirBase = dropExtension (replaceDirectory filePath outputDir)
cPath = outputDirBase ++ ".ddc.c"
oPath = outputDirBase ++ ".o"
exePathDefault = outputDirBase
exePath = fromMaybe exePathDefault (configOutputFile config)
in
PipeCoreSimplify Salt.fragment 0 normalizeSalt
[ PipeCoreCheck Salt.fragment
[ PipeCoreOutput (dump config source "dump.salt-normalized.dcs")
, PipeCoreAsSalt
[ PipeSaltTransfer
[ PipeSaltOutput (dump config source "dump.salt-transfer.dcs")
, PipeSaltCompile
(buildSpec $ configBuilder config)
(configBuilder config)
cPath
oPath
(if shouldLinkExe
then Just exePath
else Nothing)
(configKeepSeaFiles config)
]]]]
where normalizeSalt
= S.anormalize (makeNamifier Salt.freshT)
(makeNamifier Salt.freshX)
stageSaltToLLVM
:: Config -> Source
-> [PipeLlvm]
-> PipeCore () Salt.Name
stageSaltToLLVM config source pipesLLVM
= PipeCoreSimplify Salt.fragment 0 normalizeSalt
[ PipeCoreCheck Salt.fragment
[ PipeCoreOutput (dump config source "dump.salt-normalized.dcs")
, PipeCoreAsSalt
[ PipeSaltTransfer
[ PipeSaltOutput (dump config source "dump.salt-transfer.dcs")
, PipeSaltToLlvm (buildSpec $ configBuilder config)
pipesLLVM ]]]]
where normalizeSalt
= S.anormalize (makeNamifier Salt.freshT)
(makeNamifier Salt.freshX)
stageCompileLLVM
:: Config -> Source
-> FilePath
-> Bool
-> PipeLlvm
stageCompileLLVM config _source filePath shouldLinkExe
= let
outputDir = fromMaybe (takeDirectory filePath) (configOutputDir config)
outputDirBase = dropExtension (replaceDirectory filePath outputDir)
llPath = outputDirBase ++ ".ddc.ll"
sPath = outputDirBase ++ ".ddc.s"
oPath = outputDirBase ++ ".o"
exePathDefault = outputDirBase
exePath = fromMaybe exePathDefault (configOutputFile config)
in
PipeLlvmCompile
{ pipeBuilder = configBuilder config
, pipeFileLlvm = llPath
, pipeFileAsm = sPath
, pipeFileObject = oPath
, pipeFileExe = if shouldLinkExe
then Just exePath
else Nothing
, pipeKeepLlvmFiles = configKeepLlvmFiles config
, pipeKeepAsmFiles = configKeepAsmFiles config }
dump :: Config -> Source -> String -> Sink
dump config source dumpFile
| configDump config
= let outputDir
| SourceFile filePath <- source
= fromMaybe (takeDirectory filePath)
(configOutputDir config)
| otherwise
= fromMaybe "."
(configOutputDir config)
in SinkFile $ outputDir </> dumpFile
| otherwise
= SinkDiscard