diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -3,8 +3,8 @@ import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription import System.FilePath +import System.Process import System.Exit -import System.Cmd main = defaultMainWithHooks hooks @@ -33,5 +33,5 @@ -- Run the basebuild command, which builds the library. code <- system $ ddcExe ++ " -basebuild -O" case code of - ExitFailure _ -> error "Failed!" + ExitFailure _ -> error "ddc-tools.postHookInstall: Failed!" ExitSuccess -> return () diff --git a/ddc-tools.cabal b/ddc-tools.cabal --- a/ddc-tools.cabal +++ b/ddc-tools.cabal @@ -1,5 +1,5 @@ Name: ddc-tools -Version: 0.3.2.1 +Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -17,8 +17,8 @@ src/ddc-check Build-depends: - base == 4.6.*, - ddc-core == 0.3.2.* + base >= 4.6 && < 4.8, + ddc-core == 0.4.1.* Main-is: Main.hs @@ -34,26 +34,25 @@ src/ddc-main Build-depends: - base == 4.6.*, + base >= 4.6 && < 4.8, + process >= 1.1 && < 1.3, containers == 0.5.*, - process == 1.1.*, filepath == 1.3.*, haskeline == 0.7.*, - haskell-src-exts== 1.13.*, directory == 1.2.*, mtl == 2.1.*, transformers == 0.3.*, - ddc-base == 0.3.2.*, - ddc-core == 0.3.2.*, - ddc-core-eval == 0.3.2.*, - ddc-core-simpl == 0.3.2.*, - ddc-core-salt == 0.3.2.*, - ddc-core-llvm == 0.3.2.*, - ddc-core-tetra == 0.3.2.*, - ddc-code == 0.3.2.*, - ddc-build == 0.3.2.*, - ddc-driver == 0.3.2.*, - ddc-interface == 0.3.2.* + ddc-base == 0.4.1.*, + ddc-core == 0.4.1.*, + ddc-core-eval == 0.4.1.*, + ddc-core-simpl == 0.4.1.*, + ddc-core-salt == 0.4.1.*, + ddc-core-llvm == 0.4.1.*, + ddc-core-tetra == 0.4.1.*, + ddc-code == 0.4.1.*, + ddc-build == 0.4.1.*, + ddc-driver == 0.4.1.*, + ddc-interface == 0.4.1.* Main-is: Main.hs @@ -72,25 +71,25 @@ src/ddci-core Build-depends: - base == 4.6.*, + base >= 4.6 && < 4.8, + process >= 1.1 && < 1.3, containers == 0.5.*, - process == 1.1.*, filepath == 1.3.*, haskeline == 0.7.*, - haskell-src-exts== 1.*, directory == 1.2.*, mtl == 2.1.*, - ddc-base == 0.3.2.*, - ddc-core == 0.3.2.*, - ddc-core-eval == 0.3.2.*, - ddc-core-simpl == 0.3.2.*, - ddc-core-salt == 0.3.2.*, - ddc-core-llvm == 0.3.2.*, - ddc-core-tetra == 0.3.2.*, - ddc-code == 0.3.2.*, - ddc-build == 0.3.2.*, - ddc-driver == 0.3.2.*, - ddc-interface == 0.3.2.* + ddc-base == 0.4.1.*, + ddc-core == 0.4.1.*, + ddc-core-eval == 0.4.1.*, + ddc-core-simpl == 0.4.1.*, + ddc-core-salt == 0.4.1.*, + ddc-core-llvm == 0.4.1.*, + ddc-core-flow == 0.4.1.*, + ddc-core-tetra == 0.4.1.*, + ddc-code == 0.4.1.*, + ddc-build == 0.4.1.*, + ddc-driver == 0.4.1.*, + ddc-interface == 0.4.1.* Main-is: Main.hs @@ -99,13 +98,15 @@ DDCI.Core.Command.Eval DDCI.Core.Command.Help DDCI.Core.Command.Set - DDCI.Core.Command.Trans DDCI.Core.Command.TransInteract DDCI.Core.Command.With + DDCI.Core.Interface.Args DDCI.Core.Interface.Batch DDCI.Core.Interface.Interactive + DDCI.Core.Stats.Trace + DDCI.Core.Command DDCI.Core.Input DDCI.Core.Mode @@ -131,4 +132,74 @@ ghc-options: -Wall -fno-warn-missing-signatures + -fno-warn-missing-methods + -fno-warn-unused-do-bind + + +Executable ddci-tetra + hs-source-dirs: + src/ddci-tetra + + Build-depends: + base >= 4.6 && < 4.8, + process >= 1.1 && < 1.3, + containers == 0.5.*, + filepath == 1.3.*, + haskeline == 0.7.*, + directory == 1.2.*, + mtl == 2.1.*, + ddc-base == 0.4.1.*, + ddc-core == 0.4.1.*, + ddc-core-eval == 0.4.1.*, + ddc-core-simpl == 0.4.1.*, + ddc-core-salt == 0.4.1.*, + ddc-core-llvm == 0.4.1.*, + ddc-core-flow == 0.4.1.*, + ddc-core-tetra == 0.4.1.*, + ddc-source-tetra == 0.4.1.*, + ddc-code == 0.4.1.*, + ddc-build == 0.4.1.*, + ddc-driver == 0.4.1.*, + ddc-interface == 0.4.1.* + + Main-is: + Main.hs + + Other-modules: + DDCI.Tetra.Command.Desugar + DDCI.Tetra.Command.Help + DDCI.Tetra.Command.Infer + DDCI.Tetra.Command.Parse + DDCI.Tetra.Command.Set + DDCI.Tetra.Command.ToCore + + DDCI.Tetra.Interface.Args + DDCI.Tetra.Interface.Batch + DDCI.Tetra.Interface.Interactive + + DDCI.Tetra.Command + DDCI.Tetra.Input + DDCI.Tetra.Mode + DDCI.Tetra.Output + DDCI.Tetra.State + + Extensions: + DoAndIfThenElse + PatternGuards + ParallelListComp + FlexibleContexts + ExistentialQuantification + MultiParamTypeClasses + FunctionalDependencies + TypeSynonymInstances + FlexibleInstances + StandaloneDeriving + KindSignatures + RankNTypes + ScopedTypeVariables + + ghc-options: + -Wall + -fno-warn-missing-signatures + -fno-warn-missing-methods -fno-warn-unused-do-bind diff --git a/src/ddc-check/Main.hs b/src/ddc-check/Main.hs --- a/src/ddc-check/Main.hs +++ b/src/ddc-check/Main.hs @@ -12,7 +12,7 @@ import DDC.Core.Pretty import System.IO import System.Environment - +import qualified DDC.Core.Check as C main :: IO () main @@ -47,8 +47,8 @@ -- Loading the core code automatically check it -- against the provided fragment. errs <- pipeText sourceName 1 source - $ PipeTextLoadCore fragment - [ PipeCoreOutput sink ] + $ PipeTextLoadCore fragment C.Recon SinkDiscard + [ PipeCoreOutput pprDefaultMode sink ] -- If the pipeline died with errors, -- then print them. diff --git a/src/ddc-main/DDC/Main/Args.hs b/src/ddc-main/DDC/Main/Args.hs --- a/src/ddc-main/DDC/Main/Args.hs +++ b/src/ddc-main/DDC/Main/Args.hs @@ -26,14 +26,15 @@ = return $ config { configMode = ModeHelp } - | flag : file : rest <- args - , elem flag ["-make", "--make" ] + -- Language ----------------------------- + | "-infer" : rest <- args = parseArgs rest - $ setMode config $ ModeMake file + $ config { configInferTypes = True } - | "-basebuild" : rest <- args + | flag : rest <- args + , elem flag ["-recon", "-no-infer"] = parseArgs rest - $ setMode config $ ModeBaseBuild + $ config { configInferTypes = False } -- Compilation -------------------------- | flag : file : rest <- args @@ -41,14 +42,18 @@ = parseArgs rest $ setMode config $ ModeCompile file + | flag : file : rest <- args + , elem flag ["-make", "--make" ] + = parseArgs rest + $ setMode config $ ModeMake file + | "-basedir" : path : rest <- args = parseArgs rest $ config { configBaseDir = path } - | flag : file : rest <- args - , elem flag ["-o", "-output"] + | "-basebuild" : rest <- args = parseArgs rest - $ config { configOutputFile = Just file } + $ setMode config $ ModeBaseBuild | "-fvia-c" : rest <- args = parseArgs rest @@ -58,6 +63,11 @@ = parseArgs rest $ config { configViaBackend = ViaLLVM } + | flag : file : rest <- args + , elem flag ["-o", "-output"] + = parseArgs rest + $ config { configOutputFile = Just file } + | flag : dir : rest <- args , elem flag ["-output-dir"] = parseArgs rest @@ -129,18 +139,30 @@ = parseArgs rest $ setMode config $ ModeFlowLower file + | "-flow-lower-kernel" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeFlowLowerKernel file + + | "-flow-lower-vector" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeFlowLowerVector file + | "-flow-concretize" : file : rest <- args = parseArgs rest $ setMode config $ ModeFlowConcretize file - | "-flow-thread" : file : rest <- args + | "-flow-melt" : file : rest <- args = parseArgs rest - $ setMode config $ ModeFlowThread file + $ setMode config $ ModeFlowMelt file | "-flow-wind" : file : rest <- args = parseArgs rest $ setMode config $ ModeFlowWind file + | "-flow-thread" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeFlowThread file + -- Conversion --------------------------- | "-to-salt" : file : rest <- args = parseArgs rest @@ -159,10 +181,6 @@ = parseArgs rest $ config { configDump = True } - | "-ast" : file : rest <- args - = parseArgs rest - $ setMode config $ ModeAST file - | "-print-builder" : rest <- args = parseArgs rest $ setMode config ModePrintBuilder @@ -208,7 +226,7 @@ | otherwise = case flagOfMode newMode of Nothing - -> error "DDC.Main.Args.setMode: not setting mode to ModeNone" + -> error "ddc-main.setMode: not setting mode to ModeNone" Just newFlag -> case flagOfMode $ configMode config of @@ -228,13 +246,15 @@ ModeLoad{} -> Just "-load" ModeCompile{} -> Just "-compile" ModeMake{} -> Just "-make" - ModeAST{} -> Just "-ast" ModeToSalt{} -> Just "-to-salt" ModeToC{} -> Just "-to-c" ModeToLLVM{} -> Just "-to-llvm" ModeFlowPrep{} -> Just "-flow-prep" ModeFlowLower{} -> Just "-flow-lower" + ModeFlowLowerKernel{} -> Just "-flow-lower-kernel" + ModeFlowLowerVector{} -> Just "-flow-lower-vector" ModeFlowConcretize{} -> Just "-flow-concretize" + ModeFlowMelt{} -> Just "-flow-melt" ModeFlowThread{} -> Just "-flow-thread" ModeFlowWind{} -> Just "-flow-wind" ModeBaseBuild{} -> Just "-basebuild" diff --git a/src/ddc-main/DDC/Main/Config.hs b/src/ddc-main/DDC/Main/Config.hs --- a/src/ddc-main/DDC/Main/Config.hs +++ b/src/ddc-main/DDC/Main/Config.hs @@ -42,9 +42,6 @@ -- | Compile a .dcl or .dce into an executable file. | ModeMake FilePath - -- | Pretty print a module's AST. - | ModeAST FilePath - -- | Convert a module to Salt. | ModeToSalt FilePath @@ -61,12 +58,21 @@ -- | Lower a Flow program. | ModeFlowLower FilePath + -- | Lower a Flow program, producing a vector kernel. + | ModeFlowLowerKernel FilePath + + -- | Lower a Flow program using vector instructions. + | ModeFlowLowerVector FilePath + -- | Wind loop primops into tail recursive loops. | ModeFlowWind FilePath -- | Concretize rate type variables in a Flow program. | ModeFlowConcretize FilePath + -- | Melt compound data types in a Flow program. + | ModeFlowMelt FilePath + -- | Thread the World token through a Flow program. | ModeFlowThread FilePath @@ -97,6 +103,10 @@ { -- | The main compilation mode. configMode :: Mode + -- Language ----------------- + -- | Infer type annotations for Disciple Core files. + , configInferTypes :: Bool + -- Compilation -------------- -- | Directory holding the runtime and base library code. , configBaseDir :: FilePath @@ -155,6 +165,9 @@ return $ Config { configMode = ModeNone + -- Language ----------------- + , configInferTypes = True + -- Compilation -------------- , configBaseDir = baseDir , configOutputFile = Nothing diff --git a/src/ddc-main/DDC/Main/Help.hs b/src/ddc-main/DDC/Main/Help.hs --- a/src/ddc-main/DDC/Main/Help.hs +++ b/src/ddc-main/DDC/Main/Help.hs @@ -3,7 +3,7 @@ -- | The version identifier string. version :: String -version = "The Disciplined Disciple Compiler, version 0.3.2" +version = "The Disciplined Disciple Compiler, version 0.4.1" -- | What to print when we have no input files. @@ -21,82 +21,82 @@ -- -taint-avoid-type-checks Avoid type checking if possible. -- Exactly how much checking is avoided depends -- on the compilation mode. --- help :: String help = unlines [ version , "" - , "General:" - , " -help Display this help." - , " -version Display the version string." - , "" - , "Compilation:" - , " -make FILE Compile a module into an executable file." - , " -c, -compile FILE Compile a module into an object file." + , "General" + , " -help Display this help." + , " -version Display the version string." , "" - , " -o, -output FILE Redirect output to this file." - , " -output-dir DIR Redirect output to this directory." + , "Language" + , " -infer Infer types in core files. (default) (negates -recon)" + , " -recon Reconstruct types in core files. (negates -infer)" , "" - , " -fvia-llvm Compile via the LLVM backend (default)" - , " -fvia-c Compile via the C backend." + , "Compilation" + , " -make FILE Compile a module into an executable file." + , " -c, -compile FILE Compile a module into an object file." , "" - , " -keep-ll-files Keep intermediate .ll files." - , " -keep-c-files Keep intermediate .c files." - , " -keep-s-files Keep intermediate .s files." + , " -o, -output FILE Redirect output to this file." + , " -output-dir DIR Redirect output to this directory." , "" - , "Optimisation:" - , " -O0 No optimisations. (default)" - , " -O, -O1 Do standard optimisations." + , " -fvia-llvm Compile via the LLVM backend (default)" + , " -fvia-c Compile via the C backend." , "" - , "Runtime for compiled program:" - , " -run-heap BYTES Size of fixed heap (65536)" + , "Checking and Loading" + , " -parse FILE Parse a module." + , " -check FILE Parse and type check a module." + , " -load FILE Parse, type check and desugar a module to the Core IR." , "" - , "Parsing and Checking:" - , " -parse FILE Parse a module." - , " -check FILE Parse and type check a module." + , "Conversion" + , " -to-salt FILE Convert a module to Disciple Core Salt." + , " -to-llvm FILE Convert a module to LLVM code." + , " -to-c FILE Convert a module to C code." , "" - , "Conversion:" - , " -to-salt FILE Convert a module to Disciple Core Salt." - , " -to-c FILE Convert a module to C code." - , " -to-llvm FILE Convert a module to LLVM code." + , "Configuration" + , " -basedir DIR Path to the runtime and base library code." + , " -print-basedir Print directory holding the runtime and base libraries." + , " -print-builder Print external builder info for this platform." + , " -run-heap BYTES Size of the fixed runtime heap. (65536)" , "" - , "Data Flow Fusion Transforms:" - , " These work on modules in the Disciple Core Flow (.dcf) fragment." - , " -flow-prep FILE Prepare a module for lowering." - , " -flow-lower FILE Lower functions to loop code." - , " -flow-wind FILE Wind loop primops into tail recursive loops." - , " -flow-concretize FILE Rewrite primops to use concrete series lengths." + , "Optimisation and Transformation" + , " -O0 No optimisations. (default)" + , " -O, -O1 Do standard optimisations." , "" - , "Debugging:" - , " -dump Dump intermediate representations." - , " -ast FILE Pretty print the AST of a module." + , " -trans TRANS Set the transformation to use with -load." + , " -with FILE Use this module for inliner templates with -load." , "" - , "Configuration:" - , " -basedir DIR Path to the runtime and base library code." - , " -print-basedir Print directory holding the runtime and base libraries." - , " -print-builder Print external builder info for this platform." + , " TRANS ::= " + , " { TRANS } Parenthesis." + , " fix N TRANS Transform to a fixpoint, or bail out after N iterations." + , " TRANS; TRANS Sequence two transforms." + , " Id Return the original program unharmed." + , " Anonymize Anonymize names to deBruijn form." + , " Namify Introduce fresh names for deBruijn binders." + , " Snip Introduce let-bindings for nested applications." + , " SnipOver ... and over-applications." + , " Flatten Flatten nested let-bindings." + , " Beta Perform beta-reduction for value arguments." + , " BetaLets ... introducing new let-bindings for redex arguments." + , " Bubble Float casts outwards, and combine similar ones." + , " Prune Erase unused, ineffectual let-bindings." + , " Forward Float let-bindings forward into their use sites." + , " Rewrite Perform rule based rewriting." + , " Elaborate Introduce default witnesses for unconstrained regions." + , " Inline MODULE[NAME..] Perform inlining. Use '-with' to add source modules." , "" - , "Transformation:" - , " -load FILE Parse, type check and transform a module." - , " -trans TRANS Set the transformation to use with -load." - , " -with FILE Use this module for inliner templates with -load." + , "Data Flow Fusion Transforms" + , " These work on modules in the Disciple Core Flow (.dcf) fragment only." + , " -flow-prep FILE Prepare a module for lowering." + , " -flow-lower FILE Lower functions to loop code." + , " -flow-concretize FILE Rewrite primops to use concrete series lengths." + , " -flow-melt FILE Melt compound data structures." + , " -flow-wind FILE Wind loop primops into tail recursive loops." + , " -flow-thread FILE Thread state token through program." , "" - , " TRANS ::= " - , " { TRANS } Parenthesis." - , " fix N TRANS Transform to a fixpoint, or bail out after N iterations." - , " TRANS; TRANS Sequence two transforms." - , " Id Return the original program unharmed." - , " Anonymize Anonymize names to deBruijn form." - , " Namify Introduce fresh names for deBruijn binders." - , " Snip Introduce let-bindings for nested applications." - , " SnipOver ... and over-applications." - , " Flatten Flatten nested let-bindings." - , " Beta Perform beta-reduction for value arguments." - , " BetaLets ... introducing new let-bindings for redex arguments." - , " Bubble Float casts outwards, and combine similar ones." - , " Prune Erase unused, ineffectual let-bindings." - , " Forward Float let-bindings forward into their use sites." - , " Rewrite Perform rule based rewriting." - , " Elaborate Introduce default witnesses for unconstrained regions." - , " Inline MODULE[NAME..] Perform inlining. Use '-with' to add source modules." ] + , "Debugging" + , " -dump Dump intermediate representations." + , " -keep-ll-files Keep intermediate .ll files." + , " -keep-c-files Keep intermediate .c files." + , " -keep-s-files Keep intermediate .s files." ] diff --git a/src/ddc-main/DDC/Main/OptLevels.hs b/src/ddc-main/DDC/Main/OptLevels.hs --- a/src/ddc-main/DDC/Main/OptLevels.hs +++ b/src/ddc-main/DDC/Main/OptLevels.hs @@ -5,7 +5,7 @@ , getSimplSaltOfConfig) where import DDC.Main.Config -import DDC.Driver.Command.Load +import DDC.Driver.Command.Read import DDC.Driver.Command.RewriteRules import DDC.Build.Builder import DDC.Build.Platform @@ -19,6 +19,7 @@ import Data.List import Data.Monoid import Data.Maybe +import qualified DDC.Driver.Config as D import qualified DDC.Core.Fragment as C import qualified DDC.Core.Simplifier as S import qualified DDC.Core.Simplifier.Recipe as S @@ -39,28 +40,30 @@ -- as inliner templates, so we need to wait until they're all specified. -- getSimplLiteOfConfig - :: Config -> Builder + :: Config -> D.Config + -> Builder -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Lite.Name) -getSimplLiteOfConfig config builder filePath +getSimplLiteOfConfig config dconfig builder filePath = case configOptLevelLite config of - OptLevel0 -> opt0_lite config - OptLevel1 -> opt1_lite config builder filePath + OptLevel0 -> opt0_lite config + OptLevel1 -> opt1_lite config dconfig builder filePath -- | Get the simplifier for Salt code from the config. -- getSimplSaltOfConfig - :: Config -> Builder + :: Config -> D.Config + -> Builder -> Salt.Config -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Salt.Name) -getSimplSaltOfConfig config builder runtimeConfig filePath +getSimplSaltOfConfig config dconfig builder runtimeConfig filePath = case configOptLevelSalt config of - OptLevel0 -> opt0_salt config - OptLevel1 -> opt1_salt config builder runtimeConfig filePath + OptLevel0 -> opt0_salt config + OptLevel1 -> opt1_salt config dconfig builder runtimeConfig filePath -- Level 0 -------------------------------------------------------------------- @@ -83,11 +86,12 @@ -- | Level 1 optimiser for Core Lite code. opt1_lite - :: Config -> Builder + :: Config -> D.Config + -> Builder -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Lite.Name) -opt1_lite config _builder filePath +opt1_lite config dconfig _builder filePath = do -- Auto-inline basic numeric code. let inlineModulePaths @@ -100,7 +104,7 @@ -- will display the errors. minlineModules <- liftM sequence - $ mapM (cmdReadModule Lite.fragment) + $ mapM (cmdReadModule dconfig Lite.fragment) inlineModulePaths let inlineModules @@ -118,7 +122,7 @@ $ inlineModules `zip` inlineModulePaths -- Load rules for target module as well - modrules <- loadLiteRules filePath + modrules <- loadLiteRules dconfig filePath let rules' = concat rules ++ modrules @@ -141,12 +145,13 @@ -- | Level 1 optimiser for Core Salt code. opt1_salt - :: Config -> Builder + :: Config -> D.Config + -> Builder -> Salt.Config -> Maybe FilePath -- ^ path of current module -> IO (Simplifier Int () Salt.Name) -opt1_salt config builder runtimeConfig filePath +opt1_salt config dconfig builder runtimeConfig filePath = do -- Auto-inline the low-level code from the runtime system -- that constructs and destructs objects. @@ -165,7 +170,7 @@ -- will display the errors. minlineModules <- liftM sequence - $ mapM (cmdReadModule Salt.fragment) + $ mapM (cmdReadModule dconfig Salt.fragment) inlineModulePaths let inlineModules @@ -182,7 +187,7 @@ $ inlineModules `zip` inlineModulePaths -- Load rules for target module as well - modrules <- loadSaltRules builder runtimeConfig filePath + modrules <- loadSaltRules dconfig builder runtimeConfig filePath let rules' = concat rules ++ modrules @@ -205,33 +210,35 @@ -- | Load rules for main module loadLiteRules - :: Maybe FilePath + :: D.Config + -> Maybe FilePath -> IO (S.NamedRewriteRules () Lite.Name) -loadLiteRules (Just filePath) +loadLiteRules dconfig (Just filePath) | isSuffixOf ".dcl" filePath = do -- Parse module to get exported fn types - modu <- cmdReadModule' False Lite.fragment filePath + modu <- cmdReadModule' False dconfig Lite.fragment filePath case modu of Just mod' -> cmdTryReadRules Lite.fragment (filePath ++ ".rules") (reannotate (const ()) mod') Nothing -> return [] -loadLiteRules _ +loadLiteRules _ _ = return [] -- | Load rules for main module loadSaltRules - :: Builder + :: D.Config + -> Builder -> Salt.Config -> Maybe FilePath -> IO (S.NamedRewriteRules () Salt.Name) -loadSaltRules builder runtimeConfig (Just filePath) +loadSaltRules dconfig builder runtimeConfig (Just filePath) -- If the main module is a lite module, we need to load the lite then convert it to salt | isSuffixOf ".dcl" filePath - = do modu <- cmdReadModule' False Lite.fragment filePath + = do modu <- cmdReadModule' False dconfig Lite.fragment filePath let path' = (reverse $ drop 3 $ reverse filePath) ++ "dcs.rules" case modu of Just mod' -> @@ -248,12 +255,12 @@ Nothing -> return [] | isSuffixOf ".dcs" filePath - = do modu <- cmdReadModule' False Salt.fragment filePath + = do modu <- cmdReadModule' False dconfig Salt.fragment filePath case modu of Just mod' -> cmdTryReadRules Salt.fragment (filePath ++ ".rules") (reannotate (const ()) mod') Nothing -> return [] -loadSaltRules _ _ _ +loadSaltRules _ _ _ _ = return [] diff --git a/src/ddc-main/Main.hs b/src/ddc-main/Main.hs --- a/src/ddc-main/Main.hs +++ b/src/ddc-main/Main.hs @@ -12,30 +12,30 @@ import DDC.Driver.Command.Load import DDC.Driver.Command.Compile import DDC.Driver.Command.Make -import DDC.Driver.Command.Ast import DDC.Driver.Command.BaseBuild import DDC.Driver.Command.Flow.Prep import DDC.Driver.Command.Flow.Lower import DDC.Driver.Command.Flow.Concretize -import DDC.Driver.Command.Flow.Thread +import DDC.Driver.Command.Flow.Melt import DDC.Driver.Command.Flow.Wind +import DDC.Driver.Command.Flow.Thread +import qualified DDC.Core.Flow as Flow import DDC.Driver.Command.ToSalt import DDC.Driver.Command.ToC import DDC.Driver.Command.ToLlvm import DDC.Interface.Source import DDC.Build.Builder -import DDC.Build.Language import DDC.Base.Pretty import System.Environment import System.IO import System.Exit -import System.FilePath import Control.Monad.Trans.Error -import qualified DDC.Driver.Stage as Driver -import qualified DDC.Core.Salt.Runtime as Runtime - +import qualified DDC.Driver.Stage as Driver +import qualified DDC.Driver.Config as Driver +import qualified DDC.Core.Salt.Runtime as Runtime +import qualified DDC.Core.Simplifier.Recipe as Simplifier main :: IO () main @@ -69,32 +69,29 @@ ModeHelp -> putStrLn help - -- Parser a module. + -- Parse a module. ModeParse filePath -> do dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath - runError $ cmdParseModule dconfig (SourceFile filePath) str + runError $ cmdParseFromFile dconfig filePath -- Parse and type check a module. ModeCheck filePath - -> do language <- languageFromFilePath filePath - case language of - Language bundle - -> do mm <- runErrorT - $ cmdCheckModuleFromFile (bundleFragment bundle) filePath - case mm of - Left err - -> do putStrLn err - exitWith $ ExitFailure 1 + -> do dconfig <- getDriverConfig config (Just filePath) + result <- runErrorT $ cmdCheckFromFile dconfig filePath + + case result of + Left err + -> do putStrLn err + exitWith $ ExitFailure 1 - Right _ - -> return () + Right () + -> return () -- Parse, type check and transform a module. ModeLoad filePath - -> runError $ cmdLoadFromFile - (configTrans config) - (configWith config) + -> do dconfig <- getDriverConfig config (Just filePath) + runError $ cmdLoadFromFile dconfig + (configTrans config) (configWith config) filePath -- Compile a module to object code. @@ -107,35 +104,20 @@ -> do dconfig <- getDriverConfig config (Just filePath) runError $ cmdMake dconfig filePath - -- Pretty print the AST of a module. - ModeAST filePath - -> do language <- languageFromFilePath filePath - str <- readFile filePath - cmdAstModule - language - (SourceFile filePath) - str - -- Convert a module to Salt. ModeToSalt filePath - -> do language <- languageFromFilePath filePath - dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath - runError $ cmdToSalt dconfig language (SourceFile filePath) str + -> do dconfig <- getDriverConfig config (Just filePath) + runError $ cmdToSaltFromFile dconfig filePath -- Convert a module to C ModeToC filePath - -> do language <- languageFromFilePath filePath - dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath - runError $ cmdToC dconfig language (SourceFile filePath) str + -> do dconfig <- getDriverConfig config (Just filePath) + runError $ cmdToSeaFromFile dconfig filePath -- Convert a module to LLVM ModeToLLVM filePath - -> do language <- languageFromFilePath filePath - dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath - runError $ cmdToLlvm dconfig language (SourceFile filePath) str + -> do dconfig <- getDriverConfig config (Just filePath) + runError $ cmdToLlvmFromFile dconfig filePath -- Prepare a Disciple Core Flow program for lowering. ModeFlowPrep filePath @@ -145,21 +127,41 @@ -- Lower a Disciple Core Flow program to loops. ModeFlowLower filePath - -> do dconfig <- getDriverConfig config (Just filePath) + -> do configDriver <- getDriverConfig config (Just filePath) str <- readFile filePath - runError $ cmdFlowLower dconfig (SourceFile filePath) str + runError + $ cmdFlowLower + configDriver Flow.defaultConfigScalar + (SourceFile filePath) str + -- Lower a Disciple Core Flow program to loops. + ModeFlowLowerKernel filePath + -> do configDriver <- getDriverConfig config (Just filePath) + str <- readFile filePath + runError + $ cmdFlowLower + configDriver Flow.defaultConfigKernel + (SourceFile filePath) str + + -- Lower a Disciple Core Flow program to loops. + ModeFlowLowerVector filePath + -> do configDriver <- getDriverConfig config (Just filePath) + str <- readFile filePath + runError + $ cmdFlowLower configDriver Flow.defaultConfigVector + (SourceFile filePath) str + -- Concretize rate type variables in a Disciple Core Flow program. ModeFlowConcretize filePath -> do dconfig <- getDriverConfig config (Just filePath) str <- readFile filePath runError $ cmdFlowConcretize dconfig (SourceFile filePath) str - -- Thread the world token through a Disciple Core Flow program. - ModeFlowThread filePath + -- Melt compound data structures. + ModeFlowMelt filePath -> do dconfig <- getDriverConfig config (Just filePath) str <- readFile filePath - runError $ cmdFlowThread dconfig (SourceFile filePath) str + runError $ cmdFlowMelt dconfig (SourceFile filePath) str -- Wind loop primops into tail recursive loops. ModeFlowWind filePath @@ -167,6 +169,12 @@ str <- readFile filePath runError $ cmdFlowWind dconfig (SourceFile filePath) str + -- Thread the world token through a Disciple Core Flow program. + ModeFlowThread filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath + runError $ cmdFlowThread dconfig (SourceFile filePath) str + -- Build the runtime and base libraries. ModeBaseBuild -> do dconfig <- getDriverConfig config Nothing @@ -190,38 +198,37 @@ = Runtime.Config { Runtime.configHeapSize = configRuntimeHeapSize config } - simplLite <- getSimplLiteOfConfig config builder filePath - simplSalt <- getSimplSaltOfConfig config builder runtimeConfig filePath - - return $ Driver.Config - { Driver.configDump = configDump config - , Driver.configSimplLite = simplLite - , Driver.configSimplSalt = simplSalt - , Driver.configViaBackend = configViaBackend config - - , Driver.configRuntime = runtimeConfig - , Driver.configBuilder = builder - , Driver.configSuppressCoreImports = False - , Driver.configSuppressHashImports = False - , Driver.configOutputFile = configOutputFile config - , Driver.configOutputDir = configOutputDir config - , Driver.configKeepLlvmFiles = configKeepLlvmFiles config - , Driver.configKeepSeaFiles = configKeepSeaFiles config - , Driver.configKeepAsmFiles = configKeepAsmFiles config - , Driver.configTaintAvoidTypeChecks = configTaintAvoidTypeChecks config } - + let dconfig + = Driver.Config + { Driver.configDump = configDump config + , Driver.configInferTypes = configInferTypes config + , Driver.configSimplLite = Simplifier.idsimp + , Driver.configSimplSalt = Simplifier.idsimp + , Driver.configViaBackend = configViaBackend config + , Driver.configRuntime = runtimeConfig + , Driver.configBuilder = builder + , Driver.configPretty = Driver.defaultConfigPretty + , Driver.configSuppressHashImports = False + , Driver.configOutputFile = configOutputFile config + , Driver.configOutputDir = configOutputDir config + , Driver.configKeepLlvmFiles = configKeepLlvmFiles config + , Driver.configKeepSeaFiles = configKeepSeaFiles config + , Driver.configKeepAsmFiles = configKeepAsmFiles config + , Driver.configTaintAvoidTypeChecks = configTaintAvoidTypeChecks config } --- | Determine the current language based on the file extension of this path, --- and slurp out a bundle of stuff specific to that language from the config. -languageFromFilePath :: FilePath -> IO Language -languageFromFilePath filePath - = case languageOfExtension (takeExtension filePath) of - Nothing - -> do hPutStrLn stderr "Unknown file extension." - exitWith $ ExitFailure 1 + simplLite <- getSimplLiteOfConfig config + dconfig + builder filePath + + -- We need to force -infer on because the inliner templates may not + -- have full type annotations. + simplSalt <- getSimplSaltOfConfig config + dconfig { Driver.configInferTypes = True } + builder runtimeConfig filePath - Just ext - -> return ext + return $ dconfig + { Driver.configSimplLite = simplLite + , Driver.configSimplSalt = simplSalt } -- | Print errors to stderr and set the exit code. diff --git a/src/ddci-core/DDCI/Core/Command.hs b/src/ddci-core/DDCI/Core/Command.hs --- a/src/ddci-core/DDCI/Core/Command.hs +++ b/src/ddci-core/DDCI/Core/Command.hs @@ -8,14 +8,14 @@ import DDCI.Core.Command.Help import DDCI.Core.Command.Set import DDCI.Core.Command.Eval -import DDCI.Core.Command.Trans import DDCI.Core.Command.TransInteract import DDCI.Core.Command.With import DDCI.Core.State +import DDCI.Core.Mode as Mode -import DDC.Driver.Command.Ast import DDC.Driver.Command.Check import DDC.Driver.Command.Load +import DDC.Driver.Command.Trans import DDC.Driver.Command.Compile import DDC.Driver.Command.Make @@ -23,18 +23,26 @@ import DDC.Driver.Command.ToC import DDC.Driver.Command.ToLlvm +import DDC.Driver.Command.Tetra.Boxing + import DDC.Driver.Command.Flow.Prep +import DDC.Driver.Command.Flow.Rate import DDC.Driver.Command.Flow.Lower import DDC.Driver.Command.Flow.Concretize -import DDC.Driver.Command.Flow.Thread import DDC.Driver.Command.Flow.Wind +import DDC.Driver.Command.Flow.Melt +import DDC.Driver.Command.Flow.Thread +import DDC.Type.Universe + +import qualified DDC.Core.Flow as Flow +import qualified Data.Set as Set import System.IO import Control.Monad.Trans.Error import Data.List --- Command -------------------------------------------------------------------- +-- Command ---------------------------------------------------------------------------------------- -- | The commands that the interpreter supports. data Command = CommandBlank -- ^ No command was entered. @@ -42,22 +50,18 @@ | CommandHelp -- ^ Display the interpreter help. | CommandSet -- ^ Set a mode. | CommandLoad -- ^ Load a module. - | CommandKind -- ^ Show the kind of a type. - | CommandUniverse -- ^ Show the universe of a type. - | CommandUniverse1 -- ^ Given a type, show the universe of the original thing. - | CommandUniverse2 -- ^ Given a kind, show the universe of the original thing. - | CommandUniverse3 -- ^ Given a sort, show the universe of the original thing. + | CommandSort -- ^ Show the sort of a kind. + | CommandKind -- ^ Show the kind of a spec. | CommandEquivType -- ^ Check if two types are equivalent. | CommandWitType -- ^ Show the type of a witness. - | CommandExpCheck -- ^ Check an expression. + | CommandExpCheck -- ^ Check the type of an expression. + | CommandExpSynth -- ^ Synthesize the type of an expression, including existentials. | CommandExpType -- ^ Check an expression, showing its type. | CommandExpEffect -- ^ Check an expression, showing its effect. | CommandExpClosure -- ^ Check an expression, showing its closure. | CommandExpRecon -- ^ Reconstruct type annotations on binders. | CommandEval -- ^ Evaluate an expression. - | CommandAst -- ^ Show the AST of an expression. - -- Generic transformations | CommandTrans -- ^ Transform an expression. | CommandTransEval -- ^ Transform then evaluate an expression. @@ -72,20 +76,26 @@ | CommandToC -- ^ Convert a module to C code. | CommandToLlvm -- ^ Convert a module to LLVM code. - -- Core Flow passes - | CommandFlowPrep -- ^ Prepare a Core Flow module for lowering. - | CommandFlowLower -- ^ Prepare and Lower a Core Flow module. - | CommandFlowConcretize -- ^ Convert operations on type level rates to concrete ones. - | CommandFlowThread -- ^ Thread a world token through lowered code. - | CommandFlowWind -- ^ Wind loop primops into tail recursive loops. + -- Core Tetra specific passes. + | CommandTetraBoxing -- ^ Manage boxing of numeric types. + -- Core Flow specific passes + | CommandFlowRate -- ^ Perform rate inference + | CommandFlowPrep -- ^ Prepare a Core Flow module for lowering. + | CommandFlowLower Flow.Config -- ^ Prepare and Lower a Core Flow module. + | CommandFlowConcretize -- ^ Convert operations on type level rates to concrete ones. + | CommandFlowMelt -- ^ Melt compound data structures. + | CommandFlowWind -- ^ Wind loop primops into tail recursive loops. + | CommandFlowThread -- ^ Thread a world token through lowered code. + -- Inline control - | CommandWith -- ^ Add a module to the inliner table. + | CommandWith -- ^ Add a module to the inliner table. | CommandWithLite | CommandWithSalt deriving (Eq, Show) +--------------------------------------------------------------------------------------------------- -- | Names used to invoke each command. -- Short names that form prefixes of other ones must come later -- in the list. Eg ':with-lite' after ':with' @@ -95,16 +105,12 @@ , (":?", CommandHelp) , (":set", CommandSet) , (":load", CommandLoad) + , (":sort", CommandSort) , (":kind", CommandKind) - - , (":universe1", CommandUniverse1) - , (":universe2", CommandUniverse2) - , (":universe3", CommandUniverse3) - , (":universe", CommandUniverse) - , (":tequiv", CommandEquivType) , (":wtype", CommandWitType) , (":check", CommandExpCheck) + , (":synth", CommandExpSynth) , (":recon", CommandExpRecon) , (":type", CommandExpType) @@ -113,8 +119,6 @@ , (":eval", CommandEval) - , (":ast", CommandAst) - -- Generic transformations , (":trun", CommandTransEval) , (":tinteract", CommandTransInteract) @@ -125,13 +129,20 @@ , (":to-c", CommandToC) , (":to-llvm", CommandToLlvm) - -- Core Flow passes - , (":flow-prep", CommandFlowPrep) - , (":flow-lower", CommandFlowLower) - , (":flow-concretize", CommandFlowConcretize) - , (":flow-thread", CommandFlowThread) - , (":flow-wind", CommandFlowWind) + -- Core Tetra specific passes + , (":tetra-boxing", CommandTetraBoxing) + -- Core Flow specific passes + , (":flow-rate", CommandFlowRate) + , (":flow-prep", CommandFlowPrep) + , (":flow-lower-kernel", CommandFlowLower Flow.defaultConfigKernel) + , (":flow-lower-vector", CommandFlowLower Flow.defaultConfigVector) + , (":flow-lower", CommandFlowLower Flow.defaultConfigScalar) + , (":flow-concretize", CommandFlowConcretize) + , (":flow-melt", CommandFlowMelt) + , (":flow-wind", CommandFlowWind) + , (":flow-thread", CommandFlowThread) + -- Make and Compile , (":compile", CommandCompile) , (":make", CommandMake) @@ -160,7 +171,7 @@ = Nothing --- Commands ------------------------------------------------------------------- +-- Commands --------------------------------------------------------------------------------------- -- | Handle a single line of input. handleCmd :: State -> Command -> Source -> String -> IO State handleCmd state CommandBlank _ _ @@ -171,7 +182,9 @@ return state' handleCmd1 state cmd source line - = case cmd of + = let lang = stateLanguage state + traceCheck = Set.member TraceCheck (stateModes state) + in case cmd of CommandBlank -> return state @@ -191,68 +204,66 @@ return state' CommandLoad - -> do runError $ cmdLoadFromString (stateLanguage state) source line - return state - - CommandKind - -> do cmdShowKind (stateLanguage state) source line - return state - - CommandUniverse - -> do cmdUniverse (stateLanguage state) source line - return state - - CommandUniverse1 - -> do cmdUniverse1 (stateLanguage state) source line + -> do configDriver <- getDriverConfigOfState state + runError + $ cmdLoadCoreFromString + configDriver + (stateLanguage state) source line return state - CommandUniverse2 - -> do cmdUniverse2 (stateLanguage state) source line + CommandSort + -> do cmdShowType lang UniverseKind source line return state - CommandUniverse3 - -> do cmdUniverse3 (stateLanguage state) source line + CommandKind + -> do cmdShowType lang UniverseSpec source line return state CommandEquivType - -> do cmdTypeEquiv (stateLanguage state) source line + -> do cmdTypeEquiv lang source line return state CommandWitType - -> do cmdShowWType (stateLanguage state) source line + -> do cmdShowWType lang source line return state CommandExpCheck - -> do cmdShowType (stateLanguage state) ShowTypeAll source line + -> do cmdShowSpec lang ShowSpecAll False traceCheck source line return state CommandExpType - -> do cmdShowType (stateLanguage state) ShowTypeValue source line + -> do cmdShowSpec lang ShowSpecData False traceCheck source line return state CommandExpEffect - -> do cmdShowType (stateLanguage state) ShowTypeEffect source line + -> do cmdShowSpec lang ShowSpecEffect False traceCheck source line return state CommandExpClosure - -> do cmdShowType (stateLanguage state) ShowTypeClosure source line + -> do cmdShowSpec lang ShowSpecClosure False traceCheck source line return state + CommandExpSynth + -> do cmdShowSpec lang ShowSpecAll True traceCheck source line + return state + CommandExpRecon - -> do cmdExpRecon (stateLanguage state) source line + -> do cmdExpRecon lang source line return state CommandEval -> do cmdEval state source line return state - CommandAst - -> do cmdAstExp (stateLanguage state) source line - return state - -- Generic transformations -------------- CommandTrans - -> do cmdTrans state source line + -> do configDriver <- getDriverConfigOfState state + runError + $ cmdTransDetect + configDriver + (stateLanguage state) + (Set.member Mode.TraceTrans $ stateModes state) + source line return state CommandTransEval @@ -266,29 +277,39 @@ -- Conversion to machine code ----------- CommandToSalt -> do config <- getDriverConfigOfState state - runError $ cmdToSalt config (stateLanguage state) source line + runError $ cmdToSaltCoreFromString config lang source line return state CommandToC -> do config <- getDriverConfigOfState state - runError $ cmdToC config (stateLanguage state) source line + runError $ cmdToSeaCoreFromString config lang source line return state CommandToLlvm -> do config <- getDriverConfigOfState state - runError $ cmdToLlvm config (stateLanguage state) source line + runError $ cmdToLlvmCoreFromString config lang source line return state + -- Core Tetra specific passes ----------- + CommandTetraBoxing + -> do configDriver <- getDriverConfigOfState state + runError $ cmdTetraBoxing configDriver source line + return state - -- Core Flow passes ---------------------- + -- Core Flow specific passes ------------ + CommandFlowRate + -> do configDriver <- getDriverConfigOfState state + runError $ cmdFlowRate configDriver source line + return state + CommandFlowPrep -> do config <- getDriverConfigOfState state runError $ cmdFlowPrep config source line return state - CommandFlowLower - -> do config <- getDriverConfigOfState state - runError $ cmdFlowLower config source line + CommandFlowLower configLower + -> do configDriver <- getDriverConfigOfState state + runError $ cmdFlowLower configDriver configLower source line return state CommandFlowConcretize @@ -296,14 +317,19 @@ runError $ cmdFlowConcretize config source line return state - CommandFlowThread + CommandFlowMelt -> do config <- getDriverConfigOfState state - runError $ cmdFlowThread config source line + runError $ cmdFlowMelt config source line return state CommandFlowWind -> do config <- getDriverConfigOfState state runError $ cmdFlowWind config source line + return state + + CommandFlowThread + -> do config <- getDriverConfigOfState state + runError $ cmdFlowThread config source line return state -- Make and Compile --------------------- diff --git a/src/ddci-core/DDCI/Core/Command/Eval.hs b/src/ddci-core/DDCI/Core/Command/Eval.hs --- a/src/ddci-core/DDCI/Core/Command/Eval.hs +++ b/src/ddci-core/DDCI/Core/Command/Eval.hs @@ -2,16 +2,19 @@ module DDCI.Core.Command.Eval ( cmdStep , cmdEval + , cmdTransEval , evalExp) where import DDCI.Core.Stats.Trace import DDCI.Core.Output import DDCI.Core.State import DDC.Driver.Command.Check +import DDC.Driver.Command.Trans import DDC.Core.Eval.Env import DDC.Core.Eval.Step import DDC.Core.Eval.Name import DDC.Core.Transform.Reannotate +import DDC.Core.Fragment import DDC.Core.Exp import DDC.Core.Check import DDC.Core.Pretty @@ -30,22 +33,25 @@ import Data.Maybe (fromMaybe) +--------------------------------------------------------------------------------------------------- -- | Parse, check, and single step evaluate an expression. cmdStep :: State -> Source -> String -> IO () cmdStep state source str | Language bundle <- stateLanguage state - , modules0 <- bundleModules bundle + = case profileName $ fragmentProfile $ bundleFragment bundle of + "Eval" -> cmdStep_eval state source bundle str + lang -> do putStrLn $ "Cannot step '" ++ lang ++ "' expressions." + +cmdStep_eval state source bundle str + | modules0 <- bundleModules bundle , (modules :: Maybe (ModuleMap (AnTEC () Name) Name)) <- gcast modules0 , modules' <- fromMaybe Map.empty modules - = cmdParseCheckExp Eval.fragment modules' False source str >>= goStore + = cmdParseCheckExp Eval.fragment modules' Recon False False source str + >>= goStore where - -- Expression had a parse or type error. - goStore Nothing - = return () - -- Expression is well-typed. - goStore (Just x) + goStore (Just x, _) = let -- The evaluator doesn't accept any annotations x_stripped = reannotate (const ()) x @@ -54,31 +60,76 @@ in goStep store x + -- Expression had a parse or type error. + goStore _ + = return () + goStep store x = do _ <- forcePrint state store x return () +--------------------------------------------------------------------------------------------------- -- | Parse, check, and fully evaluate an expression. cmdEval :: State -> Source -> String -> IO () cmdEval state source str | Language bundle <- stateLanguage state - , modules0 <- bundleModules bundle + = case profileName $ fragmentProfile $ bundleFragment bundle of + "Eval" -> cmdEval_eval state source bundle str + lang -> do putStrLn $ "Cannot evaluate '" ++ lang ++ "' expressions." + +cmdEval_eval state source bundle str + | modules0 <- bundleModules bundle , (modules :: Maybe (ModuleMap (AnTEC () Name) Name)) <- gcast modules0 , modules' <- fromMaybe Map.empty modules - = cmdParseCheckExp Eval.fragment modules' False source str >>= goEval + = cmdParseCheckExp Eval.fragment modules' Recon False False source str + >>= goEval where - -- Expression had a parse or type error. - goEval Nothing - = return () - -- Expression is well-typed. - goEval (Just expr) + goEval (Just expr, _) = evalExp state $ reannotate (\a -> a { annotTail = ()} ) expr + -- Expression had a parse or type error. + goEval _ + = return () + +cmdTransEval :: State -> Source -> String -> IO () +cmdTransEval state source str + = do config <- getDriverConfigOfState state + cmdTransExpCont + config + (Set.member TraceTrans $ stateModes state) + (stateLanguage state) + (evalExpCast state) + source + str + + +--------------------------------------------------------------------------------------------------- +evalExpCast + :: Typeable n + => State -> Exp (AnTEC () n) n -> IO () +evalExpCast state xx + + | (Just (ExpBox xx') :: Maybe (ExpBox Name)) + <- gcast (ExpBox xx) + = evalExp state xx' + + | otherwise + = error "ddci-core: evalExpCast failed" + + +-- Proxies to help with type casting. +-- The 'gcast' function will only cast the rightmost 'n' of a type, +-- But there is also an 'n' attached to the annotation type of +-- the simplifier. We use the proxy to cast both occurrences at once. +data ExpBox n + = ExpBox (Exp (AnTEC () n) n) + + -- | Evaluate an already parsed and type-checked expression. -- Exported so transforms can test with it. evalExp :: State -> Exp (AnTEC () Name) Name -> IO () @@ -151,18 +202,19 @@ forcePrint state store x = let -- Get the type, effect and closure of the original expression. - Just annot = takeAnnotOfExp x - tX = annotType annot - effX = annotEffect annot - cloX = annotClosure annot + annot = annotOfExp x + tX = annotType annot + effX = annotEffect annot + cloX = annotClosure annot -- The evaluator doesn't want any type annotations on the expresison. x_stripped = reannotate (const ()) x in case force store x_stripped of StepProgress store' x_stripped' - -> case checkExp (configOfProfile Eval.profile) - primKindEnv primTypeEnv x_stripped' of + -> case fst $ checkExp (configOfProfile Eval.profile) + primKindEnv primTypeEnv + x_stripped' Recon of Left err -> do -- Print intermediate expression. diff --git a/src/ddci-core/DDCI/Core/Command/Help.hs b/src/ddci-core/DDCI/Core/Command/Help.hs --- a/src/ddci-core/DDCI/Core/Command/Help.hs +++ b/src/ddci-core/DDCI/Core/Command/Help.hs @@ -29,90 +29,99 @@ , "" , "----------------------------------------------------------------- Commands --" , "General" - , " :quit Exit DDCi-core." - , " :help Display this help page." + , " :quit Exit DDCi-core." + , " :help Display this help page." , "" - , "Modes" - , " :set Display active modes and program transform." - , " :set +MODE Enable a mode." - , " :set /MODE Disable a mode." - , " :set lang LANG Set the language fragment." - , " :set builder BUILDER Set the builder." - , " :set outputdir DIR Set the output directory." - , " :set output FILE Set the output file." - , " :set trans TRANS Set the program transform." + , "Compilation" + , " :compile PATH Compile the module at this path to an object file." + , " :make PATH Make the module at this path into an executable." , "" - , " :set rule NAME [an : kn] ... (xn : tn) ... exp1 = exp2" - , " Add a rewrite rule to the database." + , "Conversion" + , " :load MODULE Load and type check a module." + , " :to-salt MODULE Convert a module to Salt." + , " :to-llvm MODULE Convert a module to LLVM." + , " :to-c MODULE Convert a module to C." + , " :trans MODULE/EXP Transform the given module or expression." , "" - , " :with PATH Use this module for 'set trans' inlining." - , " :with-lite PATH ... use Lite module during -compile or -make cmds." - , " :with-salt PATH ... use Salt module during -compile or -make cmds." + , "Type Commands" + , " :kind TYPE Show the kind of a type." + , " :tequiv TYPE TYPE Check if two types are equivalent." , "" - , " MODE ::=" - , " Indent Pretty print expressions with indenting." - , " TraceEval Show the expression at every step when evaluating." - , " TraceStore Show the store at every step when evaluating." - , " SuppressImports Suppress the import list when printing modules." + , "Witness Commands" + , " :wtype WITNESS Show the type of a witness expression." , "" - , " LANG ::=" - , " Lite | Salt | Zero | Eval" + , "Expression Commands" + , " :check EXP Show the type, effect and closure of an exp." + , " :type EXP Show the type of an expression." + , " :effect EXP Show the effect of an expression." + , " :closure EXP Show the closure of an expression." + , " :eval EXP Evaluate an expression." + , " :ast EXP Show the abstract syntax tree of a exp." , "" - , " BUILDER ::= " - , " x86_32-darwin | x86_64-darwin | x86_32-linux | x86_64-linux" - , " x86_32-cygwin | ppc32-linux" + , " :trun EXP Transform the given expression then evaluate it." + , " :tinteract EXP Enter interactive transformation mode." , "" - , " TRANS ::= " - , " { TRANS } Parenthesis." - , " fix N TRANS Transform to a fixpoint, or bail out after N iters." - , " TRANS; TRANS Sequence two transforms." - , " Id Return the original program unharmed." - , " Anonymize Anonymize names to deBruijn form." - , " Namify Introduce fresh names for deBruijn binders." - , " Snip Introduce let-bindings for nested applications." - , " SnipOver ... and over-applications." - , " Flatten Flatten nested let-bindings." - , " Beta Perform beta-reduction for value arguments." - , " BetaLets ... introducing new let-bindings for redex arguments." - , " Bubble Float casts outwards, and combine similar ones." - , " Prune Erase unused, ineffectual let-bindings." - , " Forward Float let-bindings forward into their use sites." - , " Rewrite Perform rule based rewriting. Use 'set rule' to add rules." - , " Inline Perform inlining. Use 'with' to add source modules." - , " Elaborate Introduce default witnesses for unconstrained regions." , "" - , "Type Commands" - , " :kind TYPE Show the kind of a type." - , " :tequiv TYPE TYPE Check if two types are equivalent." + , "Data Flow Fusion Transforms" + , " These work on modules in the Disciple Core Flow (.dcf) fragment only." + , " :flow-prep MODULE Prepare a module for lowering." + , " :flow-lower MODULE Lower a module to loop code." + , " :flow-wind MODULE Wind loop primops into tail recursive loops." + , " :flow-concretize MODULE Rewrite primops to use concrete series lengths." + , " :flow-melt MODULE Melt compound data structures." + , " :flow-wind MODULE Wind loop primops into tail recursive loops." + , " :flow-thread MODULE Thread state token through program." + + , "Modes" + , " :set Display active modes and program transform." + , " :set +MODE Enable a mode." + , " :set /MODE Disable a mode." + , " :set lang LANG Set the language fragment." + , " :set builder BUILDER Set the builder." + , " :set outputdir DIR Set the output directory." + , " :set output FILE Set the output file." + , " :set trans TRANS Set the program transform." , "" - , "Witness Commands" - , " :wtype WITNESS Show the type of a witness expression." + , " :set rule NAME [an : kn] ... (xn : tn) ... exp1 = exp2" + , " Add a rewrite rule to the database." , "" - , "Expression Commands" - , " :check EXP Show the type, effect and closure of an exp." - , " :type EXP Show the type of an expression." - , " :effect EXP Show the effect of an expression." - , " :closure EXP Show the closure of an expression." - , " :eval EXP Evaluate an expression." - , " :ast EXP Show the abstract syntax tree of a exp." + , " :with PATH Use this module for 'set trans' inlining." + , " :with-lite PATH ... use Lite module during -compile or -make cmds." + , " :with-salt PATH ... use Salt module during -compile or -make cmds." , "" - , " :trans EXP Transform the given expression." - , " :trun EXP Transform the given expression then evaluate it." - , " :tinteract EXP Enter interactive transformation mode." + , " MODE ::=" + , " Synth Use type synthesis when loading source." + , " Indent Pretty print expressions with indenting." + , " TraceEval Show the expression at every step when evaluating." + , " TraceStore Show the store at every step when evaluating." + , " PrettyUseLetCase Pretty print single-alt case expressions as 'letcase'." + , " SuppressImports Suppress the import list when printing modules." + , " SuppressLetTypes Suppress type annots on let-binders." , "" - , "Module Commands" - , " :compile PATH Compile the module at this path to an object file." - , " :make PATH Make the module at this path into an executable." + , " LANG ::=" + , " Lite | Salt | Zero | Eval" , "" - , " :load MODULE Type check and desugar module source code." - , " :to-salt MODULE Convert module source code to Salt." - , " :to-c MODULE Convert module source code to C." - , " :to-llvm MODULE Convert module source code to LLVM." + , " BUILDER ::= " + , " x86_32-darwin | x86_64-darwin | x86_32-linux | x86_64-linux" + , " x86_32-cygwin | ppc32-linux" , "" - , "Data Flow Fusion Transforms" - , " :flow-prep MODULE Prepare a module for lowering." - , " :flow-lower MODULE Lower a module to loop code." - , " :flow-wind MODULE Wind loop primops into tail recursive loops." - , " :flow-concretize MODULE Rewrite primops to use concrete series lengths." + , " TRANS ::= " + , " { TRANS } Parenthesis." + , " fix N TRANS Transform to a fixpoint, or bail out after N iters." + , " TRANS; TRANS Sequence two transforms." + , " Id Return the original program unharmed." + , " Anonymize Anonymize names to deBruijn form." + , " Namify Introduce fresh names for deBruijn binders." + , " Snip Introduce let-bindings for nested applications." + , " SnipOver ... and over-applications." + , " Flatten Flatten nested let-bindings." + , " Beta Perform beta-reduction for value arguments." + , " BetaLets ... introducing new let-bindings for redex arguments." + , " Bubble Float casts outwards, and combine similar ones." + , " Prune Erase unused, ineffectual let-bindings." + , " Forward Float let-bindings forward into their use sites." + , " Rewrite Perform rule based rewriting. Use 'set rule' to add rules." + , " Inline Perform inlining. Use 'with' to add source modules." + , " Elaborate Introduce default witnesses for unconstrained regions." , "" ] diff --git a/src/ddci-core/DDCI/Core/Command/Set.hs b/src/ddci-core/DDCI/Core/Command/Set.hs --- a/src/ddci-core/DDCI/Core/Command/Set.hs +++ b/src/ddci-core/DDCI/Core/Command/Set.hs @@ -12,11 +12,11 @@ import DDC.Core.Fragment import DDC.Core.Simplifier.Parser import DDC.Core.Transform.Reannotate -import DDC.Core.Check import DDC.Base.Pretty import Control.Monad import Data.Char import Data.List +import qualified DDC.Core.Check as Check import qualified DDCI.Core.Rewrite as R import qualified Data.Map as Map import qualified Data.Set as Set @@ -89,7 +89,7 @@ = case R.parseRewrite fragment modules rest of Right (R.SetAdd name rule) -> do chatStrLn state $ "ok, added " ++ name - let rule' = reannotate (\a -> a { annotTail = ()}) rule + let rule' = reannotate (\a -> a { Check.annotTail = ()}) rule let rules' = Map.insert name rule' rules let bundle' = bundle { bundleRewriteRules = rules' } return $ state { stateLanguage = Language bundle' } diff --git a/src/ddci-core/DDCI/Core/Command/Trans.hs b/src/ddci-core/DDCI/Core/Command/Trans.hs deleted file mode 100644 --- a/src/ddci-core/DDCI/Core/Command/Trans.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# OPTIONS -Werror #-} - -module DDCI.Core.Command.Trans - ( cmdTrans - , cmdTransEval - , applyTransAndCheck) -where -import DDCI.Core.Command.Eval -import DDCI.Core.Output -import DDCI.Core.State -import DDC.Driver.Command.Check -import DDC.Core.Fragment -import DDC.Core.Transform.Reannotate -import DDC.Core.Simplifier -import DDC.Core.Check -import DDC.Core.Exp -import DDC.Core.Compounds -import DDC.Type.Equiv -import DDC.Type.Subsumes -import DDC.Base.Pretty -import DDC.Type.Env as Env -import qualified Control.Monad.State.Strict as S -import qualified DDC.Build.Language.Eval as Eval -import qualified DDC.Core.Eval.Name as Eval -import qualified Data.Set as Set -import Data.Typeable -import Control.Monad -import DDC.Core.Module - - --- Trans ---------------------------------------------------------------------- --- | Apply the current transform to an expression. -cmdTrans :: State -> Source -> String -> IO () -cmdTrans state source str - | Language bundle <- stateLanguage state - , fragment <- bundleFragment bundle - , modules <- bundleModules bundle - , simpl <- bundleSimplifier bundle - , zero <- bundleStateInit bundle - , profile <- fragmentProfile fragment - = cmdParseCheckExp fragment modules True source str - >>= goStore profile modules zero simpl - where - -- Expression had a parse or type error. - goStore _ _ _ _ Nothing - = do return () - - -- Expression is well-typed. - goStore profile modules zero simpl (Just x) - = do let kenv = modulesExportKinds modules (profilePrimKinds profile) - let tenv = modulesExportTypes modules (profilePrimTypes profile) - - tr <- applyTransAndCheck state profile kenv tenv zero simpl - $ reannotate (\a -> a { annotTail = ()}) x - - case tr of - Nothing -> return () - Just x' -> outDocLn state $ ppr x' - - --- TransEval ------------------------------------------------------------------ --- | Apply the current transform to an expression, --- then evaluate and display the result -cmdTransEval :: State -> Source -> String -> IO () -cmdTransEval state source str - | Language bundle <- stateLanguage state - , fragment <- bundleFragment bundle - , modules0 <- bundleModules bundle - , zero <- bundleStateInit bundle - , simpl0 <- bundleSimplifier bundle - , profile0 <- fragmentProfile fragment - - -- The evaluator only works on expressions with Eval.Names, - -- The actual name type is an existential of Bundle, - -- so we use gcast to check whether the bundle is really - -- set to Eval. - , Just (profile :: Profile Eval.Name) <- gcast profile0 - , Just (SimplBox simpl) <- gcast (SimplBox simpl0) - , Just (modules :: ModuleMap (AnTEC () Eval.Name) Eval.Name) - <- gcast modules0 - = do result' <- cmdParseCheckExp Eval.fragment modules False source str - case result' of - Nothing -> return () - Just xx - -> do let kenv = modulesExportKinds modules (profilePrimKinds profile) - let tenv = modulesExportTypes modules (profilePrimTypes profile) - - -- Apply the current transform. - tr <- applyTransAndCheck state profile kenv tenv zero simpl - $ reannotate (\a -> a { annotTail = () }) xx - - case tr of - Nothing -> return () - Just x' - -- Evaluate the transformed expression. - -> do outDocLn state $ ppr x' - evalExp state x' - return () - - | otherwise - = outDocLn state $ text "Language must be set to Eval for :teval" - - --- Proxies to help with type casting. --- The 'gcast' function will only cast the rightmost 'n' of a type, --- But there is also an 'n' attached to the annotation type of --- the simplifier. We use the proxy to cast both occurrences at once. -data SimplBox s n - = SimplBox (Simplifier s (AnTEC () n) n) - - --- Trans ---------------------------------------------------------------------- --- | Transform an expression, or display errors -applyTransAndCheck - :: (Eq n, Ord n, Pretty n, Show n) - => State - -> Profile n - -> Env n -- Kind Environment. - -> Env n -- Type Environment. - -> s - -> Simplifier s (AnTEC () n) n - -> Exp (AnTEC () n) n - -> IO (Maybe (Exp (AnTEC () n) n)) - -applyTransAndCheck state profile kenv tenv zero simpl xx - = do - let Just annot = takeAnnotOfExp xx - let t1 = annotType annot - let eff1 = annotEffect annot - let clo1 = annotClosure annot - - -- Apply the simplifier. - let tx = flip S.evalState zero - $ applySimplifierX profile kenv tenv simpl xx - - let x' = reannotate (const ()) $ result tx - - when (Set.member TraceTrans $ stateModes state) - $ case (resultInfo tx) of - TransformInfo inf - -> outDocLn state - $ text "* TRANSFORM INFORMATION: " <$> indent 4 (ppr inf) <$> text "" - - -- Check that the simplifier perserved the type of the expression. - case checkExp (configOfProfile profile) kenv tenv x' of - Right (x2, t2, eff2, clo2) - | equivT t1 t2 - , subsumesT kEffect eff1 eff2 - , subsumesT kClosure clo1 clo2 - -> do return (Just x2) - - | otherwise - -> do putStrLn $ renderIndent $ vcat - [ text "* CRASH AND BURN: Transform is not type preserving." - , ppr x' - , text ":: 1 " <+> ppr t1 - , text ":: 2 " <+> ppr t2 - , text ":!:1 " <+> ppr eff1 - , text ":!:2 " <+> ppr eff2 - , text ":$:1 " <+> ppr clo1 - , text ":$:2 " <+> ppr clo2 ] - return Nothing - - Left err - -> do putStrLn $ renderIndent $ vcat - [ text "* CRASH AND BURN: Type error in transformed program." - , ppr err - , text "" ] - - outDocLn state $ text "Transformed expression:" - outDocLn state $ ppr x' - return Nothing - diff --git a/src/ddci-core/DDCI/Core/Command/TransInteract.hs b/src/ddci-core/DDCI/Core/Command/TransInteract.hs --- a/src/ddci-core/DDCI/Core/Command/TransInteract.hs +++ b/src/ddci-core/DDCI/Core/Command/TransInteract.hs @@ -2,10 +2,10 @@ ( cmdTransInteract , cmdTransInteractLoop) where -import DDCI.Core.Command.Trans import DDCI.Core.Output import DDCI.Core.State import DDC.Driver.Command.Check +import DDC.Driver.Command.Trans import DDC.Build.Language import DDC.Core.Fragment import DDC.Core.Simplifier.Parser @@ -14,7 +14,8 @@ import DDC.Core.Check import DDC.Core.Module import DDC.Base.Pretty -import qualified Data.Map as Map +import qualified Data.Map as Map +import qualified Data.Set as Set -- TransInteract -------------------------------------------------------------- @@ -24,18 +25,14 @@ | Language bundle <- stateLanguage state , fragment <- bundleFragment bundle , modules <- bundleModules bundle - = cmdParseCheckExp fragment modules True source str + = cmdParseCheckExp fragment modules Recon False False source str >>= goStore bundle where - -- Expression had a parse or type error. - goStore _ Nothing - = do return state - -- Expression is well-typed. - goStore bundle (Just xx) + goStore bundle (Just xx, _) = do let xx' = reannotate (\a -> a { annotTail = () }) xx - let Just annot = takeAnnotOfExp xx' + let annot = annotOfExp xx' let t1 = annotType annot let eff1 = annotEffect annot let clo1 = annotClosure annot @@ -47,6 +44,10 @@ return state { stateTransInteract = Just hist } + -- Expression had a parse or type error. + goStore _ _ + = do return state + cmdTransInteractLoop :: State -> String -> IO State cmdTransInteractLoop state str @@ -96,16 +97,18 @@ return state Right tr' -> do - let kenv = modulesExportKinds + let kenv = modulesExportTypes (bundleModules bundle) (profilePrimKinds profile) - let tenv = modulesExportTypes + let tenv = modulesExportValues (bundleModules bundle) (profilePrimTypes profile) - x_trans <- applyTransAndCheck state profile kenv tenv - (bundleStateInit bundle) tr' x' + x_trans <- transExp + (Set.member TraceTrans $ stateModes state) + profile kenv tenv + (bundleStateInit bundle) tr' x' case x_trans of Nothing -> return state diff --git a/src/ddci-core/DDCI/Core/Command/With.hs b/src/ddci-core/DDCI/Core/Command/With.hs --- a/src/ddci-core/DDCI/Core/Command/With.hs +++ b/src/ddci-core/DDCI/Core/Command/With.hs @@ -13,9 +13,10 @@ import Control.Monad import Data.IORef import Data.Char -import qualified Data.Map as Map +import qualified DDC.Core.Check as C import qualified DDC.Build.Language.Lite as Lite import qualified DDC.Build.Language.Salt as Salt +import qualified Data.Map as Map -- | Add a module to the inliner table. @@ -39,18 +40,20 @@ = do res <- cmdWith_load Lite.fragment str case res of Nothing -> return state - Just mdl -> - return $ state - { stateWithLite = Map.insert (moduleName mdl) mdl (stateWithLite state) } + Just mdl + -> return $ state + { stateWithLite = Map.insert (moduleName mdl) mdl + (stateWithLite state) } cmdWithSalt :: State -> Source -> String -> IO State cmdWithSalt state _source str = do res <- cmdWith_load Salt.fragment str case res of Nothing -> return state - Just mdl -> - return $ state - { stateWithSalt = Map.insert (moduleName mdl) mdl (stateWithSalt state) } + Just mdl + -> return $ state + { stateWithSalt = Map.insert (moduleName mdl) mdl + (stateWithSalt state) } cmdWith_load frag str @@ -71,10 +74,10 @@ cmdWith_parse frag source src = do ref <- newIORef Nothing errs <- pipeText (nameOfSource source) (lineStartOfSource source) src - $ PipeTextLoadCore frag + $ PipeTextLoadCore frag C.Recon SinkDiscard [ PipeCoreReannotate (\a -> a { annotTail = ()}) [ PipeCoreHacks (Canned (\m -> writeIORef ref (Just m) >> return m)) - [PipeCoreOutput SinkDiscard] ]] + [ PipeCoreOutput pprDefaultMode SinkDiscard] ]] case errs of [] -> do diff --git a/src/ddci-core/DDCI/Core/Interface/Interactive.hs b/src/ddci-core/DDCI/Core/Interface/Interactive.hs --- a/src/ddci-core/DDCI/Core/Interface/Interactive.hs +++ b/src/ddci-core/DDCI/Core/Interface/Interactive.hs @@ -1,6 +1,6 @@ module DDCI.Core.Interface.Interactive - ( runInteractive) + (runInteractive) where import DDCI.Core.Input import DDCI.Core.State @@ -15,7 +15,7 @@ -- | Run an interactive session, reading commands from the console. runInteractive :: IO () runInteractive - = do putStrLn "DDCi-core, version 0.3.2: http://disciple.ouroborus.net." + = do putStrLn "DDCi-core, version 0.4.1: http://disciple.ouroborus.net." putStrLn "Type :help for help." -- Setup terminal mode. diff --git a/src/ddci-core/DDCI/Core/Mode.hs b/src/ddci-core/DDCI/Core/Mode.hs --- a/src/ddci-core/DDCI/Core/Mode.hs +++ b/src/ddci-core/DDCI/Core/Mode.hs @@ -5,30 +5,57 @@ where --- | DDCI mode flags. +-- | ddci-core mode flags. data Mode + -- | Use type synthesis / bidirectional type checking + -- when loading source code. + = Synth + + -- | Render expressions displayed to user using indenting. + | Indent + + -- Tracing -------------------- + -- | Display type checker trace with check commands. + | TraceCheck + -- | Display the expression at each step in the evaluation. - = TraceEval + | TraceEval -- | Display the store state at each step in the evaluation. | TraceStore - -- | Render expressions displayed to user using indenting. - | Indent + -- | Display information about each transformation step + | TraceTrans - -- | Suppress import lists when printing modules + -- Pretty Printer Config ------ + -- There is one mode here for each field in Driver.Config.ConfigPretty + + -- | Use 'letcase' when pretty printing core modules. + | PrettyUseLetCase + + -- | Display types on primitive variables. + | PrettyVarTypes + + -- | Display types on primitive constructors. + | PrettyConTypes + + -- | Suppress import lists when printing modules. | SuppressImports + -- | Suppress export lists when printing modules. + | SuppressExports + + -- | Suppress type annotations on let-bindings. + | SuppressLetTypes + + ------------------------------ -- | When pretty printing Salt modules as C code, -- include the #includes etc needed for compilation. | SaltPrelude -- | Dump all intermediate versions of the code during compilation. | Dump - - -- | Display information about each transformation step - | TraceTrans - + -- | Avoid type checking if possible. -- Helpful when debugging program transformations to see invalid -- code instead of an error message. @@ -40,13 +67,20 @@ readMode :: String -> Maybe Mode readMode str = case str of + "Synth" -> Just Synth + "Indent" -> Just Indent + "TraceCheck" -> Just TraceCheck "TraceEval" -> Just TraceEval "TraceStore" -> Just TraceStore - "Indent" -> Just Indent + "TraceTrans" -> Just TraceTrans + "PrettyUseLetCase" -> Just PrettyUseLetCase + "PrettyVarTypes" -> Just PrettyVarTypes + "PrettyConTypes" -> Just PrettyConTypes "SuppressImports" -> Just SuppressImports + "SuppressExports" -> Just SuppressExports + "SuppressLetTypes" -> Just SuppressLetTypes "SaltPrelude" -> Just SaltPrelude "Dump" -> Just Dump - "TraceTrans" -> Just TraceTrans "TaintAvoidTypeChecks" -> Just TaintAvoidTypeChecks _ -> Nothing diff --git a/src/ddci-core/DDCI/Core/Rewrite.hs b/src/ddci-core/DDCI/Core/Rewrite.hs --- a/src/ddci-core/DDCI/Core/Rewrite.hs +++ b/src/ddci-core/DDCI/Core/Rewrite.hs @@ -87,8 +87,8 @@ kinds = profilePrimKinds (fragmentProfile fragment) types = profilePrimTypes (fragmentProfile fragment) - kinds' = modulesExportKinds modules kinds - types' = modulesExportTypes modules types + kinds' = modulesExportTypes modules kinds + types' = modulesExportValues modules types -- | Display rule diff --git a/src/ddci-core/DDCI/Core/State.hs b/src/ddci-core/DDCI/Core/State.hs --- a/src/ddci-core/DDCI/Core/State.hs +++ b/src/ddci-core/DDCI/Core/State.hs @@ -3,7 +3,8 @@ ( State (..) , Bundle (..) , initState - , getDriverConfigOfState + , Mode (..) + , adjustMode , TransHistory (..) @@ -11,11 +12,11 @@ , Language (..) , languages - , getDefaultBuilderConfig - , getActiveBuilder - , Mode (..) - , adjustMode) + -- Driver config. + , getDriverConfigOfState + , getDefaultBuilderConfig + , getActiveBuilder) where import DDCI.Core.Mode import DDC.Code.Config @@ -23,7 +24,6 @@ import DDC.Interface.Source import DDC.Build.Builder import DDC.Build.Language -import DDC.Core.Check import DDC.Core.Exp import DDC.Core.Module import DDC.Core.Simplifier @@ -32,12 +32,14 @@ import System.FilePath import Data.Map (Map) import Data.Set (Set) +import DDC.Core.Check (AnTEC(..)) import qualified DDC.Build.Language.Eval as Eval import qualified DDC.Core.Salt as Salt import qualified DDC.Core.Lite as Lite import qualified DDC.Core.Simplifier as S import qualified DDC.Core.Salt.Runtime as Runtime import qualified DDC.Driver.Stage as D +import qualified DDC.Driver.Config as D import qualified Data.Map as Map import qualified Data.Set as Set @@ -129,8 +131,9 @@ = do builder <- getActiveBuilder state return $ D.Config - { D.configDump = Set.member Dump (stateModes state) - , D.configViaBackend = D.ViaLLVM + { D.configDump = Set.member Dump (stateModes state) + , D.configInferTypes = Set.member Synth (stateModes state) + , D.configViaBackend = D.ViaLLVM -- ISSUE #300: Allow the default heap size to be set when -- compiling the program. @@ -143,7 +146,7 @@ , D.configSimplLite = stateSimplLite state , D.configSimplSalt = stateSimplSalt state , D.configBuilder = builder - , D.configSuppressCoreImports = Set.member SuppressImports (stateModes state) + , D.configPretty = configPretty , D.configSuppressHashImports = not $ Set.member SaltPrelude (stateModes state) , D.configKeepLlvmFiles = False , D.configKeepSeaFiles = False @@ -152,7 +155,18 @@ , D.configTaintAvoidTypeChecks = Set.member TaintAvoidTypeChecks (stateModes state) } + where modes = stateModes state + + configPretty + = D.ConfigPretty + { D.configPrettyVarTypes = Set.member PrettyVarTypes modes + , D.configPrettyConTypes = Set.member PrettyConTypes modes + , D.configPrettyUseLetCase = Set.member PrettyUseLetCase modes + , D.configPrettySuppressImports = Set.member SuppressImports modes + , D.configPrettySuppressExports = Set.member SuppressExports modes + , D.configPrettySuppressLetTypes = Set.member SuppressLetTypes modes } + -- | Holds platform independent builder info. getDefaultBuilderConfig :: IO BuilderConfig getDefaultBuilderConfig @@ -174,7 +188,7 @@ -> do config <- getDefaultBuilderConfig mBuilder <- determineDefaultBuilder config case mBuilder of - Nothing -> error "getActiveBuilder unrecognised host platform" + Nothing -> error "ddci-core.getActiveBuilder: unrecognised host platform" Just builder -> return builder diff --git a/src/ddci-core/DDCI/Core/Stats/Trace.hs b/src/ddci-core/DDCI/Core/Stats/Trace.hs --- a/src/ddci-core/DDCI/Core/Stats/Trace.hs +++ b/src/ddci-core/DDCI/Core/Stats/Trace.hs @@ -26,14 +26,12 @@ traceStoreX store entered xx = let down = traceStoreX store entered in case xx of - XVar{} -> xx - - XCon _ dc - | Just n@(NameLoc l) <- takeNameOfDaCon dc - , not $ Set.member n entered + XVar _ (UPrim n@(NameLoc l) _) + | not $ Set.member n entered , Just sbind <- lookupBind l store -> traceStoreX store (Set.insert n entered) (expOfSBind sbind) + XVar{} -> xx XCon{} -> xx XApp a x1 x2 -> XApp a (down x1) (down x2) XLAM a b x -> XLAM a b (down x) @@ -52,7 +50,7 @@ in case ls of LLet b x -> LLet b (down x) LRec bxs -> LRec [(b, down x) | (b, x) <- bxs] - LLetRegions{} -> ls + LPrivate{} -> ls LWithRegion{} -> ls @@ -78,5 +76,5 @@ -- | Convert a store location to a constructor expression. expOfLoc :: Loc -> Exp () Name -expOfLoc l = XCon () (mkDaConSolid (NameLoc l) (tBot kData)) +expOfLoc l = XVar () (UPrim (NameLoc l) (tBot kData)) diff --git a/src/ddci-tetra/DDCI/Tetra/Command.hs b/src/ddci-tetra/DDCI/Tetra/Command.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command.hs @@ -0,0 +1,123 @@ + +module DDCI.Tetra.Command + ( Command (..) + , commands + , readCommand + , handleCommand) +where +import DDCI.Tetra.State +import DDCI.Tetra.Command.Help +import DDCI.Tetra.Command.Set +import DDCI.Tetra.Command.Parse +import DDCI.Tetra.Command.Desugar +import DDCI.Tetra.Command.Infer +import DDCI.Tetra.Command.ToCore +import DDC.Interface.Source +import DDC.Driver.Command.ToSalt +import Control.Monad.Trans.Error +import Data.List +import System.IO + + +-- | Commands accepted by ddci-tetra. +data Command + = CommandBlank -- ^ No command was entered. + | CommandUnknown -- ^ Some unknown (invalid) command. + | CommandHelp -- ^ Display the interpreter help. + | CommandSet -- ^ Set an interpreter mode. + | CommandParse -- ^ Parse a Tetra source module. + | CommandDesugar -- ^ Desugar a Tetra source module. + | CommandInfer -- ^ Perform type inference. + | CommandToCore -- ^ Convert to Core Tetra. + | CommandToSalt -- ^ Convert to Core Salt. + deriving (Eq, Show) + + +-- | Names used to invoke each command. +commands :: [(String, Command)] +commands + = [ (":help", CommandHelp) + , (":?", CommandHelp) + , (":set", CommandSet) + , (":parse", CommandParse) + , (":desugar", CommandDesugar) + , (":infer", CommandInfer) + , (":to-core", CommandToCore) + , (":to-salt", CommandToSalt) ] + + +-- | Read the command from the front of a string. +readCommand :: String -> Maybe (Command, String) +readCommand ss + | null $ words ss + = Just (CommandBlank, ss) + + | (cmd, rest) : _ + <- [ (cmd, drop (length str) ss) + | (str, cmd) <- commands + , isPrefixOf str ss ] + = Just (cmd, rest) + + | ':' : _ <- ss + = Just (CommandUnknown, ss) + + | otherwise + = Nothing + + +handleCommand :: State -> Command -> Source -> String -> IO State +handleCommand state cmd source line + = do state' <- handleCommand1 state cmd source line + return state' + +handleCommand1 state cmd source line + = case cmd of + CommandBlank + -> return state + + CommandUnknown + -> do putStr $ unlines + [ "unknown command." + , "use :? for help." ] + + return state + + CommandHelp + -> do putStrLn help + return state + + CommandSet + -> do state' <- cmdSet state line + return state' + + CommandParse + -> do cmdParse state source line + return state + + CommandDesugar + -> do cmdDesugar state source line + return state + + CommandInfer + -> do cmdInfer state source line + return state + + CommandToCore + -> do config <- getDriverConfigOfState state + cmdToCore state config source line + return state + + CommandToSalt + -> do config <- getDriverConfigOfState state + runError $ cmdToSaltSourceTetraFromString config source line + return state + + +-- | Just print errors to stdout and continue the session. +runError :: ErrorT String IO () -> IO () +runError m + = do result <- runErrorT m + case result of + Left err -> hPutStrLn stdout err + Right _ -> return () + diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs b/src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs @@ -0,0 +1,38 @@ + +module DDCI.Tetra.Command.Desugar + (cmdDesugar) +where +import DDC.Interface.Source +import DDCI.Tetra.State +import DDC.Base.Pretty +import DDC.Source.Tetra.Lexer +import DDC.Source.Tetra.Parser +import DDC.Source.Tetra.Pretty () +import DDC.Source.Tetra.Transform.Defix +import qualified DDC.Core.Lexer as C +import qualified DDC.Base.Parser as BP + + +cmdDesugar :: State -> Source -> String -> IO () +cmdDesugar _state source str + = goLex + where goLex + = let tokens = lexModuleString (nameOfSource source) 1 str + in goParse tokens + + goParse tokens + = let context = Context + { contextTrackedEffects = True + , contextTrackedClosures = True + , contextFunctionalEffects = False + , contextFunctionalClosures = False } + + in case BP.runTokenParser C.describeTok (nameOfSource source) + (pModule context) tokens of + Left err -> error $ show err + Right mm -> goDesugar mm + + goDesugar mm + = case defix defaultFixTable mm of + Left err -> putStrLn (renderIndent $ ppr err) + Right mm' -> putStrLn (renderIndent $ ppr mm') diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Help.hs b/src/ddci-tetra/DDCI/Tetra/Command/Help.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command/Help.hs @@ -0,0 +1,36 @@ + +module DDCI.Tetra.Command.Help +where + +help :: String +help = unlines + [ "-------------------------------------------------------------------- Usage --" + , "" + , " On the command line" + , " Prefix commands with '-'" + , " $ ddci-tetra -parse \"\\(x : Unit). x\"" + , "" + , " Read input from a file with ':'" + , " $ ddci-tetra -load: SomeFile.dst" + , "" + , " Interactively" + , " Prefix commands with ':'" + , " > :check \\(x : Unit). x" + , "" + , " Split commands over multiple lines with '..', terminating with ';;'" + , " > :check.." + , " \\(x : Unit). x;;" + , "" + , " Read input from a file with '<'" + , " > :load< SomeFile.dst" + , "" + , "----------------------------------------------------------------- Commands --" + , "General" + , " :quit Exit DDCi-core." + , " :help Display this help page." + , " :parse MODULE Parse a module." + , " :desugar MODULE Desugar a module." + , " :infer MODULE Prepare a module for type inference." + , " :to-core MODULE Convert a module to Core Tetra." + , " :to-salt MODULE Convert a module to Core Salt." + ] diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs b/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs @@ -0,0 +1,46 @@ + +module DDCI.Tetra.Command.Infer + (cmdInfer) +where +import DDC.Interface.Source +import DDCI.Tetra.State +import DDC.Base.Pretty +import DDC.Source.Tetra.Env +import DDC.Source.Tetra.Lexer +import DDC.Source.Tetra.Parser +import DDC.Source.Tetra.Pretty () +import DDC.Source.Tetra.Transform.Defix +import DDC.Source.Tetra.Transform.Expand as Expand +import qualified DDC.Core.Lexer as C +import qualified DDC.Base.Parser as BP + + +cmdInfer :: State -> Source -> String -> IO () +cmdInfer _state source str + = goLex + where goLex + = let tokens = lexModuleString (nameOfSource source) 1 str + in goParse tokens + + goParse tokens + = let context = Context + { contextTrackedEffects = True + , contextTrackedClosures = True + , contextFunctionalEffects = False + , contextFunctionalClosures = False } + + in case BP.runTokenParser C.describeTok (nameOfSource source) + (pModule context) tokens of + Left err -> error $ show err + Right mm -> goDesugar mm + + goDesugar mm + = case defix defaultFixTable mm of + Left err -> putStrLn (renderIndent $ ppr err) + Right mm' -> goExpand mm' + + goExpand mm + = do let mm' = Expand.expand Expand.configDefault + primKindEnv primTypeEnv mm + putStrLn (renderIndent $ ppr mm') + diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs b/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs @@ -0,0 +1,36 @@ + +module DDCI.Tetra.Command.Parse + (cmdParse) +where +import DDC.Interface.Source +import DDCI.Tetra.State +import DDC.Base.Pretty +import DDC.Source.Tetra.Lexer +import DDC.Source.Tetra.Parser +import DDC.Source.Tetra.Pretty () +import qualified DDC.Core.Lexer as C +import qualified DDC.Base.Parser as BP + + +cmdParse :: State -> Source -> String -> IO () +cmdParse _state source str + = goLex + where goLex + = let tokens = lexModuleString (nameOfSource source) 1 str + in goParse tokens + + goParse tokens + = let context = Context + { contextTrackedEffects = True + , contextTrackedClosures = True + , contextFunctionalEffects = False + , contextFunctionalClosures = False } + + in case BP.runTokenParser + C.describeTok + (nameOfSource source) + (pModule context) + tokens of + Left err -> error $ show err + Right mm + -> do putStrLn (renderIndent $ ppr mm) diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Set.hs b/src/ddci-tetra/DDCI/Tetra/Command/Set.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command/Set.hs @@ -0,0 +1,73 @@ + +module DDCI.Tetra.Command.Set + (cmdSet) +where +import DDCI.Tetra.State +import DDCI.Tetra.Mode +import DDC.Build.Builder +import DDC.Base.Pretty +import Data.Char +import Data.List +import qualified Data.Set as Set + + +cmdSet :: State -> String -> IO State + +cmdSet state [] + = do putDocLn RenderIndent + $ vcat [ text "Modes: " + <> text (show $ Set.toList $ stateModes state) ] + + return state + +cmdSet state cmd + | "builder" : name : [] <- words cmd + = do config <- getDefaultBuilderConfig + case find (\b -> builderName b == name) (builders config) of + Nothing + -> do putStrLn "unknown builder" + return state + + Just builder + -> do putStrLn "ok" + return state { stateBuilder = Just builder } + + | otherwise + = case parseModeChanges cmd of + Just changes + -> do let state' = foldr (uncurry adjustMode) state changes + putStrLn "ok" + return state' + + Nothing + -> do putStrLn "mode parse error" + return state + + +-- | Parse a string of mode changes. +parseModeChanges :: String -> Maybe [(Bool, Mode)] +parseModeChanges str + = sequence $ map parseModeChange $ words str + + +-- | Parse a mode change setting. +-- "Mode" or "+Mode" to enable. "-Mode" to disable. +parseModeChange :: String -> Maybe (Bool, Mode) +parseModeChange str + = case str of + ('+' : strMode) + | Just mode <- readMode strMode + -> Just (True, mode) + + ('/' : strMode) + | Just mode <- readMode strMode + -> Just (False, mode) + + (c : strMode) + | isUpper c + , Just mode <- readMode (c : strMode) + -> Just (True, mode) + + _ -> Nothing + + diff --git a/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs b/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs @@ -0,0 +1,28 @@ +module DDCI.Tetra.Command.ToCore + (cmdToCore) +where +import DDCI.Tetra.State +import DDC.Interface.Source +import DDC.Driver.Stage +import DDC.Build.Pipeline +import DDC.Base.Pretty +import qualified DDC.Driver.Config as D + + +-- Convert Disciple Source Tetra text into Disciple Core Tetra. +cmdToCore :: State -> D.Config -> Source -> String -> IO () +cmdToCore _state config source str + = let + pmode = D.prettyModeOfConfig $ D.configPretty config + + pipeLoad + = pipeText (nameOfSource source) (lineStartOfSource source) str + $ stageSourceTetraLoad config source + [ PipeCoreOutput pmode SinkStdout ] + + in do + errs <- pipeLoad + case errs of + [] -> return () + es -> putStrLn (renderIndent $ ppr es) + diff --git a/src/ddci-tetra/DDCI/Tetra/Input.hs b/src/ddci-tetra/DDCI/Tetra/Input.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Input.hs @@ -0,0 +1,34 @@ + +module DDCI.Tetra.Input + ( InputState (..) + , Input (..) + , readInput + , eatLine) +where +import DDCI.Tetra.State +import DDCI.Tetra.Command +import DDC.Interface.Input + + +-- Eating input lines. +eatLine :: State + -> InputState Command + -> String + -> IO (State, InputState Command) + +eatLine state inputState chunk + = do (inputState', mCmdLine) + <- inputLine (stateInterface state) inputState chunk + + case mCmdLine of + Nothing + -> return (state, inputState') + + Just (source, Nothing, line) + -> do state' <- handleCommand state CommandHelp source line + return (state', inputState') + + Just (source, Just cmd, line) + -> do state' <- handleCommand state cmd source line + return (state', inputState') + diff --git a/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs b/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs @@ -0,0 +1,49 @@ + +module DDCI.Tetra.Interface.Args + (runArgs) +where +import DDCI.Tetra.Command.Help +import DDCI.Tetra.Command +import DDCI.Tetra.State +import DDC.Interface.Input +import DDC.Interface.Source +import DDC.Data.ListUtils +import Data.List + + +-- | Run in unix command-line mode, reading commands from a list of arguments. +runArgs :: [String] -> IO () +runArgs args + = do let state = initState InputInterfaceArgs + + -- If the help command is one of the arguments then just + -- display the help and don't do anything else. + if elem "--help" args + then putStr help + else loop state args + + where + -- No more args, we're done. + loop _state [] + = do return () + + loop state (('-':cmdColon) : filePath : rest) + | isSuffixOf ":" cmdColon + , Just cmdStr <- takeInit cmdColon + , Just (cmd, []) <- readCommand (':' : cmdStr) + = do contents <- readFile filePath + state' <- handleCommand state cmd (SourceFile filePath) + contents + loop state' rest + + loop state (('-':cmdStr) : rest) + | Just (cmd, []) <- readCommand (':' : cmdStr) + , (argss, more) <- break (isPrefixOf "-") rest + = do state' <- handleCommand state cmd SourceArgs + (concat $ intersperse " " argss) + loop state' more + + loop _state xs + = error $ "Cannot parse arguments: " + ++ intercalate " " xs + diff --git a/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs b/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs @@ -0,0 +1,62 @@ + +module DDCI.Tetra.Interface.Batch + (runBatch) +where +import DDCI.Tetra.State +import DDCI.Tetra.Input +import DDCI.Tetra.Command +import DDC.Interface.Input +import Data.List + + +-- | Run in batch mode, reading commands from the given string. +runBatch :: FilePath -> String -> IO () +runBatch filePath str + = do let state = initState (InputInterfaceBatch filePath) + + let inputState + = InputState + { inputParseCommand = readCommand + , inputMode = InputLine + , inputCommand = Nothing + , inputLineNumber = 1 + , inputAcc = [] } + + + loop state inputState (lines str) + where + -- No more lines, we're done. + -- There might be a command in the buffer though. + loop state inputState [] + = do eatLine state inputState [] + return () + + loop state inputState (l:ls) + -- Echo comment lines back. + | isPrefixOf "--" l + = do putStrLn l + let inputState' + = inputState + { inputLineNumber = inputLineNumber inputState + 1 } + + loop state inputState' ls + + -- Echo blank lines back if we're between commands. + | Nothing <- inputCommand inputState + , null l + = do putStr "\n" + let inputState' + = inputState + { inputLineNumber = inputLineNumber inputState + 1 } + + loop state inputState' ls + + -- Quit the program. + | isPrefixOf ":quit" l + = do return () + + -- Handle a line of input. + | otherwise + = do (state', inputState') <- eatLine state inputState l + loop state' inputState' ls + diff --git a/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs b/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs @@ -0,0 +1,59 @@ + +module DDCI.Tetra.Interface.Interactive + (runInteractive) +where +import DDCI.Tetra.Input +import DDCI.Tetra.State +import DDCI.Tetra.Command +import DDC.Interface.Input +import Data.List +import Data.Maybe +import qualified System.Console.Haskeline as HL +import qualified System.Console.Haskeline.IO as HL + + +-- | Run an interactive session, reading commands from the console. +runInteractive :: IO () +runInteractive + = do putStrLn "DDCi-tetra, version 0.4.1: http://disciple.ouroborus.net." + putStrLn "Type :help for help." + + -- Setup terminal mode. + loopInteractive + + +-- | The main REPL loop. +loopInteractive :: IO () +loopInteractive + = do hlState <- HL.initializeInput HL.defaultSettings + let state = initState InputInterfaceConsole + + let inputState + = InputState + { inputParseCommand = readCommand + , inputMode = InputLine + , inputCommand = Nothing + , inputLineNumber = 1 + , inputAcc = [] } + + loop state inputState hlState + where + loop state inputState hlState + = do -- Read a line from the user and echo it back. + line <- getInput hlState "> " + + if isPrefixOf ":quit" line + || isPrefixOf ":q" line + then return () + else do + (state', inputState') + <- eatLine state inputState line + + loop state' inputState' hlState + + +-- | Get an input line from the console, using given prompt +getInput :: HL.InputState -> String -> IO String +getInput hlState prompt + = do line <- HL.queryInput hlState (HL.getInputLine prompt) + return (fromMaybe ":quit" line) diff --git a/src/ddci-tetra/DDCI/Tetra/Mode.hs b/src/ddci-tetra/DDCI/Tetra/Mode.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Mode.hs @@ -0,0 +1,50 @@ + +module DDCI.Tetra.Mode + ( Mode (..) + , readMode) +where + + +-- | ddci-tetra mode flags. +data Mode + -- | Dump all intermediate versions of the code during compilation. + = Dump + + -- Pretty Printer Config ------ + -- There is one mode here for each field in Driver.Config.ConfigPretty + + -- | Use 'letcase' when pretty printing core modules. + | PrettyUseLetCase + + -- | Display types on primitive variables. + | PrettyVarTypes + + -- | Display types on primitive constructors. + | PrettyConTypes + + -- | Suppress import lists when printing modules. + | SuppressImports + + -- | Suppress export lists when printing modules. + | SuppressExports + + -- | Suppress type annotations on let-bindings. + | SuppressLetTypes + + deriving (Eq, Ord, Show) + + +-- Parse a mode from a string. +readMode :: String -> Maybe Mode +readMode str + = case str of + "Dump" -> Just Dump + "PrettyUseLetCase" -> Just PrettyUseLetCase + "PrettyVarTypes" -> Just PrettyVarTypes + "PrettyConTypes" -> Just PrettyConTypes + "SuppressImports" -> Just SuppressImports + "SuppressExports" -> Just SuppressExports + "SuppressLetTypes" -> Just SuppressLetTypes + _ -> Nothing + + diff --git a/src/ddci-tetra/DDCI/Tetra/Output.hs b/src/ddci-tetra/DDCI/Tetra/Output.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/Output.hs @@ -0,0 +1,41 @@ + +module DDCI.Tetra.Output + ( outDoc, outDocLn + , outStr, outStrLn + , chatStrLn) +where +import DDCI.Tetra.State +import DDC.Interface.Input +import DDC.Base.Pretty + + +-- | Output a document to the console. +outDoc :: State -> Doc -> IO () +outDoc _state doc + = putDocLn RenderIndent doc + + +outDocLn :: State -> Doc -> IO () +outDocLn _state doc + = putDocLn RenderIndent doc + + +-- | Output a string to the console. +outStr :: State -> String -> IO () +outStr _state str + = putStr str + + +outStrLn :: State -> String -> IO () +outStrLn _state str + = putStrLn str + + +-- | Output chatty 'ok' type responses. +-- These are only displayed in the Interactive and Batch interfaces. +chatStrLn :: State -> String -> IO () +chatStrLn state str + = case stateInterface state of + InputInterfaceConsole -> putStrLn str + InputInterfaceBatch _ -> putStrLn str + _ -> return () diff --git a/src/ddci-tetra/DDCI/Tetra/State.hs b/src/ddci-tetra/DDCI/Tetra/State.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/DDCI/Tetra/State.hs @@ -0,0 +1,127 @@ + +module DDCI.Tetra.State + ( State (..) + , initState + , adjustMode + + -- * Driver Config + , getDriverConfigOfState + , getDefaultBuilderConfig) +where +import DDCI.Tetra.Mode +import DDC.Code.Config +import DDC.Interface.Input +import DDC.Build.Builder +import System.FilePath +import Data.Set (Set) +import qualified DDC.Core.Simplifier as S +import qualified DDC.Driver.Stage as D +import qualified DDC.Driver.Config as D +import qualified DDC.Core.Salt.Runtime as Runtime +import qualified Data.Set as Set + + +------------------------------------------------------------------------------- +data State + = State + { -- ddci interface state + stateInterface :: InputInterface + + -- ddci mode flags. + , stateModes :: Set Mode + + -- Force the builder to this one, which sets the address width etc. + -- If `Nothing` then query the host system for the default builder. + , stateBuilder :: Maybe Builder } + + +-- | Initial ddci-tetra state. +initState :: InputInterface -> State +initState interface + = State + { stateInterface = interface + , stateModes = Set.empty + , stateBuilder = Nothing } + + +-- | Adjust a mode setting in the state. +adjustMode + :: Bool -- ^ Whether to enable or disable the mode. + -> Mode -- ^ Mode to adjust. + -> State -> State + +adjustMode True mode state + = state { stateModes = Set.insert mode (stateModes state) } + +adjustMode False mode state + = state { stateModes = Set.delete mode (stateModes state) } + + +-- Driver Config -------------------------------------------------------------- +-- | Slurp out the relevant parts of the ddci-tetra state into a driver config. +-- The driver config controls how the compiler treats core files. +-- +getDriverConfigOfState :: State -> IO D.Config +getDriverConfigOfState state + = do builder <- getActiveBuilder state + return + $ D.Config + { D.configDump = Set.member Dump (stateModes state) + , D.configInferTypes = False + , D.configViaBackend = D.ViaLLVM + + -- ISSUE #300: Allow the default heap size to be set when + -- compiling the program. + , D.configRuntime + = Runtime.Config + { Runtime.configHeapSize = 65536 } + + , D.configOutputFile = Nothing + , D.configOutputDir = Nothing + , D.configSimplLite = S.Trans S.Id + , D.configSimplSalt = S.Trans S.Id + , D.configBuilder = builder + , D.configPretty = configPretty + , D.configSuppressHashImports = False + , D.configKeepLlvmFiles = False + , D.configKeepSeaFiles = False + , D.configKeepAsmFiles = False + + , D.configTaintAvoidTypeChecks = False + } + + where modes = stateModes state + configPretty + = D.ConfigPretty + { D.configPrettyVarTypes = Set.member PrettyVarTypes modes + , D.configPrettyConTypes = Set.member PrettyConTypes modes + , D.configPrettyUseLetCase = Set.member PrettyUseLetCase modes + , D.configPrettySuppressImports = Set.member SuppressImports modes + , D.configPrettySuppressExports = Set.member SuppressExports modes + , D.configPrettySuppressLetTypes = Set.member SuppressLetTypes modes } + + +-- | Holds platform independent builder info. +getDefaultBuilderConfig :: IO BuilderConfig +getDefaultBuilderConfig + = do baseLibraryPath <- locateBaseLibrary + return $ BuilderConfig + { builderConfigBaseSrcDir = baseLibraryPath + , builderConfigBaseLibDir = baseLibraryPath "build" } + + +-- | Get the active builder. +-- If one is set explicitly in the state then use that, +-- otherwise query the host system to determine the builder. +-- If that fails as well then 'error'. +getActiveBuilder :: State -> IO Builder +getActiveBuilder state + = case stateBuilder state of + Just builder -> return builder + Nothing + -> do config <- getDefaultBuilderConfig + mBuilder <- determineDefaultBuilder config + case mBuilder of + Nothing -> error "ddci-tetra.getActiveBuilder: unrecognised host platform" + Just builder -> return builder + diff --git a/src/ddci-tetra/Main.hs b/src/ddci-tetra/Main.hs new file mode 100644 --- /dev/null +++ b/src/ddci-tetra/Main.hs @@ -0,0 +1,37 @@ + +-- | Interactive interface to DDC for Tetra programs. +-- This also accepts interpreter commands as arguments on the command-line. +-- If you want a more unixy inferface then use the ddc-main interface instead. +module Main where +import DDCI.Tetra.Command.Help +import DDCI.Tetra.Interface.Args +import DDCI.Tetra.Interface.Batch +import DDCI.Tetra.Interface.Interactive +import System.Environment +import Data.List + + +main :: IO () +main + = do args <- getArgs + case args of + [] -> runInteractive + + -- Display the help. + ["--help"] + -> putStr help + + -- Run commands from a file in batch mode. + ["--batch", filePath] + -> do file <- readFile filePath + runBatch filePath file + + -- Run a Disciple-Core-Exchange file. + [filePath] + | isSuffixOf ".dsx" filePath + -> do file <- readFile filePath + runBatch filePath file + + + _ -> runArgs args +