diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -6,7 +6,8 @@ import System.Process import System.Exit -main = defaultMainWithHooks hooks +main + = defaultMainWithHooks hooks hooks = simpleUserHooks { postInst = hookPostInstall } 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.4.1.3 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -12,13 +12,14 @@ Synopsis: Disciplined Disciple Compiler command line tools. Description: Disciplined Disciple Compiler command line tools. + Executable ddc-check hs-source-dirs: src/ddc-check Build-depends: - base >= 4.6 && < 4.8, - ddc-core == 0.4.1.* + base >= 4.6 && < 4.9, + ddc-core == 0.4.2.* Main-is: Main.hs @@ -34,25 +35,23 @@ src/ddc-main Build-depends: - base >= 4.6 && < 4.8, + base >= 4.6 && < 4.9, process >= 1.1 && < 1.3, containers == 0.5.*, - filepath == 1.3.*, - haskeline >= 0.7.1.3, + filepath >= 1.3 && < 1.5, + haskeline == 0.7.*, directory == 1.2.*, - mtl == 2.2.*, + mtl == 2.2.1.*, transformers == 0.4.*, - 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.* + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-simpl == 0.4.2.*, + ddc-core-salt == 0.4.2.*, + ddc-core-llvm == 0.4.2.*, + ddc-core-tetra == 0.4.2.*, + ddc-code == 0.4.2.*, + ddc-build == 0.4.2.*, + ddc-driver == 0.4.2.* Main-is: Main.hs @@ -71,31 +70,28 @@ src/ddci-core Build-depends: - base >= 4.6 && < 4.8, + base >= 4.6 && < 4.9, process >= 1.1 && < 1.3, containers == 0.5.*, - filepath == 1.3.*, + filepath >= 1.3 && < 1.5, haskeline == 0.7.*, directory == 1.2.*, - mtl == 2.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.* + mtl == 2.2.1.*, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-simpl == 0.4.2.*, + ddc-core-salt == 0.4.2.*, + ddc-core-llvm == 0.4.2.*, + ddc-core-flow == 0.4.2.*, + ddc-core-tetra == 0.4.2.*, + ddc-code == 0.4.2.*, + ddc-build == 0.4.2.*, + ddc-driver == 0.4.2.* Main-is: Main.hs Other-modules: - DDCI.Core.Command.Eval DDCI.Core.Command.Help DDCI.Core.Command.Set DDCI.Core.Command.TransInteract @@ -105,8 +101,6 @@ DDCI.Core.Interface.Batch DDCI.Core.Interface.Interactive - DDCI.Core.Stats.Trace - DDCI.Core.Command DDCI.Core.Input DDCI.Core.Mode @@ -115,19 +109,19 @@ DDCI.Core.State Extensions: - DoAndIfThenElse - PatternGuards - ParallelListComp - FlexibleContexts ExistentialQuantification - MultiParamTypeClasses FunctionalDependencies + MultiParamTypeClasses TypeSynonymInstances - FlexibleInstances + ScopedTypeVariables StandaloneDeriving + FlexibleInstances + ParallelListComp + FlexibleContexts KindSignatures + DoAndIfThenElse + PatternGuards RankNTypes - ScopedTypeVariables ghc-options: -Wall @@ -141,26 +135,24 @@ src/ddci-tetra Build-depends: - base >= 4.6 && < 4.8, + base >= 4.6 && < 4.9, process >= 1.1 && < 1.3, containers == 0.5.*, - filepath == 1.3.*, + filepath >= 1.3 && < 1.5, haskeline == 0.7.*, directory == 1.2.*, - mtl == 2.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-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.* + mtl == 2.2.1.*, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-simpl == 0.4.2.*, + ddc-core-salt == 0.4.2.*, + ddc-core-llvm == 0.4.2.*, + ddc-core-flow == 0.4.2.*, + ddc-core-tetra == 0.4.2.*, + ddc-source-tetra == 0.4.2.*, + ddc-code == 0.4.2.*, + ddc-build == 0.4.2.*, + ddc-driver == 0.4.2.* Main-is: Main.hs @@ -184,19 +176,19 @@ DDCI.Tetra.State Extensions: - DoAndIfThenElse - PatternGuards - ParallelListComp - FlexibleContexts ExistentialQuantification - MultiParamTypeClasses FunctionalDependencies + MultiParamTypeClasses TypeSynonymInstances - FlexibleInstances + ScopedTypeVariables StandaloneDeriving + FlexibleInstances + FlexibleContexts + ParallelListComp + DoAndIfThenElse KindSignatures + PatternGuards RankNTypes - ScopedTypeVariables ghc-options: -Wall diff --git a/src/ddc-check/Config.hs b/src/ddc-check/Config.hs --- a/src/ddc-check/Config.hs +++ b/src/ddc-check/Config.hs @@ -1,9 +1,9 @@ module Config where import DDC.Build.Language -import qualified DDC.Build.Language.Lite as Lite import System.FilePath import System.Exit +import qualified DDC.Build.Language.Tetra as Tetra -- | DDC type checker command line interface config. @@ -24,7 +24,7 @@ defaultConfig = Config { configSourceFile = Nothing - , configLanguage = Language Lite.bundle + , configLanguage = Language Tetra.bundle , configQuiet = False } @@ -81,7 +81,7 @@ , " Flags:" , " -help Display this help." , " -quiet Don't print checked module to stdout." - , " -language Set the language fragment. (default Lite)" + , " -language Set the language fragment. (default Tetra)" , " fragment one of " ++ (show $ map fst languages) , "" ] 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 @@ -47,6 +47,11 @@ = parseArgs rest $ setMode config $ ModeMake file + | flag : file : rest <- args + , elem flag ["-build", "--build"] + = parseArgs rest + $ setMode config $ ModeBuild file + | "-basedir" : path : rest <- args = parseArgs rest $ config { configBaseDir = path } @@ -76,14 +81,12 @@ -- Optimisation ------------------------- | "-O0" : rest <- args = parseArgs rest - $ config { configOptLevelLite = OptLevel0 - , configOptLevelSalt = OptLevel0 } + $ config { configOptLevelSalt = OptLevel0 } | flag : rest <- args , elem flag [ "-O", "-O1" ] = parseArgs rest - $ config { configOptLevelLite = OptLevel1 - , configOptLevelSalt = OptLevel1 } + $ config { configOptLevelSalt = OptLevel1 } -- Intermediates ------------------------ | flag : rest <- args @@ -105,8 +108,12 @@ | "-run-heap" : bytes : rest <- args , all isDigit bytes = parseArgs rest - $ config { configRuntimeHeapSize = read bytes } + $ config { configRuntimeHeapSize = read bytes } + | "-run-link-static" : rest <- args + = parseArgs rest + $ config { configRuntimeLinkStrategy = LinkStatic } + -- Parsing ------------------------------ | "-parse" : file : rest <- args = parseArgs rest @@ -130,6 +137,15 @@ = parseArgs rest $ config { configWith = configWith config ++ [file] } + -- Tetra -------------------------------- + | "-tetra-boxing" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeTetraBoxing file + + | "-tetra-curry" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeTetraCurry file + -- Flow --------------------------------- | "-flow-prep" : file : rest <- args = parseArgs rest @@ -176,6 +192,10 @@ = parseArgs rest $ setMode config $ ModeToLLVM file + | "-to-php" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeToPHP file + -- Debugging ---------------------------- | "-dump" : rest <- args = parseArgs rest @@ -246,9 +266,13 @@ ModeLoad{} -> Just "-load" ModeCompile{} -> Just "-compile" ModeMake{} -> Just "-make" + ModeBuild{} -> Just "-build" ModeToSalt{} -> Just "-to-salt" ModeToC{} -> Just "-to-c" ModeToLLVM{} -> Just "-to-llvm" + ModeToPHP{} -> Just "-to-php" + ModeTetraCurry{} -> Just "-tetra-curry" + ModeTetraBoxing{} -> Just "-tetra-boxing" ModeFlowPrep{} -> Just "-flow-prep" ModeFlowLower{} -> Just "-flow-lower" ModeFlowLowerKernel{} -> Just "-flow-lower-kernel" 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 @@ -2,10 +2,11 @@ -- | Define the command line configuation arguments. module DDC.Main.Config - ( Mode (..) - , OptLevel (..) - , D.ViaBackend (..) - , Config (..) + ( Mode (..) + , OptLevel (..) + , D.ViaBackend (..) + , D.RuntimeLinkStrategy (..) + , Config (..) , getDefaultConfig , defaultBuilderConfig) @@ -36,12 +37,15 @@ -- | Parse, type-check and transform a module. | ModeLoad FilePath - -- | Compile a .dcl or .dce into an object file. + -- | Compile source code into an object code. | ModeCompile FilePath - -- | Compile a .dcl or .dce into an executable file. + -- | Compile source code into an executable. | ModeMake FilePath + -- | Build libraries or executables following a build .spec file. + | ModeBuild FilePath + -- | Convert a module to Salt. | ModeToSalt FilePath @@ -51,31 +55,44 @@ -- | Convert a module to LLVM. | ModeToLLVM FilePath + -- | Convert a module to PHP. + | ModeToPHP FilePath + + + -- Disciple Core Tetra specific --------- + -- | Manage higher order functions. + | ModeTetraCurry FilePath + + -- | Manage boxing. + | ModeTetraBoxing FilePath + + -- Disciple Core Flow specific ---------- -- | Prepare a Flow program for lowering. - | ModeFlowPrep FilePath + | ModeFlowPrep FilePath -- | Lower a Flow program. - | ModeFlowLower FilePath + | ModeFlowLower FilePath -- | Lower a Flow program, producing a vector kernel. - | ModeFlowLowerKernel FilePath + | ModeFlowLowerKernel FilePath -- | Lower a Flow program using vector instructions. - | ModeFlowLowerVector FilePath + | ModeFlowLowerVector FilePath -- | Wind loop primops into tail recursive loops. - | ModeFlowWind FilePath + | ModeFlowWind FilePath -- | Concretize rate type variables in a Flow program. - | ModeFlowConcretize FilePath + | ModeFlowConcretize FilePath -- | Melt compound data types in a Flow program. - | ModeFlowMelt FilePath + | ModeFlowMelt FilePath -- | Thread the World token through a Flow program. - | ModeFlowThread FilePath + | ModeFlowThread FilePath + -- Builder ------------------------------ -- | Build the base libraries and runtime. | ModeBaseBuild @@ -122,17 +139,18 @@ -- Optimisation ------------- -- | What optimisation levels to use - , configOptLevelLite :: OptLevel , configOptLevelSalt :: OptLevel -- | Paths to modules to use as inliner templates. - , configWithLite :: [FilePath] , configWithSalt :: [FilePath] -- Runtime ------------------- -- | Default size of heap for compiled program. , configRuntimeHeapSize :: Integer + -- | Strategy for linking the runtime. + , configRuntimeLinkStrategy :: D.RuntimeLinkStrategy + -- Intermediates ------------- , configKeepLlvmFiles :: Bool , configKeepSeaFiles :: Bool @@ -175,13 +193,12 @@ , configViaBackend = D.ViaLLVM -- Optimisation ------------- - , configOptLevelLite = OptLevel0 , configOptLevelSalt = OptLevel0 - , configWithLite = [] , configWithSalt = [] -- Runtime ------------------ - , configRuntimeHeapSize = 65536 + , configRuntimeHeapSize = 64 * 1024 * 1024 + , configRuntimeLinkStrategy = D.LinkDefault -- Intermediates ------------ , configKeepLlvmFiles = False @@ -204,5 +221,11 @@ defaultBuilderConfig config = BuilderConfig { builderConfigBaseSrcDir = configBaseDir config - , builderConfigBaseLibDir = configBaseDir config "build" } + , builderConfigBaseLibDir = configBaseDir config "build" + , builderConfigLibFile + = \static dynamic + -> if configRuntimeLinkStrategy config == D.LinkStatic + then static + else dynamic } + 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 @@ -1,9 +1,6 @@ module DDC.Main.Help where - --- | The version identifier string. -version :: String -version = "The Disciplined Disciple Compiler, version 0.4.1" +import qualified DDC.Version as Version -- | What to print when we have no input files. @@ -23,7 +20,7 @@ -- on the compilation mode. help :: String help = unlines - [ version + [ Version.splash , "" , "General" , " -help Display this help." @@ -36,6 +33,7 @@ , "Compilation" , " -make FILE Compile a module into an executable file." , " -c, -compile FILE Compile a module into an object file." + , " -build FILE Build a library or executable defined in a .build file" , "" , " -o, -output FILE Redirect output to this file." , " -output-dir DIR Redirect output to this directory." @@ -58,8 +56,10 @@ , " -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)" + , " -run-link-static Force the runtime to be linked statically." , "" - , "Optimisation and Transformation" + , "Generic Transforms, that work on all fragments." + , " To uses the transforms, set the desired one with -trans, then -load a file." , " -O0 No optimisations. (default)" , " -O, -O1 Do standard optimisations." , "" @@ -72,21 +72,26 @@ , " 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." + , " Flatten Flatten nested let-bindings." + , " Forward Move let-bindings forward into their use sites." , " Inline MODULE[NAME..] Perform inlining. Use '-with' to add source modules." + , " Lambdas Perform lambda-lifting." + , " Namify Introduce fresh names for deBruijn binders." + , " Prune Erase unused, ineffectual let-bindings." + , " Rewrite Perform rule based rewriting." + , " Snip Introduce let-bindings for nested applications." + , " SnipOver ... and over-applications." , "" - , "Data Flow Fusion Transforms" - , " These work on modules in the Disciple Core Flow (.dcf) fragment only." + , "Core Tetra Tranfsorms (that work on .dct files only)" + , " -tetra-suspend FILE Eta-expand around suspended expressions." + , " -tetra-curry FILE Reify function closures and insert function call prims." + , " -tetra-boxing FILE Manage boxing/unboxing in prep for conversion to Core Salt." + , "" + , "Core Flow Transforms (that work on .dcf files 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." 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 @@ -1,8 +1,7 @@ -- | Define the default optimisation levels. module DDC.Main.OptLevels - ( getSimplLiteOfConfig - , getSimplSaltOfConfig) + ( getSimplSaltOfConfig) where import DDC.Main.Config import DDC.Driver.Command.Read @@ -20,37 +19,14 @@ 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 -import qualified DDC.Core.Lite as Lite import qualified DDC.Core.Salt as Salt import qualified DDC.Core.Salt.Runtime as Salt import qualified DDC.Build.Language.Salt as Salt -import qualified DDC.Build.Language.Lite as Lite import qualified Data.Map as Map import qualified Data.Set as Set - --- | Get the simplifier for Lite code from the config. --- This also reads up all the modules we use for inliner templates. --- --- We don't want to delay this until all arguments are parsed, --- because the simplifier spec also contains the list of modules used --- as inliner templates, so we need to wait until they're all specified. --- -getSimplLiteOfConfig - :: Config -> D.Config - -> Builder - -> Maybe FilePath -- ^ path of current module - -> IO (Simplifier Int () Lite.Name) - -getSimplLiteOfConfig config dconfig builder filePath - = case configOptLevelLite config of - OptLevel0 -> opt0_lite config - OptLevel1 -> opt1_lite config dconfig builder filePath - - -- | Get the simplifier for Salt code from the config. -- getSimplSaltOfConfig @@ -69,12 +45,6 @@ -- Level 0 -------------------------------------------------------------------- -- This just passes the code through unharmed. --- | Level 0 optimiser for Core Lite code. -opt0_lite :: Config -> IO (Simplifier Int () Lite.Name) -opt0_lite _ - = return $ S.Trans S.Id - - -- | Level 0 optimiser for Core Salt code. opt0_salt :: Config -> IO (Simplifier Int () Salt.Name) opt0_salt _ @@ -84,65 +54,6 @@ -- Level 1 -------------------------------------------------------------------- -- Do full optimsiations. --- | Level 1 optimiser for Core Lite code. -opt1_lite - :: Config -> D.Config - -> Builder - -> Maybe FilePath -- ^ path of current module - -> IO (Simplifier Int () Lite.Name) - -opt1_lite config dconfig _builder filePath - = do - -- Auto-inline basic numeric code. - let inlineModulePaths - = [ configBaseDir config "lite/base/Data/Numeric/Int.dcl" - , configBaseDir config "lite/base/Data/Numeric/Nat.dcl" ] - ++ (configWithLite config) - - -- Load all the modules that we're using for inliner templates. - -- If any of these don't load then the 'cmdReadModule' function - -- will display the errors. - minlineModules - <- liftM sequence - $ mapM (cmdReadModule dconfig Lite.fragment) - inlineModulePaths - - let inlineModules - = map (reannotate (const ())) - $ fromMaybe (error "Imported modules do not parse.") - minlineModules - - let inlineSpec - = Map.fromList - [ (ModuleName ["Int"], InlineSpecAll (ModuleName ["Int"]) Set.empty) - , (ModuleName ["Nat"], InlineSpecAll (ModuleName ["Nat"]) Set.empty) ] - - -- Optionally load the rewrite rules for each 'with' module - rules <- mapM (\(m,file) -> cmdTryReadRules Lite.fragment (file ++ ".rules") m) - $ inlineModules `zip` inlineModulePaths - - -- Load rules for target module as well - modrules <- loadLiteRules dconfig filePath - - let rules' = concat rules ++ modrules - - -- Simplifier to convert to a-normal form. - let normalizeLite - = S.anormalize - (makeNamifier Lite.freshT) - (makeNamifier Lite.freshX) - - - -- Perform rewrites before inlining - return $ (S.Trans $ S.Rewrite rules') - <> (S.Trans $ S.Inline - $ lookupTemplateFromModules inlineSpec inlineModules) - <> S.Fix 5 (S.beta - <> S.bubble <> S.flatten - <> normalizeLite <> S.forward - <> (S.Trans $ S.Rewrite rules')) - - -- | Level 1 optimiser for Core Salt code. opt1_salt :: Config -> D.Config @@ -178,10 +89,22 @@ $ fromMaybe (error "Imported modules do not parse.") minlineModules + + -- Inline simple leaf functions from the runtime system. let inlineSpec = Map.fromList - [ (ModuleName ["Object"], InlineSpecAll (ModuleName ["Int"]) Set.empty) ] + [ ( ModuleName ["Runtime", "Object"] + , InlineSpecNone (ModuleName ["Runtime", "Object"]) + $ Set.fromList + $ map Salt.NameVar + [ "funThunk", "paramsThunk", "boxesThunk", "argsThunk", "runThunk" + , "setThunk", "getThunk" + , "getBoxed", "setBoxed" + , "getMixed", "payloadMixed" + , "payloadRaw", "payloadSizeRaw" + , "payloadSmall"])] + -- Optionally load the rewrite rules for each 'with' module rules <- mapM (\(m,file) -> cmdTryReadRules Salt.fragment (file ++ ".rules") m) $ inlineModules `zip` inlineModulePaths @@ -209,25 +132,6 @@ -- | Load rules for main module -loadLiteRules - :: D.Config - -> Maybe FilePath - -> IO (S.NamedRewriteRules () Lite.Name) - -loadLiteRules dconfig (Just filePath) - | isSuffixOf ".dcl" filePath - = do -- Parse module to get exported fn types - modu <- cmdReadModule' False dconfig Lite.fragment filePath - case modu of - Just mod' -> cmdTryReadRules Lite.fragment (filePath ++ ".rules") - (reannotate (const ()) mod') - Nothing -> return [] - -loadLiteRules _ _ - = return [] - - --- | Load rules for main module loadSaltRules :: D.Config -> Builder @@ -235,25 +139,7 @@ -> Maybe FilePath -> IO (S.NamedRewriteRules () Salt.Name) -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 dconfig Lite.fragment filePath - let path' = (reverse $ drop 3 $ reverse filePath) ++ "dcs.rules" - case modu of - Just mod' -> - case Lite.saltOfLiteModule (buildSpec builder) - runtimeConfig - (C.profilePrimDataDefs Lite.profile) - (C.profilePrimKinds Lite.profile) - (C.profilePrimTypes Lite.profile) - mod' - of Left _ -> return [] - Right mm' -> cmdTryReadRules Salt.fragment path' - (reannotate (const ()) mm') - - Nothing -> return [] - +loadSaltRules dconfig _builder _runtimeConfig (Just filePath) | isSuffixOf ".dcs" filePath = do modu <- cmdReadModule' False dconfig Salt.fragment filePath case modu of 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 @@ -7,13 +7,17 @@ import DDC.Main.Help import DDC.Main.Args import DDC.Main.OptLevels + import DDC.Driver.Command.Parse import DDC.Driver.Command.Check import DDC.Driver.Command.Load import DDC.Driver.Command.Compile -import DDC.Driver.Command.Make +import DDC.Driver.Command.Build import DDC.Driver.Command.BaseBuild +import DDC.Driver.Command.Tetra.Curry +import DDC.Driver.Command.Tetra.Boxing + import DDC.Driver.Command.Flow.Prep import DDC.Driver.Command.Flow.Lower import DDC.Driver.Command.Flow.Concretize @@ -25,18 +29,27 @@ import DDC.Driver.Command.ToSalt import DDC.Driver.Command.ToC import DDC.Driver.Command.ToLlvm -import DDC.Interface.Source +import DDC.Driver.Command.ToPHP + +import DDC.Driver.Interface.Source import DDC.Build.Builder import DDC.Base.Pretty import System.Environment import System.IO import System.Exit -import Control.Monad.Trans.Error +import Data.Maybe +import Control.Monad +import Control.Monad.Trans.Except +import qualified System.FilePath as System +import qualified System.Directory as System 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 +import qualified DDC.Version as Version +import qualified DDC.Build.Interface.Store as Store + main :: IO () main = do args <- getArgs @@ -50,6 +63,7 @@ -- the command-line arguments. config <- parseArgs args config0 + -- Run the main compiler. run config @@ -63,7 +77,7 @@ -- Display the version string. ModeVersion - -> putStrLn version + -> putStrLn Version.splash -- Display the help page. ModeHelp @@ -77,7 +91,8 @@ -- Parse and type check a module. ModeCheck filePath -> do dconfig <- getDriverConfig config (Just filePath) - result <- runErrorT $ cmdCheckFromFile dconfig filePath + store <- Store.new + result <- runExceptT $ cmdCheckFromFile dconfig store filePath case result of Left err @@ -89,100 +104,135 @@ -- Parse, type check and transform a module. ModeLoad filePath - -> do dconfig <- getDriverConfig config (Just filePath) - runError $ cmdLoadFromFile dconfig + -> do dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdLoadFromFile dconfig store (configTrans config) (configWith config) filePath -- Compile a module to object code. ModeCompile filePath - -> do dconfig <- getDriverConfig config (Just filePath) - runError $ cmdCompile dconfig filePath + -> do forceBaseBuild config + dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdCompileRecursive dconfig False store filePath -- Compile a module into an executable. ModeMake filePath - -> do dconfig <- getDriverConfig config (Just filePath) - runError $ cmdMake dconfig filePath + -> do forceBaseBuild config + dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdCompileRecursive dconfig True store filePath + -- Build libraries or executables following a .spec file. + ModeBuild filePath + -> do forceBaseBuild config + dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdBuild dconfig store filePath + -- Convert a module to Salt. ModeToSalt filePath - -> do dconfig <- getDriverConfig config (Just filePath) - runError $ cmdToSaltFromFile dconfig filePath + -> do dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdToSaltFromFile dconfig store filePath -- Convert a module to C ModeToC filePath - -> do dconfig <- getDriverConfig config (Just filePath) - runError $ cmdToSeaFromFile dconfig filePath + -> do dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdToSeaFromFile dconfig store filePath -- Convert a module to LLVM ModeToLLVM filePath - -> do dconfig <- getDriverConfig config (Just filePath) - runError $ cmdToLlvmFromFile dconfig filePath + -> do dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdToLlvmFromFile dconfig store filePath + -- Convert a module to C + ModeToPHP filePath + -> do dconfig <- getDriverConfig config (Just filePath) + store <- Store.new + runError $ cmdToPHPFromFile dconfig store filePath + + + -- Tetra specific ----------------------------------------------------- + ModeTetraCurry filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath + runError $ cmdTetraCurry dconfig (SourceFile filePath) str + + ModeTetraBoxing filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath + runError $ cmdTetraBoxing dconfig (SourceFile filePath) str + + -- Flow specific ------------------------------------------------------ -- Prepare a Disciple Core Flow program for lowering. ModeFlowPrep filePath - -> do dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError $ cmdFlowPrep dconfig (SourceFile filePath) str -- Lower a Disciple Core Flow program to loops. ModeFlowLower filePath - -> do configDriver <- getDriverConfig config (Just filePath) - str <- readFile filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError - $ cmdFlowLower - configDriver Flow.defaultConfigScalar + $ cmdFlowLower dconfig Flow.defaultConfigScalar (SourceFile filePath) str -- Lower a Disciple Core Flow program to loops. ModeFlowLowerKernel filePath - -> do configDriver <- getDriverConfig config (Just filePath) - str <- readFile filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError - $ cmdFlowLower - configDriver Flow.defaultConfigKernel + $ cmdFlowLower dconfig Flow.defaultConfigKernel (SourceFile filePath) str -- Lower a Disciple Core Flow program to loops. ModeFlowLowerVector filePath - -> do configDriver <- getDriverConfig config (Just filePath) - str <- readFile filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError - $ cmdFlowLower configDriver Flow.defaultConfigVector + $ cmdFlowLower dconfig 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 + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError $ cmdFlowConcretize dconfig (SourceFile filePath) str -- Melt compound data structures. ModeFlowMelt filePath - -> do dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError $ cmdFlowMelt dconfig (SourceFile filePath) str -- Wind loop primops into tail recursive loops. ModeFlowWind filePath - -> do dconfig <- getDriverConfig config (Just filePath) - str <- readFile filePath + -> do dconfig <- getDriverConfig config (Just filePath) + 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 + -> do dconfig <- getDriverConfig config (Just filePath) + str <- readFile filePath runError $ cmdFlowThread dconfig (SourceFile filePath) str + -- Build -------------------------------------------------------------- -- Build the runtime and base libraries. ModeBaseBuild - -> do dconfig <- getDriverConfig config Nothing - runError $ cmdBaseBuild dconfig + -> do dconfig <- getDriverConfig config Nothing + store <- Store.new + runError $ cmdBaseBuild dconfig store + -- Print -------------------------------------------------------------- -- Print the external builder info for this platform. ModePrintBuilder - -> do dconfig <- getDriverConfig config Nothing + -> do dconfig <- getDriverConfig config Nothing putStrLn $ renderIndent $ ppr (Driver.configBuilder dconfig) -- Print where the runtime and base libraries are installed. @@ -192,49 +242,59 @@ -- | Get the compile driver from the config. getDriverConfig :: Config -> Maybe FilePath -> IO Driver.Config -getDriverConfig config filePath - = do Just builder <- determineDefaultBuilder (defaultBuilderConfig config) +getDriverConfig config mFilePath + = do + -- Determine the default builder config. + Just builder + <- determineDefaultBuilder + $ defaultBuilderConfig config + + -- Treat the directory holding a module to compile as a base + -- directory where we look for other modules. + let moduleBaseDirs + = maybeToList + $ fmap System.takeDirectory mFilePath + + -- The default runtime system config. let runtimeConfig = Runtime.Config - { Runtime.configHeapSize = configRuntimeHeapSize config } + { Runtime.configHeapSize = configRuntimeHeapSize config } + -- Build driver config. let dconfig = Driver.Config - { Driver.configDump = configDump config + { Driver.configLogBuild = True + , 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.configModuleBaseDirectories = moduleBaseDirs , Driver.configOutputFile = configOutputFile config , Driver.configOutputDir = configOutputDir config , Driver.configKeepLlvmFiles = configKeepLlvmFiles config , Driver.configKeepSeaFiles = configKeepSeaFiles config , Driver.configKeepAsmFiles = configKeepAsmFiles config - , Driver.configTaintAvoidTypeChecks = configTaintAvoidTypeChecks config } - - simplLite <- getSimplLiteOfConfig config - dconfig - builder filePath + , Driver.configTaintAvoidTypeChecks = configTaintAvoidTypeChecks config + , Driver.configRuntimeLinkStrategy = configRuntimeLinkStrategy config } -- 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 + builder runtimeConfig mFilePath return $ dconfig - { Driver.configSimplLite = simplLite - , Driver.configSimplSalt = simplSalt } + { Driver.configSimplSalt = simplSalt } -- | Print errors to stderr and set the exit code. -runError :: ErrorT String IO () -> IO () +runError :: ExceptT String IO a -> IO () runError m - = do result <- runErrorT m + = do result <- runExceptT m case result of Left err -> do hPutStrLn stderr err @@ -242,4 +302,28 @@ Right _ -> return () + + +-- | Force build of base library if it doesn't already exist. +-- +-- Due to bugs in cabal-install 1.22 it can't be trusted to run the +-- post-install hook that builds our base library. To work around this +-- we check that it is built before running any command that might +-- need it. +-- +forceBaseBuild :: Config -> IO () +forceBaseBuild config + = do + -- Check if the runtime library has already been built. + -- If it hasn't then force a basebuild. + exist <- System.doesFileExist + $ configBaseDir config + System. "build" + System. "libddc-runtime.a" + + when (not exist) + $ do putStrLn "* Building base library..." + dconfig <- getDriverConfig config Nothing + store <- Store.new + runError $ cmdBaseBuild dconfig store 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 @@ -7,7 +7,6 @@ where import DDCI.Core.Command.Help import DDCI.Core.Command.Set -import DDCI.Core.Command.Eval import DDCI.Core.Command.TransInteract import DDCI.Core.Command.With import DDCI.Core.State @@ -17,14 +16,10 @@ import DDC.Driver.Command.Load import DDC.Driver.Command.Trans import DDC.Driver.Command.Compile -import DDC.Driver.Command.Make - import DDC.Driver.Command.ToSalt 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 @@ -32,13 +27,15 @@ import DDC.Driver.Command.Flow.Wind import DDC.Driver.Command.Flow.Melt import DDC.Driver.Command.Flow.Thread - +import DDC.Driver.Command.Flow.ToTetra import DDC.Type.Universe +import qualified DDC.Build.Interface.Store as Store + import qualified DDC.Core.Flow as Flow import qualified Data.Set as Set import System.IO -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Data.List @@ -60,11 +57,9 @@ | CommandExpEffect -- ^ Check an expression, showing its effect. | CommandExpClosure -- ^ Check an expression, showing its closure. | CommandExpRecon -- ^ Reconstruct type annotations on binders. - | CommandEval -- ^ Evaluate an expression. -- Generic transformations | CommandTrans -- ^ Transform an expression. - | CommandTransEval -- ^ Transform then evaluate an expression. | CommandTransInteract -- ^ Interactively transform an expression. -- Make and compile @@ -80,18 +75,30 @@ | 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. + | CommandFlowRate -- ^ Perform rate inference + | CommandFlowRateLower Flow.Config + -- ^ Perform rate inference, followed by lowering + + | 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. + + | CommandFlowToTetra Flow.Config + -- ^ Convert to Disciple Tetra, which can then be converted to Salt + -- Inline control - | CommandWith -- ^ Add a module to the inliner table. - | CommandWithLite - | CommandWithSalt + | CommandWith -- ^ Add a module to the inliner table. + | CommandWithSalt deriving (Eq, Show) @@ -117,10 +124,7 @@ , (":effect", CommandExpEffect) , (":closure", CommandExpClosure) - , (":eval", CommandEval) - -- Generic transformations - , (":trun", CommandTransEval) , (":tinteract", CommandTransInteract) , (":trans", CommandTrans) @@ -133,6 +137,7 @@ , (":tetra-boxing", CommandTetraBoxing) -- Core Flow specific passes + , (":flow-rate-lower", CommandFlowRateLower Flow.defaultConfigScalar) , (":flow-rate", CommandFlowRate) , (":flow-prep", CommandFlowPrep) , (":flow-lower-kernel", CommandFlowLower Flow.defaultConfigKernel) @@ -142,13 +147,13 @@ , (":flow-melt", CommandFlowMelt) , (":flow-wind", CommandFlowWind) , (":flow-thread", CommandFlowThread) + , (":flow-tetra", CommandFlowToTetra Flow.defaultConfigScalar) -- Make and Compile , (":compile", CommandCompile) , (":make", CommandMake) -- Inliner control - , (":with-lite", CommandWithLite) , (":with-salt", CommandWithSalt) , (":with", CommandWith) ] @@ -251,10 +256,6 @@ -> do cmdExpRecon lang source line return state - CommandEval - -> do cmdEval state source line - return state - -- Generic transformations -------------- CommandTrans -> do configDriver <- getDriverConfigOfState state @@ -266,10 +267,6 @@ source line return state - CommandTransEval - -> do cmdTransEval state source line - return state - CommandTransInteract -> do cmdTransInteract state source line @@ -302,6 +299,11 @@ runError $ cmdFlowRate configDriver source line return state + CommandFlowRateLower configLower + -> do configDriver <- getDriverConfigOfState state + runError $ cmdFlowRateLower configDriver configLower source line + return state + CommandFlowPrep -> do config <- getDriverConfigOfState state runError $ cmdFlowPrep config source line @@ -332,15 +334,22 @@ runError $ cmdFlowThread config source line return state + CommandFlowToTetra configLower + -> do config <- getDriverConfigOfState state + runError $ cmdFlowToTetraCoreFromString config configLower lang source line + return state + -- Make and Compile --------------------- CommandCompile -> do config <- getDriverConfigOfState state - runError $ cmdCompile config line + store <- Store.new + runError $ cmdCompile config False store line return state CommandMake -> do config <- getDriverConfigOfState state - runError $ cmdMake config line + store <- Store.new + runError $ cmdCompile config True store line return state @@ -348,17 +357,14 @@ CommandWith -> cmdWith state source line - CommandWithLite - -> cmdWithLite state source line - CommandWithSalt -> cmdWithSalt state source line -- | Just print errors to stdout and continue the session. -runError :: ErrorT String IO () -> IO () +runError :: ExceptT String IO a -> IO () runError m - = do result <- runErrorT m + = do result <- runExceptT m case result of Left err -> hPutStrLn stdout err Right _ -> return () diff --git a/src/ddci-core/DDCI/Core/Command/Eval.hs b/src/ddci-core/DDCI/Core/Command/Eval.hs deleted file mode 100644 --- a/src/ddci-core/DDCI/Core/Command/Eval.hs +++ /dev/null @@ -1,298 +0,0 @@ - -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 -import DDC.Core.Collect -import DDC.Core.Compounds -import DDC.Type.Equiv -import DDC.Type.Subsumes -import Control.Monad -import DDC.Core.Eval.Store (Store) -import qualified DDC.Core.Eval.Store as Store -import qualified Data.Set as Set -import qualified DDC.Build.Language.Eval as Eval -import qualified Data.Map as Map -import Data.Typeable -import DDC.Core.Module (ModuleMap) -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 - = 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' Recon False False source str - >>= goStore - where - -- Expression is well-typed. - goStore (Just x, _) - = let -- The evaluator doesn't accept any annotations - x_stripped = reannotate (const ()) x - - -- Create the initial store. - store = startingStoreForExp x_stripped - - 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 - = 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' Recon False False source str - >>= goEval - where - -- Expression is well-typed. - 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 () -evalExp state x0 - = do - -- The evaluator doesn't want any annotations - let x0_stripped = reannotate (const ()) x0 - let x0_zapped = reannotate (\a -> a { annotTail = ()}) x0 - - -- Create the initial store. - let store = startingStoreForExp x0_stripped - - -- Print starting expression. - when (Set.member TraceEval $ stateModes state) - $ outDocLn state (text "* STEP: " <> ppr x0_stripped) - - -- Print starting store. - when (Set.member TraceStore $ stateModes state) - $ do putStrLn $ renderIndent $ ppr store - outStr state "\n" - - goStep store x0_zapped - - where - goStep store x - = do mResult <- forcePrint state store x - case mResult of - Nothing - -> return () - - Just (store', x') - -> goStep store' x' - - --- | Create a starting store for the given expression. --- We pre-allocate any region handles in the expression, --- and ensure that the next region to be allocated is higher --- than all of these. -startingStoreForExp :: Exp () Name -> Store -startingStoreForExp xx - = let - -- Gather up all the region handles already in the expression. - rs = [ r | UPrim (NameRgn r) _ <- Set.toList $ collectBound xx] - - -- Decide what new region should be allocated first. - -- Region 0 is reserved for thunks. - iAllocBump - | _ : _ <- rs - , Rgn iR <- maximum rs - = iR - - | otherwise - = 0 - - store = Store.initial - - in store - { Store.storeNextRgn = Store.storeNextRgn store + iAllocBump - , Store.storeRegions = Store.storeRegions store `Set.union` Set.fromList rs - , Store.storeGlobal = Store.storeGlobal store `Set.union` Set.fromList rs } - - --- | Perform a single step of evaluation and print what happened. -forcePrint - :: State - -> Store - -> Exp (AnTEC a Name) Name - -> IO (Maybe (Store, Exp (AnTEC () Name) Name)) - -forcePrint state store x - = let - -- Get the type, effect and closure of the original expression. - 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 fst $ checkExp (configOfProfile Eval.profile) - primKindEnv primTypeEnv - x_stripped' Recon of - Left err - -> do - -- Print intermediate expression. - when (Set.member TraceEval $ stateModes state) - $ do outDocLn state $ text "* STEP: " <> ppr x_stripped' - - -- Print intermediate store - when (Set.member TraceStore $ stateModes state) - $ do putStrLn $ renderIndent $ ppr store' - outStr state "\n" - - putStrLn $ renderIndent - $ vcat [ text "* OFF THE RAILS!" - , ppr err - , empty ] - - return $ Nothing - - Right (x', tX', effX', cloX') - -> do - -- Print intermediate expression. - when (Set.member TraceEval $ stateModes state) - $ do outDocLn state $ text "* STEP: " <> ppr x' - - -- Print intermediate store - when (Set.member TraceStore $ stateModes state) - $ do putStrLn $ renderIndent $ ppr store' - putStr "\n" - - -- Check expression has the same type as before, - -- and that the effect and closure are no greater. - let deathT = not $ equivT tX tX' - let deathE = not $ subsumesT kEffect effX effX' - - -- ISSUE #290: locations don't reveal closure information. --- let deathC = not $ subsumesT kClosure cloX cloX' - let death = deathT || deathE -- deathC - - - when death - $ putStrLn $ renderIndent - $ vcat [ empty - , text "* OFF THE RAILS! ************************" - , text "Starting expression:" - , indent 4 $ ppr x - , empty - , text "Has type:", indent 4 $ ppr tX - , text "Has efect:", indent 4 $ ppr effX - , text "Has closure:", indent 4 $ ppr cloX - , empty - , text "Reduced expression:" - , indent 4 $ ppr x' - , empty - , text "Has type:", indent 4 $ ppr tX' - , text "Has effect:", indent 4 $ ppr effX' - , text "Has closure:", indent 4 $ ppr cloX' ] - - if death - then return Nothing - else return $ Just (store', x') - - StepDone - -> do -- Load the final expression back from the store to display. - outDocLn state $ ppr $ traceStore store x_stripped - return Nothing - - StepStuck - -> do outDocLn state - $ vcat [ text "* STUCK!" - , empty] - - return Nothing - - StepMistyped err - -> do putStrLn $ renderIndent - $ vcat [ text "* OFF THE RAILS!" - , ppr err - , empty] - - return Nothing - 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 @@ -86,7 +86,6 @@ , " Add a rewrite rule to the database." , "" , " :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." , "" , " MODE ::=" @@ -99,7 +98,7 @@ , " SuppressLetTypes Suppress type annots on let-binders." , "" , " LANG ::=" - , " Lite | Salt | Zero | Eval" + , " Salt | Tetra | Flow | Eval | Zero" , "" , " BUILDER ::= " , " x86_32-darwin | x86_64-darwin | x86_32-linux | x86_64-linux" 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 @@ -17,9 +17,10 @@ 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 DDCI.Core.Rewrite as R +import qualified Data.Map as Map import qualified Data.Set as Set +import Prelude hiding ((<$>)) cmdSet :: State -> String -> IO State @@ -39,7 +40,6 @@ , text "Simplifier: " <> ppr simpl , text "Builder: " <> text (show $ liftM builderName $ stateBuilder state) ] <$> vcat (text "With: " : map ppr (Map.keys modules)) - <$> vcat (text "With Lite: " : map ppr (Map.keys (stateWithLite state))) <$> vcat (text "With Salt: " : map ppr (Map.keys (stateWithSalt state))) return state @@ -87,27 +87,27 @@ , modules <- bundleModules bundle , rules <- bundleRewriteRules bundle = case R.parseRewrite fragment modules rest of - Right (R.SetAdd name rule) - -> do chatStrLn state $ "ok, added " ++ name + Right (R.SetAdd name rule) + -> do chatStrLn state $ "ok, added " ++ name 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' } + return $ state { stateLanguage = Language bundle' } - Right (R.SetRemove name) - -> do chatStrLn state $ "ok, removed " ++ name - let rules' = Map.delete name rules + Right (R.SetRemove name) + -> do chatStrLn state $ "ok, removed " ++ name + let rules' = Map.delete name rules let bundle' = bundle { bundleRewriteRules = rules' } return $ state { stateLanguage = Language bundle' } - Right R.SetList - -> do let rules' = Map.toList rules - mapM_ (uncurry $ R.showRule state 0) rules' - return state - - Left e - -> do chatStrLn state e - return state + Right R.SetList + -> do let rules' = Map.toList rules + mapM_ (uncurry $ R.showRule state 0) rules' + return state + + Left e + -> do chatStrLn state e + return state | "builder" : name : [] <- words cmd = do config <- getDefaultBuilderConfig 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 @@ -1,6 +1,6 @@ module DDCI.Core.Command.TransInteract ( cmdTransInteract - , cmdTransInteractLoop) + , cmdTransInteractLoop) where import DDCI.Core.Output import DDCI.Core.State @@ -10,7 +10,7 @@ import DDC.Core.Fragment import DDC.Core.Simplifier.Parser import DDC.Core.Transform.Reannotate -import DDC.Core.Compounds +import DDC.Core.Exp.Annot import DDC.Core.Check import DDC.Core.Module import DDC.Base.Pretty @@ -38,11 +38,11 @@ let clo1 = annotClosure annot let hist = TransHistory - { historyExp = (xx', t1, eff1, clo1) - , historySteps = [] + { historyExp = (xx', t1, eff1, clo1) + , historySteps = [] , historyBundle = bundle } - return state { stateTransInteract = Just hist } + return state { stateTransInteract = Just hist } -- Expression had a parse or type error. goStore _ _ @@ -57,46 +57,46 @@ , profile <- fragmentProfile fragment = case str of ":back" -> do - let steps' = case steps of - [] -> [] - (_:ss) -> ss + let steps' = case steps of + [] -> [] + (_:ss) -> ss - putStrLn "Going back: " - let x' = case steps' of - [] -> x - ((xz,_):_) -> xz - outDocLn state $ ppr x' + putStrLn "Going back: " + let x' = case steps' of + [] -> x + ((xz,_):_) -> xz + outDocLn state $ ppr x' - let hist' = TransHistory (x,t,e,c) steps' bundle - return state { stateTransInteract = Just hist' } + let hist' = TransHistory (x,t,e,c) steps' bundle + return state { stateTransInteract = Just hist' } ":done" -> do - let simps = reverse $ map (indent 4 . ppr . snd) steps - outStrLn state "* TRANSFORM SEQUENCE:" - mapM_ (outDocLn state) simps - return state { stateTransInteract = Nothing } + let simps = reverse $ map (indent 4 . ppr . snd) steps + outStrLn state "* TRANSFORM SEQUENCE:" + mapM_ (outDocLn state) simps + return state { stateTransInteract = Nothing } - _ -> do + _ -> do - let tr = parseSimplifier + let tr = parseSimplifier (fragmentReadName fragment) - (SimplifierDetails + (SimplifierDetails (bundleMakeNamifierT bundle) (bundleMakeNamifierX bundle) - (Map.assocs $ bundleRewriteRules bundle) + (Map.assocs $ bundleRewriteRules bundle) (Map.elems $ bundleModules bundle)) - str + str - let x' = case steps of - [] -> x - ((xz,_):_) -> xz + let x' = case steps of + [] -> x + ((xz,_):_) -> xz - case tr of + case tr of Left _err -> do putStrLn "Error parsing simplifier" return state - Right tr' -> do + Right tr' -> do let kenv = modulesExportTypes (bundleModules bundle) (profilePrimKinds profile) @@ -105,17 +105,17 @@ (bundleModules bundle) (profilePrimTypes profile) - x_trans <- transExp + x_trans <- transExp (Set.member TraceTrans $ stateModes state) profile kenv tenv - (bundleStateInit bundle) tr' x' + (bundleStateInit bundle) tr' x' - case x_trans of - Nothing -> return state - Just x_trans' -> do - outDocLn state $ ppr x_trans' - let steps' = (x_trans', tr') : steps - let hist' = TransHistory (x,t,e,c) steps' bundle - return state { stateTransInteract = Just hist' } + case x_trans of + Nothing -> return state + Just x_trans' -> do + outDocLn state $ ppr x_trans' + let steps' = (x_trans', tr') : steps + let hist' = TransHistory (x,t,e,c) steps' bundle + return state { stateTransInteract = Just hist' } | otherwise = error "No transformation history!" 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 @@ -1,20 +1,19 @@ module DDCI.Core.Command.With - (cmdWith, cmdWithLite, cmdWithSalt) + (cmdWith, cmdWithSalt) where import DDCI.Core.State -import DDC.Interface.Source -import DDC.Core.Pretty +import DDC.Driver.Interface.Source import DDC.Build.Pipeline +import DDC.Core.Pretty import DDC.Core.Module -import DDC.Data.Canned import DDC.Core.Check +import DDC.Data.Canned import System.Directory import Control.Monad import Data.IORef import Data.Char 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 @@ -26,38 +25,28 @@ , modules <- bundleModules bundle , fragment <- bundleFragment bundle = do res <- cmdWith_load fragment str - case res of - Nothing -> return state - Just mdl + case res of + Nothing -> return state + Just mdl -> do - let modules' = Map.insert (moduleName mdl) mdl modules + let modules' = Map.insert (moduleName mdl) mdl modules let bundle' = bundle { bundleModules = modules' } - return $ state { stateLanguage = Language bundle' } + return $ state { stateLanguage = Language bundle' } -cmdWithLite :: State -> Source -> String -> IO State -cmdWithLite state _source str - = 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) } - 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 + case res of + Nothing -> return state + Just mdl -> return $ state - { stateWithSalt = Map.insert (moduleName mdl) mdl + { stateWithSalt = Map.insert (moduleName mdl) mdl (stateWithSalt state) } cmdWith_load frag str - = do -- Always treat the string as a filename + = do -- Always treat the string as a filename let source = SourceFile str -- Read in the source file. @@ -68,7 +57,7 @@ src <- readFile filePath - cmdWith_parse frag source src + cmdWith_parse frag source src cmdWith_parse frag source src diff --git a/src/ddci-core/DDCI/Core/Input.hs b/src/ddci-core/DDCI/Core/Input.hs --- a/src/ddci-core/DDCI/Core/Input.hs +++ b/src/ddci-core/DDCI/Core/Input.hs @@ -8,7 +8,7 @@ import DDCI.Core.State import DDCI.Core.Command import DDCI.Core.Command.TransInteract -import DDC.Interface.Input +import DDC.Driver.Interface.Input -- Eating input lines. @@ -20,7 +20,7 @@ eatLine state inputState chunk | Just _ <- stateTransInteract state = do state' <- cmdTransInteractLoop state chunk - return ( state' + return ( state' , inputState { inputLineNumber = inputLineNumber inputState + 1 }) | otherwise @@ -31,9 +31,8 @@ Nothing -> return (state, inputState') - Just (source, Nothing, line) - -> do state' <- handleCmd state CommandEval source line - return (state', inputState') + Just (_source, Nothing, _line) + -> do return (state, inputState') Just (source, Just cmd, line) -> do state' <- handleCmd state cmd source line diff --git a/src/ddci-core/DDCI/Core/Interface/Args.hs b/src/ddci-core/DDCI/Core/Interface/Args.hs --- a/src/ddci-core/DDCI/Core/Interface/Args.hs +++ b/src/ddci-core/DDCI/Core/Interface/Args.hs @@ -5,7 +5,7 @@ import DDCI.Core.Command.Help import DDCI.Core.Command import DDCI.Core.State -import DDC.Interface.Input +import DDC.Driver.Interface.Input import DDC.Data.ListUtils import Data.List diff --git a/src/ddci-core/DDCI/Core/Interface/Batch.hs b/src/ddci-core/DDCI/Core/Interface/Batch.hs --- a/src/ddci-core/DDCI/Core/Interface/Batch.hs +++ b/src/ddci-core/DDCI/Core/Interface/Batch.hs @@ -5,7 +5,7 @@ import DDCI.Core.State import DDCI.Core.Input import DDCI.Core.Command -import DDC.Interface.Input +import DDC.Driver.Interface.Input import Data.List 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 @@ -5,7 +5,7 @@ import DDCI.Core.Input import DDCI.Core.State import DDCI.Core.Command -import DDC.Interface.Input +import DDC.Driver.Interface.Input import Data.List import Data.Maybe import qualified System.Console.Haskeline as HL @@ -15,7 +15,7 @@ -- | Run an interactive session, reading commands from the console. runInteractive :: IO () runInteractive - = do putStrLn "DDCi-core, version 0.4.1: http://disciple.ouroborus.net." + = do putStrLn "DDCi-core, version 0.4.2: http://disciple.ouroborus.net." putStrLn "Type :help for help." -- Setup terminal mode. @@ -42,8 +42,8 @@ = do -- If this isn't the first line then print the prompt. let prompt = if isJust (inputCommand inputState) then "" - else if isJust (stateTransInteract state) - then "trans> " + else if isJust (stateTransInteract state) + then "trans> " else "> " -- Read a line from the user and echo it back. 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 @@ -55,7 +55,7 @@ -- | Dump all intermediate versions of the code during compilation. | Dump - + -- | Avoid type checking if possible. -- Helpful when debugging program transformations to see invalid -- code instead of an error message. diff --git a/src/ddci-core/DDCI/Core/Output.hs b/src/ddci-core/DDCI/Core/Output.hs --- a/src/ddci-core/DDCI/Core/Output.hs +++ b/src/ddci-core/DDCI/Core/Output.hs @@ -5,7 +5,7 @@ , chatStrLn) where import DDCI.Core.State -import DDC.Interface.Input +import DDC.Driver.Interface.Input import DDC.Base.Pretty import qualified Data.Set as Set 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 @@ -2,8 +2,8 @@ module DDCI.Core.Rewrite ( SetRuleCommand(..) , parseFirstWord - , parseRewrite - , showRule ) + , parseRewrite + , showRule ) where import DDC.Base.Pretty import DDC.Build.Language @@ -31,7 +31,7 @@ | SetRemove { setRuleName :: String } - | SetList + | SetList deriving (Eq, Show) type Error = String @@ -48,27 +48,27 @@ parseRewrite :: (Ord n, Show n, Pretty n) => Fragment n err - -> Map ModuleName (Module (C.AnTEC () n) n) + -> Map ModuleName (Module (C.AnTEC () n) n) -> String -> Either Error (SetRuleCommand (C.AnTEC BP.SourcePos n) n) parseRewrite fragment modules str = case dropWhile isSpace str of - [] -> Right SetList - ('+':rest) -> parseAdd fragment modules rest + [] -> Right SetList + ('+':rest) -> parseAdd fragment modules rest - ('-':rest) + ('-':rest) -> let (name,_) = parseFirstWord rest in Right $ SetRemove name - rest -> parseAdd fragment modules rest + rest -> parseAdd fragment modules rest -- | Parse add rule parseAdd :: (Ord n, Show n, Pretty n) => Fragment n err - -> Map ModuleName (Module (C.AnTEC () n) n) + -> Map ModuleName (Module (C.AnTEC () n) n) -> String -> Either Error (SetRuleCommand (C.AnTEC BP.SourcePos n) n) @@ -84,11 +84,11 @@ Right rule' -> Right $ SetAdd name rule' where config = C.configOfProfile (fragmentProfile fragment) - kinds = profilePrimKinds (fragmentProfile fragment) - types = profilePrimTypes (fragmentProfile fragment) + kinds = profilePrimKinds (fragmentProfile fragment) + types = profilePrimTypes (fragmentProfile fragment) - kinds' = modulesExportTypes modules kinds - types' = modulesExportValues modules types + kinds' = modulesExportTypes modules kinds + types' = modulesExportValues modules types -- | Display rule @@ -96,7 +96,7 @@ => State -> Int -> String -> RewriteRule a n -> IO () showRule state indentBy name rule - = do putStr $ (take indentBy $ repeat '\t') ++ name ++ " " - outDocLn state - $ ppr rule + = do putStr $ (take indentBy $ repeat '\t') ++ name ++ " " + outDocLn state + $ ppr 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 @@ -6,7 +6,7 @@ , Mode (..) , adjustMode - , TransHistory (..) + , TransHistory (..) , Source (..) @@ -20,22 +20,23 @@ where import DDCI.Core.Mode import DDC.Code.Config -import DDC.Interface.Input -import DDC.Interface.Source +import DDC.Driver.Interface.Input +import DDC.Driver.Interface.Source import DDC.Build.Builder import DDC.Build.Language + import DDC.Core.Exp import DDC.Core.Module import DDC.Core.Simplifier import DDC.Base.Pretty hiding (()) +import DDC.Base.Name import Data.Typeable 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.Build.Language.Tetra as Tetra 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 @@ -58,11 +59,9 @@ , stateLanguage :: Language -- | Maps of modules we can use as inliner templates. - , stateWithLite :: Map ModuleName (Module (AnTEC () Lite.Name) Lite.Name) , stateWithSalt :: Map ModuleName (Module (AnTEC () Salt.Name) Salt.Name) -- | Simplifier to apply to core program. - , stateSimplLite :: Simplifier Int () Lite.Name , stateSimplSalt :: Simplifier Int () Salt.Name -- | Force the builder to this one, this sets the address width etc. @@ -75,20 +74,20 @@ -- | Output dir for @compile@ and @make@ commands , stateOutputDir :: Maybe FilePath - -- | Interactive transform mode - , stateTransInteract :: Maybe TransHistory} + -- | Interactive transform mode + , stateTransInteract :: Maybe TransHistory} data TransHistory - = forall s n err - . (Typeable n, Ord n, Show n, Pretty n) - => TransHistory - { -- | Original expression and its types - historyExp :: (Exp (AnTEC () n) n, Type n, Effect n, Closure n) + = forall s n err + . (Typeable n, Ord n, Show n, Pretty n, CompoundName n) + => TransHistory + { -- | Original expression and its types + historyExp :: (Exp (AnTEC () n) n, Type n, Effect n, Closure n) - -- | Keep history of steps so we can go back and construct final sequence - , historySteps :: [(Exp (AnTEC () n) n, Simplifier s (AnTEC () n) n)] + -- | Keep history of steps so we can go back and construct final sequence + , historySteps :: [(Exp (AnTEC () n) n, Simplifier s (AnTEC () n) n)] -- | Bundle for the language that we're transforming. , historyBundle :: Bundle s n err } @@ -114,15 +113,13 @@ = State { stateInterface = interface , stateModes = Set.empty - , stateLanguage = Eval.language - , stateWithLite = Map.empty + , stateLanguage = Tetra.language , stateWithSalt = Map.empty - , stateSimplLite = S.Trans S.Id , stateSimplSalt = S.Trans S.Id , stateBuilder = Nothing , stateOutputFile = Nothing , stateOutputDir = Nothing - , stateTransInteract = Nothing } + , stateTransInteract = Nothing } -- | Slurp out the relevant parts of the DDCI stage into a driver config. @@ -131,26 +128,28 @@ = do builder <- getActiveBuilder state return $ D.Config - { D.configDump = Set.member Dump (stateModes state) - , D.configInferTypes = Set.member Synth (stateModes state) - , D.configViaBackend = D.ViaLLVM + { D.configLogBuild = True + , 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. , D.configRuntime = Runtime.Config - { Runtime.configHeapSize = 65536 } + { Runtime.configHeapSize = 65536 } - , D.configOutputFile = stateOutputFile state - , D.configOutputDir = stateOutputDir state - , D.configSimplLite = stateSimplLite state - , D.configSimplSalt = stateSimplSalt state - , D.configBuilder = builder - , D.configPretty = configPretty - , D.configSuppressHashImports = not $ Set.member SaltPrelude (stateModes state) - , D.configKeepLlvmFiles = False - , D.configKeepSeaFiles = False - , D.configKeepAsmFiles = False + , D.configRuntimeLinkStrategy = D.LinkDefault + , D.configModuleBaseDirectories = [] + , D.configOutputFile = stateOutputFile state + , D.configOutputDir = stateOutputDir state + , D.configSimplSalt = stateSimplSalt state + , D.configBuilder = builder + , D.configPretty = configPretty + , D.configSuppressHashImports = not $ Set.member SaltPrelude (stateModes state) + , D.configKeepLlvmFiles = False + , D.configKeepSeaFiles = False + , D.configKeepAsmFiles = False , D.configTaintAvoidTypeChecks = Set.member TaintAvoidTypeChecks (stateModes state) } @@ -159,12 +158,12 @@ 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 } + { 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. @@ -173,7 +172,8 @@ = do baseLibraryPath <- locateBaseLibrary return $ BuilderConfig { builderConfigBaseSrcDir = baseLibraryPath - , builderConfigBaseLibDir = baseLibraryPath "build" } + , builderConfigBaseLibDir = baseLibraryPath "build" + , builderConfigLibFile = \_static dynamic -> dynamic } -- | Get the active builder. diff --git a/src/ddci-core/DDCI/Core/Stats/Trace.hs b/src/ddci-core/DDCI/Core/Stats/Trace.hs deleted file mode 100644 --- a/src/ddci-core/DDCI/Core/Stats/Trace.hs +++ /dev/null @@ -1,80 +0,0 @@ - -module DDCI.Core.Stats.Trace - (traceStore) -where -import DDC.Core.Eval.Store -import DDC.Core.Eval.Name -import DDC.Type.Compounds -import DDC.Core.Compounds -import DDC.Core.Exp -import qualified Data.Set as Set -import Data.Set (Set) - - --- | Replace non-recursive store locations in an expression by their values. --- --- * If the value is recursive then we just leave the original store location. --- * Constructors in the result just have *0 for their type annotation. --- -traceStore :: Store -> Exp () Name -> Exp () Name -traceStore store xx - = traceStoreX store Set.empty xx - - --- | Trace an expression. -traceStoreX :: Store -> Set Name -> Exp () Name -> Exp () Name -traceStoreX store entered xx - = let down = traceStoreX store entered - in case xx of - 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) - XLam a b x -> XLam a b (down x) - XLet a ls x -> XLet a (traceStoreLs store entered ls) (down x) - XCase a x alts -> XCase a (down x) (map (traceStoreA store entered) alts) - XCast a c x -> XCast a c (down x) - XType{} -> xx - XWitness{} -> xx - - --- | Trace lets. -traceStoreLs :: Store -> Set Name -> Lets () Name -> Lets () Name -traceStoreLs store entered ls - = let down = traceStoreX store entered - in case ls of - LLet b x -> LLet b (down x) - LRec bxs -> LRec [(b, down x) | (b, x) <- bxs] - LPrivate{} -> ls - LWithRegion{} -> ls - - --- | Trace case alts. -traceStoreA :: Store -> Set Name -> Alt () Name -> Alt () Name -traceStoreA store entered (AAlt p x) - = AAlt p (traceStoreX store entered x) - - --- | Convert a store binding to an expression. -expOfSBind :: SBind -> Exp () Name -expOfSBind sbind - = case sbind of - SObj dcTag lsArgs - -> xApps () (XCon () dcTag) (map expOfLoc lsArgs) - - SLams fbs x - -> makeXLamFlags () fbs x - - SThunk x - -> x - - --- | Convert a store location to a constructor expression. -expOfLoc :: Loc -> Exp () Name -expOfLoc l = XVar () (UPrim (NameLoc l) (tBot kData)) - diff --git a/src/ddci-core/Main.hs b/src/ddci-core/Main.hs --- a/src/ddci-core/Main.hs +++ b/src/ddci-core/Main.hs @@ -8,13 +8,13 @@ import DDCI.Core.Interface.Batch import DDCI.Core.Interface.Interactive import DDCI.Core.State -import DDC.Interface.Input -import DDC.Driver.Command.Make +import DDC.Driver.Command.Compile +import DDC.Driver.Interface.Input import System.Environment import System.IO -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Data.List - +import qualified DDC.Build.Interface.Store as Store main :: IO () main @@ -36,8 +36,9 @@ -- so we behave more like GHC. ["--make", filePath] -> do let state = initState (InputInterfaceBatch filePath) - config <- getDriverConfigOfState state - runError $ cmdMake config filePath + dconfig <- getDriverConfigOfState state + store <- Store.new + runError $ cmdCompileRecursive dconfig True store filePath -- Run a Disciple-Core-Exchange file. [filePath] @@ -50,9 +51,9 @@ -- | Just print errors to stdout and continue the session. -runError :: ErrorT String IO () -> IO () +runError :: ExceptT String IO a -> IO () runError m - = do result <- runErrorT m + = do result <- runExceptT m case result of Left err -> hPutStrLn stdout err Right _ -> return () diff --git a/src/ddci-tetra/DDCI/Tetra/Command.hs b/src/ddci-tetra/DDCI/Tetra/Command.hs --- a/src/ddci-tetra/DDCI/Tetra/Command.hs +++ b/src/ddci-tetra/DDCI/Tetra/Command.hs @@ -12,11 +12,12 @@ import DDCI.Tetra.Command.Desugar import DDCI.Tetra.Command.Infer import DDCI.Tetra.Command.ToCore -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Driver.Command.ToSalt -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Data.List import System.IO +import qualified DDC.Build.Interface.Store as Store -- | Commands accepted by ddci-tetra. @@ -104,19 +105,21 @@ CommandToCore -> do config <- getDriverConfigOfState state - cmdToCore state config source line + store <- Store.new + cmdToCore state config store source line return state CommandToSalt -> do config <- getDriverConfigOfState state - runError $ cmdToSaltSourceTetraFromString config source line + store <- Store.new + runError $ cmdToSaltSourceTetraFromString config store source line return state -- | Just print errors to stdout and continue the session. -runError :: ErrorT String IO () -> IO () +runError :: ExceptT String IO () -> IO () runError m - = do result <- runErrorT m + = do result <- runExceptT 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 --- a/src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs +++ b/src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs @@ -1,8 +1,8 @@ - +{-# LANGUAGE TypeFamilies #-} module DDCI.Tetra.Command.Desugar (cmdDesugar) where -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDCI.Tetra.State import DDC.Base.Pretty import DDC.Source.Tetra.Lexer @@ -21,13 +21,7 @@ in goParse tokens goParse tokens - = let context = Context - { contextTrackedEffects = True - , contextTrackedClosures = True - , contextFunctionalEffects = False - , contextFunctionalClosures = False } - - in case BP.runTokenParser C.describeTok (nameOfSource source) + = case BP.runTokenParser C.describeTok (nameOfSource source) (pModule context) tokens of Left err -> error $ show err Right mm -> goDesugar mm diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs b/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs --- a/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs +++ b/src/ddci-tetra/DDCI/Tetra/Command/Infer.hs @@ -1,9 +1,9 @@ - +{-# LANGUAGE TypeFamilies #-} module DDCI.Tetra.Command.Infer (cmdInfer) where -import DDC.Interface.Source import DDCI.Tetra.State +import DDC.Driver.Interface.Source import DDC.Base.Pretty import DDC.Source.Tetra.Env import DDC.Source.Tetra.Lexer @@ -23,13 +23,7 @@ in goParse tokens goParse tokens - = let context = Context - { contextTrackedEffects = True - , contextTrackedClosures = True - , contextFunctionalEffects = False - , contextFunctionalClosures = False } - - in case BP.runTokenParser C.describeTok (nameOfSource source) + = case BP.runTokenParser C.describeTok (nameOfSource source) (pModule context) tokens of Left err -> error $ show err Right mm -> goDesugar mm diff --git a/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs b/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs --- a/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs +++ b/src/ddci-tetra/DDCI/Tetra/Command/Parse.hs @@ -2,7 +2,7 @@ module DDCI.Tetra.Command.Parse (cmdParse) where -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDCI.Tetra.State import DDC.Base.Pretty import DDC.Source.Tetra.Lexer @@ -20,13 +20,7 @@ in goParse tokens goParse tokens - = let context = Context - { contextTrackedEffects = True - , contextTrackedClosures = True - , contextFunctionalEffects = False - , contextFunctionalClosures = False } - - in case BP.runTokenParser + = case BP.runTokenParser C.describeTok (nameOfSource source) (pModule context) diff --git a/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs b/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs --- a/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs +++ b/src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs @@ -2,22 +2,22 @@ (cmdToCore) where import DDCI.Tetra.State -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Driver.Stage import DDC.Build.Pipeline import DDC.Base.Pretty import qualified DDC.Driver.Config as D - +import DDC.Build.Interface.Store (Store) -- Convert Disciple Source Tetra text into Disciple Core Tetra. -cmdToCore :: State -> D.Config -> Source -> String -> IO () -cmdToCore _state config source str +cmdToCore :: State -> D.Config -> Store -> Source -> String -> IO () +cmdToCore _state config store source str = let pmode = D.prettyModeOfConfig $ D.configPretty config pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageSourceTetraLoad config source + $ stageSourceTetraLoad config source store [ PipeCoreOutput pmode SinkStdout ] in do diff --git a/src/ddci-tetra/DDCI/Tetra/Input.hs b/src/ddci-tetra/DDCI/Tetra/Input.hs --- a/src/ddci-tetra/DDCI/Tetra/Input.hs +++ b/src/ddci-tetra/DDCI/Tetra/Input.hs @@ -7,7 +7,7 @@ where import DDCI.Tetra.State import DDCI.Tetra.Command -import DDC.Interface.Input +import DDC.Driver.Interface.Input -- Eating input lines. diff --git a/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs b/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs --- a/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs +++ b/src/ddci-tetra/DDCI/Tetra/Interface/Args.hs @@ -5,8 +5,8 @@ import DDCI.Tetra.Command.Help import DDCI.Tetra.Command import DDCI.Tetra.State -import DDC.Interface.Input -import DDC.Interface.Source +import DDC.Driver.Interface.Input +import DDC.Driver.Interface.Source import DDC.Data.ListUtils import Data.List diff --git a/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs b/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs --- a/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs +++ b/src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs @@ -5,7 +5,7 @@ import DDCI.Tetra.State import DDCI.Tetra.Input import DDCI.Tetra.Command -import DDC.Interface.Input +import DDC.Driver.Interface.Input import Data.List diff --git a/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs b/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs --- a/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs +++ b/src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs @@ -5,7 +5,7 @@ import DDCI.Tetra.Input import DDCI.Tetra.State import DDCI.Tetra.Command -import DDC.Interface.Input +import DDC.Driver.Interface.Input import Data.List import Data.Maybe import qualified System.Console.Haskeline as HL @@ -15,7 +15,7 @@ -- | Run an interactive session, reading commands from the console. runInteractive :: IO () runInteractive - = do putStrLn "DDCi-tetra, version 0.4.1: http://disciple.ouroborus.net." + = do putStrLn "DDCi-tetra, version 0.4.2: http://disciple.ouroborus.net." putStrLn "Type :help for help." -- Setup terminal mode. diff --git a/src/ddci-tetra/DDCI/Tetra/Output.hs b/src/ddci-tetra/DDCI/Tetra/Output.hs --- a/src/ddci-tetra/DDCI/Tetra/Output.hs +++ b/src/ddci-tetra/DDCI/Tetra/Output.hs @@ -5,7 +5,7 @@ , chatStrLn) where import DDCI.Tetra.State -import DDC.Interface.Input +import DDC.Driver.Interface.Input import DDC.Base.Pretty diff --git a/src/ddci-tetra/DDCI/Tetra/State.hs b/src/ddci-tetra/DDCI/Tetra/State.hs --- a/src/ddci-tetra/DDCI/Tetra/State.hs +++ b/src/ddci-tetra/DDCI/Tetra/State.hs @@ -10,7 +10,7 @@ where import DDCI.Tetra.Mode import DDC.Code.Config -import DDC.Interface.Input +import DDC.Driver.Interface.Input import DDC.Build.Builder import System.FilePath import Data.Set (Set) @@ -66,7 +66,8 @@ = do builder <- getActiveBuilder state return $ D.Config - { D.configDump = Set.member Dump (stateModes state) + { D.configLogBuild = True + , D.configDump = Set.member Dump (stateModes state) , D.configInferTypes = False , D.configViaBackend = D.ViaLLVM @@ -76,9 +77,10 @@ = Runtime.Config { Runtime.configHeapSize = 65536 } + , D.configRuntimeLinkStrategy = D.LinkDefault + , D.configModuleBaseDirectories = [] , D.configOutputFile = Nothing , D.configOutputDir = Nothing - , D.configSimplLite = S.Trans S.Id , D.configSimplSalt = S.Trans S.Id , D.configBuilder = builder , D.configPretty = configPretty @@ -107,7 +109,8 @@ = do baseLibraryPath <- locateBaseLibrary return $ BuilderConfig { builderConfigBaseSrcDir = baseLibraryPath - , builderConfigBaseLibDir = baseLibraryPath "build" } + , builderConfigBaseLibDir = baseLibraryPath "build" + , builderConfigLibFile = \_static dynamic -> dynamic } -- | Get the active builder.