diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +-------------------------------------------------------------------------------- +The Disciplined Disciple Compiler License (MIT style) + +Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force +All rights reversed. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +------------------------------------------------------------------------------- +Under Australian law copyright is free and automatic. +By contributing to DDC authors grant all rights they have regarding their +contributions to the other members of the Disciplined Disciple Compiler Strike +Force, past, present and future, as well as placing their contributions under +the above license. + +Use "darcs show authors" to get a list of Strike Force members. + +-------------------------------------------------------------------------------- +Redistributions of libraries in ./external are governed by their own licenses: + + - TinyPTC GNU Lesser General Public License + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,37 @@ +import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription +import System.FilePath +import System.Exit +import System.Cmd + +main = defaultMainWithHooks hooks + +hooks = simpleUserHooks + { postInst = hookPostInstall } + + +-- Build the base library from the ddc-code package after we've installed ddc. +hookPostInstall + :: Args + -> InstallFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () + +hookPostInstall _args _flags desc buildInfo + = do putStrLn "Building base libraries..." + + -- Find out where Cabal has put the DDC executable. + let installDirs = absoluteInstallDirs desc buildInfo NoCopyDest + let ddcExe = (bindir $ installDirs) + (fromPathTemplate $ progPrefix buildInfo) + ++ "ddc" + <.> (fromPathTemplate $ progSuffix buildInfo) + + -- Run the basebuild command, which builds the library. + code <- system $ ddcExe ++ " -basebuild -O" + case code of + ExitFailure _ -> error "Failed!" + ExitSuccess -> return () diff --git a/ddc-tools.cabal b/ddc-tools.cabal new file mode 100644 --- /dev/null +++ b/ddc-tools.cabal @@ -0,0 +1,130 @@ +Name: ddc-tools +Version: 0.3.1.1 +License: MIT +License-file: LICENSE +Author: The Disciplined Disciple Compiler Strike Force +Maintainer: Ben Lippmeier +Build-Type: Custom +Cabal-Version: >=1.6 +Stability: experimental +Category: Compilers/Interpreters +Homepage: http://disciple.ouroborus.net +Bug-reports: disciple@ouroborus.net +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.*, + ddc-core == 0.3.1.* + + Main-is: + Main.hs + + Other-modules: + Config + + Extensions: + PatternGuards + +Executable ddc + hs-source-dirs: + src/ddc-main + + Build-depends: + base == 4.6.*, + containers == 0.5.*, + process == 1.1.*, + filepath == 1.3.*, + haskeline == 0.7.*, + haskell-src-exts== 1.13.*, + directory == 1.2.*, + mtl == 2.1.*, + transformers == 0.3.*, + ddc-base == 0.3.1.*, + ddc-core == 0.3.1.*, + ddc-core-eval == 0.3.1.*, + ddc-core-simpl == 0.3.1.*, + ddc-core-salt == 0.3.1.*, + ddc-core-llvm == 0.3.1.*, + ddc-build == 0.3.1.*, + ddc-driver == 0.3.1.*, + ddc-code == 0.3.1.* + + Main-is: + Main.hs + + Other-modules: + DDC.Main.Args + DDC.Main.Config + DDC.Main.Help + DDC.Main.OptLevels + + Extensions: + PatternGuards + +Executable ddci-core + hs-source-dirs: + src/ddci-core + + Build-depends: + base == 4.6.*, + containers == 0.5.*, + process == 1.1.*, + filepath == 1.3.*, + haskeline == 0.7.*, + haskell-src-exts== 1.*, + directory == 1.2.*, + mtl == 2.1.*, + ddc-base == 0.3.1.*, + ddc-core == 0.3.1.*, + ddc-core-eval == 0.3.1.*, + ddc-core-simpl == 0.3.1.*, + ddc-core-salt == 0.3.1.*, + ddc-core-llvm == 0.3.1.*, + ddc-build == 0.3.1.*, + ddc-driver == 0.3.1.* + + Main-is: + Main.hs + + Other-modules: + DDCI.Core.Command.Eval + DDCI.Core.Command.Help + DDCI.Core.Command.Set + DDCI.Core.Command.Trans + DDCI.Core.Command.TransInteract + DDCI.Core.Command.With + DDCI.Core.Interface.Args + DDCI.Core.Interface.Batch + DDCI.Core.Interface.Interactive + DDCI.Core.Stats.Trace + DDCI.Core.Command + DDCI.Core.Input + DDCI.Core.Mode + DDCI.Core.Output + DDCI.Core.Rewrite + DDCI.Core.State + + Extensions: + DoAndIfThenElse + PatternGuards + ParallelListComp + FlexibleContexts + ExistentialQuantification + MultiParamTypeClasses + FunctionalDependencies + TypeSynonymInstances + FlexibleInstances + StandaloneDeriving + KindSignatures + RankNTypes + ScopedTypeVariables + + ghc-options: + -Wall + -fno-warn-missing-signatures + -fno-warn-unused-do-bind diff --git a/src/ddc-check/Config.hs b/src/ddc-check/Config.hs new file mode 100644 --- /dev/null +++ b/src/ddc-check/Config.hs @@ -0,0 +1,87 @@ + +module Config where +import DDC.Build.Language +import qualified DDC.Build.Language.Lite as Lite +import System.FilePath +import System.Exit + + +-- | DDC type checker command line interface config. +data Config + = Config + { -- | Source file to load, or Nothing to read source from stdin. + configSourceFile :: Maybe String + + -- | Language fragment to check. + , configLanguage :: Language + + -- | If true then don't print checked source file to stdout. + , configQuiet :: Bool } + + +-- | Default command line configuration. +defaultConfig :: Config +defaultConfig + = Config + { configSourceFile = Nothing + , configLanguage = Language Lite.bundle + , configQuiet = False } + + +-- | Parse command line arguments. +parseArgs :: [String] -> Config -> IO Config +parseArgs [] config + = return config + +parseArgs args@(arg : more) config + -- Display usage help. + | arg == "-help" || arg == "--help" + = do putStr usage + exitWith ExitSuccess + + -- Set quiet mode. + | arg == "-quiet" + = do parseArgs more $ config { configQuiet = True } + + -- Set the language fragment manually. + | "-language" : lang : rest <- args + = case lookup lang languages of + Just l -> parseArgs rest $ config { configLanguage = l } + Nothing -> error $ unlines + [ "unknown language " ++ lang + , " options are: " ++ (show $ map fst languages) ] + + -- Try to guess the language fragment based on the file name extension. + | fileName : [] <- args + , extension <- takeExtension fileName + = case languageOfExtension extension of + Just language + -> return + $ config { configSourceFile = Just fileName + , configLanguage = language } + + Nothing + -> error $ "unrecognised extension " ++ show extension + + | otherwise + = do putStr usage + error $ "unknown argument " ++ show arg + + +-- | Command line usage information. +usage :: String +usage + = unlines + [ "Disciplined Disciple Compiler type checker." + , "" + , " Usage:" + , " ddc-check [flags] Read input from stdin." + , " ddc-check [flags] Read input from file." + , "" + , " Flags:" + , " -help Display this help." + , " -quiet Don't print checked module to stdout." + , " -language Set the language fragment. (default Lite)" + , " fragment one of " ++ (show $ map fst languages) + , "" ] + diff --git a/src/ddc-check/Main.hs b/src/ddc-check/Main.hs new file mode 100644 --- /dev/null +++ b/src/ddc-check/Main.hs @@ -0,0 +1,56 @@ + +-- | Command-line interface to the DDC type checker, which is also +-- possible via the plain 'ddc' command. +-- +-- This code is provided as an example of how to drive the DDC +-- compiler framework. +-- +module Main where +import Config +import DDC.Build.Language +import DDC.Build.Pipeline +import DDC.Core.Pretty +import System.IO +import System.Environment + + +main :: IO () +main + = do args <- getArgs + config <- parseArgs args defaultConfig + + -- Get the source text. + -- either from a file or stdin + (source, sourceName) + <- case configSourceFile config of + Just fileName + -> do src <- readFile fileName + return (src, fileName) + + Nothing + -> do src <- hGetContents stdin + return (src, "") + + -- Check with the configured language fragment. + runLanguage config source sourceName (configLanguage config) + + +runLanguage config source sourceName language + | Language bundle <- language + , fragment <- bundleFragment bundle + = do + -- In quiet mode just drop the checked module on the floor. + let sink + | configQuiet config = SinkDiscard + | otherwise = SinkStdout + + -- Loading the core code automatically check it + -- against the provided fragment. + errs <- pipeText sourceName 1 source + $ PipeTextLoadCore fragment + [ PipeCoreOutput sink ] + + -- If the pipeline died with errors, + -- then print them. + mapM_ (putStrLn . renderIndent . ppr) errs + diff --git a/src/ddc-main/DDC/Main/Args.hs b/src/ddc-main/DDC/Main/Args.hs new file mode 100644 --- /dev/null +++ b/src/ddc-main/DDC/Main/Args.hs @@ -0,0 +1,207 @@ + +-- | Parsing of command line configuation arguments. +module DDC.Main.Args + ( parseArgs + , help) +where +import DDC.Main.Config +import DDC.Main.Help +import Data.Char + + +-- | Parse command line arguments. +parseArgs :: [String] -> Config -> IO Config +parseArgs [] config + = return config + +parseArgs args config + -- General ------------------------------ + | flag : _ <- args + , elem flag ["-version", "--version"] + = return + $ config { configMode = ModeVersion } + + | flag : _ <- args + , elem flag ["-h", "-help", "--help"] + = return + $ config { configMode = ModeHelp } + + | flag : file : rest <- args + , elem flag ["-make", "--make" ] + = parseArgs rest + $ setMode config $ ModeMake file + + | "-basebuild" : rest <- args + = parseArgs rest + $ setMode config $ ModeBaseBuild + + -- Compilation -------------------------- + | flag : file : rest <- args + , elem flag ["-c", "-compile", "--compile"] + = parseArgs rest + $ setMode config $ ModeCompile file + + | "-basedir" : path : rest <- args + = parseArgs rest + $ config { configBaseDir = path } + + | flag : file : rest <- args + , elem flag ["-o", "-output"] + = parseArgs rest + $ config { configOutputFile = Just file } + + | "-fvia-c" : rest <- args + = parseArgs rest + $ config { configViaBackend = ViaC } + + | "-fvia-llvm" : rest <- args + = parseArgs rest + $ config { configViaBackend = ViaLLVM } + + | flag : dir : rest <- args + , elem flag ["-output-dir"] + = parseArgs rest + $ config { configOutputDir = Just dir } + + -- Optimisation ------------------------- + | "-O0" : rest <- args + = parseArgs rest + $ config { configOptLevelLite = OptLevel0 + , configOptLevelSalt = OptLevel0 } + + | flag : rest <- args + , elem flag [ "-O", "-O1" ] + = parseArgs rest + $ config { configOptLevelLite = OptLevel1 + , configOptLevelSalt = OptLevel1 } + + -- Intermediates ------------------------ + | flag : rest <- args + , elem flag ["-keep-ll-files", "-keep-llvm-files" ] + = parseArgs rest + $ config { configKeepLlvmFiles = True } + + | flag : rest <- args + , elem flag ["-keep-c-files", "-keep-sea-files" ] + = parseArgs rest + $ config { configKeepSeaFiles = True } + + | flag : rest <- args + , elem flag ["-keep-s-files", "-keep-asm-files" ] + = parseArgs rest + $ config { configKeepAsmFiles = True } + + -- Runtime ------------------------------ + | "-run-heap" : bytes : rest <- args + , all isDigit bytes + = parseArgs rest + $ config { configRuntimeHeapSize = read bytes } + + -- Checking ----------------------------- + | "-check" : file : rest <- args + = parseArgs rest + $ config { configMode = ModeCheck file } + + -- Transformation ----------------------- + | "-load" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeLoad file + + | "-trans" : trans : rest <- args + = parseArgs rest + $ config { configTrans = Just trans } + + | "-with" : file : rest <- args + = parseArgs rest + $ config { configWith = configWith config ++ [file] } + + -- Conversion --------------------------- + | "-to-salt" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeToSalt file + + | "-to-c" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeToC file + + | "-to-llvm" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeToLLVM file + + -- Debugging ---------------------------- + | "-dump" : rest <- args + = parseArgs rest + $ config { configDump = True } + + | "-ast" : file : rest <- args + = parseArgs rest + $ setMode config $ ModeAST file + + | "-print-builder" : rest <- args + = parseArgs rest + $ setMode config ModePrintBuilder + + | "-print-basedir" : rest <- args + = parseArgs rest + $ setMode config ModePrintBaseDir + + -- If we get some other argument starting with '-' then assume it's + -- a flag we don't support. + | arg : _ <- args + , '-' : _ <- arg + = error $ "Cannot parse arguments " ++ show args + + -- Otherwise, treat the argument as a source file to make. + | arg : rest <- args + = parseArgs rest + $ setMode config (ModeMake arg) + + | otherwise + = error $ "Cannot parse arguments " ++ show args + + +-- | Set the major mode of DDC. +-- +-- We can't have two major modes like '-make' and '-compile' set at the same time. +-- If this happens then `error`. +setMode :: Config -> Mode -> Config +setMode config newMode + | ModeMake{} <- configMode config + , ModeMake{} <- newMode + = error "Multi-module compilation is not supported yet." + + | ModeCompile{} <- configMode config + , ModeCompile{} <- newMode + = error "Multi-module compilation is not supported yet." + + | otherwise + = case flagOfMode newMode of + Nothing + -> error "DDC.Main.Args.setMode: not setting mode to ModeNone" + + Just newFlag + -> case flagOfMode $ configMode config of + Nothing -> config { configMode = newMode } + Just oldFlag -> error $ "Cannot use " ++ newFlag ++ " with " ++ oldFlag + + +-- | Get the flag used to set DDC to this mode. +flagOfMode :: Mode -> Maybe String +flagOfMode mode + = case mode of + ModeNone{} -> Nothing + ModeVersion{} -> Just "-version" + ModeHelp{} -> Just "-help" + ModeCheck{} -> Just "-check" + ModeLoad{} -> Just "-load" + ModeCompile{} -> Just "-compile" + ModeMake{} -> Just "-make" + ModeAST{} -> Just "-ast" + ModeToSalt{} -> Just "-to-salt" + ModeToC{} -> Just "-to-c" + ModeToLLVM{} -> Just "-to-llvm" + ModeBaseBuild{} -> Just "-basebuild" + ModePrintBuilder{} -> Just "-print-builder" + ModePrintBaseDir{} -> Just "-print-basedir" + + diff --git a/src/ddc-main/DDC/Main/Config.hs b/src/ddc-main/DDC/Main/Config.hs new file mode 100644 --- /dev/null +++ b/src/ddc-main/DDC/Main/Config.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP #-} + +-- | Define the command line configuation arguments. +module DDC.Main.Config + ( Mode (..) + , OptLevel (..) + , D.ViaBackend (..) + , Config (..) + + , getDefaultConfig + , defaultBuilderConfig) +where +import DDC.Code.Config +import DDC.Build.Builder +import System.FilePath +import qualified DDC.Driver.Stage as D + + +-- | The main command that we're running. +data Mode + -- | Don't do anything + = ModeNone + + -- | Display the version string. + | ModeVersion + + -- | Display the help page. + | ModeHelp + + -- | Parse and type-check a module. + | ModeCheck FilePath + + -- | Parse, type-check and transform a module. + | ModeLoad FilePath + + -- | Compile a .dcl or .dce into an object file. + | ModeCompile FilePath + + -- | Compile a .dcl or .dce into an executable file. + | ModeMake FilePath + + -- | Pretty print a module's AST. + | ModeAST FilePath + + -- | Convert a module to Salt. + | ModeToSalt FilePath + + -- | Convert a module to C. + | ModeToC FilePath + + -- | Convert a module to LLVM. + | ModeToLLVM FilePath + + -- | Build the base libraries and runtime. + | ModeBaseBuild + + -- | Print the builder info for this platform. + | ModePrintBuilder + + -- | Print where the runtime and base libraries are intalled. + | ModePrintBaseDir + deriving (Eq, Show) + + +data OptLevel + -- | Don't do any optimisations. + = OptLevel0 + + -- | Do standard optimisations. + | OptLevel1 + deriving Show + + +-- | DDC config. +data Config + = Config + { -- | The main compilation mode. + configMode :: Mode + + -- Compilation -------------- + -- | Directory holding the runtime and base library code. + , configBaseDir :: FilePath + + -- | Redirect output to this file. + , configOutputFile :: Maybe FilePath + + -- | Redirect output to this directory. + , configOutputDir :: Maybe FilePath + + -- | What backend to use for compilation + , configViaBackend :: D.ViaBackend + + -- 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 + + -- Intermediates ------------- + , configKeepLlvmFiles :: Bool + , configKeepSeaFiles :: Bool + , configKeepAsmFiles :: Bool + + -- Transformation ------------ + -- | String containing the transform definition to apply with + -- the -load command. We can't parse this definition until + -- we know what language we're dealing with. + , configTrans :: Maybe String + + -- | Other modules to use for inliner templates. + , configWith :: [FilePath] + + -- Debugging ----------------- + -- | Dump intermediate representations. + , configDump :: Bool } + deriving (Show) + + +-- | Default configuation. +getDefaultConfig :: IO Config +getDefaultConfig + = do baseDir <- locateBaseLibrary + + return $ Config + { configMode = ModeNone + + -- Compilation -------------- + , configBaseDir = baseDir + , configOutputFile = Nothing + , configOutputDir = Nothing + , configViaBackend = D.ViaLLVM + + -- Optimisation ------------- + , configOptLevelLite = OptLevel0 + , configOptLevelSalt = OptLevel0 + , configWithLite = [] + , configWithSalt = [] + + -- Runtime ------------------ + , configRuntimeHeapSize = 65536 + + -- Intermediates ------------ + , configKeepLlvmFiles = False + , configKeepSeaFiles = False + , configKeepAsmFiles = False + + -- Transformation ----------- + , configTrans = Nothing + , configWith = [] + + -- Debugging ---------------- + , configDump = False } + + +-- | Get the builder configuation from the ddc configuration. +defaultBuilderConfig :: Config -> BuilderConfig +defaultBuilderConfig config + = BuilderConfig + { builderConfigBaseSrcDir = configBaseDir config + , builderConfigBaseLibDir = configBaseDir config "build" } + diff --git a/src/ddc-main/DDC/Main/Help.hs b/src/ddc-main/DDC/Main/Help.hs new file mode 100644 --- /dev/null +++ b/src/ddc-main/DDC/Main/Help.hs @@ -0,0 +1,87 @@ + +module DDC.Main.Help where + +-- | The version identifier string. +version :: String +version = "The Disciplined Disciple Compiler, version 0.3.0" + + +-- | What to print when we have no input files. +hello :: String +hello = unlines + [ "ddc: no input files" + , "For usage information, try the -help option." ] + + +-- | The command-line help page. +help :: String +help = unlines + [ version + , "" + , "General:" + , " -help Display this help." + , " -version Display the version string." + , "" + , "Compilation:" + , " -make FILE Compile a module into an executable file." + , " -c, -compile FILE Compile a module into an object file." + , "" + , " -o, -output FILE Redirect output to this file." + , " -output-dir DIR Redirect output to this directory." + , "" + , " -fvia-llvm Compile via the LLVM backend (default)" + , " -fvia-c Compile via the C backend." + , "" + , " -keep-ll-files Keep intermediate .ll files." + , " -keep-c-files Keep intermediate .c files." + , " -keep-s-files Keep intermediate .s files." + , "" + , "Optimisation:" + , " -O0 No optimisations. (default)" + , " -O, -O1 Do standard optimisations." + , "" + , "Runtime for compiled program:" + , " -run-heap BYTES Size of fixed heap (65536)" + , "" + , "Checking:" + , " -check FILE Parse and type check a core module." + , "" + , "Conversion:" + , " -to-salt FILE Convert a module to Disciple Core Salt." + , " -to-c FILE Convert a module to C code." + , " -to-llvm FILE Convert a module to LLVM code." + , "" + , "Debugging:" + , " -dump Dump intermediate representations." + , " -ast FILE Pretty print the AST of a module." + , "" + , "Configuration:" + , " -basedir DIR Path to the runtime and base library code." + , " -print-basedir Print directory holding the runtime and base libraries." + , " -print-builder Print external builder info for this platform." + , "" + , "Transformation:" + , " -load FILE Parse, type check and transform a module." + , " -trans TRANS Set the transformation to use with -load." + , " -with FILE Use this module for inliner templates with -load." + , "" + , " TRANS ::= " + , " { TRANS } Parenthesis." + , " fix N TRANS Transform to a fixpoint, or bail out after N iterations." + , " TRANS; TRANS Sequence two transforms." + , " Id Return the original program unharmed." + , " Anonymize Anonymize names to deBruijn form." + , " Namify Introduce fresh names for deBruijn binders." + , " Snip Introduce let-bindings for nested applications." + , " SnipOver ... and over-applications." + , " Flatten Flatten nested let-bindings." + , " Beta Perform beta-reduction for value arguments." + , " BetaLets ... introducing new let-bindings for redex arguments." + , " Bubble Float casts outwards, and combine similar ones." + , " Prune Erase unused, ineffectual let-bindings." + , " Forward Float let-bindings forward into their use sites." + , " Rewrite Perform rule based rewriting." + , " Elaborate Introduce default witnesses for unconstrained regions." + , " Inline MODULE[NAME..] Perform inlining. Use '-with' to add source modules." ] + + diff --git a/src/ddc-main/DDC/Main/OptLevels.hs b/src/ddc-main/DDC/Main/OptLevels.hs new file mode 100644 --- /dev/null +++ b/src/ddc-main/DDC/Main/OptLevels.hs @@ -0,0 +1,188 @@ + +-- | Define the default optimisation levels. +module DDC.Main.OptLevels + ( getSimplLiteOfConfig + , getSimplSaltOfConfig) +where +import DDC.Main.Config +import DDC.Driver.Command.Load +import DDC.Driver.Command.RewriteRules +import DDC.Build.Builder +import DDC.Build.Platform +import DDC.Core.Module +import DDC.Core.Transform.Inline +import DDC.Core.Transform.Namify +import DDC.Core.Transform.Reannotate +import DDC.Core.Simplifier (Simplifier) +import System.FilePath +import Control.Monad +import Data.Monoid +import Data.Maybe +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.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 -> Builder + -> IO (Simplifier Int () Lite.Name) + +getSimplLiteOfConfig config builder + = case configOptLevelLite config of + OptLevel0 -> opt0_lite config + OptLevel1 -> opt1_lite config builder + + +-- | Get the simplifier for Salt code from the config. +-- +getSimplSaltOfConfig + :: Config -> Builder + -> IO (Simplifier Int () Salt.Name) + +getSimplSaltOfConfig config builder + = case configOptLevelSalt config of + OptLevel0 -> opt0_salt config + OptLevel1 -> opt1_salt config builder + + +-- 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 _ + = return $ S.Trans S.Id + + +-- Level 1 -------------------------------------------------------------------- +-- Do full optimsiations. + +-- | Level 1 optimiser for Core Lite code. +opt1_lite + :: Config -> Builder + -> IO (Simplifier Int () Lite.Name) + +opt1_lite config _builder + = 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 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 + + let rules' = concat rules + + -- 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 -> Builder + -> IO (Simplifier Int () Salt.Name) + +opt1_salt config builder + = do + -- Auto-inline the low-level code from the runtime system + -- that constructs and destructs objects. + let targetWidth + = archPointerWidth $ platformArch $ buildTarget builder + + -- The runtime system code comes in different versions, + -- depending on the pointer width of the target architecture. + let inlineModulePaths + = [ configBaseDir config + "salt/runtime" ++ show targetWidth "Object.dcs"] + ++ configWithSalt config + + -- Load all the modues 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 Salt.fragment) + inlineModulePaths + + let inlineModules + = map (reannotate (const ())) + $ fromMaybe (error "Imported modules do not parse.") + minlineModules + + let inlineSpec + = Map.fromList + [ (ModuleName ["Object"], InlineSpecAll (ModuleName ["Int"]) Set.empty) ] + + -- Optionally load the rewrite rules for each 'with' module + rules <- mapM (\(m,file) -> cmdTryReadRules Salt.fragment (file ++ ".rules") m) + $ inlineModules `zip` inlineModulePaths + let rules' = concat rules + + + -- Simplifier to convert to a-normal form. + let normalizeSalt + = S.anormalize + (makeNamifier Salt.freshT) + (makeNamifier Salt.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 + <> normalizeSalt <> S.forward + <> (S.Trans $ S.Rewrite rules')) + diff --git a/src/ddc-main/Main.hs b/src/ddc-main/Main.hs new file mode 100644 --- /dev/null +++ b/src/ddc-main/Main.hs @@ -0,0 +1,198 @@ + +-- | Unix-style command line interface to DDC. +-- This interface exports commands that work on whole modules at a time, +-- and does unix-style command line argument parsing. +-- +import DDC.Main.Config +import DDC.Main.Help +import DDC.Main.Args +import DDC.Main.OptLevels +import DDC.Driver.Command.Load +import DDC.Driver.Command.Check +import DDC.Driver.Command.Compile +import DDC.Driver.Command.Make +import DDC.Driver.Command.Ast +import DDC.Driver.Command.BaseBuild +import DDC.Driver.Command.ToSalt +import DDC.Driver.Command.ToC +import DDC.Driver.Command.ToLlvm +import DDC.Driver.Source +import DDC.Build.Builder +import DDC.Build.Language +import DDC.Base.Pretty +import System.Environment +import System.IO +import System.Exit +import System.FilePath +import Control.Monad.Trans.Error +import qualified DDC.Driver.Stage as Driver +import qualified DDC.Core.Salt.Runtime as Runtime + + +main :: IO () +main + = do args <- getArgs + + -- Get the default configuration. + -- This contains static information such as where the code + -- for the base libraries and runtime system is installed. + config0 <- getDefaultConfig + + -- Update the static config with dynamic config read from + -- the command-line arguments. + config <- parseArgs args config0 + + -- Run the main compiler. + run config + + +run :: Config -> IO () +run config + = case configMode config of + -- We didn't get any arguments on the command line. + ModeNone + -> putStr hello + + -- Display the version string. + ModeVersion + -> putStrLn version + + -- Display the help page. + ModeHelp + -> putStrLn help + + -- Parse and type check a module. + ModeCheck filePath + -> do language <- languageFromFilePath filePath + case language of + Language bundle + -> do mm <- runErrorT + $ cmdCheckModuleFromFile (bundleFragment bundle) filePath + case mm of + Left err + -> do putStrLn err + exitWith $ ExitFailure 1 + + Right _ + -> return () + + + -- Parse, type check and transform a module. + ModeLoad filePath + -> runError $ cmdLoadFromFile + (configTrans config) + (configWith config) + filePath + + -- Compile a module to object code. + ModeCompile filePath + -> do dconfig <- getDriverConfig config + runError $ cmdCompile dconfig filePath + + + -- Compile a module into an executable. + ModeMake filePath + -> do dconfig <- getDriverConfig config + runError $ cmdMake dconfig filePath + + + -- Pretty print the AST of a module. + ModeAST filePath + -> do language <- languageFromFilePath filePath + str <- readFile filePath + cmdAstModule + language + (SourceFile filePath) + str + + + -- Convert a module to Salt. + ModeToSalt filePath + -> do language <- languageFromFilePath filePath + dconfig <- getDriverConfig config + str <- readFile filePath + runError $ cmdToSalt dconfig language (SourceFile filePath) str + + + -- Convert a module to C + ModeToC filePath + -> do language <- languageFromFilePath filePath + dconfig <- getDriverConfig config + str <- readFile filePath + runError $ cmdToC dconfig language (SourceFile filePath) str + + + -- Convert a module to LLVM + ModeToLLVM filePath + -> do language <- languageFromFilePath filePath + dconfig <- getDriverConfig config + str <- readFile filePath + runError $ cmdToLlvm dconfig language (SourceFile filePath) str + + -- Build the runtime and base libraries. + ModeBaseBuild + -> do dconfig <- getDriverConfig config + runError $ cmdBaseBuild dconfig + + -- Print the external builder info for this platform. + ModePrintBuilder + -> do dconfig <- getDriverConfig config + putStrLn $ renderIndent $ ppr (Driver.configBuilder dconfig) + + -- Print where the runtime and base libraries are installed. + ModePrintBaseDir + -> putStrLn $ configBaseDir config + + +-- | Get the compile driver from the config. +getDriverConfig :: Config -> IO Driver.Config +getDriverConfig config + = do Just builder <- determineDefaultBuilder (defaultBuilderConfig config) + simplLite <- getSimplLiteOfConfig config builder + simplSalt <- getSimplSaltOfConfig config builder + + return $ Driver.Config + { Driver.configDump = configDump config + , Driver.configSimplLite = simplLite + , Driver.configSimplSalt = simplSalt + , Driver.configViaBackend = configViaBackend config + + , Driver.configRuntime + = Runtime.Config + { Runtime.configHeapSize = configRuntimeHeapSize config } + + , Driver.configBuilder = builder + , Driver.configSuppressCoreImports = False + , Driver.configSuppressHashImports = False + , Driver.configOutputFile = configOutputFile config + , Driver.configOutputDir = configOutputDir config + , Driver.configKeepLlvmFiles = configKeepLlvmFiles config + , Driver.configKeepSeaFiles = configKeepSeaFiles config + , Driver.configKeepAsmFiles = configKeepAsmFiles config } + + +-- | Determine the current language based on the file extension of this path, +-- and slurp out a bundle of stuff specific to that language from the config. +languageFromFilePath :: FilePath -> IO Language +languageFromFilePath filePath + = case languageOfExtension (takeExtension filePath) of + Nothing + -> do hPutStrLn stderr "Unknown file extension." + exitWith $ ExitFailure 1 + + Just ext + -> return ext + + +-- | Print errors to stderr and set the exit code. +runError :: ErrorT String IO () -> IO () +runError m + = do result <- runErrorT m + case result of + Left err + -> do hPutStrLn stderr err + exitWith $ ExitFailure 1 + + Right _ + -> return () + diff --git a/src/ddci-core/DDCI/Core/Command.hs b/src/ddci-core/DDCI/Core/Command.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command.hs @@ -0,0 +1,265 @@ + +module DDCI.Core.Command + ( Command(..) + , commands + , readCommand + , handleCmd) +where +import DDCI.Core.Command.Help +import DDCI.Core.Command.Set +import DDCI.Core.Command.Eval +import DDCI.Core.Command.Trans +import DDCI.Core.Command.TransInteract +import DDCI.Core.Command.With +import DDCI.Core.State +import DDC.Driver.Command.Ast +import DDC.Driver.Command.Check +import DDC.Driver.Command.Load +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 System.IO +import Control.Monad.Trans.Error +import Data.List + + +-- Command -------------------------------------------------------------------- +-- | The commands that the interpreter supports. +data Command + = CommandBlank -- ^ No command was entered. + | CommandUnknown -- ^ Some unknown (invalid) command. + | CommandHelp -- ^ Display the interpreter help. + | CommandSet -- ^ Set a mode. + | CommandLoad -- ^ Load a module. + | CommandKind -- ^ Show the kind of a type. + | CommandUniverse -- ^ Show the universe of a type. + | CommandUniverse1 -- ^ Given a type, show the universe of the original thing. + | CommandUniverse2 -- ^ Given a kind, show the universe of the original thing. + | CommandUniverse3 -- ^ Given a sort, show the universe of the original thing. + | CommandEquivType -- ^ Check if two types are equivalent. + | CommandWitType -- ^ Show the type of a witness. + | CommandExpCheck -- ^ Check an expression. + | CommandExpType -- ^ Check an expression, showing its type. + | CommandExpEffect -- ^ Check an expression, showing its effect. + | CommandExpClosure -- ^ Check an expression, showing its closure. + | CommandExpRecon -- ^ Reconstruct type annotations on binders. + | CommandEval -- ^ Evaluate an expression. + | CommandTrans -- ^ Transform an expression. + | CommandTransEval -- ^ Transform then evaluate an expression. + | CommandTransInteract -- ^ Interactively transform an expression. + + | CommandAst -- ^ Show the AST of an expression. + + | CommandCompile -- ^ Compile a file. + | CommandMake -- ^ Compile and link and executable. + + | CommandToSalt -- ^ Convert a module to Disciple Salt. + | CommandToC -- ^ Convert a module to C code. + | CommandToLlvm -- ^ Convert a module to LLVM code. + + | CommandWith -- ^ Add a module to the inliner table. + | CommandWithLite + | CommandWithSalt + deriving (Eq, Show) + + +-- | Names used to invoke each command. +-- Short names that form prefixes of other ones must come later +-- in the list. Eg ':with-lite' after ':with' +commands :: [(String, Command)] +commands + = [ (":help", CommandHelp) + , (":?", CommandHelp) + , (":set", CommandSet) + , (":load", CommandLoad) + , (":kind", CommandKind) + , (":universe1", CommandUniverse1) + , (":universe2", CommandUniverse2) + , (":universe3", CommandUniverse3) + , (":universe", CommandUniverse) + , (":tequiv", CommandEquivType) + , (":wtype", CommandWitType) + , (":check", CommandExpCheck) + , (":recon", CommandExpRecon) + , (":type", CommandExpType) + , (":effect", CommandExpEffect) + , (":closure", CommandExpClosure) + , (":eval", CommandEval) + , (":trun", CommandTransEval) + , (":tinteract", CommandTransInteract) + , (":trans", CommandTrans) + , (":ast", CommandAst) + , (":compile", CommandCompile) + , (":make", CommandMake) + , (":to-salt", CommandToSalt) + , (":to-c", CommandToC) + , (":to-llvm", CommandToLlvm) + , (":with-lite", CommandWithLite) + , (":with-salt", CommandWithSalt) + , (":with", CommandWith) ] + + +-- | Read the command from the front of a string. +readCommand :: String -> Maybe (Command, String) +readCommand ss + | null $ words ss + = Just (CommandBlank, ss) + + | (cmd, rest) : _ <- [ (cmd, drop (length str) ss) + | (str, cmd) <- commands + , isPrefixOf str ss ] + = Just (cmd, rest) + + | ':' : _ <- ss + = Just (CommandUnknown, ss) + + | otherwise + = Nothing + + +-- Commands ------------------------------------------------------------------- +-- | Handle a single line of input. +handleCmd :: State -> Command -> Source -> String -> IO State +handleCmd state CommandBlank _ _ + = return state + +handleCmd state cmd source line + = do state' <- handleCmd1 state cmd source line + return state' + +handleCmd1 state cmd source line + = case cmd of + CommandBlank + -> return state + + CommandUnknown + -> do putStr $ unlines + [ "unknown command." + , "use :? for help." ] + + return state + + CommandHelp + -> do putStr help + return state + + CommandSet + -> do state' <- cmdSet state line + return state' + + CommandLoad + -> do runError $ cmdLoadFromString (stateLanguage state) source line + return state + + CommandKind + -> do cmdShowKind (stateLanguage state) source line + return state + + CommandUniverse + -> do cmdUniverse (stateLanguage state) source line + return state + + CommandUniverse1 + -> do cmdUniverse1 (stateLanguage state) source line + return state + + CommandUniverse2 + -> do cmdUniverse2 (stateLanguage state) source line + return state + + CommandUniverse3 + -> do cmdUniverse3 (stateLanguage state) source line + return state + + CommandEquivType + -> do cmdTypeEquiv (stateLanguage state) source line + return state + + CommandWitType + -> do cmdShowWType (stateLanguage state) source line + return state + + CommandExpCheck + -> do cmdShowType (stateLanguage state) ShowTypeAll source line + return state + + CommandExpType + -> do cmdShowType (stateLanguage state) ShowTypeValue source line + return state + + CommandExpEffect + -> do cmdShowType (stateLanguage state) ShowTypeEffect source line + return state + + CommandExpClosure + -> do cmdShowType (stateLanguage state) ShowTypeClosure source line + return state + + CommandExpRecon + -> do cmdExpRecon (stateLanguage state) source line + return state + + CommandEval + -> do cmdEval state source line + return state + + CommandTrans + -> do cmdTrans state source line + return state + + CommandTransEval + -> do cmdTransEval state source line + return state + + CommandTransInteract + -> do cmdTransInteract state source line + + CommandAst + -> do cmdAstExp (stateLanguage state) source line + return state + + CommandToSalt + -> do config <- getDriverConfigOfState state + runError $ cmdToSalt config (stateLanguage state) source line + return state + + CommandToC + -> do config <- getDriverConfigOfState state + runError $ cmdToC config (stateLanguage state) source line + return state + + CommandToLlvm + -> do config <- getDriverConfigOfState state + runError $ cmdToLlvm config (stateLanguage state) source line + return state + + CommandCompile + -> do config <- getDriverConfigOfState state + runError $ cmdCompile config line + return state + + CommandMake + -> do config <- getDriverConfigOfState state + runError $ cmdMake config line + return state + + 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 m + = do result <- runErrorT 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 new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command/Eval.hs @@ -0,0 +1,244 @@ + +module DDCI.Core.Command.Eval + ( cmdStep + , cmdEval + , evalExp) +where +import DDCI.Core.Stats.Trace +import DDCI.Core.Output +import DDCI.Core.State +import DDC.Driver.Command.Check +import DDC.Core.Eval.Env +import DDC.Core.Eval.Step +import DDC.Core.Eval.Name +import DDC.Core.Transform.Reannotate +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 + , modules0 <- bundleModules bundle + , (modules :: Maybe (ModuleMap (AnTEC () Name) Name)) + <- gcast modules0 + , modules' <- fromMaybe Map.empty modules + = cmdParseCheckExp Eval.fragment modules' False source str >>= goStore + where + -- Expression had a parse or type error. + goStore Nothing + = return () + + -- 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 + + goStep store x + = do _ <- forcePrint state store x + return () + + +-- | Parse, check, and fully evaluate an expression. +cmdEval :: State -> Source -> String -> IO () +cmdEval state source str + | Language bundle <- stateLanguage state + , modules0 <- bundleModules bundle + , (modules :: Maybe (ModuleMap (AnTEC () Name) Name)) + <- gcast modules0 + , modules' <- fromMaybe Map.empty modules + = cmdParseCheckExp Eval.fragment modules' False source str >>= goEval + where + -- Expression had a parse or type error. + goEval Nothing + = return () + + -- Expression is well-typed. + goEval (Just expr) + = evalExp state expr + + +-- | 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 + + -- 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 + + 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. + Just annot = takeAnnotOfExp x + tX = annotType annot + effX = annotEffect annot + cloX = annotClosure annot + + -- The evaluator doesn't want any type annotations on the expresison. + x_stripped = reannotate (const ()) x + + in case force store x_stripped of + StepProgress store' x_stripped' + -> case checkExp (configOfProfile Eval.profile) + primKindEnv primTypeEnv x_stripped' of + 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 new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command/Help.hs @@ -0,0 +1,112 @@ + +module DDCI.Core.Command.Help where + +help :: String +help = unlines + [ "-------------------------------------------------------------------- Usage --" + , "" + , " On the command line" + , " Prefix commands with '-'" + , " $ ddci-core -check \"\\(x : Unit). x\"" + , "" + , " Read input from a file with ':'" + , " $ ddci-core -set lang Salt -load: SomeFile.dcs" + , "" + , " Interactively" + , " Prefix commands with ':'" + , " > :check \\(x : Unit). x" + , "" + , " Split commands over multiple lines with '..', terminating with ';;'" + , " > :check.." + , " \\(x : Unit). x;;" + , "" + , " Read input from a file with '<'" + , " > :load< SomeFile.dcs" + , "" + , " Expressions in the Eval fragment can be evaluated at the prompt." + , " > addInt [:R0# R0# R0#:] (2 [R0#] ()) (3 [R0#] ())" + , " 5" + , "" + , "----------------------------------------------------------------- Commands --" + , "General" + , " :quit Exit DDCi-core." + , " :help Display this help page." + , "" + , "Modes" + , " :set Display active modes and program transform." + , " :set +MODE Enable a mode." + , " :set /MODE Disable a mode." + , " :set lang LANG Set the language fragment." + , " :set builder BUILDER Set the builder." + , " :set outputdir DIR Set the output directory." + , " :set output FILE Set the output file." + , " :set trans TRANS Set the program transform." + , "" + , " :set rule NAME [an : kn] ... (xn : tn) ... exp1 = exp2" + , " 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 ::=" + , " Indent Pretty print expressions with indenting." + , " TraceEval Show the expression at every step when evaluating." + , " TraceStore Show the store at every step when evaluating." + , " SuppressImports Suppress the import list when printing modules." + , "" + , " LANG ::=" + , " Lite | Salt | Zero | Eval" + , "" + , " BUILDER ::= " + , " x86_32-darwin | x86_64-darwin | x86_32-linux | x86_64-linux" + , " x86_32-cygwin | ppc32-linux" + , "" + , " TRANS ::= " + , " { TRANS } Parenthesis." + , " fix N TRANS Transform to a fixpoint, or bail out after N iters." + , " TRANS; TRANS Sequence two transforms." + , " Id Return the original program unharmed." + , " Anonymize Anonymize names to deBruijn form." + , " Namify Introduce fresh names for deBruijn binders." + , " Snip Introduce let-bindings for nested applications." + , " SnipOver ... and over-applications." + , " Flatten Flatten nested let-bindings." + , " Beta Perform beta-reduction for value arguments." + , " BetaLets ... introducing new let-bindings for redex arguments." + , " Bubble Float casts outwards, and combine similar ones." + , " Prune Erase unused, ineffectual let-bindings." + , " Forward Float let-bindings forward into their use sites." + , " Rewrite Perform rule based rewriting. Use 'set rule' to add rules." + , " Inline Perform inlining. Use 'with' to add source modules." + , " Elaborate Introduce default witnesses for unconstrained regions." + , "" + , "Type Commands" + , " :kind TYPE Show the kind of a type." + , " :tequiv TYPE TYPE Check if two types are equivalent." + , "" + , "Witness Commands" + , " :wtype WITNESS Show the type of a witness expression." + , "" + , "Expression Commands" + , " :check EXP Show the type, effect and closure of an exp." + , " :type EXP Show the type of an expression." + , " :effect EXP Show the effect of an expression." + , " :closure EXP Show the closure of an expression." + , " :eval EXP Evaluate an expression." + , " :ast EXP Show the abstract syntax tree of a exp." + , "" + , " :trans EXP Transform the given expression." + , " :trun EXP Transform the given expression then evaluate it." + , " :tinteract EXP Enter interactive transformation mode." + , "" + , "Module Commands" + , " :compile PATH Compile the module at this path to an object file." + , " :make PATH Make the module at this path into an executable." + , "" + , " :load MODULE Type check and desugar module source code." + , " :to-salt MODULE Convert module source code to Salt." + , " :to-c MODULE Convert module source code to C." + , " :to-llvm MODULE Convert module source code to LLVM." + , "" + ] diff --git a/src/ddci-core/DDCI/Core/Command/Set.hs b/src/ddci-core/DDCI/Core/Command/Set.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command/Set.hs @@ -0,0 +1,164 @@ + +-- | Display and toggle active interpreter modes. +module DDCI.Core.Command.Set + ( Mode(..) + , cmdSet) +where +import DDCI.Core.State +import DDCI.Core.Mode +import DDCI.Core.Output +import DDC.Build.Builder +import DDC.Build.Language +import DDC.Core.Fragment +import DDC.Core.Simplifier.Parser +import DDC.Base.Pretty +import Control.Monad +import Data.Char +import Data.List +import qualified DDCI.Core.Rewrite as R +import qualified Data.Map as Map +import qualified Data.Set as Set + + +cmdSet :: State -> String -> IO State + +-- Display the active modes. +cmdSet state [] + | Language bundle <- stateLanguage state + , fragment <- bundleFragment bundle + , modules <- bundleModules bundle + , simpl <- bundleSimplifier bundle + = do + let langName = profileName (fragmentProfile fragment) + + putStrLn $ renderIndent + $ vcat [ text "Modes: " <> text (show $ Set.toList $ stateModes state) + , text "Language: " <> text langName + , 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 + +-- Toggle active modes. +cmdSet state cmd + | ["lang", name] <- words cmd + = do case lookup name languages of + Just language + -> do putStrLn "ok" + return $ state { stateLanguage = language } + + Nothing + -> do putStrLn "unknown language" + return state + + | "trans" : rest <- words cmd + , Language bundle <- stateLanguage state + , modules <- bundleModules bundle + , rules <- bundleRewriteRules bundle + , mkNamT <- bundleMakeNamifierT bundle + , mkNamX <- bundleMakeNamifierX bundle + , fragment <- bundleFragment bundle + = do case parseSimplifier + (fragmentReadName fragment) + (SimplifierDetails + mkNamT mkNamX + (Map.assocs rules) + (Map.elems modules)) + (concat $ intersperse " " rest) of + + Left _err + -> do putStrLn $ "transform spec parse error" + return state + + Right simpl + -> do chatStrLn state "ok" + let bundle' = bundle { bundleSimplifier = simpl } + return $ state { stateLanguage = Language bundle' } + + + | ("rule", rest) <- R.parseFirstWord cmd + , Language bundle <- stateLanguage state + , fragment <- bundleFragment bundle + , modules <- bundleModules bundle + , rules <- bundleRewriteRules bundle + = case R.parseRewrite fragment modules rest of + Right (R.SetAdd name rule) + -> do chatStrLn state $ "ok, added " ++ name + let rules' = Map.insert name rule rules + let bundle' = bundle { bundleRewriteRules = rules' } + return $ state { stateLanguage = Language bundle' } + + 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 + + | "builder" : name : [] <- words cmd + = do config <- getDefaultBuilderConfig + case find (\b -> builderName b == name) (builders config) of + Nothing + -> do putStrLn "unknown builder" + return state + + Just builder + -> do chatStrLn state "ok" + return state { stateBuilder = Just builder } + + | "outputdir" : dir : [] <- words cmd + = return $ state { stateOutputDir = Just dir } + + | "output" : file : [] <- words cmd + = return $ state { stateOutputFile = Just file } + + | otherwise + = case parseModeChanges cmd of + Just changes + -> do let state' = foldr (uncurry adjustMode) state changes + chatStrLn state "ok" + return state' + + Nothing + -> do chatStrLn state "mode parse error" + return state + + +-- | Parse a string of mode changes. +parseModeChanges :: String -> Maybe [(Bool, Mode)] +parseModeChanges str + = sequence $ map parseModeChange $ words str + + +-- | Parse a mode change setting. +-- "Mode" or "+Mode" to enable. "-Mode" to disable. +parseModeChange :: String -> Maybe (Bool, Mode) +parseModeChange str + = case str of + ('+' : strMode) + | Just mode <- readMode strMode + -> Just (True, mode) + + ('/' : strMode) + | Just mode <- readMode strMode + -> Just (False, mode) + + (c : strMode) + | isUpper c + , Just mode <- readMode (c : strMode) + -> Just (True, mode) + + _ -> Nothing + + diff --git a/src/ddci-core/DDCI/Core/Command/Trans.hs b/src/ddci-core/DDCI/Core/Command/Trans.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command/Trans.hs @@ -0,0 +1,170 @@ +{-# OPTIONS -Werror #-} + +module DDCI.Core.Command.Trans + ( cmdTrans + , cmdTransEval + , applyTransAndCheck) +where +import DDCI.Core.Command.Eval +import DDCI.Core.Output +import DDCI.Core.State +import DDC.Driver.Command.Check +import DDC.Core.Fragment +import DDC.Core.Transform.Reannotate +import DDC.Core.Simplifier +import DDC.Core.Check +import DDC.Core.Exp +import DDC.Core.Compounds +import DDC.Type.Equiv +import DDC.Type.Subsumes +import DDC.Base.Pretty +import DDC.Type.Env as Env +import qualified Control.Monad.State.Strict as S +import qualified DDC.Build.Language.Eval as Eval +import qualified DDC.Core.Eval.Name as Eval +import qualified Data.Set as Set +import Data.Typeable +import Control.Monad +import DDC.Core.Module + + +-- Trans ---------------------------------------------------------------------- +-- | Apply the current transform to an expression. +cmdTrans :: State -> Source -> String -> IO () +cmdTrans state source str + | Language bundle <- stateLanguage state + , fragment <- bundleFragment bundle + , modules <- bundleModules bundle + , simpl <- bundleSimplifier bundle + , zero <- bundleStateInit bundle + , profile <- fragmentProfile fragment + = cmdParseCheckExp fragment modules True source str + >>= goStore profile modules zero simpl + where + -- Expression had a parse or type error. + goStore _ _ _ _ Nothing + = do return () + + -- Expression is well-typed. + goStore profile modules zero simpl (Just x) + = do let kenv = modulesExportKinds modules (profilePrimKinds profile) + let tenv = modulesExportTypes modules (profilePrimTypes profile) + + tr <- applyTransAndCheck state profile kenv tenv zero simpl x + case tr of + Nothing -> return () + Just x' -> outDocLn state $ ppr x' + + +-- TransEval ------------------------------------------------------------------ +-- | Apply the current transform to an expression, +-- then evaluate and display the result +cmdTransEval :: State -> Source -> String -> IO () +cmdTransEval state source str + | Language bundle <- stateLanguage state + , fragment <- bundleFragment bundle + , modules0 <- bundleModules bundle + , zero <- bundleStateInit bundle + , simpl0 <- bundleSimplifier bundle + , profile0 <- fragmentProfile fragment + + -- The evaluator only works on expressions with Eval.Names, + -- The actual name type is an existential of Bundle, + -- so we use gcast to check whether the bundle is really + -- set to Eval. + , Just (profile :: Profile Eval.Name) <- gcast profile0 + , Just (SimplBox simpl) <- gcast (SimplBox simpl0) + , Just (modules :: ModuleMap (AnTEC () Eval.Name) Eval.Name) + <- gcast modules0 + = do result' <- cmdParseCheckExp Eval.fragment modules False source str + case result' of + Nothing -> return () + Just xx + -> do let kenv = modulesExportKinds modules (profilePrimKinds profile) + let tenv = modulesExportTypes modules (profilePrimTypes profile) + + -- Apply the current transform. + tr <- applyTransAndCheck state profile kenv tenv zero simpl xx + + case tr of + Nothing -> return () + Just x' + -- Evaluate the transformed expression. + -> do outDocLn state $ ppr x' + evalExp state x' + return () + + | otherwise + = outDocLn state $ text "Language must be set to Eval for :teval" + + +-- Proxies to help with type casting. +-- The 'gcast' function will only cast the rightmost 'n' of a type, +-- But there is also an 'n' attached to the annotation type of +-- the simplifier. We use the proxy to cast both occurrences at once. +data SimplBox s n + = SimplBox (Simplifier s (AnTEC () n) n) + + +-- Trans ---------------------------------------------------------------------- +-- | Transform an expression, or display errors +applyTransAndCheck + :: (Eq n, Ord n, Pretty n, Show n, Show a) + => State + -> Profile n + -> Env n -- Kind Environment. + -> Env n -- Type Environment. + -> s + -> Simplifier s (AnTEC a n) n + -> Exp (AnTEC a n) n + -> IO (Maybe (Exp (AnTEC () n) n)) + +applyTransAndCheck state profile kenv tenv zero simpl xx + = do + let Just annot = takeAnnotOfExp xx + let t1 = annotType annot + let eff1 = annotEffect annot + let clo1 = annotClosure annot + + -- Apply the simplifier. + let tx = flip S.evalState zero + $ applySimplifierX profile kenv tenv simpl xx + + let x' = reannotate (const ()) $ result tx + + when (Set.member TraceTrans $ stateModes state) + $ case (resultInfo tx) of + TransformInfo inf + -> outDocLn state + $ text "* TRANSFORM INFORMATION: " <$> indent 4 (ppr inf) <$> text "" + + -- Check that the simplifier perserved the type of the expression. + case checkExp (configOfProfile profile) kenv tenv x' of + Right (x2, t2, eff2, clo2) + | equivT t1 t2 + , subsumesT kEffect eff1 eff2 + , subsumesT kClosure clo1 clo2 + -> do return (Just x2) + + | otherwise + -> do putStrLn $ renderIndent $ vcat + [ text "* CRASH AND BURN: Transform is not type preserving." + , ppr x' + , text ":: 1 " <+> ppr t1 + , text ":: 2 " <+> ppr t2 + , text ":!:1 " <+> ppr eff1 + , text ":!:2 " <+> ppr eff2 + , text ":$:1 " <+> ppr clo1 + , text ":$:2 " <+> ppr clo2 ] + return Nothing + + Left err + -> do putStrLn $ renderIndent $ vcat + [ text "* CRASH AND BURN: Type error in transformed program." + , ppr err + , text "" ] + + outDocLn state $ text "Transformed expression:" + outDocLn state $ ppr x' + return Nothing + diff --git a/src/ddci-core/DDCI/Core/Command/TransInteract.hs b/src/ddci-core/DDCI/Core/Command/TransInteract.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command/TransInteract.hs @@ -0,0 +1,116 @@ +module DDCI.Core.Command.TransInteract + ( cmdTransInteract + , cmdTransInteractLoop) +where +import DDCI.Core.Command.Trans +import DDCI.Core.Output +import DDCI.Core.State +import DDC.Driver.Command.Check +import DDC.Build.Language +import DDC.Core.Fragment +import DDC.Core.Simplifier.Parser +import DDC.Core.Compounds +import DDC.Core.Check +import DDC.Core.Module +import DDC.Base.Pretty +import qualified Data.Map as Map + + +-- TransInteract -------------------------------------------------------------- +-- | Apply the current transform to an expression. +cmdTransInteract :: State -> Source -> String -> IO State +cmdTransInteract state source str + | Language bundle <- stateLanguage state + , fragment <- bundleFragment bundle + , modules <- bundleModules bundle + = cmdParseCheckExp fragment modules True source str + >>= goStore bundle + where + -- Expression had a parse or type error. + goStore _ Nothing + = do return state + + -- Expression is well-typed. + goStore bundle (Just xx) + = do + let Just annot = takeAnnotOfExp xx + let t1 = annotType annot + let eff1 = annotEffect annot + let clo1 = annotClosure annot + + let hist = TransHistory + { historyExp = (xx, t1, eff1, clo1) + , historySteps = [] + , historyBundle = bundle } + + return state { stateTransInteract = Just hist } + + +cmdTransInteractLoop :: State -> String -> IO State +cmdTransInteractLoop state str + | Just hist <- stateTransInteract state + , TransHistory (x,t,e,c) steps bundle <- hist + , fragment <- bundleFragment bundle + , profile <- fragmentProfile fragment + = case str of + ":back" -> do + let steps' = case steps of + [] -> [] + (_:ss) -> ss + + 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' } + + ":done" -> do + let simps = reverse $ map (indent 4 . ppr . snd) steps + outStrLn state "* TRANSFORM SEQUENCE:" + mapM_ (outDocLn state) simps + return state { stateTransInteract = Nothing } + + _ -> do + + let tr = parseSimplifier + (fragmentReadName fragment) + (SimplifierDetails + (bundleMakeNamifierT bundle) + (bundleMakeNamifierX bundle) + (Map.assocs $ bundleRewriteRules bundle) + (Map.elems $ bundleModules bundle)) + str + + let x' = case steps of + [] -> x + ((xz,_):_) -> xz + + case tr of + Left _err -> do + putStrLn "Error parsing simplifier" + return state + + Right tr' -> do + let kenv = modulesExportKinds + (bundleModules bundle) + (profilePrimKinds profile) + + let tenv = modulesExportTypes + (bundleModules bundle) + (profilePrimTypes profile) + + x_trans <- applyTransAndCheck state profile kenv tenv + (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' } + + | 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 new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Command/With.hs @@ -0,0 +1,85 @@ + +module DDCI.Core.Command.With + (cmdWith, cmdWithLite, cmdWithSalt) +where +import DDCI.Core.State +import DDC.Driver.Source +import DDC.Core.Pretty +import DDC.Build.Pipeline +import DDC.Core.Module +import DDC.Data.Canned +import System.Directory +import Control.Monad +import Data.IORef +import Data.Char +import qualified Data.Map as Map +import qualified DDC.Build.Language.Lite as Lite +import qualified DDC.Build.Language.Salt as Salt + + +-- | Add a module to the inliner table. +cmdWith :: State -> Source -> String -> IO State +cmdWith state _source str + | Language bundle <- stateLanguage state + , modules <- bundleModules bundle + , fragment <- bundleFragment bundle + = do res <- cmdWith_load fragment str + case res of + Nothing -> return state + Just mdl + -> do + let modules' = Map.insert (moduleName mdl) mdl modules + let bundle' = bundle { bundleModules = modules' } + 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 -> + return $ state + { stateWithSalt = Map.insert (moduleName mdl) mdl (stateWithSalt state) } + + +cmdWith_load frag str + = do -- Always treat the string as a filename + let source = SourceFile str + + -- Read in the source file. + let filePath = dropWhile isSpace str + exists <- doesFileExist filePath + when (not exists) + $ error $ "No such file " ++ show filePath + + src <- readFile filePath + + cmdWith_parse frag source src + + +cmdWith_parse frag source src + = do ref <- newIORef Nothing + errs <- pipeText (nameOfSource source) (lineStartOfSource source) src + $ PipeTextLoadCore frag + [ PipeCoreHacks (Canned (\m -> writeIORef ref (Just m) >> return m)) + [PipeCoreOutput SinkDiscard] ] + + case errs of + [] -> do + putStrLn "ok" + readIORef ref + + _ -> do + mapM_ (putStrLn . renderIndent . ppr) errs + return Nothing + diff --git a/src/ddci-core/DDCI/Core/Input.hs b/src/ddci-core/DDCI/Core/Input.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Input.hs @@ -0,0 +1,161 @@ + +module DDCI.Core.Input + ( InputState (..) + , Input (..) + , readInput + , eatLine) +where +import DDCI.Core.State +import DDCI.Core.Command +import DDCI.Core.Command.TransInteract +import DDC.Data.ListUtils +import System.Directory +import Data.List +import Data.Char + + +-- InputState ---------------------------------------------------------------------- +-- Interpreter input state +data InputState + = InputState + { -- Command that we're still receiving input for, + -- along with the line number it started on. + inputCommand :: Maybe (Command, Int) + + -- Input mode. + , _inputMode :: Input + + -- The current line number in the command stream. + , inputLineNumber :: Int + + -- Accumulation of current input buffer. + , _inputAcc :: String } + + +-- | How we're reading the input expression. +data Input + -- | Read input line-by-line, using a backslash at the end of the + -- line to continue to the next. + = InputLine + + -- | Read input as a block terminated by a double semicolon (;;) + | InputBlock + + -- | Read input from a file specified on the prompt + | InputFile FilePath + deriving (Eq, Show) + + +-- | Read the input mode from the front of a string. +readInput :: String -> (Input, String) +readInput ss + | isPrefixOf ".." ss + = (InputBlock, drop 2 ss) + + | isPrefixOf "<" ss + , filePath <- dropWhile isSpace (drop 1 ss) + = (InputFile filePath, drop (length filePath) ss) + + | otherwise + = (InputLine, ss) + + +-- Eat ------------------------------------------------------------------------ +-- Eating input lines. +eatLine :: State -> InputState -> String -> IO (State, InputState) +eatLine state (InputState mCommand inputMode lineNumber acc) line + | Just _ <- stateTransInteract state + = do + state' <- cmdTransInteractLoop state line + return (state', InputState mCommand inputMode (lineNumber+1) acc) + + | otherwise + = do + -- If this is the first line then try to read the command and + -- input mode from the front so we know how to continue. + -- If we can't read an explicit command then assume this is + -- an expression to evaluate. + let (cmd, lineStart, (input, rest)) + = case mCommand of + -- We haven't started a command yet. + Nothing + -> case readCommand line of + Just (cmd', rest') -> (cmd', lineNumber, readInput rest') + Nothing -> (CommandEval, lineNumber, (InputLine, line)) + + -- We've already started a command, and this is more input for it. + Just (cmd', lineStart') + -> (cmd', lineStart', (inputMode, line)) + + let source + -- We were instructed to read the program from a file. + -- Report this file as the source location, independent + -- of how we were instructed to read it. + | InputFile filePath <- input + = SourceFile filePath + + -- The program was embedded in the command stream. + | otherwise + = case stateInterface state of + InterfaceArgs -> SourceArgs + InterfaceConsole -> SourceConsole lineStart + InterfaceBatch file -> SourceBatch file lineStart + + + case input of + -- For line-by-line mode, if the line ends with backslash then keep + -- reading, otherwise run the command. + -- We also convert the backslash to a newline so the source + -- position comes out right in parser error messages. + InputLine + | not $ null rest + , last rest == '\\' + , Just initRest <- takeInit rest + -> do return ( state + , InputState (Just (cmd, lineStart)) input + (lineNumber + 1) + (acc ++ initRest ++ "\n")) + + | otherwise + -> do state' <- handleCmd state cmd source (acc ++ rest) + return ( state' + , InputState Nothing InputLine + (lineNumber + 1) + []) + + + -- For block mode, if the line ends with ';;' then run the command, + -- otherwise keep reading. + InputBlock + | isSuffixOf ";;" rest + -> do let rest' = take (length rest - 2) rest + state' <- handleCmd state cmd source (acc ++ rest') + return ( state' + , InputState Nothing InputLine + (lineNumber + 1) + []) + + | otherwise + -> return ( state + , InputState (Just (cmd, lineStart)) input + (lineNumber + 1) + (acc ++ rest ++ "\n")) + + -- Read input from a file + InputFile filePath + -> do exists <- doesFileExist filePath + if exists + then do + contents <- readFile filePath + state' <- handleCmd state cmd source contents + return ( state' + , InputState Nothing InputLine + (lineNumber + 1) + []) + else do + putStrLn "No such file." + return ( state + , InputState Nothing InputLine + (lineNumber + 1) + []) + diff --git a/src/ddci-core/DDCI/Core/Interface/Args.hs b/src/ddci-core/DDCI/Core/Interface/Args.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Interface/Args.hs @@ -0,0 +1,47 @@ + +module DDCI.Core.Interface.Args + (runArgs) +where +import DDCI.Core.Command.Help +import DDCI.Core.Command +import DDCI.Core.State +import DDC.Data.ListUtils +import Data.List + + +-- | Run in unix command-line mode, reading commands from a list of arguments. +runArgs :: [String] -> IO () +runArgs args + = do let state = initState InterfaceArgs + + -- If the help command is one of the arguments then just + -- display the help and don't do anything else. + if elem "--help" args + then putStr help + else loop state args + + where + -- No more args, we're done. + loop _state [] + = do return () + + loop state (('-':cmdColon) : filePath : rest) + | isSuffixOf ":" cmdColon + , Just cmdStr <- takeInit cmdColon + , Just (cmd, []) <- readCommand (':' : cmdStr) + = do contents <- readFile filePath + state' <- handleCmd state cmd (SourceFile filePath) + contents + loop state' rest + + loop state (('-':cmdStr) : rest) + | Just (cmd, []) <- readCommand (':' : cmdStr) + , (argss, more) <- break (isPrefixOf "-") rest + = do state' <- handleCmd state cmd SourceArgs + (concat $ intersperse " " argss) + loop state' more + + loop _state xs + = error $ "Cannot parse arguments: " + ++ intercalate " " xs + diff --git a/src/ddci-core/DDCI/Core/Interface/Batch.hs b/src/ddci-core/DDCI/Core/Interface/Batch.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Interface/Batch.hs @@ -0,0 +1,51 @@ + +module DDCI.Core.Interface.Batch + (runBatch) +where +import DDCI.Core.State +import DDCI.Core.Input +import Data.List + + +-- | Run in batch mode, reading commands from the given string. +runBatch :: FilePath -> String -> IO () +runBatch filePath str + = do let state = initState (InterfaceBatch filePath) + let inputState = InputState Nothing InputLine 1 [] + loop state inputState (lines str) + where + -- No more lines, we're done. + -- There might be a command in the buffer though. + loop state inputState [] + = do eatLine state inputState [] + return () + + loop state inputState (l:ls) + -- Echo comment lines back. + | isPrefixOf "--" l + = do putStrLn l + let inputState' + = inputState + { inputLineNumber = inputLineNumber inputState + 1 } + + loop state inputState' ls + + -- Echo blank lines back if we're between commands. + | Nothing <- inputCommand inputState + , null l + = do putStr "\n" + let inputState' + = inputState + { inputLineNumber = inputLineNumber inputState + 1 } + + loop state inputState' ls + + -- Quit the program. + | isPrefixOf ":quit" l + = do return () + + -- Handle a line of input. + | otherwise + = do (state', inputState') <- eatLine state inputState l + loop state' inputState' ls + diff --git a/src/ddci-core/DDCI/Core/Interface/Interactive.hs b/src/ddci-core/DDCI/Core/Interface/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Interface/Interactive.hs @@ -0,0 +1,58 @@ + +module DDCI.Core.Interface.Interactive + ( runInteractive) +where +import DDCI.Core.Input +import DDCI.Core.State +import Data.List +import Data.Maybe +import qualified System.Console.Haskeline as HL +import qualified System.Console.Haskeline.IO as HL + + +-- Interactive ---------------------------------------------------------------- +-- | Run an interactive session, reading commands from the console. +runInteractive :: IO () +runInteractive + = do putStrLn "DDCi-core, version 0.3.0: http://disciple.ouroborus.net." + putStrLn "Type :help for help." + + -- Setup terminal mode. + loopInteractive + + +-- | The main REPL loop. +loopInteractive :: IO () +loopInteractive + = do hlState <- HL.initializeInput HL.defaultSettings + let state = initState InterfaceConsole + let inputState = InputState Nothing InputLine 1 [] + loop state inputState hlState + where + loop state inputState hlState + = 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 "> " + + -- Read a line from the user and echo it back. + line <- getInput hlState prompt + + if isPrefixOf ":quit" line + || isPrefixOf ":q" line + then return () + else do + (state', inputState') + <- eatLine state inputState line + + loop state' inputState' hlState + + +-- | Get an input line from the console, using given prompt +getInput :: HL.InputState -> String -> IO String +getInput hlState prompt + = do line <- HL.queryInput hlState (HL.getInputLine prompt) + return (fromMaybe ":quit" line) + diff --git a/src/ddci-core/DDCI/Core/Mode.hs b/src/ddci-core/DDCI/Core/Mode.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Mode.hs @@ -0,0 +1,46 @@ + +module DDCI.Core.Mode + ( Mode(..) + , readMode) +where + + +-- | DDCI mode flags. +data Mode + -- | Display the expression at each step in the evaluation. + = TraceEval + + -- | Display the store state at each step in the evaluation. + | TraceStore + + -- | Render expressions displayed to user using indenting. + | Indent + + -- | Suppress import lists when printing modules + | SuppressImports + + -- | When pretty printing Salt modules as C code, + -- include the #includes etc needed for compilation. + | SaltPrelude + + -- | Dump all intermediate versions of the code during compilation. + | Dump + + -- | Display information about each transformation step + | TraceTrans + deriving (Eq, Ord, Show) + + +-- | Parse a mode from a string. +readMode :: String -> Maybe Mode +readMode str + = case str of + "TraceEval" -> Just TraceEval + "TraceStore" -> Just TraceStore + "Indent" -> Just Indent + "SuppressImports" -> Just SuppressImports + "SaltPrelude" -> Just SaltPrelude + "Dump" -> Just Dump + "TraceTrans" -> Just TraceTrans + _ -> Nothing + diff --git a/src/ddci-core/DDCI/Core/Output.hs b/src/ddci-core/DDCI/Core/Output.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Output.hs @@ -0,0 +1,49 @@ + +module DDCI.Core.Output + ( outDoc, outDocLn + , outStr, outStrLn + , chatStrLn) +where +import DDCI.Core.State +import DDC.Base.Pretty +import qualified Data.Set as Set + + +-- | Output a document to the console. +outDoc :: State -> Doc -> IO () +outDoc state doc + | Set.member Indent $ stateModes state + = putDocLn RenderIndent doc + + | otherwise + = putDocLn RenderPlain doc + + +outDocLn :: State -> Doc -> IO () +outDocLn state doc + | Set.member Indent $ stateModes state + = putDocLn RenderIndent doc + + | otherwise + = putDocLn RenderPlain doc + + +-- | Output a string to the console. +outStr :: State -> String -> IO () +outStr _state str + = putStr str + + +outStrLn :: State -> String -> IO () +outStrLn _state str + = putStrLn str + + +-- | Output chatty 'ok' type responses. +-- These are only displayed in the Interactive and Batch interfaces. +chatStrLn :: State -> String -> IO () +chatStrLn state str + = case stateInterface state of + InterfaceConsole -> putStrLn str + InterfaceBatch _ -> putStrLn str + _ -> return () diff --git a/src/ddci-core/DDCI/Core/Rewrite.hs b/src/ddci-core/DDCI/Core/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Rewrite.hs @@ -0,0 +1,100 @@ + +module DDCI.Core.Rewrite + ( SetRuleCommand(..) + , parseFirstWord + , parseRewrite + , showRule ) +where +import DDC.Base.Pretty +import DDC.Build.Language +import DDC.Core.Lexer +import DDC.Core.Fragment hiding (Error) +import DDC.Core.Transform.Rewrite.Rule hiding (Error) +import DDC.Core.Transform.Rewrite.Parser +import DDCI.Core.State +import DDCI.Core.Output +import Data.Char +import qualified DDC.Core.Check as C +import qualified DDC.Base.Parser as BP + +import DDC.Core.Module +import Data.Map (Map) + + +-- | :set rule command +data SetRuleCommand a n + = SetAdd + { setRuleName :: String + , setRuleRule :: RewriteRule a n } + + | SetRemove + { setRuleName :: String } + + | SetList + deriving (Eq, Show) + +type Error = String + + +-- | Return first word and remainder of string +parseFirstWord :: String -> (String,String) +parseFirstWord s = break isSpace $ dropWhile isSpace s + + +-- | Parse a :set rule command +-- +name rule, name rule: add rewrite rule +-- -name remove rule +parseRewrite + :: (Ord n, Show n, Pretty n) + => Fragment n err + -> Map ModuleName (Module (C.AnTEC () n) n) + -> String + -> Either Error (SetRuleCommand (C.AnTEC () n) n) + +parseRewrite fragment modules str + = case dropWhile isSpace str of + [] -> Right SetList + ('+':rest) -> parseAdd fragment modules rest + + ('-':rest) + -> let (name,_) = parseFirstWord rest + in Right $ SetRemove name + + 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) + -> String + -> Either Error (SetRuleCommand (C.AnTEC () n) n) + +parseAdd fragment modules str + | (name, rest) <- parseFirstWord str + = case BP.runTokenParser describeTok "" pRule + (fragmentLexExp fragment "interactive" 0 rest) of + Left err -> Left $ renderIndent $ ppr err + Right rule -> + case checkRewriteRule config kinds' types' rule of + Left err -> Left $ renderIndent $ ppr err + Right rule' -> Right $ SetAdd name rule' + where + config = C.configOfProfile (fragmentProfile fragment) + kinds = profilePrimKinds (fragmentProfile fragment) + types = profilePrimTypes (fragmentProfile fragment) + + kinds' = modulesExportKinds modules kinds + types' = modulesExportTypes modules types + + +-- | Display rule +showRule :: (Eq n, Pretty n) + => State -> Int -> String -> RewriteRule a n -> IO () + +showRule state indentBy name 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 new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/State.hs @@ -0,0 +1,190 @@ + +module DDCI.Core.State + ( State (..) + , Bundle (..) + , initState + , getDriverConfigOfState + + , TransHistory (..) + + , Interface (..) + , Source (..) + + , Language (..) + , languages + , getDefaultBuilderConfig + , getActiveBuilder + + , Mode (..) + , adjustMode) +where +import DDCI.Core.Mode +import DDC.Code.Config +import DDC.Driver.Source +import DDC.Build.Builder +import DDC.Build.Language +import DDC.Core.Check +import DDC.Core.Exp +import DDC.Core.Module +import DDC.Core.Simplifier +import DDC.Base.Pretty hiding (()) +import Data.Typeable +import System.FilePath +import Data.Map (Map) +import Data.Set (Set) +import qualified DDC.Build.Language.Eval as Eval +import qualified DDC.Core.Salt as Salt +import qualified DDC.Core.Lite as Lite +import qualified DDC.Core.Simplifier as S +import qualified DDC.Core.Salt.Runtime as Runtime +import qualified DDC.Driver.Stage as D +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-- | Interpreter state. +-- This is adjusted by interpreter commands. +data State + = State + { -- | ddci interface state. + stateInterface :: Interface + + -- | ddci mode flags. + , stateModes :: Set Mode + + -- | Source language to accept. + , 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. + -- If Nothing then query the host system for the default builder. + , stateBuilder :: Maybe Builder + + -- | Output file for @compile@ and @make@ commands. + , stateOutputFile :: Maybe FilePath + + -- | Output dir for @compile@ and @make@ commands + , stateOutputDir :: Maybe FilePath + + -- | 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) + + -- | 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 } + + +-- | What interface is being used. +data Interface + -- | Read commands from unix command-line args. + = InterfaceArgs + + -- | Read commands interactively from the console. + | InterfaceConsole + + -- | Read commands from the file with this name. + | InterfaceBatch FilePath + deriving (Eq, Show) + + +-- | Adjust a mode setting in the state. +adjustMode + :: Bool -- ^ Whether to enable or disable the mode. + -> Mode -- ^ Mode to adjust. + -> State + -> State + +adjustMode True mode state + = state { stateModes = Set.insert mode (stateModes state) } + +adjustMode False mode state + = state { stateModes = Set.delete mode (stateModes state) } + + +-- | The initial state. +initState :: Interface -> State +initState interface + = State + { stateInterface = interface + , stateModes = Set.empty + , stateLanguage = Eval.language + , stateWithLite = Map.empty + , stateWithSalt = Map.empty + , stateSimplLite = S.Trans S.Id + , stateSimplSalt = S.Trans S.Id + , stateBuilder = Nothing + , stateOutputFile = Nothing + , stateOutputDir = Nothing + , stateTransInteract = Nothing } + + +-- | Slurp out the relevant parts of the DDCI stage into a driver config. +getDriverConfigOfState :: State -> IO D.Config +getDriverConfigOfState state + = do builder <- getActiveBuilder state + return + $ D.Config + { D.configDump = Set.member Dump (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 } + + , D.configOutputFile = stateOutputFile state + , D.configOutputDir = stateOutputDir state + , D.configSimplLite = stateSimplLite state + , D.configSimplSalt = stateSimplSalt state + , D.configBuilder = builder + , D.configSuppressCoreImports = Set.member SuppressImports (stateModes state) + , D.configSuppressHashImports = not $ Set.member SaltPrelude (stateModes state) + , D.configKeepLlvmFiles = False + , D.configKeepSeaFiles = False + , D.configKeepAsmFiles = False } + + +-- | Holds platform independent builder info. +getDefaultBuilderConfig :: IO BuilderConfig +getDefaultBuilderConfig + = do baseLibraryPath <- locateBaseLibrary + return $ BuilderConfig + { builderConfigBaseSrcDir = baseLibraryPath + , builderConfigBaseLibDir = baseLibraryPath "build" } + + +-- | Get the active builder. +-- If one is set explicitly in the state then use that, +-- otherwise query the host system to determine the builder. +-- If that fails as well then 'error'. +getActiveBuilder :: State -> IO Builder +getActiveBuilder state + = case stateBuilder state of + Just builder -> return builder + Nothing + -> do config <- getDefaultBuilderConfig + mBuilder <- determineDefaultBuilder config + case mBuilder of + Nothing -> error "getActiveBuilder unrecognised host platform" + Just builder -> return builder + + diff --git a/src/ddci-core/DDCI/Core/Stats/Trace.hs b/src/ddci-core/DDCI/Core/Stats/Trace.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/DDCI/Core/Stats/Trace.hs @@ -0,0 +1,82 @@ + +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{} -> xx + + XCon _ dc + | Just n@(NameLoc l) <- takeNameOfDaCon dc + , not $ Set.member n entered + , Just sbind <- lookupBind l store + -> traceStoreX store (Set.insert n entered) (expOfSBind sbind) + + 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 m b x -> LLet m b (down x) + LRec bxs -> LRec [(b, down x) | (b, x) <- bxs] + LLetRegions{} -> 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 = XCon () (mkDaConSolid (NameLoc l) (tBot kData)) + diff --git a/src/ddci-core/Main.hs b/src/ddci-core/Main.hs new file mode 100644 --- /dev/null +++ b/src/ddci-core/Main.hs @@ -0,0 +1,58 @@ + +-- | Interactive interface to DDC. +-- This also accepts interpreter commands as arguments on the command-line. +-- If you want a more unixy inferface then use the ddc-main interface instead. +module Main where +import DDCI.Core.Command.Help +import DDCI.Core.Interface.Args +import DDCI.Core.Interface.Batch +import DDCI.Core.Interface.Interactive +import DDCI.Core.State +import DDC.Driver.Command.Make +import System.Environment +import System.IO +import Control.Monad.Trans.Error +import Data.List + + +main :: IO () +main + = do args <- getArgs + case args of + [] -> runInteractive + + -- Display the help. + ["--help"] + -> putStr help + + -- Run commands from a file in batch mode. + ["--batch", filePath] + -> do file <- readFile filePath + runBatch filePath file + + -- Make a file, depending on what the extension is. + -- This gets us --make on the command line as well as -make + -- so we behave more like GHC. + ["--make", filePath] + -> do let state = initState (InterfaceBatch filePath) + config <- getDriverConfigOfState state + runError $ cmdMake config filePath + + -- Run a Disciple-Core-Exchange file. + [filePath] + | isSuffixOf ".dcx" filePath + -> do file <- readFile filePath + runBatch filePath file + + + _ -> runArgs args + + +-- | Just print errors to stdout and continue the session. +runError :: ErrorT String IO () -> IO () +runError m + = do result <- runErrorT m + case result of + Left err -> hPutStrLn stdout err + Right _ -> return () +