ddc-tools 0.4.1.3 → 0.4.2.1
raw patch · 35 files changed
+539/−920 lines, 35 filesdep −ddc-core-evaldep −ddc-interfacedep ~basedep ~ddc-basedep ~ddc-buildsetup-changed
Dependencies removed: ddc-core-eval, ddc-interface
Dependency ranges changed: base, ddc-base, ddc-build, ddc-code, ddc-core, ddc-core-flow, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, ddc-core-tetra, ddc-driver, ddc-source-tetra, filepath, haskeline, mtl
Files
- Setup.hs +2/−1
- ddc-tools.cabal +58/−66
- src/ddc-check/Config.hs +3/−3
- src/ddc-main/DDC/Main/Args.hs +29/−5
- src/ddc-main/DDC/Main/Config.hs +43/−20
- src/ddc-main/DDC/Main/Help.hs +20/−15
- src/ddc-main/DDC/Main/OptLevels.hs +15/−129
- src/ddc-main/Main.hs +140/−56
- src/ddci-core/DDCI/Core/Command.hs +44/−38
- src/ddci-core/DDCI/Core/Command/Eval.hs +0/−298
- src/ddci-core/DDCI/Core/Command/Help.hs +1/−2
- src/ddci-core/DDCI/Core/Command/Set.hs +17/−17
- src/ddci-core/DDCI/Core/Command/TransInteract.hs +38/−38
- src/ddci-core/DDCI/Core/Command/With.hs +15/−26
- src/ddci-core/DDCI/Core/Input.hs +4/−5
- src/ddci-core/DDCI/Core/Interface/Args.hs +1/−1
- src/ddci-core/DDCI/Core/Interface/Batch.hs +1/−1
- src/ddci-core/DDCI/Core/Interface/Interactive.hs +4/−4
- src/ddci-core/DDCI/Core/Mode.hs +1/−1
- src/ddci-core/DDCI/Core/Output.hs +1/−1
- src/ddci-core/DDCI/Core/Rewrite.hs +16/−16
- src/ddci-core/DDCI/Core/State.hs +41/−41
- src/ddci-core/DDCI/Core/Stats/Trace.hs +0/−80
- src/ddci-core/Main.hs +9/−8
- src/ddci-tetra/DDCI/Tetra/Command.hs +9/−6
- src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs +3/−9
- src/ddci-tetra/DDCI/Tetra/Command/Infer.hs +3/−9
- src/ddci-tetra/DDCI/Tetra/Command/Parse.hs +2/−8
- src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs +5/−5
- src/ddci-tetra/DDCI/Tetra/Input.hs +1/−1
- src/ddci-tetra/DDCI/Tetra/Interface/Args.hs +2/−2
- src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs +1/−1
- src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs +2/−2
- src/ddci-tetra/DDCI/Tetra/Output.hs +1/−1
- src/ddci-tetra/DDCI/Tetra/State.hs +7/−4
Setup.hs view
@@ -6,7 +6,8 @@ import System.Process import System.Exit -main = defaultMainWithHooks hooks+main + = defaultMainWithHooks hooks hooks = simpleUserHooks { postInst = hookPostInstall }
ddc-tools.cabal view
@@ -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
src/ddc-check/Config.hs view
@@ -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 <fragment> Set the language fragment. (default Lite)"+ , " -language <fragment> Set the language fragment. (default Tetra)" , " fragment one of " ++ (show $ map fst languages) , "" ]
src/ddc-main/DDC/Main/Args.hs view
@@ -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"
src/ddc-main/DDC/Main/Config.hs view
@@ -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 }+
src/ddc-main/DDC/Main/Help.hs view
@@ -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."
src/ddc-main/DDC/Main/OptLevels.hs view
@@ -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
src/ddc-main/Main.hs view
@@ -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
src/ddci-core/DDCI/Core/Command.hs view
@@ -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 ()
− src/ddci-core/DDCI/Core/Command/Eval.hs
@@ -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-
src/ddci-core/DDCI/Core/Command/Help.hs view
@@ -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"
src/ddci-core/DDCI/Core/Command/Set.hs view
@@ -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
src/ddci-core/DDCI/Core/Command/TransInteract.hs view
@@ -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!"
src/ddci-core/DDCI/Core/Command/With.hs view
@@ -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
src/ddci-core/DDCI/Core/Input.hs view
@@ -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
src/ddci-core/DDCI/Core/Interface/Args.hs view
@@ -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
src/ddci-core/DDCI/Core/Interface/Batch.hs view
@@ -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
src/ddci-core/DDCI/Core/Interface/Interactive.hs view
@@ -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.
src/ddci-core/DDCI/Core/Mode.hs view
@@ -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.
src/ddci-core/DDCI/Core/Output.hs view
@@ -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
src/ddci-core/DDCI/Core/Rewrite.hs view
@@ -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
src/ddci-core/DDCI/Core/State.hs view
@@ -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.
− src/ddci-core/DDCI/Core/Stats/Trace.hs
@@ -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))-
src/ddci-core/Main.hs view
@@ -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 ()
src/ddci-tetra/DDCI/Tetra/Command.hs view
@@ -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 ()
src/ddci-tetra/DDCI/Tetra/Command/Desugar.hs view
@@ -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
src/ddci-tetra/DDCI/Tetra/Command/Infer.hs view
@@ -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
src/ddci-tetra/DDCI/Tetra/Command/Parse.hs view
@@ -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)
src/ddci-tetra/DDCI/Tetra/Command/ToCore.hs view
@@ -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
src/ddci-tetra/DDCI/Tetra/Input.hs view
@@ -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.
src/ddci-tetra/DDCI/Tetra/Interface/Args.hs view
@@ -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
src/ddci-tetra/DDCI/Tetra/Interface/Batch.hs view
@@ -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
src/ddci-tetra/DDCI/Tetra/Interface/Interactive.hs view
@@ -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.
src/ddci-tetra/DDCI/Tetra/Output.hs view
@@ -5,7 +5,7 @@ , chatStrLn) where import DDCI.Tetra.State-import DDC.Interface.Input+import DDC.Driver.Interface.Input import DDC.Base.Pretty
src/ddci-tetra/DDCI/Tetra/State.hs view
@@ -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.