diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 00000000..5ace4600 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: + - package-ecosystem: "github-actions" + directory: "/" + schedule: + interval: "weekly" diff --git a/.github/workflows/run_tests.yml b/.github/workflows/run_tests.yml index e1ab935f..154d9dd6 100644 --- a/.github/workflows/run_tests.yml +++ b/.github/workflows/run_tests.yml @@ -108,8 +108,8 @@ jobs: echo "Runtime built successfully, troupe.mjs found" - name: compile lib run: make lib - - name: compile service - run: make service + - name: compile trp-rt + run: make trp-rt - name: run basic test run: ./local.sh tests/rt/pos/core/fib10.trp - name: run ci network test diff --git a/.gitignore b/.gitignore index 3d381d7d..b7c422ac 100644 --- a/.gitignore +++ b/.gitignore @@ -1,35 +1,61 @@ -dist -dist-* -cabal-dev -*.o -*.hi -*.chi -*.chs.h -*.DS_Store -*.dyn_o -*.dyn_hi -.hpc -.hsenv +TAGS + +################################################## +# NPM +node_modules + +################################################## +# Haskell + +## Cabal Sandbox .cabal-sandbox/ cabal.sandbox.config +cabal.project.local + +## Program Coverage +.hpc *.prof *.aux *.hp *.eventlog -.stack-work/ -cabal.project.local -.HTF/ -TAGS -*.vscode -/out + +## Test Framework +.HTF + +## Virtual Environment +.hsenv + +## Build files *.o *.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi + +################################################## +# Binaries from `compiler` bin/* -node_modules -yarn.lock -yarn-error.log + +################################################## +# Troupe Compiler (`troupec`) output +out/* + +################################################## +# Editors + +## Visual Studio Code +*.vscode + +## Vi *.swp -bin/troupe -bin/understudy -trp-rt/out/ + +## Emacs *.#* +*~ + +################################################## +# Operating Systems + +## MacOS +*.DS_Store \ No newline at end of file diff --git a/Makefile b/Makefile index 0012dafc..28b76d54 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ -.PHONY: rt compiler lib p2p-tools +.PHONY: rt trp-rt compiler lib p2p-tools # TODO: Rename to 'build/*' ? -all: npm rt compiler p2p-tools lib service +all: npm compiler rt trp-rt p2p-tools lib npm: npm install @@ -20,16 +20,16 @@ p2p-tools: lib: cd lib; $(MAKE) build -service: - mkdir -p ./trp-rt/out - $(COMPILER) ./trp-rt/service.trp -l +trp-rt: + cd trp-rt/; $(MAKE) build -# TODO: Rename to 'clean/*' ? -clean: clean/compiler clean/rt clean/lib +clean: clean/compiler clean/rt clean/trp-rt clean/p2p-tools clean/lib clean/compiler: cd compiler; $(MAKE) clean clean/rt: cd rt; $(MAKE) clean +clean/trp-rt: + cd lib; $(MAKE) clean clean/p2p-tools: cd p2p-tools; $(MAKE) clean clean/lib: diff --git a/compiler/.gitignore b/compiler/.gitignore index d5daa3ed..f04c37cb 100644 --- a/compiler/.gitignore +++ b/compiler/.gitignore @@ -1,6 +1,15 @@ +################################################## +# Stack artifacts .stack-work/ +stack.yaml.lock + +################################################## +# Cabal artifacts Troupe-compiler.cabal +dist +dist-* +cabal-dev + +################################################## +# Local compilation output ir2raw-out -stack.yaml.lock -*~ -out diff --git a/compiler/ChangeLog.md b/compiler/ChangeLog.md deleted file mode 100644 index e69de29b..00000000 diff --git a/compiler/LICENSE b/compiler/LICENSE deleted file mode 100644 index e037c729..00000000 --- a/compiler/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2018 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/compiler/Makefile b/compiler/Makefile index 216554ec..47df99ca 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -1,9 +1,20 @@ .PHONY: test -all: - stack -v build $(STACK_OPTS) +all: build install + +build: VERBOSITY_FLAG = +build: + stack $(VERBOSITY_FLAG) build $(STACK_OPTS) +build/verbose: + $(MAKE) $(MAKE_FLAGS) build VERBOSITY_FLAG="-v" + +install: VERBOSITY_FLAG = +install: + $(MAKE) $(MAKE_FLAGS) build mkdir -p ./../bin - stack -v install $(STACK_OPTS) --local-bin-path ./../bin/ + stack $(VERBOSITY_FLAG) install $(STACK_OPTS) --local-bin-path ./../bin/ +install/verbose: + $(MAKE) $(MAKE_FLAGS) install VERBOSITY_FLAG="-v" clean: rm *.cabal @@ -11,14 +22,14 @@ clean: rm -rf ../bin # If problems still persist after this, remove all GHC compilers in ~/.stack/programs/**/ -ghci-irtester: - stack ghci --main-is Troupe-compiler:exe:irtester --no-load - -ghci-troupec: - stack ghci --main-is Troupe-compiler:exe:troupec --no-load - test: stack test $(STACK_OPTS) parser-info: stack exec happy -- -i src/Parser.y + +ghci/irtester: + stack ghci --main-is Troupe-compiler:exe:irtester --no-load + +ghci/troupec: + stack ghci --main-is Troupe-compiler:exe:troupec --no-load diff --git a/compiler/README.md b/compiler/README.md deleted file mode 100644 index a433982a..00000000 --- a/compiler/README.md +++ /dev/null @@ -1 +0,0 @@ -# PicoML-compiler diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index fd007e2b..00fb1f78 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -14,16 +14,14 @@ import qualified IR as CCIR import qualified IROpt -- import qualified RetRewrite as Rewrite import qualified CPSOpt as CPSOpt -import qualified IR2JS import qualified IR2Raw --- import qualified Stack import qualified Raw2Stack +import qualified Stack import qualified Stack2JS import qualified RawOpt -- import System.IO (isEOF) -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS import Data.ByteString.Base64 (decode) -import qualified Data.ByteString.Char8 as BSChar8 import qualified Data.ByteString.Lazy.Char8 as BSLazyChar8 import System.IO import System.Exit @@ -39,14 +37,11 @@ import Data.List as List import Data.Maybe (fromJust) import System.FilePath --- import System.Console.Haskeline --- import System.Process +-------------------------------------------------------------------------------- +----- COMPILER FLAGS ----------------------------------------------------------- - --- compiler flags --- data Flag - = IRMode + = TextIRMode | JSONIRMode | LibMode | NoRawOpt @@ -58,205 +53,194 @@ data Flag options :: [OptDescr Flag] options = - [ Option ['i'] ["ir"] (NoArg IRMode) "ir interactive mode" - , Option ['j'] ["json"] (NoArg JSONIRMode) "ir json interactive mode" - , Option [] ["no-rawopt"] (NoArg NoRawOpt) "disable Raw optimization" - , Option ['v'] ["verbose"] (NoArg Verbose) "verbose output" - , Option ['d'] ["debug"] (NoArg Debug) "debugging information in the .js file" - , Option ['l'] ["lib"] (NoArg LibMode) "compiling a library" - , Option ['h'] ["help"] (NoArg Help) "print usage" - , Option ['o'] ["output"] (ReqArg OutputFile "FILE") "output FILE" + [ Option [] ["text-ir"] (NoArg TextIRMode) "ir interactive mode (text)" + , Option [] ["json-ir"] (NoArg JSONIRMode) "ir interactive mode (json)" + , Option [] ["no-rawopt"] (NoArg NoRawOpt) "disable Raw optimization" + , Option ['v'] ["verbose"] (NoArg Verbose) "verbose output" + , Option ['d'] ["debug"] (NoArg Debug) "debugging information in the .js file" + , Option [] ["lib"] (NoArg LibMode) "compiling a library [deprecated]" + , Option ['h'] ["help"] (NoArg Help) "print usage" + , Option ['o'] ["output"] (ReqArg OutputFile "FILE") "output FILE" ] --- debugTokens (Right tks) = - -- mapM_ print tks +-------------------------------------------------------------------------------- +----- PIPELINE FROM FLAGS TO IR AND JS ----------------------------------------- process :: [Flag] -> Maybe String -> String -> IO ExitCode process flags fname input = do - -- let tokens = parseTokens input - -- debugTokens tokens let ast = parseProg input - let compileMode = - if elem LibMode flags then Export - else Normal + let compileMode = if LibMode `elem` flags then Library else Normal let verbose = Verbose `elem` flags noRawOpt = NoRawOpt `elem` flags + debugJS = Debug `elem` flags case ast of Left err -> do - -- putStrLn ("Tokens: " ++ show tokens) die $ "Parse Error:\n" ++ err Right prog_parsed -> do - let prog_empty_imports = - case compileMode of - Normal -> addAmbientMethods prog_parsed - Export -> prog_parsed - prog <- processImports prog_empty_imports - - exports <- case compileMode of - Normal -> return Nothing - Export -> case runExcept (extractExports prog) of - Right es -> return (Just (es)) - Left s -> die s - + let outPath = outFile flags (fromJust fname) + + -- To print all tokens from the parser, uncomment the following line: + -- debugTokens (Right tks) = mapM_ print tks + + ------------------------------------------------------ + -- TROUPE (FRONTEND) --------------------------------- + let prog_without_dependencies = case compileMode of Normal -> addAmbientMethods prog_parsed + _ -> prog_parsed + + prog <- (processImports) prog_without_dependencies + + exports <- case compileMode of Library -> case runExcept (extractExports prog) of + Right es -> return (Just (es)) + Left s -> die s + _ -> return Nothing when verbose $ do printSep "SYNTAX" + writeFileD "out/out.syntax" (showIndent 2 prog) putStrLn (showIndent 2 prog) - - -------------------------------------------------- + ------------------------------------------------------ prog' <- case runExcept (C.trans compileMode (AF.visitProg prog)) of Right p -> return p Left s -> die s when verbose $ do printSep "PATTERN MATCH ELIMINATION" writeFileD "out/out.nopats" (showIndent 2 prog') - -------------------------------------------------- + ------------------------------------------------------ let lowered = Core.lowerProg prog' when verbose $ do printSep "LOWERING FUNS AND LETS" writeFileD "out/out.lowered" (showIndent 2 lowered) - -------------------------------------------------- + ------------------------------------------------------ let renamed = Core.renameProg lowered when verbose $ do printSep "α RENAMING" writeFileD "out/out.alpha" (showIndent 2 renamed) - -------------------------------------------------- + ------------------------------------------------------ let cpsed = RetDFCPS.transProg renamed when verbose $ do printSep "CPSED" writeFileD "out/out.cps" (showIndent 2 cpsed) - -------------------------------------------------- - let rwcps = CPSOpt.rewrite cpsed -- Rewrite.rewrite cpsed + ------------------------------------------------------ + let rwcps = CPSOpt.rewrite cpsed when verbose $ do printSep "REWRITING CPS" writeFileD "out/out.cpsopt" (showIndent 2 rwcps) - -------------------------------------------------- + + ------------------------------------------------------ + ------ IR (BACKEND) ---------------------------------- ir <- case runExcept (CC.closureConvert compileMode rwcps) of Right ir -> return ir Left s -> die $ "troupec: " ++ s - - - when verbose $ writeFileD "out/out.ir" (show ir) let iropt = IROpt.iropt ir when verbose $ writeFileD "out/out.iropt" (show iropt) - - - -------------------------------------------------- - let debugOut = elem Debug flags - - ------ RAW ----------------------------------------- + ------ RAW ------------------------------------------- let raw = IR2Raw.prog2raw iropt when verbose $ printSep "GENERATING RAW" when verbose $ writeFileD "out/out.rawout" (show raw) - ----- RAW OPT -------------------------------------- - + ----- RAW OPT ---------------------------------------- rawopt <- do - if noRawOpt - then return raw - else do - let opt = RawOpt.rawopt raw - when verbose $ printSep "OPTIMIZING RAW OPT" - when verbose $ writeFileD "out/out.rawopt" (show opt) - return opt - - ----- STACK ---------------------------------------- + if noRawOpt + then return raw + else do + let opt = RawOpt.rawopt raw + when verbose $ printSep "OPTIMIZING RAW OPT" + when verbose $ writeFileD "out/out.rawopt" (show opt) + return opt + + ----- STACK ------------------------------------------ let stack = Raw2Stack.rawProg2Stack rawopt - when verbose $ printSep "GENARTING STACK" + when verbose $ printSep "GENERATING STACK" when verbose $ writeFileD "out/out.stack" (show stack) - let stackjs = Stack2JS.irProg2JSString compileMode debugOut stack - let jsFile = outFile flags (fromJust fname) - writeFile jsFile stackjs + ----- JAVASCRIPT ------------------------------------- + let stackjs = Stack2JS.stack2JSString compileMode + debugJS + (Stack.ProgramStackUnit stack) + writeFile outPath stackjs - case exports of - Nothing -> return () - Just es -> writeExports jsFile es - when verbose printHr + -- case compileMode of Library -> ... + case exports of Nothing -> return () + Just es -> writeExports outPath es + ----- EPILOGUE -------------------------------------- + when verbose printHr exitSuccess - - - -writeExports jsF exports = - let exF' = if takeExtension jsF == ".js" then dropExtension jsF else jsF - in writeFileD (exF' ++ ".exports") (intercalate "\n" exports) - - - -defaultName f = - let ext = ".trp" - in concat [ takeDirectory f - , "/out/" - , if takeExtension f == ext then takeBaseName f else takeFileName f - ] - - -isOutFlag (OutputFile _) = True -isOutFlag _ = False - +-- TODO: 'where' for all helper functions below? outFile :: [Flag] -> String -> String -outFile flags fname | LibMode `elem` flags = - case List.find isOutFlag flags of +outFile flags fname = case List.find isOutFlag flags of Just (OutputFile s) -> s - _ -> defaultName fname ++ ".js" -outFile flags _ = - case List.find isOutFlag flags of - Just (OutputFile s) -> s - _ -> "out/out.stack.js" + _ -> if LibMode `elem` flags + then defaultName fname ++ ".js" + else "out/out.stack.js" + where isOutFlag (OutputFile _) = True + isOutFlag _ = False + + defaultName f = concat [ takeDirectory f + , "/out/" + , if takeExtension f == ".trp" then takeBaseName f else takeFileName f + ] + +writeExports path exports = + let path' = if takeExtension path == ".js" then dropExtension path else path + in writeFileD (path' ++ ".exports") (intercalate "\n" exports) + +-- Utility functions for printing things out +hrWidth = 70 + +printSep :: String -> IO () +printSep s = do + let prefix = replicate 5 '-' + suffix = replicate (hrWidth - length s - 5 - 2) '-' + s' = prefix ++ " " ++ s ++ " " ++ suffix + putStrLn s' --- AA: 2018-07-15: consider timestamping these entries -debugOut s = - appendFile "/tmp/debug" (s ++ "\n") +printHr :: IO () +printHr = putStrLn (replicate hrWidth '-') +-------------------------------------------------------------------------------- +----- DESERIALIZATION FOR INTERACTIVE MODES ------------------------------------ -fromStdinIR = do +fromStdinIR putStrLn format = do eof <- isEOF if eof then exitSuccess else do input <- BS.getLine - if BS.isPrefixOf "!ECHO " input - then let response = BS.drop 6 input - in do BSChar8.putStrLn response --- debugOut "echo" + let echo = "!ECHO " + if BS.isPrefixOf echo input + then let response = BS.drop (BS.length echo) input + in do BS.putStrLn response else case decode input of Right bs -> case CCIR.deserialize bs - of Right x -> do putStrLn (IR2JS.irToJSString x) --- debugOut "deserialization OK" - + of Right x -> do (putStrLn . format . ir2Stack) x Left s -> do putStrLn "ERROR in deserialization" debugOut $ "deserialization error" ++ s Left s -> do putStrLn "ERROR in B64 decoding" debugOut $ "decoding error" ++s putStrLn "" -- magic marker to be recognized by the JS runtime; 2018-03-04; aa hFlush stdout - fromStdinIR + fromStdinIR putStrLn format + -- AA: 2018-07-15: consider timestamping these entries + where debugOut s = appendFile "/tmp/debug" (s ++ "\n") + ir2Stack = Raw2Stack.raw2Stack . RawOpt.rawopt . IR2Raw.ir2raw -fromStdinIRJson = do - eof <- isEOF - if eof then exitSuccess else do - input <- BS.getLine - if BS.isPrefixOf "!ECHO " input - then let response = BS.drop 6 input - in BSChar8.putStrLn response - else - case decode input of - Right bs -> - case CCIR.deserialize bs - of Right x -> BSLazyChar8.putStrLn (IR2JS.irToJSON x) - Left s -> do putStrLn "ERROR in deserialization" - debugOut $ "deserialization error" ++ s - Left s -> do putStrLn "ERROR in B64 decoding" - debugOut $ "decoding error" ++s - putStrLn "" -- magic marker to be recognized by the JS runtime; 2018-03-04; aa - hFlush stdout - fromStdinIRJson +fromStdinTextIR = + let format = Stack2JS.stack2JSString CompileMode.Normal False + in fromStdinIR putStrLn format + +fromStdinJsonIR = + let putStrLn = BSLazyChar8.putStrLn + format = Stack2JS.stack2JSON CompileMode.Normal False + in fromStdinIR putStrLn format + +-------------------------------------------------------------------------------- +----- MAIN --------------------------------------------------------------------- main :: IO ExitCode main = do @@ -270,50 +254,21 @@ main = do putStrLn compilerUsage exitSuccess - ([JSONIRMode], [], []) -> fromStdinIRJson - - ([IRMode], [], []) -> do - fromStdinIR - -- hSetBuffering stdout NoBuffering - - (o, [file], []) | optionsOK o -> - fromFile o file + ([TextIRMode], [], []) -> fromStdinTextIR + ([JSONIRMode], [], []) -> fromStdinJsonIR + (o, [file], []) | optionsOK o -> do + input <- readFile file + process o (Just file) input (_,_, errs) -> die $ concat errs ++ compilerUsage where compilerUsage = usageInfo header options where header = "Usage: [OPTION...] file" - -- Check options for consistency optionsOK :: [Flag] -> Bool optionsOK o | length o >=2 = -- certain options must not be combined - not.or $ map (`elem` o) [IRMode, Help] + not.or $ map (`elem` o) [TextIRMode, Help] optionsOK _ = True - - - -fromFile :: [Flag] -> String -> IO ExitCode -fromFile flags fname = do - input <- readFile fname - process flags (Just fname) input - - --- utility functions for printing things out - -hrWidth = 70 - -printSep :: String -> IO () -printSep s = do - let prefix = replicate 5 '-' - suffix = replicate (hrWidth - length s - 5 - 2) '-' - s' = prefix ++ " " ++ s ++ " " ++ suffix - putStrLn s' - - -printHr :: IO () -printHr = putStrLn (replicate hrWidth '-') - --------------------------------------------------- diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index a50c1547..df470b1a 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -21,12 +21,12 @@ import Data.List (nub, (\\)) type Trans = Except String trans :: CompileMode -> S.Prog -> Trans T.Prog -trans mode (S.Prog imports atms tm) = do - let tm' = case mode of - Normal -> - S.Let [ S.ValDecl (S.VarPattern "authority") (S.Var "$$authorityarg") _srcRT ] - tm - Export -> tm +trans compileMode (S.Prog imports atms tm) = do + let tm' = case compileMode of + CompileMode.Library -> tm + _ -> + S.Let [ S.ValDecl (S.VarPattern "authority") (S.Var "$$authorityarg") _srcRT ] + tm atms' <- transAtoms atms tm'' <- transTerm tm' return (T.Prog imports atms' tm'') @@ -302,4 +302,4 @@ transFields = mapM $ \case (f, Nothing) -> return (f, T.Var f) (f, Just t) -> do t' <- transTerm t - return (f, t') \ No newline at end of file + return (f, t') diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index d92d4024..f10c7a69 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -201,7 +201,7 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do cpsToIR (CPS.LetRet (CPS.Cont arg kt') kt) = do t <- cpsToIR kt t' <- local (insVar arg) (cpsToIR kt') - return $ CCIR.BB [] $ Call arg t t' + return $ CCIR.BB [] $ StackExpand arg t t' cpsToIR (CPS.LetFun fdefs kt) = do let vnames_orig = map (\(CPS.Fun fname _) -> fname) fdefs let localExt = local (insVars vnames_orig) @@ -224,9 +224,10 @@ cpsToIR (CPS.Halt v) = do (compileMode,_ , _ , _, _ ) <- ask let constructor = case compileMode of - Normal -> CCIR.Ret -- Compiling library, then generate export instruction - Export -> CCIR.LibExport + CompileMode.Library -> CCIR.LibExport + -- Otherwise, keep it as a simple return + _ -> CCIR.Ret return $ CCIR.BB [] $ constructor v' @@ -275,8 +276,11 @@ closureConvert compileMode (CPS.Prog (C.Atoms atms) t) = (bb, (fdefs, _, consts_wo_levs)) = evalRWS (cpsToIR t) initEnv initState (argumentName, toplevel) = case compileMode of - Normal -> ("$$authorityarg", "main") -- passing authority through the argument to main - Export -> ("$$dummy", "export") + -- Top level function of a library is named 'export' + CompileMode.Library -> ("$$dummy", "export") + -- Passing authority through the argument to main + _ -> ("$$authorityarg", "main") + -- obs that our 'main' may have two names depending on the compilation mode; 2018-07-02; AA consts = (fst.unzip) consts_wo_levs diff --git a/compiler/src/CompileMode.hs b/compiler/src/CompileMode.hs index e5de67a6..c92f8955 100644 --- a/compiler/src/CompileMode.hs +++ b/compiler/src/CompileMode.hs @@ -1,4 +1,10 @@ module CompileMode where -data CompileMode = Normal | Export +-- | Different modes of compilation. +data CompileMode = -- | Compilation of a single file for a Troupe program + Normal + -- | Compiling a libary (deprecated) + | Library + -- | Interactive deserialization of IR + | Interactive diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 8621c088..675197a5 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -28,7 +28,6 @@ import Data.Serialize (Serialize) import qualified Data.Serialize as Serialize import GHC.Generics (Generic) -import CompileMode import Text.PrettyPrint.HughesPJ (hsep, nest, text, vcat, ($$), (<+>)) import qualified Text.PrettyPrint.HughesPJ as PP import TroupePositionInfo @@ -91,7 +90,7 @@ data IRTerminator -- and then execute the second BB, which can refer to this variable and -- where PC is reset to the level before entering the first BB. -- Represents a "let x = ... in ..." format. - | Call VarName IRBBTree IRBBTree + | StackExpand VarName IRBBTree IRBBTree deriving (Eq,Show,Generic) @@ -147,23 +146,13 @@ instance ComputesDependencies IRBBTree where instance ComputesDependencies IRTerminator where dependencies (If _ bb1 bb2) = mapM_ dependencies [bb1, bb2] dependencies (AssertElseError _ bb1 _ _) = dependencies bb1 - dependencies (Call _ t1 t2) = dependencies t1 >> dependencies t2 + dependencies (StackExpand _ t1 t2) = dependencies t1 >> dependencies t2 dependencies _ = return () instance ComputesDependencies FunDef where dependencies (FunDef _ _ _ bb) = dependencies bb -ppDeps :: ComputesDependencies a => a -> (PP.Doc , PP.Doc, PP.Doc) -ppDeps a = let (ffs_0,lls_0, atoms_0) = execWriter (dependencies a) - (ffs, lls, aas) = (nub ffs_0, nub lls_0, nub atoms_0) - - format dd = - let tt = map (PP.doubleQuotes . ppId) dd in - (PP.brackets.PP.hsep) (PP.punctuate PP.comma tt) - in ( format ffs, format lls , format aas ) - - ----------------------------------------------------------- -- Serialization instances ----------------------------------------------------------- @@ -231,15 +220,15 @@ instance WellFormedIRCheck IRInst where wfir (Assign (VN x) e) = do checkId x wfir e wfir (MkFunClosures _ fdefs) = mapM_ (\((VN x), _) -> checkId x) fdefs - + instance WellFormedIRCheck IRTerminator where wfir (If _ bb1 bb2) = do wfir bb1 wfir bb2 wfir (AssertElseError _ bb _ _) = wfir bb - wfir (Call (VN x) bb1 bb2 ) = do - checkId x + wfir (StackExpand (VN x) bb1 bb2 ) = do + checkId x wfir bb1 wfir bb2 @@ -442,7 +431,8 @@ ppIR (MkFunClosures varmap fdefs) = -ppTr (Call vn bb1 bb2) = (ppId vn <+> text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) + +ppTr (StackExpand vn bb1 bb2) = (ppId vn <+> text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) ppTr (AssertElseError va ir va2 _) diff --git a/compiler/src/IR2JS.hs b/compiler/src/IR2JS.hs deleted file mode 100644 index ab217dd9..00000000 --- a/compiler/src/IR2JS.hs +++ /dev/null @@ -1,23 +0,0 @@ -module IR2JS where - -import Data.ByteString.Lazy (ByteString) -import IR -import qualified IR2Raw (ir2raw) -import qualified RawOpt -import qualified Raw2Stack (raw2Stack) -import qualified Stack -import qualified Stack2JS - - --- RT calls this to compile received code. -ir2Stack :: SerializationUnit -> Stack.StackUnit -ir2Stack = Raw2Stack.raw2Stack . RawOpt.rawopt . IR2Raw.ir2raw - - -irToJSString :: SerializationUnit -> String -irToJSString = Stack2JS.stack2JSString . ir2Stack - - -irToJSON :: SerializationUnit -> ByteString -irToJSON = Stack2JS.stack2JSON . ir2Stack - diff --git a/compiler/src/IR2Raw.hs b/compiler/src/IR2Raw.hs index 7f663c17..6bc633c9 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -699,7 +699,7 @@ tr2raw = \case return $ If r bb1' bb2' -- Revision 2023-08: Equivalent, only way of modifying bb2 changed. - IR.Call v irBB1 irBB2 -> do + IR.StackExpand v irBB1 irBB2 -> do bb1 <- tree2raw irBB1 BB insts2 tr2 <- tree2raw irBB2 -- Prepend before insts2 instructions to store in variable v the result @@ -711,7 +711,7 @@ tr2raw = \case -- generally using Sequence (faster concatenation) for instructions -- might improve performance let bb2 = BB insts2' tr2 - return $ Call bb1 bb2 + return $ StackExpand bb1 bb2 -- Note: This is translated into branching and Error for throwing RT exception -- Revision 2023-08: More fine-grained raising of blocking label, see below. diff --git a/compiler/src/IROpt.hs b/compiler/src/IROpt.hs index 610c1f24..f0676ef2 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -67,7 +67,7 @@ instance Substitutable IRTerminator where AssertElseError (apply subst x) (apply subst bb) (apply subst y) pos LibExport x -> LibExport (apply subst x) Error x pos -> Error (apply subst x) pos - Call decVar bb1 bb2 -> Call decVar (apply subst bb1) (apply subst bb2) + StackExpand decVar bb1 bb2 -> StackExpand decVar (apply subst bb1) (apply subst bb2) instance Substitutable IRBBTree where apply subst (BB insts tr) = @@ -462,7 +462,7 @@ trPeval (AssertElseError x bb y_err pos) = do return $ BB [] (AssertElseError x bb' y_err pos) -trPeval (Call x bb1 bb2) = do +trPeval (StackExpand x bb1 bb2) = do bb1' <- peval bb1 bb2' <- peval bb2 @@ -473,7 +473,7 @@ trPeval (Call x bb1 bb2) = do setChangeFlag return $ BB (insts1 ++ insts2) tr2 _ -> - return $ BB [] (Call x bb1' bb2') + return $ BB [] (StackExpand x bb1' bb2') trPeval tr@(Ret x) = do markUsed' x diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index a9a17046..a6d94131 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -30,7 +30,6 @@ import Control.Monad.Writer import Data.List import qualified Data.ByteString as BS -import CompileMode import Text.PrettyPrint.HughesPJ (hsep, nest, text, vcat, ($$), (<+>)) import qualified Text.PrettyPrint.HughesPJ as PP import TroupePositionInfo @@ -158,7 +157,7 @@ data RawTerminator | Error RawVar PosInf -- | Execute the first BB and then execute the second BB where -- PC is reset to the level before entering the first BB. - | Call RawBBTree RawBBTree + | StackExpand RawBBTree RawBBTree deriving (Eq, Show) @@ -341,7 +340,7 @@ ppIR (MkFunClosures varmap fdefs) = -- ppIR (LevelOperations _ insts) = -- text "level operation" $$ nest 2 (vcat (map ppIR insts)) -ppTr (Call bb1 bb2) = (text "call" $$ nest 4 (ppBB bb1)) $$ (ppBB bb2) +ppTr (StackExpand bb1 bb2) = (text "call" $$ nest 4 (ppBB bb1)) $$ (ppBB bb2) -- ppTr (AssertElseError va ir va2 _) diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index caf87c3b..54494782 100644 --- a/compiler/src/Raw2Stack.hs +++ b/compiler/src/Raw2Stack.hs @@ -34,7 +34,6 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.ByteString.Lazy (ByteString) import Data.ByteString.Base64 (encode,decode) -import CompileMode import TroupePositionInfo import qualified Data.Aeson as Aeson import GHC.Generics (Generic) @@ -188,7 +187,7 @@ trTr (Raw.LibExport v) = do return $ Stack.LibExport v trTr (Raw.Error r1 p) = do return $ Stack.Error r1 p -trTr (Raw.Call bb1 bb2) = do +trTr (Raw.StackExpand bb1 bb2) = do __callDepth <- localCallDepth <$> ask bb1' <- local (\tenv -> tenv { localCallDepth = __callDepth + 1 } ) $ trBB bb1 n <- getBlockNumber @@ -205,7 +204,7 @@ trTr (Raw.Call bb1 bb2) = do | x <- filter filterConsts (Set.elems varsToLoad) ] bb2'@(Stack.BB inst_2 tr_2) <- trBB bb2 - return $ Stack.Call bb1' (Stack.BB (loads ++ inst_2) tr_2) + return $ Stack.StackExpand bb1' (Stack.BB (loads ++ inst_2) tr_2) trBB :: Raw.RawBBTree -> Tr Stack.StackBBTree diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index c6b7314f..7c7d4534 100644 --- a/compiler/src/RawDefUse.hs +++ b/compiler/src/RawDefUse.hs @@ -39,7 +39,6 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.ByteString.Lazy (ByteString) import Data.ByteString.Base64 (encode,decode) -import CompileMode import TroupePositionInfo import qualified Data.Aeson as Aeson import GHC.Generics (Generic) @@ -233,7 +232,7 @@ instance Trav RawTerminator where trav bb2 LibExport v -> use v Error r _ -> use r - Call bb1 bb2 -> do + StackExpand bb1 bb2 -> do trav bb1 modify (\s -> let (c, _) = locInfo s diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 937dc8be..e7253b77 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -78,7 +78,7 @@ instance Substitutable RawTerminator where If r bb1 bb2 -> If (apply subst r) (apply subst bb1) (apply subst bb2) Error r p -> Error (apply subst r) p - Call bb1 bb2 -> Call (apply subst bb1) (apply subst bb2) + StackExpand bb1 bb2 -> StackExpand (apply subst bb1) (apply subst bb2) _ -> tr instance Substitutable RawBBTree where @@ -420,7 +420,7 @@ instance PEval RawTerminator where } bb2' <- peval bb2 return $ If x bb1' bb2' - Call bb1 bb2 -> do + StackExpand bb1 bb2 -> do s <- get bb1' <- peval bb1 put $ s { stateMon = Map.empty @@ -428,7 +428,7 @@ instance PEval RawTerminator where , stateJoins = stateJoins s } -- reset the monitor state bb2' <- peval bb2 - return $ Call bb1' bb2' + return $ StackExpand bb1' bb2' Ret -> do return tr' TailCall x -> do @@ -470,14 +470,15 @@ filterInstBwd ls = f (Nothing, Nothing) (reverse ls) [] --- | This optimization for 'Call' moves instructions from the continuation to before the 'Call'. --- This can result in a 'Call' which just contains a 'Ret', which is then optimized away. --- The optimization compensates for redundant assignments introduced by the translation. -hoistCalls :: RawBBTree -> RawBBTree -hoistCalls bb@(BB insts tr) = +-- | This optimization for 'StackExpand' moves instructions from the continuation to before the +-- 'StackExpand'. This can result in a 'StackExpand' which just contains a 'Ret', which is then +-- optimized away. The optimization compensates for redundant assignments introduced by the +-- translation. +hoistStackExpand :: RawBBTree -> RawBBTree +hoistStackExpand bb@(BB insts tr) = case tr of -- Here we check which instructions from ii_1 can be moved to before the call - Call (BB ii_1 tr_1) bb2 -> + StackExpand (BB ii_1 tr_1) bb2 -> let isFrameSpecific i = case i of SetBranchFlag -> True @@ -487,7 +488,7 @@ hoistCalls bb@(BB insts tr) = -- jx_1: non-frame-specific instructions, are moved to before the call -- jx_2: frame-specific instructions, stay under the call's instructions (jx_1, jx_2) = Data.List.break isFrameSpecific ii_1 - in BB (insts ++ jx_1) (Call (BB jx_2 tr_1) bb2) + in BB (insts ++ jx_1) (StackExpand (BB jx_2 tr_1) bb2) -- If returning, the current frame will be removed, and thus all PC set instructions -- are redundant and can be removed. Ret -> @@ -537,7 +538,7 @@ instance PEval RawBBTree where If x (BB (set_pc_bl ++ i_then) tr_then) (BB (set_pc_bl ++ i_else) tr_else) - _ -> hoistCalls $ BB (insts_no_ret ++ set_pc_bl) tr'' + _ -> hoistStackExpand $ BB (insts_no_ret ++ set_pc_bl) tr'' let insts_sorted = instOrder insts_ return $ BB insts_sorted bb_ diff --git a/compiler/src/Stack.hs b/compiler/src/Stack.hs index 6427a452..4d427a20 100644 --- a/compiler/src/Stack.hs +++ b/compiler/src/Stack.hs @@ -30,7 +30,6 @@ import Control.Monad.Writer import Data.List import qualified Data.ByteString as BS -import CompileMode import Text.PrettyPrint.HughesPJ (hsep, nest, text, vcat, ($$), (<+>)) import qualified Text.PrettyPrint.HughesPJ as PP import TroupePositionInfo @@ -47,7 +46,7 @@ data StackTerminator | If RawVar StackBBTree StackBBTree | LibExport VarAccess | Error RawVar PosInf - | Call StackBBTree StackBBTree + | StackExpand StackBBTree StackBBTree deriving (Eq, Show) @@ -150,7 +149,7 @@ ppIR (MkFunClosures varmap fdefs) = ppIR (LabelGroup insts) = text "group" $$ nest 2 (vcat (map ppIR insts)) -ppTr (Call bb1 bb2) = (text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) +ppTr (StackExpand bb1 bb2) = (text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) -- ppTr (AssertElseError va ir va2 _) diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index 5717b99f..b3210355 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -60,51 +60,39 @@ import DCLabels (dcLabelExpToDCLabel) data LibAccess = LibAccess Basics.LibName Basics.VarName deriving (Eq, Show,Generic) - -data JSOutput = JSOutput { libs :: [LibAccess] - , fname:: Maybe String - , code :: String - , atoms :: [Basics.AtomName] - } deriving (Show, Generic) - -instance Aeson.ToJSON Basics.LibName +instance Aeson.ToJSON Basics.LibName instance Aeson.ToJSON LibAccess -instance Aeson.ToJSON JSOutput - -ppLibAccess :: LibAccess -> PP.Doc -ppLibAccess (LibAccess (Basics.LibName libname) varname) = PP.braces $ - PP.text "lib:" <+> (PP.doubleQuotes. PP.text) libname <+> PP.text "," <+> - PP.text "decl:" <+> (PP.doubleQuotes. PP.text) varname - - -ppLibs :: [LibAccess] -> PP.Doc -ppLibs libs = PP.brackets $ - vcat $ PP.punctuate (text ",") - $ map ppLibAccess (nub libs) jsLoadLibs = vcat $ map text [ "this.libSet = new Set ()", "this.libs = []", - "this.addLib = function (lib, decl) { if (!this.libSet.has (lib +'.'+decl)) { this.libSet.add (lib +'.'+decl); this.libs.push ({lib:lib, decl:decl})} }", - "this.loadlibs = function (cb) { rt.linkLibs (this.libs, this, cb) }" ] - - -addOneLib (LibAccess (Basics.LibName libname) varname) = - let args = (PP.doubleQuotes.PP.text) libname <+> text "," <+> (PP.doubleQuotes. PP.text) varname - in text "this.addLib " <+> PP.parens args + "this.addLib = function (lib, decl) { if (!this.libSet.has (lib +'.'+decl)) { this.libSet.add (lib +'.'+decl); this.libs.push ({lib:lib, decl:decl})} }" ] addLibs xs = vcat $ nub (map addOneLib xs) + where addOneLib (LibAccess (Basics.LibName libname) varname) = + let args = (PP.doubleQuotes.PP.text) libname <+> text "," <+> (PP.doubleQuotes. PP.text) varname + in text "this.addLib " <+> PP.parens args + + +data JSOutput = JSOutput { libs :: [LibAccess] + , fname:: Maybe String + , code :: String + , atoms :: [Basics.AtomName] + } deriving (Show, Generic) + +instance Aeson.ToJSON JSOutput data TheState = TheState { freshCounter :: Integer , frameSize :: Int - , sparseSlot :: Int + , sparseSlot :: Int , consts :: Raw.Consts , stHFN :: IR.HFN } type RetKontText = PP.Doc -type W = RWS Bool ([LibAccess], [Basics.AtomName], [RetKontText]) TheState +type WData = ([LibAccess], [Basics.AtomName], [RetKontText]) +type W = RWS Bool WData TheState initState = TheState { freshCounter = 0 @@ -149,45 +137,48 @@ instance Identifier Raw.Assignable where class ToJS a where toJS :: a -> W PP.Doc +stack2PPDoc :: CompileMode -> Bool -> StackUnit -> (PP.Doc, WData) +stack2PPDoc compileMode debugMode (ProgramStackUnit sp) = + let (fns, _, w@(libs, atoms, konts)) = runRWS (toJS sp) debugMode initState + inner = vcat $ + [ jsLoadLibs + , addLibs libs + ] + ++ (fns:konts) ++ + [ ] -irProg2JSString :: CompileMode -> Bool -> StackProgram -> String -irProg2JSString compileMode debugOut ir = - let (fns, _, (_,_,konts)) = runRWS (toJS ir) debugOut initState - inner = vcat (fns:konts) - outer = vcat $ - stdlib - ++ - [ "function" <+> ppNamespaceName <+> text "(rt) {" ] - ++ - [ nest 2 inner - , text "}" ] - ++ - suffix - in - PP.render $ - case compileMode of - Normal -> outer - Export -> inner + outer = ("function Top (rt)" <+> PP.lbrace) + $$+ inner + $$ PP.rbrace + $$ PP.text "module.exports = Top" + ppDoc = case compileMode of CompileMode.Library -> inner + _ -> outer + in (ppDoc, w) -stack2JSString :: StackUnit -> String -stack2JSString x = - let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState - in PP.render (addLibs libs $$ (vcat (inner:konts))) +stack2PPDoc _ debugMode su = + let (inner, _, w@(libs, _, konts)) = runRWS (toJS su) debugMode initState + ppDoc = vcat $ [ addLibs libs ] ++ (inner:konts) + in (ppDoc, w) +stack2JSString :: CompileMode -> Bool -> StackUnit -> String +stack2JSString compileMode debugMode su = + let (ppDoc, _) = stack2PPDoc compileMode debugMode su + in PP.render ppDoc -stack2JSON :: StackUnit -> ByteString -stack2JSON (ProgramStackUnit _) = error "needs to be ported" -stack2JSON x = - let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState + +stack2JSON :: CompileMode -> Bool -> StackUnit -> ByteString +stack2JSON compileMode debugMode su = + let (ppDoc, (libs, atoms, konts)) = stack2PPDoc compileMode debugMode su + fname = case su of FunStackUnit (FunDef (HFN n) _ _ _ _) -> Just n + AtomStackUnit _ -> Nothing in Aeson.encode $ JSOutput { libs = libs - , fname = case x of FunStackUnit (FunDef (HFN n)_ _ _ _) -> Just n - _ -> Nothing - , atoms = atoms - , code = PP.render (addLibs libs $$ (vcat (inner:konts))) - } + , fname = fname + , atoms = atoms + , code = PP.render ppDoc + } instance ToJS StackUnit where @@ -203,33 +194,11 @@ instance ToJS IR.VarAccess where return $ text fname --- instance (Identifier a) => ToJS a where --- toJS x = return $ ppId x - -ppNamespaceName = text "Top" -- should be generating a new namespace per received blob - - -irProg2JsWrapped prog = do - inner <- toJS prog - return $ - text "function" <+> ppNamespaceName <+> text "(rt) {" - $$ nest 2 inner - $$ text "}" - - - instance ToJS StackProgram where toJS (StackProgram atoms funs) = do jjA <- toJS atoms - (jjF, (libsF, atoms', _)) <- listen $ mapM toJS funs - - return $ - vcat $ [ jsLoadLibs - , addLibs libsF - , jjA - ] ++ jjF - - + jjF <- mapM toJS funs + return $ vcat $ [jjA] ++ jjF instance ToJS C.Atoms where @@ -270,7 +239,17 @@ instance ToJS FunDef where let lits = constsToJS consts jj <- toJS bb debug <- ask - let (irdeps, libdeps, atomdeps ) = IR.ppDeps irfdef + + let ppDeps :: IR.ComputesDependencies a => a -> (PP.Doc, PP.Doc, PP.Doc) + ppDeps a = let (ffs_0,lls_0, atoms_0) = execWriter (IR.dependencies a) + + (ffs, lls, aas) = (nub ffs_0, nub lls_0, nub atoms_0) + + format dd = let tt = map (PP.doubleQuotes . ppId) dd + in (PP.brackets.PP.hsep) (PP.punctuate PP.comma tt) + in (format ffs, format lls, format aas) + + let (irdeps, libdeps, atomdeps ) = ppDeps irfdef sparseSlotIdxPP <- ppSparseSlotIdx return $ @@ -452,7 +431,7 @@ ir2js InvalidateSparseBit = return $ {-- TERMINATORS --} -tr2js (Call bb bb2) = do +tr2js (StackExpand bb bb2) = do _frameSize <- gets frameSize _sparseSlot <- gets sparseSlot _consts <- gets consts @@ -632,9 +611,6 @@ ppPosInfo :: GetPosInfo a => a -> PP.Doc ppPosInfo = PP.doubleQuotes . text . show . posInfo pickle = PP.doubleQuotes.text.T.unpack.decodeUtf8.encode -stdlib = [] -- "let runtime = require('../runtimeMonitored.js')"] -suffix = [ "module.exports = Top "] - jsClosure var env f = vcat [ ppLet var <+> ((text "rt.mkVal") <> (PP.parens ((text "rt.RawClosure") <> (PP.parens (PP.hsep $ PP.punctuate "," [ppId env, text "this", text "this." PP.<> ppId f]))))) diff --git a/compiler/test/ir2raw-test/testcases/TR.hs b/compiler/test/ir2raw-test/testcases/TR.hs index 4800b478..f330a8e0 100644 --- a/compiler/test/ir2raw-test/testcases/TR.hs +++ b/compiler/test/ir2raw-test/testcases/TR.hs @@ -30,8 +30,8 @@ tcs = map (second mkP) (BB [Assign (VN "b1") (Base "v1") ] (LibExport (mkV "b1"))) (BB [Assign (VN "b2") (Base "v2") ] (LibExport (mkV "b2"))) ), - ( "Call" - , Call (VN "x") + ( "StackExpand" + , StackExpand (VN "x") (BB [Assign (VN "b1") (Base "v1") ] (LibExport (mkV "b1"))) (BB [Assign (VN "b2") (Base "v2") ] (LibExport (mkV "b2"))) ), diff --git a/lib/Hash.trp b/lib/Hash.trp index 5a4b0d90..f10ec7b0 100644 --- a/lib/Hash.trp +++ b/lib/Hash.trp @@ -68,15 +68,13 @@ let (*--- Module ---*) val Hash = { - hashString = hashString, - hashMultiplyShift = hashMultiplyShift, - hashInt = hashInt, - hashNumber = hashNumber, - hashList = hashList, - hash = hash + hashString, + hashMultiplyShift, + hashInt, + hashNumber, + hashList, + hash } -in [ ("Hash", Hash) - , ("hash", hash) - ] +in [ ("Hash", Hash), ("hash", hash) ] end diff --git a/lib/HashMap.trp b/lib/HashMap.trp index 43358544..a8e25072 100644 --- a/lib/HashMap.trp +++ b/lib/HashMap.trp @@ -202,24 +202,20 @@ let (* NOTE: The map is implemented as a Hash Array Mapped Trie (HAMT), i.e. a p (*--- Module ---*) val HashMap = { - (* Construction *) - empty = empty, - singleton = singleton, - insert = insert, - remove = remove, - (* Queries *) - null = null, - size = size, - findOpt = findOpt, - find = find, - mem = mem, - (* Manipulation *) - fold = fold, - (* List Conversion*) - keys = keys, - values = values, - toList = toList, - fromList = fromList + empty, + singleton, + insert, + remove, + null, + size, + findOpt, + find, + mem, + fold, + keys, + values, + toList, + fromList } in [ ("HashMap", HashMap) ] diff --git a/lib/HashSet.trp b/lib/HashSet.trp index 0ffccbc5..ccad42d0 100644 --- a/lib/HashSet.trp +++ b/lib/HashSet.trp @@ -47,21 +47,17 @@ let (* NOTE: The set is implemented as a HashMap with dummy values, `()`. This i (*--- Module ---*) val HashSet = { - (* Construction *) - empty = empty, - singleton = singleton, - insert = insert, - remove = remove, - (* Queries *) - null = null, - size = size, - mem = mem, - (* Manipulation *) - fold = fold, - (* List Conversion*) - elems = elems, - toList = toList, - fromList = fromList + empty, + singleton, + insert, + remove, + null, + size, + mem, + fold, + elems, + toList, + fromList } in [ ("HashSet", HashSet) ] diff --git a/lib/List.trp b/lib/List.trp index 872936e9..775007e3 100644 --- a/lib/List.trp +++ b/lib/List.trp @@ -169,33 +169,26 @@ let (* -- List Access -- *) (*--- Module ---*) val List = { - head = head, - tail = tail, - nth = nth, - - null = null, - elem = elem, - length = length, - - reverse = reverse, - append = append, - revAppend = revAppend, - appendAt = appendAt, - sublist = sublist, - - map = map, - mapi = mapi, - foldl = foldl, - filter = filter, - filteri = filteri, - partition = partition, - - range = range, - - sort = sort + head, + tail, + nth, + null, + elem, + length, + reverse, + append, + revAppend, + appendAt, + sublist, + map, + mapi, + foldl, + filter, + filteri, + partition, + range, + sort } -in [ ("List", List), - ("length", length) - ] +in [ ("List", List), ("length", length) ] end diff --git a/lib/ListPair.trp b/lib/ListPair.trp index 20d03ca6..94b54eed 100644 --- a/lib/ListPair.trp +++ b/lib/ListPair.trp @@ -64,22 +64,19 @@ let (* -- ListPair Generation -- *) (*--- Module ---*) val ListPair = { - zip = zip, - unzip = unzip, - - null = null, - length = length, - - reverse = reverse, - append = append, - revAppend = revAppend, - - findOpt = findOpt, - find = find, - mem = mem, - - map = map, - foldl = foldl + zip, + unzip, + null, + length, + reverse, + append, + revAppend, + findOpt, + find, + mem, + map, + foldl } -in [ ("ListPair", ListPair) ] end +in [ ("ListPair", ListPair) ] +end diff --git a/lib/Makefile b/lib/Makefile index e8942aca..c75d4894 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -3,26 +3,26 @@ COMPILER=../bin/troupec build: mkdir -p out # Standard Library - $(COMPILER) ./Number.trp -l - $(COMPILER) ./List.trp -l - $(COMPILER) ./ListPair.trp -l - $(COMPILER) ./String.trp -l - $(COMPILER) ./Hash.trp -l - $(COMPILER) ./Unit.trp -l - $(COMPILER) ./StencilVector.trp -l - $(COMPILER) ./HashMap.trp -l - $(COMPILER) ./HashSet.trp -l + $(COMPILER) --lib ./Number.trp + $(COMPILER) --lib ./List.trp + $(COMPILER) --lib ./ListPair.trp + $(COMPILER) --lib ./String.trp + $(COMPILER) --lib ./Hash.trp + $(COMPILER) --lib ./Unit.trp + $(COMPILER) --lib ./StencilVector.trp + $(COMPILER) --lib ./HashMap.trp + $(COMPILER) --lib ./HashSet.trp # Old stuff, here be dragons... - $(COMPILER) ./nsuref.trp -l - $(COMPILER) ./printService.trp -l - $(COMPILER) ./timeout.trp -l - $(COMPILER) ./NetHealth.trp -l - $(COMPILER) ./declassifyutil.trp -l - $(COMPILER) ./stdio.trp -l - $(COMPILER) ./raft.trp -l - $(COMPILER) ./raft_debug.trp -l - $(COMPILER) ./bst.trp -l - $(COMPILER) ./localregistry.trp -l + $(COMPILER) --lib ./nsuref.trp + $(COMPILER) --lib ./printService.trp + $(COMPILER) --lib ./timeout.trp + $(COMPILER) --lib ./NetHealth.trp + $(COMPILER) --lib ./declassifyutil.trp + $(COMPILER) --lib ./stdio.trp + $(COMPILER) --lib ./raft.trp + $(COMPILER) --lib ./raft_debug.trp + $(COMPILER) --lib ./bst.trp + $(COMPILER) --lib ./localregistry.trp clean: rm -rf out diff --git a/lib/Number.trp b/lib/Number.trp index ad9b7527..a8867220 100644 --- a/lib/Number.trp +++ b/lib/Number.trp @@ -93,25 +93,26 @@ let (** Largest (safe) possible integral value. Anything larger than this cannot (*--- Module ---*) val Number = { - maxInt = maxInt, - minInt = minInt, - precision = precision, - maxInt32 = maxInt32, - minInt32 = minInt32, - maxNum = maxNum, - minNum = minNum, - abs = abs, - min = min, - max = max, - ceil = ceil, - floor = floor, - round = round, - sqrt = sqrt, - isInt = isInt, - toInt = toInt, - toInt32 = toInt32, - toString = toString, - fromString = fromString + maxInt, + minInt, + precision, + maxInt32, + minInt32, + maxNum, + minNum, + abs, + min, + max, + ceil, + floor, + round, + sqrt, + isInt, + toInt, + toInt32, + toString, + fromString } + in [("Number", Number)] end diff --git a/lib/README.md b/lib/README.md index ea43f188..44119947 100644 --- a/lib/README.md +++ b/lib/README.md @@ -21,13 +21,19 @@ reviewed rigorously rather than depend on the monitor. To compile a module as part of the standard library, add it to the list of files in the `lib` target of the *makefile*. +## Design Principles + +- File names are written in `CamelCase`. This makes them conform to the Standard ML Basis Library. +- It is more important to match the function names and signatures in the Standard ML library than to + improve on them. For example, `String.sub` would make more sense with the type `[Char] -> Int -> + Char` but to match the SML library, we will stick with `[Char] * Int -> Char`. +- Each module exports a single *record* with the same name as the file. This (1) makes it closer to + the SML module system and (2) allows for name resolution, e.g. `HashMap.findOpt` and + `ListPair.findOpt` can be used in the same file. +- Each function that is exported has to be documented (`(** *)`). In the long run, we will + auto-generate documentation for the Standard Library. + ## TODO -- To conform with the Standard ML Basis Library, we should have the files conform to a `CamelCase` - style. -- To fake namespaced import, e.g. `List.length`, the library should export a struct instead. Only - certain functions should "pollute" the global namespace. -- Quite a lot of the standard library is not documented in any way. What is the purpose of each - function and each module? The [modules](#modules) above are the ones that have been updated and - documented. -- There are a lot of things in here - some of it dead. Can we merge/remove some things? +The [modules](#modules) mentioned above already follow the [design principles](#design-principles). +The remaining files either need to be updated or to be removed. diff --git a/lib/StencilVector.trp b/lib/StencilVector.trp index a272bc91..f73701cc 100644 --- a/lib/StencilVector.trp +++ b/lib/StencilVector.trp @@ -146,26 +146,24 @@ let (*--- Constants ---*) (* TODO: Lift list functions `mapi`, `find` and `filter`? *) + (*--- Module ---*) val StencilVector = { - (* Constants *) - maskBits = maskBits, - maskMax = maskMax, - (* Functions *) - empty = empty, - singleton = singleton, - get = get, - getOrDefault = getOrDefault, - set = set, - unset = unset, - mem = mem, - valid = valid, - null = null, - mask = mask, - length = length, - map = map, - fold = fold + maskBits, + maskMax, + empty, + singleton, + get, + getOrDefault, + set, + unset, + mem, + valid, + null, + mask, + length, + map, + fold } -in (* Export public functions *) - [ ("StencilVector", StencilVector) - ] + +in [ ("StencilVector", StencilVector) ] end diff --git a/lib/String.trp b/lib/String.trp index b275f776..2dfe068e 100644 --- a/lib/String.trp +++ b/lib/String.trp @@ -70,17 +70,18 @@ let (** The maximum length of a string. (*--- Module ---*) val String = { - maxSize = maxSize, - size = size, - sub = sub, - subCode = subCode, - substring = substring, - concat = concat, - concatWith = concatWith, - implode = implode, - explode = explode, - map = map, - translate = translate + maxSize, + size, + sub, + subCode, + substring, + concat, + concatWith, + implode, + explode, + map, + translate } + in [("String", String)] end diff --git a/lib/Unit.trp b/lib/Unit.trp index 483d32ac..f4b49eba 100644 --- a/lib/Unit.trp +++ b/lib/Unit.trp @@ -112,13 +112,13 @@ let (*--- Module ---*) val Unit = { - group = group, - it = it, - isEq = isEq, - isTrue = isTrue, - isFalse = isFalse, - isNeq = isNeq, - run = run + group, + it, + isEq, + isTrue, + isFalse, + isNeq, + run } in [ ("Unit", Unit) ] diff --git a/rt/src/deserialize.mts b/rt/src/deserialize.mts index 2c194875..c1d23013 100644 --- a/rt/src/deserialize.mts +++ b/rt/src/deserialize.mts @@ -39,7 +39,7 @@ const HEADER:string = this.libs.push ({lib:lib, decl:decl})} }\n" function startCompiler() { - __compilerOsProcess = spawn(process.env.TROUPE + '/bin/troupec', ['--json']); + __compilerOsProcess = spawn(process.env.TROUPE + '/bin/troupec', ['--json-ir']); __compilerOsProcess.on('exit', (code: number) => { process.exit(code); }); diff --git a/trp-rt/.gitignore b/trp-rt/.gitignore new file mode 100644 index 00000000..e2e7327c --- /dev/null +++ b/trp-rt/.gitignore @@ -0,0 +1 @@ +/out diff --git a/trp-rt/Makefile b/trp-rt/Makefile new file mode 100644 index 00000000..e1f71340 --- /dev/null +++ b/trp-rt/Makefile @@ -0,0 +1,9 @@ +COMPILER=../bin/troupec + +build: + mkdir -p out + # Standard Library + $(COMPILER) --lib ./service.trp + +clean: + rm -rf out