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..4f5ae461 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -4,6 +4,8 @@ module Main (main) where import qualified AtomFolding as AF import Parser +import qualified Direct +import qualified Basics as Basics import qualified Core as Core import RetDFCPS import qualified CaseElimination as C @@ -14,41 +16,39 @@ 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 Data.ByteString.Base64 (decode) -import qualified Data.ByteString.Char8 as BSChar8 +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Base64 (decode, encode) import qualified Data.ByteString.Lazy.Char8 as BSLazyChar8 import System.IO import System.Exit -import ProcessImports import AddAmbientMethods import ShowIndent -import Exports import CompileMode import Control.Monad.Except -import Control.Monad (when) +import Control.Monad (when, filterM) import System.Console.GetOpt +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding import Data.List as List import Data.Maybe (fromJust) +import System.Directory import System.FilePath +import qualified Crypto.Hash.SHA256 as SHA256 --- import System.Console.Haskeline --- import System.Process +-------------------------------------------------------------------------------- +----- COMPILER FLAGS ----------------------------------------------------------- - --- compiler flags --- data Flag - = IRMode + = TextIRMode | JSONIRMode - | LibMode + | Include String + | Module | NoRawOpt | OutputFile String | Verbose @@ -58,205 +58,246 @@ 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 Main.TextIRMode) "ir interactive mode (text)" + , Option [] ["json-ir"] (NoArg Main.JSONIRMode) "ir interactive mode (json)" + , Option [] ["no-rawopt"] (NoArg Main.NoRawOpt) "disable Raw optimization" + , Option ['v'] ["verbose"] (NoArg Main.Verbose) "verbose output" + , Option ['d'] ["debug"] (NoArg Main.Debug) "debugging information in the .js file" + , Option ['i'] ["include"] (ReqArg Main.Include "DIR") "directory for required modules" + , Option ['m'] ["module"] (NoArg Main.Module) "compile as a module" + , Option ['h'] ["help"] (NoArg Main.Help) "print usage" + , Option ['o'] ["output"] (ReqArg Main.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 ast = parseProg input - let compileMode = - if elem LibMode flags then Export - else Normal + let compileMode = if Main.Module `elem` flags then CompileMode.Module + else CompileMode.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 CompileMode.Normal -> addAmbientMethods prog_parsed + _ -> prog_parsed + + prog_with_imps_and_reqs <- (processModules $ includeDirs flags) prog_without_dependencies + + let prog = prog_with_imps_and_reqs 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 <- case runExcept (CC.closureConvert compileMode rwcps) of + + ------------------------------------------------------ + ------ IR (BACKEND) ---------------------------------- + ir <- case runExcept (CC.closureConvert 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 + let iroptSerialized = CCIR.serializeProgram iropt + let iroptHash = SHA256.hash (iroptSerialized) + case compileMode of CompileMode.Module -> writeModule outPath iroptSerialized iroptHash + _ -> return () - ------ 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 - - - case exports of - Nothing -> return () - Just es -> writeExports jsFile es - 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) + ----- JAVASCRIPT ------------------------------------- + let stackjs = Stack2JS.stack2JSString compileMode + debugJS + (iroptSerialized, iroptHash) + (Stack.ProgramStackUnit stack) + when verbose $ do printSep "GENERATING JAVASCRIPT" + writeFileD "out/out.js" stackjs -defaultName f = - let ext = ".trp" - in concat [ takeDirectory f - , "/out/" - , if takeExtension f == ext then takeBaseName f else takeFileName f - ] + writeFile outPath stackjs + ----- EPILOGUE -------------------------------------- + when verbose printHr + exitSuccess -isOutFlag (OutputFile _) = True -isOutFlag _ = False +-- TODO: 'where' for all helper functions below? +-- Obtain the name of the output file 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 Main.Module `elem` flags + then defaultName fname <.> "js" + else "out" "out" <.> "stack" <.> "js" + where isOutFlag (OutputFile _) = True + isOutFlag _ = False + + defaultName f = (takeDirectory f) + "out" + (if takeExtension f == ".trp" then takeBaseName else takeFileName) f + +-- Obtain the list of directories to look up required modules. +includeDirs :: [Flag] -> [String] +includeDirs flags = List.foldl mapDir [] flags + -- TODO (merging imports & requires): Add 'lib/' folder + where mapDir y (Include x) = x:y + mapDir y _ = y + +-- Given the include directories and the program, we attempt to find the corresponding '.ir'/'.hash' +-- file for each module that was 'imported' or 'required'. If succesful, the program is updated to +-- include these hashes. +processModules :: [String] -> Direct.Prog -> IO Direct.Prog +processModules paths (Direct.Prog (Basics.Modules imps) (Basics.Modules reqs) atoms term) = do + maybeTroupeEnv <- lookupEnv "TROUPE" + troupeEnv <- case maybeTroupeEnv of + Just tp -> return tp + Nothing -> die "TROUPE environment variable not set!" + + let defaultPaths = [troupeEnv "lib" "out"] + imps' <- Basics.Modules <$> mapM (processModule defaultPaths) imps + + let paths' = (paths++defaultPaths) >>= (\p -> [p, p "out"]) + reqs' <- Basics.Modules <$> mapM (processModule paths') reqs + return $ Direct.Prog imps' reqs' atoms term + where processModule paths' (Basics.ModName n, _) = do + matches <- filterM doesFileExist $ List.map (\p -> p n <.> "hash") paths' + + match <- case matches of + x:[] -> return x + _:_ -> die $ "Multiple modules with name: '" ++ n ++ "'" + [] -> die $ "Could not find module: '" ++ n ++ "'" + + matchContent <- readFile match + let matchContent' = lines matchContent + + hash <- case matchContent' of + x:_ -> return x + [] -> die $ "File '" ++ match ++ "' is empty" + + return $ ((Basics.ModName n), (Just $ Basics.ModHash $ hash)) + +-- Output to disk the intermediate representation and its hash of a Troupe program +writeModule path prog hash = + let path' = if takeExtension path == ".js" then dropExtension path else path + in do + writeFileD (path' ++ ".ir") (pickle prog) + writeFileD (path' ++ ".hash") (pickle hash) + where pickle = Text.unpack . TextEncoding.decodeUtf8 . encode + +-- 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 '-') -fromStdinIR = do +-------------------------------------------------------------------------------- +----- DESERIALIZATION FOR INTERACTIVE MODES ------------------------------------ + +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 (bs, SHA256.hash bs)) . 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 +311,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/package.yaml b/compiler/package.yaml index 35486416..83827eba 100644 --- a/compiler/package.yaml +++ b/compiler/package.yaml @@ -62,6 +62,7 @@ executables: - -W dependencies: - Troupe-compiler + - cryptohash-sha256 dclabels: main: DCTest.hs diff --git a/compiler/src/AddAmbientMethods.hs b/compiler/src/AddAmbientMethods.hs index a88d67ac..ec19c075 100644 --- a/compiler/src/AddAmbientMethods.hs +++ b/compiler/src/AddAmbientMethods.hs @@ -42,6 +42,6 @@ printStringDecl = FunDecl "printString" addAmbientMethods :: Prog -> Prog -addAmbientMethods (Prog imports atoms t) = +addAmbientMethods (Prog imps reqs atoms t) = let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t - in Prog imports atoms t' \ No newline at end of file + in Prog imps reqs atoms t' diff --git a/compiler/src/AtomFolding.hs b/compiler/src/AtomFolding.hs index 1aad7ba8..a6b0d4cc 100644 --- a/compiler/src/AtomFolding.hs +++ b/compiler/src/AtomFolding.hs @@ -6,8 +6,8 @@ import Data.Maybe import Control.Monad visitProg :: Prog -> Prog -visitProg (Prog imports (Atoms atms) tm) = - Prog imports (Atoms atms) (visitTerm atms tm) +visitProg (Prog imps reqs (Atoms atms) tm) = + Prog imps reqs (Atoms atms) (visitTerm atms tm) visitTerm :: [AtomName] -> Term -> Term visitTerm atms (Lit lit) = Lit lit diff --git a/compiler/src/Basics.hs b/compiler/src/Basics.hs index 622e31a0..bf628ed9 100644 --- a/compiler/src/Basics.hs +++ b/compiler/src/Basics.hs @@ -99,24 +99,27 @@ opPrec FlowsTo = 50 opPrec RaisedTo = 50 opPrec HasField = 50 -newtype LibName = LibName String deriving (Eq, Show, Generic, Ord) -instance Serialize LibName - - - --- 2018-07-02; AA: note on the data structure that we use for imports: --- For each `import` declaration, the parser returns the name of the --- library that is imported together with a Nothing value. After --- parsing we produce a version where we replace the Nothing value --- with the list of names that are exported from the library. - - -data Imports = Imports [(LibName, Maybe [VarName])] +-- 2025-11-12; SS: note on the data structure that we use each +-- `import`/`require` declaration: the parser returns the name of the module +-- together with a Nothing value. After parsing we search for the library to +-- find its files. This includes its hash which we use as a unique and canonical +-- reference to the module. +-- +-- 2025-09-29; SS: a module exports a single value. In most cases, this value is +-- a record of functions. Until the introduction of gradual types, this makes it +-- impossible to check for correct usage of each individual functions. +-- +-- TODO: When gradual types are added, this needs to be extended with a +-- `Maybe Type` which is populated as part of `processRequires`. +newtype ModName = ModName String deriving (Eq, Show, Generic, Ord) +instance Serialize ModName + +newtype ModHash = ModHash String deriving (Eq, Show, Generic, Ord) +instance Serialize ModHash + +data Modules = Modules [(ModName, Maybe ModHash)] deriving (Eq, Show, Ord) - - - op1Prec :: UnaryOp -> Precedence op1Prec x = 50 diff --git a/compiler/src/CPSOpt.hs b/compiler/src/CPSOpt.hs index de68c0d8..9903b21f 100644 --- a/compiler/src/CPSOpt.hs +++ b/compiler/src/CPSOpt.hs @@ -11,7 +11,6 @@ module CPSOpt (rewrite) where -- todo: consider renaming this to CPSRewrite -import Debug.Trace import qualified Basics import RetCPS as CPS import qualified Core as C @@ -86,7 +85,8 @@ instance Substitutable SimpleTerm where ListCons v v' -> ListCons (fwd v) (fwd v') ValSimpleTerm sv -> ValSimpleTerm (apply subst sv) Base v -> Base v - Lib l v -> Lib l v + ImpBase m -> ImpBase m + ReqBase m -> ReqBase m where fwd x = Map.findWithDefault x x varmap fwdFields fields = map (\(f, x) -> (f, fwd x)) fields @@ -153,7 +153,8 @@ instance CensusCollectible SimpleTerm where List vs -> updateCensus vs ListCons v vs -> updateCensus v >> updateCensus vs Base _ -> return () - Lib _ _ -> return () + ImpBase _ -> return () + ReqBase _ -> return () instance CensusCollectible KLambda where updateCensus kl = case kl of @@ -378,7 +379,8 @@ simplifySimpleTerm t = List _ -> _nochange ListCons _ _ -> _nochange Base _ -> _nochange - Lib _ _ -> _nochange + ImpBase _ -> _nochange + ReqBase _ -> _nochange --} _ -> _nochange @@ -417,7 +419,8 @@ failFree st = case st of List _ -> True ListCons _ _ -> False -- List cons can fail if second arg is not a list Base _ -> False -- Base function calls can have side effects or fail - Lib _ _ -> False -- Library function calls can have side effects or fail + ImpBase _ -> True -- Modules are initialised prior to execution; it is safe to access it at this point. + ReqBase _ -> True -- Modules are initialised prior to execution; it is safe to access it at this point. instance Simplifiable KTerm where simpl k = do @@ -545,5 +548,5 @@ iter kt = iter kt' rewrite :: Prog -> Prog -rewrite (Prog atoms kterm) = - Prog atoms (iter kterm) \ No newline at end of file +rewrite (Prog imps reqs atoms kterm) = + Prog imps reqs atoms (iter kterm) diff --git a/compiler/src/CaseElimination.hs b/compiler/src/CaseElimination.hs index a50c1547..9bee7bb8 100644 --- a/compiler/src/CaseElimination.hs +++ b/compiler/src/CaseElimination.hs @@ -20,16 +20,15 @@ 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 imps reqs atms tm) = do + let tm' = case compileMode of + CompileMode.Module -> 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'') + return (T.Prog imps reqs atms' tm'') transAtoms :: S.Atoms -> Trans T.Atoms transAtoms (S.Atoms atms) = return (T.Atoms atms) @@ -302,4 +301,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..74ab7605 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -18,7 +18,6 @@ import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader import Data.List -import CompileMode import Control.Monad.Except import IR as CCIR @@ -45,7 +44,7 @@ type CC = RWS FreshCounter -- state: the counter for fresh name generation -type CCEnv = (CompileMode, C.Atoms, NestingLevel, Map VarName VarLevel, Maybe VarName) +type CCEnv = (C.Atoms, NestingLevel, Map VarName VarLevel, Maybe VarName) type Frees = [(VarName, NestingLevel)] type FunDefs = [CCIR.FunDef] type ConstEntry = (VarName, C.Lit) @@ -59,9 +58,8 @@ consBB:: CCIR.IRInst -> CCIR.IRBBTree -> CCIR.IRBBTree consBB i (BB insts t) = BB (i:insts) t insVar :: VarName -> CCEnv -> CCEnv -insVar vn (compileMode, atms, lev, vmap, fname) = - ( compileMode - , atms +insVar vn (atms, lev, vmap, fname) = + ( atms , lev , Map.insert vn (VarNested lev) vmap , fname @@ -73,12 +71,12 @@ insVars vars ccenv = askLev = do - (_, _, lev, _, _) <- ask + (_, lev, _, _) <- ask return lev -incLev fname (compileMode, atms, lev, vmap, _) = - (compileMode, atms, lev + 1, vmap, (Just fname)) +incLev fname (atms, lev, vmap, _) = + (atms, lev + 1, vmap, (Just fname)) -- this helper function looks up the variable name @@ -87,7 +85,7 @@ incLev fname (compileMode, atms, lev, vmap, _) = transVar :: VarName -> CC VarAccess transVar v@(VN vname) = do - (_, C.Atoms atms, lev, vmap, maybe_fname) <- ask + (C.Atoms atms, lev, vmap, maybe_fname) <- ask case maybe_fname of Just fname | fname == v -> return $ VarFunSelfRef _ -> @@ -109,19 +107,17 @@ transVars = mapM transVar isDeclaredEarlierThan lev (_, l) = l < lev -transFunDec f@(VN fname) (CPS.Unary var kt) = do +transFunDec imps reqs f@(VN fname) (CPS.Unary var kt) = do lev <- askLev let filt = isDeclaredEarlierThan lev (bb, (_, frees, consts_wo_levs)) <- censor (\(a,b,c ) -> (a, filter filt b, filter (\(_, l) -> l == lev ) c)) - $ listen - $ local ((insVar var) . (incLev f)) - $ cpsToIR kt + $ listen $ local ((insVar var) . (incLev f)) $ cpsToIR imps reqs kt let consts = (fst.unzip) consts_wo_levs - tell ([FunDef (HFN fname) var consts bb], [], []) + tell ([FunDef (HFN fname) var imps reqs consts bb], [], []) return (nub frees) -transFunDec (VN _) (CPS.Nullary _) = error "not implemented" +transFunDec _ _ (VN _) (CPS.Nullary _) = error "not implemented" -- state accessors @@ -148,13 +144,14 @@ transFields fields = do lst' <- transVars vv return $ zip ff lst' -cpsToIR :: CPS.KTerm -> CC CCIR.IRBBTree -cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do +cpsToIR :: Modules -> Modules -> CPS.KTerm -> CC CCIR.IRBBTree +cpsToIR imps reqs (CPS.LetSimple vname@(VN ident) st kt) = do i <- let _assign arg = return $ Just $ CCIR.Assign vname arg in case st of CPS.Base base -> _assign $ Base base - CPS.Lib lib base -> _assign (Lib lib base) + CPS.ImpBase mod -> _assign (CCIR.ImpBase mod) + CPS.ReqBase mod -> _assign (CCIR.ReqBase mod) CPS.Bin binop v1 v2 -> do v1' <- transVar v1 v2' <- transVar v2 @@ -189,26 +186,26 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do tell ([],[],[((vname, lit), lev)]) return Nothing CPS.ValSimpleTerm (CPS.KAbs klam) -> do - freeVars <- transFunDec vname klam + freeVars <- transFunDec imps reqs vname klam envBindings <- mkEnvBindings freeVars return $ Just $ CCIR.MkFunClosures envBindings [(vname, HFN ident)] - t <- local (insVar vname) (cpsToIR kt) + t <- local (insVar vname) (cpsToIR imps reqs kt) return $ case i of Just i' -> i' `consBB` t Nothing -> t -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' -cpsToIR (CPS.LetFun fdefs kt) = do +cpsToIR imps reqs (CPS.LetRet (CPS.Cont arg kt') kt) = do + t <- cpsToIR imps reqs kt + t' <- local (insVar arg) (cpsToIR imps reqs kt') + return $ CCIR.BB [] $ StackExpand arg t t' +cpsToIR imps reqs (CPS.LetFun fdefs kt) = do let vnames_orig = map (\(CPS.Fun fname _) -> fname) fdefs let localExt = local (insVars vnames_orig) - t <- localExt (cpsToIR kt) -- translate the body + t <- localExt (cpsToIR imps reqs kt) -- translate the body frees <- mapM (\(CPS.Fun fname klam) -> - localExt (transFunDec fname klam)) + localExt (transFunDec imps reqs fname klam)) fdefs let freeVars = (nub.concat) frees @@ -219,39 +216,32 @@ cpsToIR (CPS.LetFun fdefs kt) = do return $ (CCIR.MkFunClosures envBindings fnBindings) `consBB` t -- Special Halt continuation, for exiting program -cpsToIR (CPS.Halt v) = do +cpsToIR _ _ (CPS.Halt v) = do v' <- transVar v - (compileMode,_ , _ , _, _ ) <- ask - let constructor = - case compileMode of - Normal -> CCIR.Ret - -- Compiling library, then generate export instruction - Export -> CCIR.LibExport + return $ CCIR.BB [] $ CCIR.Ret v' - return $ CCIR.BB [] $ constructor v' - -cpsToIR (CPS.KontReturn v) = do +cpsToIR _ _ (CPS.KontReturn v) = do v' <- transVar v return $ CCIR.BB [] $ CCIR.Ret v' -cpsToIR (CPS.ApplyFun fname v) = do +cpsToIR _ _ (CPS.ApplyFun fname v) = do fname' <- transVar fname v' <- transVar v return $ CCIR.BB [] $ CCIR.TailCall fname' v' -cpsToIR (CPS.If v kt1 kt2) = do +cpsToIR imps reqs (CPS.If v kt1 kt2) = do v' <- transVar v - bb1 <- cpsToIR kt1 - bb2 <- cpsToIR kt2 + bb1 <- cpsToIR imps reqs kt1 + bb2 <- cpsToIR imps reqs kt2 return $ CCIR.BB [] $ CCIR.If v' bb1 bb2 -cpsToIR (CPS.AssertElseError v kt1 z p) = do +cpsToIR imps reqs (CPS.AssertElseError v kt1 z p) = do v' <- transVar v z' <- transVar z - bb <- cpsToIR kt1 + bb <- cpsToIR imps reqs kt1 return $ CCIR.BB [] $ CCIR.AssertElseError v' bb z' p -cpsToIR (CPS.Error v p) = do +cpsToIR _ _ (CPS.Error v p) = do v' <- transVar v return $ CCIR.BB [] $ CCIR.Error v' p @@ -262,25 +252,22 @@ cpsToIR (CPS.Error v p) = do -- Top-level function ------------------------------------------------------------ -closureConvert :: CompileMode -> CPS.Prog -> Except String CCIR.IRProgram -closureConvert compileMode (CPS.Prog (C.Atoms atms) t) = +closureConvert :: CPS.Prog -> Except String CCIR.IRProgram +closureConvert (CPS.Prog (C.Modules imps) (C.Modules reqs) (C.Atoms atms) t) = let atms' = C.Atoms atms - initEnv = ( compileMode - , atms' + initEnv = ( atms' , 0 -- initial nesting counter , Map.empty , Nothing -- top level code has no function name ) initState = 0 - (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") + (bb, (fdefs, _, consts_wo_levs)) = evalRWS (cpsToIR imps reqs t) initEnv initState + argName = "$$authorityarg" + topLevel = "main" -- obs that our 'main' may have two names depending on the compilation mode; 2018-07-02; AA consts = (fst.unzip) consts_wo_levs - main = FunDef (HFN toplevel) (VN argumentName) consts bb + main = FunDef (HFN topLevel) (VN argName) imps reqs consts bb irProg = CCIR.IRProgram (C.Atoms atms) $ fdefs++[main] in do CCIR.wfIRProg irProg diff --git a/compiler/src/CompileMode.hs b/compiler/src/CompileMode.hs index e5de67a6..017dd0c6 100644 --- a/compiler/src/CompileMode.hs +++ b/compiler/src/CompileMode.hs @@ -1,4 +1,9 @@ -module CompileMode - where +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 module + | Module + -- | Interactive deserialization of IR + | Interactive diff --git a/compiler/src/Core.hs b/compiler/src/Core.hs index 72af085f..50aa07e6 100644 --- a/compiler/src/Core.hs +++ b/compiler/src/Core.hs @@ -9,6 +9,7 @@ module Core ( Lambda (..) , Lit(..) , AtomName , Atoms(..) + , Core.Modules(..) , Prog(..) , VarAccess(..) , lowerProg @@ -20,6 +21,7 @@ import GHC.Generics(Generic) import Data.Serialize (Serialize) import qualified Data.Ord +import Data.Maybe (fromJust) import Basics import qualified DirectWOPats as D import qualified Data.Map.Strict as Map @@ -94,8 +96,10 @@ type Fields = [(FieldName, Term)] data VarAccess -- | A normal variable = RegVar VarName - -- | Referring to a definition from a library - | LibVar LibName VarName + -- | Referring to the value 'exported' from an imported module + | ImpVar ModName + -- | Referring to the value 'exported' from a required module + | ReqVar ModName -- | A predefined name (e.g. send, receive) | BaseName VarName deriving (Eq) @@ -124,10 +128,11 @@ data Atoms = Atoms [AtomName] deriving (Eq, Show, Generic) instance Serialize Atoms - -data Prog = Prog Imports Atoms Term +data Modules = Modules [(ModName, ModHash)] deriving (Eq, Show) +data Prog = Prog Core.Modules Core.Modules Atoms Term + deriving (Eq, Show) {-- @@ -151,14 +156,17 @@ The module also contains pretty printing for the Core representation. -- 1. Lowering -------------------------------------------------- -lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term) - +lowerProg (D.Prog imps reqs atms term) = + Prog (transModules imps) (transModules reqs) (transAtoms atms) (lower term) -- the rest of the declarations in this part are not exported -trans :: D.Atoms -> Atoms -trans (D.Atoms atms) = Atoms atms +transAtoms :: D.Atoms -> Atoms +transAtoms (D.Atoms atms) = Atoms atms + +transModules :: Basics.Modules -> Core.Modules +transModules (Basics.Modules modules) = Core.Modules $ map (\(m,h) -> (m, fromJust h)) modules lowerLam (D.Lambda vs t) = case vs of @@ -221,13 +229,13 @@ lower (D.Un op e) = Un op (lower e) -- This is the only function that is exported here renameProg :: Prog -> Prog -renameProg (Prog imports (Atoms atms) term) = +renameProg (Prog imps reqs (Atoms atms) term) = let alist = map (\ a -> (a, a)) atms initEnv = Map.fromList alist - initReader = mapFromImports imports + initReader = (makeModEnv imps, makeModEnv reqs) initState = 0 (term', _) = evalRWS (rename term initEnv) initReader initState - in Prog imports (Atoms atms) term' + in Prog imps reqs (Atoms atms) term' -- The rest of the declarations here are not exported @@ -235,7 +243,7 @@ renameProg (Prog imports (Atoms atms) term) = The renaming occurs in RWS monad that is instantiated as follows: -* The reader is the library environment +* The reader is the library environment / module environment * The state is the unique variable counter * The output is not used so we instantiate it to a dummy unit type @@ -245,23 +253,14 @@ threaded explicitly. That is encoded in the `Env` map. --} -type S = RWS LibEnv () Integer +type S = RWS (ModEnv, ModEnv) () Integer -type LibEnv = Map.Map VarName LibName +type ModEnv = Map.Map VarName ModName type Env = Map.Map VarName VarName - -mapFromImports :: Imports -> LibEnv -mapFromImports (Imports imports) = - foldl insLib Map.empty imports - where - insLib map (lib, Just defs) = - foldl (\map def -> Map.insert def lib map) map defs - insLib map (lib, Nothing) = error "malformed lib import data structure" - -- TODO: 2018-07-02; better error message for the above case - -- or even better: a data structure that avoids needing to make a check like that - -- (we should be in theory able to do that) - +makeModEnv :: Core.Modules -> ModEnv +makeModEnv (Core.Modules modules) = + foldl (\ s (m@(ModName m'), _) -> Map.insert m' m s) Map.empty modules -- | Sanitize variable names to be JavaScript-compatible identifiers sanitizeForJS :: VarName -> VarName @@ -284,12 +283,17 @@ lookforalpha v m = Map.findWithDefault v v m lookforgen :: VarName -> Env -> S VarAccess lookforgen v m = case Map.lookup v m of - Just v -> return $ RegVar v + -- Previously defined variable + Just v' -> return $ RegVar v' Nothing -> do - libmap <- ask - case Map.lookup v libmap of - Just lib' -> return $ LibVar lib' v - Nothing -> return $ BaseName v + (imps, reqs) <- ask + case (Map.lookup v imps, Map.lookup v reqs) of + -- Definition from an import + (Just v', _) -> return $ ImpVar v' + -- Definition from a require + (_, Just v') -> return $ ReqVar v' + -- Otherwise, treat it as a new variable + _ -> return $ BaseName v extend :: VarName -> VarName -> Env -> Env @@ -413,15 +417,16 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = +ppProg (Prog (Core.Modules imps) (Core.Modules reqs) (Atoms atoms) term) = let ppAtoms = if null atoms then PP.empty else (text "datatype Atoms = ") <+> (hsep $ PP.punctuate (text " |") (map text atoms)) - ppImports = if null imports then PP.empty else text "<>\n" - in ppImports $$ ppAtoms $$ ppTerm 0 term + ppImports = if null imps then PP.empty else text "<>\n" + ppRequires = if null reqs then PP.empty else text "<>\n" + in ppImports $$ ppRequires $$ ppAtoms $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc @@ -464,7 +469,8 @@ ppTerm' (ListCons hd tl) = ppTerm consPrec hd PP.<> text "::" PP.<> ppTerm consPrec tl ppTerm' (Var (RegVar x)) = text x -ppTerm' (Var (LibVar (LibName lib) var)) = text lib <+> text "." <+> text var +ppTerm' (Var (ImpVar (ModName mod))) = text mod +ppTerm' (Var (ReqVar (ModName mod))) = text mod ppTerm' (Var (BaseName v)) = text v ppTerm' (Abs lam) = let (ppArgs, ppBody) = qqLambda lam diff --git a/compiler/src/Direct.hs b/compiler/src/Direct.hs index 6df77c46..edc366cd 100644 --- a/compiler/src/Direct.hs +++ b/compiler/src/Direct.hs @@ -110,7 +110,7 @@ data Atoms = Atoms [AtomName] deriving (Eq, Show) -data Prog = Prog Imports Atoms Term +data Prog = Prog Modules Modules Atoms Term deriving (Eq, Show) @@ -130,7 +130,7 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = +ppProg (Prog (Modules imps) (Modules reqs) (Atoms atoms) term) = let ppAtoms = if null atoms then PP.empty @@ -138,12 +138,21 @@ ppProg (Prog (Imports imports) (Atoms atoms) term) = (hsep $ PP.punctuate (text " |") (map text atoms)) ppImports = - if null imports then PP.empty + if null imps then PP.empty else - let ppLibName ((LibName s, _)) = text "import" <+> text s + let ppModName ((ModName s, _)) = text "import" <+> text s in - (vcat $ (map ppLibName imports)) $$ PP.text "" + (vcat $ (map ppModName imps)) $$ PP.text "" + + ppRequires = + if null reqs then PP.empty + else + let ppModName ((ModName s, _)) = text "require" <+> text s + in + (vcat $ (map ppModName reqs)) $$ PP.text "" + in vcat [ ppImports + , ppRequires , ppAtoms , ppTerm 0 term ] diff --git a/compiler/src/DirectWOPats.hs b/compiler/src/DirectWOPats.hs index 3fd5e022..06fcdca9 100644 --- a/compiler/src/DirectWOPats.hs +++ b/compiler/src/DirectWOPats.hs @@ -65,7 +65,7 @@ data Term data Atoms = Atoms [AtomName] deriving (Eq, Show) -data Prog = Prog Imports Atoms Term +data Prog = Prog Modules Modules Atoms Term deriving (Eq, Show) @@ -88,14 +88,15 @@ instance ShowIndent Prog where ppProg :: Prog -> PP.Doc -ppProg (Prog (Imports imports) (Atoms atoms) term) = +ppProg (Prog (Modules imps) (Modules reqs) (Atoms atoms) term) = let ppAtoms = if null atoms then PP.empty else (text "datatype Atoms = ") <+> (hsep $ PP.punctuate (text " |") (map text atoms)) - ppImports = if null imports then PP.empty else text "<>\n" - in ppImports $$ ppAtoms $$ ppTerm 0 term + ppImports = if null imps then PP.empty else text "<>\n" + ppRequires = if null reqs then PP.empty else text "<>\n" + in ppImports $$ ppRequires $$ ppAtoms $$ ppTerm 0 term ppTerm :: Precedence -> Term -> PP.Doc diff --git a/compiler/src/Exports.hs b/compiler/src/Exports.hs deleted file mode 100644 index 0f9bd610..00000000 --- a/compiler/src/Exports.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Exports where - --- 2018-07-02: 21.09: this moudle may be redundant; AA - --- 2018-07-02: aa: consider renaming it to ProcessExports for --- consistency w the imports handling module; though on the other hand --- the exports are handled in many places throughout the compilation --- pipeline. - - -import Basics -import Direct -import Control.Monad.Except - -type Exports = [(Basics.VarName, Basics.VarName)] - -extractMain :: Term -> Term -extractMain (Let _ term) = extractMain term -extractMain x = x - -errorMessage = "parse error: libraries need to use restricted syntax for their main body" - - -extractExports :: Prog -> Except String [String] -extractExports (Prog imports atoms term) = do - case extractMain term of - List exports -> reify exports - _ -> throwError errorMessage - - -reify :: [Term] -> Except String [String] -reify = mapM checkOne - - -checkOne :: Term -> Except String String -checkOne (Tuple [Lit (LString s), Var vn]) = return s -checkOne _ = throwError errorMessage diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 8621c088..87ead05c 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 @@ -66,9 +65,10 @@ data IRExpr | Const C.Lit -- | Predefined base function names. | Base Basics.VarName - -- | Returns the definition (variable) with the given name - -- from the given library. - | Lib Basics.LibName Basics.VarName + -- | Access to the value exported by an (imported) module. + | ImpBase Basics.ModName + -- | Access to the value exported by a (required) module. + | ReqBase Basics.ModName deriving (Eq, Show, Generic) -- | A block of instructions followed by a terminator, which can contain further 'IRBBTree's. @@ -91,7 +91,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) @@ -105,14 +105,17 @@ data IRInst deriving (Eq, Show, Generic) - +-- | A module together with its associated hash. +type Modules = [(Basics.ModName, Basics.ModHash)] -- | A literal together with the variable name the constant is accessed through. type Consts = [(VarName, C.Lit)] -- Function definition data FunDef = FunDef HFN -- name of the function VarName -- name of the argument - Consts -- constants used in the function + Modules -- imported modules used in the function + Modules -- required modules used in the function + Consts -- constants used in the function IRBBTree -- body deriving (Eq,Generic) @@ -127,16 +130,17 @@ data IRProgram = IRProgram C.Atoms [FunDef] deriving (Generic) -- For dependencies, we only need the function dependencies class ComputesDependencies a where - dependencies :: a -> Writer ([HFN], [Basics.LibName], [Basics.AtomName]) () + dependencies :: a -> Writer ([HFN], [Basics.ModName], [Basics.ModName], [Basics.AtomName]) () instance ComputesDependencies IRInst where dependencies (MkFunClosures _ fdefs) = - mapM_ (\(_, hfn) -> tell ([hfn],[],[])) fdefs - dependencies (Assign _ (Lib libname _)) = - tell ([], [libname],[]) + mapM_ (\(_, hfn) -> tell ([hfn], [], [], [])) fdefs + dependencies (Assign _ (ImpBase modName)) = + tell ([], [modName], [], []) + dependencies (Assign _ (ReqBase modName)) = + tell ([], [], [modName], []) dependencies (Assign _ (Const (C.LAtom a))) = - tell ([], [], [a]) - + tell ([], [], [], [a]) dependencies _ = return () instance ComputesDependencies IRBBTree where @@ -147,21 +151,11 @@ 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 ) + dependencies (FunDef _ _ _ _ _ bb) = dependencies bb ----------------------------------------------------------- @@ -195,6 +189,9 @@ serializeFunDef fdef = Serialize.runPut ( Serialize.put (FunSerialization fdef) serializeAtoms :: C.Atoms -> BS.ByteString serializeAtoms atoms = Serialize.runPut (Serialize.put (AtomsSerialization atoms)) +serializeProgram :: IRProgram -> BS.ByteString +serializeProgram prog = Serialize.runPut ( Serialize.put (ProgramSerialization prog) ) + deserializeAtoms :: BS.ByteString -> Either String C.Atoms deserializeAtoms bs = Serialize.runGet (Serialize.get) bs @@ -208,6 +205,10 @@ deserialize bs = Left s -> Left "ir not well-formed" -- if wfFun fdecl then (Right x) -- else Left "ir not well-formed" + Right x@(ProgramSerialization prog) -> + case runExcept (wfIRProg prog) of + Right _ -> Right x + Left s -> Left "ir not well-formed" Right x -> Right x ----------------------------------------------------------- @@ -231,15 +232,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 @@ -358,7 +359,7 @@ wfIRProg :: IRProgram -> Except String () wfIRProg (IRProgram _ funs) = mapM_ wfFun funs wfFun :: FunDef -> Except String () -wfFun (FunDef (HFN fn) (VN arg) consts bb) = +wfFun (FunDef (HFN fn) (VN arg) _ _ consts bb) = let initVars =[ fn,arg] ++ [i | VN i <- fst (unzip consts)] act = do mapM checkId initVars @@ -387,12 +388,24 @@ ppProg (IRProgram atoms funs) = instance Show IRProgram where show = PP.render.ppProg +ppImps modules = + vcat $ map ppModule modules + where ppModule (Basics.ModName m, Basics.ModHash h) = + text "imports: " <+> hsep [text m, text "@", text h] + +ppReqs modules = + vcat $ map ppModule modules + where ppModule (Basics.ModName m, Basics.ModHash h) = + text "requires: " <+> hsep [text m, text "@", text h] + ppConsts consts = vcat $ map ppConst consts where ppConst (x, lit) = hsep [ ppId x , text "=", ppLit lit ] -ppFunDef (FunDef hfn arg consts insts) +ppFunDef (FunDef hfn arg imps reqs consts insts) = vcat [ text "func" <+> ppFunCall (ppId hfn) [ppId arg] <+> text "{" + , nest 2 (ppImps imps) + , nest 2 (ppReqs reqs) , nest 2 (ppConsts consts) , nest 2 (ppBB insts) , text "}"] @@ -415,7 +428,8 @@ ppIRExpr (Const lit) = ppLit lit ppIRExpr (Base v) = if v == "$$authorityarg" -- special casing; hack; 2018-10-18: AA then text v else text v <> text "$base" -ppIRExpr (Lib (Basics.LibName l) v) = text l <> text "." <> text v +ppIRExpr (ImpBase (Basics.ModName m)) = text m +ppIRExpr (ReqBase (Basics.ModName m)) = text m ppIRExpr (Record fields) = PP.braces $ qqFields fields ppIRExpr (WithRecord x fields) = PP.braces $ PP.hsep[ ppId x, text "with", qqFields fields] ppIRExpr (ProjField x f) = @@ -442,7 +456,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 _) @@ -463,7 +478,7 @@ ppTr (If va ir1 ir2) text "}" ppTr (TailCall va1 va2) = ppFunCall (text "tail") [ppId va1, ppId va2] ppTr (Ret va) = ppFunCall (text "ret") [ppId va] -ppTr (LibExport va) = ppFunCall (text "export") [ppId va] +ppTr (LibExport va) = ppFunCall (text "export") [ppId va] ppTr (Error va _) = (text "error") <> (ppId va) @@ -495,8 +510,8 @@ instance Identifier VarAccess where instance Identifier HFN where ppId (HFN n) = text n -instance Identifier Basics.LibName where - ppId (Basics.LibName s) = text s +instance Identifier Basics.ModName where + ppId (Basics.ModName s) = text s instance Identifier Basics.AtomName where ppId = text 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..296a923c 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -485,9 +485,16 @@ expr2rawComp = \case -- Revision 2023-08: Changed the RT operation to return an unlabelled value, -- as the labels are PC anyway. - IR.Lib libname funname -> + IR.ImpBase modName -> return SimpleRawComp - { cVal = RExpr $ Lib libname funname + { cVal = RExpr $ ImpBase modName + , cValLbl = PC + , cTyLbl = PC + } + + IR.ReqBase modName -> + return SimpleRawComp + { cVal = RExpr $ ReqBase modName , cValLbl = PC , cTyLbl = PC } @@ -699,7 +706,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 +718,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. @@ -755,8 +762,8 @@ tree2raw (IR.BB irInsts irTr) = do -- Revision 2023-08: new code, but equivalent fun2raw :: IR.FunDef -> FunDef -fun2raw irfdef@(IR.FunDef hfn vname consts (IR.BB irInsts irTr)) = - FunDef hfn rawConsts (BB insts tr) irfdef +fun2raw irfdef@(IR.FunDef hfn vname imps reqs consts (IR.BB irInsts irTr)) = + FunDef hfn imps reqs rawConsts (BB insts tr) irfdef where ((tr, rawConsts), insts) = evalRWS comp () 0 comp = do -- Store the argument from R0 in the variable under which the argument is expected. diff --git a/compiler/src/IROpt.hs b/compiler/src/IROpt.hs index 610c1f24..6f2ff02a 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -5,15 +5,16 @@ import IR import Control.Monad.RWS.Lazy import Data.Map.Lazy (Map) import Data.Set(Set) +import qualified Data.List as List import qualified Data.Set as Set import qualified Basics import qualified Core as C import TroupePositionInfo +import qualified Control.Monad.Writer as CMW import qualified Data.Map.Lazy as Map import RetCPS (VarName (..)) - -------------------------------------------------- -- substitutions for IR -------------------------------------------------- @@ -46,7 +47,8 @@ instance Substitutable IRExpr where ListCons x y -> ListCons (apply subst x) (apply subst y) Const x -> Const x Base name -> Base name - Lib name name' -> Lib name name' + ImpBase name -> ImpBase name + ReqBase name -> ReqBase name where _ff fields = map (\(f,x) -> (f, apply subst x)) fields instance Substitutable IRInst where @@ -67,7 +69,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) = @@ -190,7 +192,13 @@ canFailOrHasEffects expr = case expr of -- Function calls can have side effects Base _ -> True - Lib _ _ -> True + + -- At runtime, all modules have been successfully initialized. Accessing these are safe and has + -- no side effects. Completely removing the mention of a module, thereby possibly not + -- initializing the module, neither has any side effects as module initialisation is forced to + -- be pure. + ImpBase _ -> False + ReqBase _ -> False -- These are generally safe Tuple _ -> False @@ -372,7 +380,10 @@ irExprPeval e = (Base _) -> do r_ (Unknown, e) - (Lib _ _) -> do + (ImpBase _) -> do + r_ (Unknown, e) + + (ReqBase _) -> do r_ (Unknown, e) (Un Basics.TupleLength x) -> do @@ -462,7 +473,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 +484,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 @@ -524,11 +535,16 @@ instance PEval IRBBTree where funopt :: FunDef -> FunDef -funopt (FunDef hfn argname consts bb) = +funopt (FunDef hfn argname imps reqs consts bb) = let initEnv = (Map.singleton argname Unknown, False) (bb', (_, hasChanges), _) = runRWS (peval bb) () initEnv - new = FunDef hfn argname consts bb' + (_, impRefs, reqRefs, _) = CMW.execWriter (IR.dependencies bb') + + imps' = List.nub $ List.filter (\ (modName, _) -> List.elem modName impRefs) imps + reqs' = List.nub $ List.filter (\ (modName, _) -> List.elem modName reqRefs) reqs + + new = FunDef hfn argname imps' reqs' consts bb' in if (bb /= bb') then funopt new else new diff --git a/compiler/src/Lexer.x b/compiler/src/Lexer.x index 6c4aaca6..2a551251 100644 --- a/compiler/src/Lexer.x +++ b/compiler/src/Lexer.x @@ -93,6 +93,7 @@ tokens:- <0> case { mkL TokenCase } <0> of { mkL TokenOf } <0> import { mkL TokenImport } +<0> require { mkL TokenRequire } <0> andalso { mkL TokenAndAlso } <0> orelse { mkL TokenOrElse } <0> raisedTo { mkL TokenRaisedTo } @@ -202,6 +203,7 @@ data Token | TokenCase | TokenOf | TokenImport + | TokenRequire | TokenReceive | TokenPini | TokenWhen diff --git a/compiler/src/Parser.y b/compiler/src/Parser.y index 3d67eb45..d7e3cf3c 100644 --- a/compiler/src/Parser.y +++ b/compiler/src/Parser.y @@ -39,7 +39,8 @@ import Control.Monad.Except else { L _ TokenElse } case { L _ TokenCase } of { L _ TokenOf } - import { L _ TokenImport } + import { L _ TokenImport } + require { L _ TokenRequire } datatype { L _ TokenDatatype } Atoms { L _ TokenAtoms } fn { L _ TokenFn } @@ -134,17 +135,19 @@ import Control.Monad.Except -Prog : ImportDecl AtomsDecl Expr { Prog (Imports $1) (Atoms $2) $3 } +Prog : ImportDecl RequireDecl AtomsDecl Expr { Prog (Modules $1) (Modules $2) (Atoms $3) $4 } -ImportDecl: import VAR ImportDecl { ((LibName (varTok $2), Nothing)): $3 } - | { [] } +ImportDecl: import VAR ImportDecl { ((ModName (varTok $2), Nothing)): $3 } + | {[]} +RequireDecl: require VAR RequireDecl { ((ModName (varTok $2), Nothing)): $3 } + | {[]} -AtomsDecl : datatype Atoms '=' VAR AtomsList { (varTok $4):$5 } +AtomsDecl : datatype Atoms '=' VAR AtomsList { (varTok $4):$5 } | {[]} -AtomsList : { [] } - | '|' VAR AtomsList { (varTok $2): $3 } +AtomsList : {[]} + | '|' VAR AtomsList { (varTok $2): $3 } Expr: Form { $1 } diff --git a/compiler/src/ProcessImports.hs b/compiler/src/ProcessImports.hs deleted file mode 100644 index eb579f23..00000000 --- a/compiler/src/ProcessImports.hs +++ /dev/null @@ -1,49 +0,0 @@ -module ProcessImports (processImports) where -import Basics -import Direct -import System.Environment -import System.Exit -import Data.String.Utils - -defaultLibFolder="/lib/out/" -defaultBin="/bin/troupec" - -getRelativeHome :: IO String -getRelativeHome = do - progPath <- getExecutablePath - if endswith defaultBin progPath - then do - let home = take ( length progPath - length defaultBin) progPath - return home - else do - die "Cannot determine Troupe home folder. Consider setting up the TROUPE environment variable" - -getTroupeHome :: IO String -getTroupeHome = do - maybeVar <- lookupEnv "TROUPE" - case maybeVar of - Nothing -> getRelativeHome - Just troupeEnv -> return troupeEnv - - - -processImport (LibName lib, _) = do - troupeEnv <- getTroupeHome - let fname = troupeEnv ++ defaultLibFolder ++ lib ++ ".exports" - input <- readFile fname - return ( LibName lib, Just (lines input)) - - -processImports' :: Imports -> IO Imports -processImports' (Imports imports)= - Imports <$> mapM processImport imports - - -processImports :: Prog -> IO Prog -processImports (Prog imports atoms term) = do - imports' <- processImports' imports - return $ Prog imports' atoms term - - --- TODO: 2018-07-02: AA: proper error handling in case we have errors --- loading information from the lib files diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index a9a17046..c4b035bb 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 @@ -112,9 +111,12 @@ data RawExpr -- | Cons operation with the new head (labelled value) and the list (simple value). | ListCons VarAccess RawVar | Const C.Lit - -- | Reference to a definition in a library - | Lib Basics.LibName Basics.VarName + -- | Base function in the runtime. | Base Basics.VarName + -- | Reference to the exported value from an (imported) module. + | ImpBase Basics.ModName + -- | Reference to the exported value from a (required) module. + | ReqBase Basics.ModName -- | Make a labelled value out of the given 'RawVar's (value, value label, type label). | ConstructLVal RawVar RawVar RawVar deriving (Eq, Show) @@ -158,7 +160,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) @@ -188,12 +190,16 @@ ppRTAssertionCode f a = f (text $ "rt.rawAssert" ++ rtFun) args ppRTAssertion :: RTAssertion -> PP.Doc ppRTAssertion = ppRTAssertionCode ppFunCall +-- Function definition +type Modules = [(Basics.ModName, Basics.ModHash)] + type Consts = [(RawVar, C.Lit )] --- Function definition data FunDef = FunDef - HFN -- name of the function - Consts + HFN -- name of the function + Modules -- imported modules used in the function + Modules -- required modules used in the function + Consts -- constants used in the function RawBBTree -- body IR.FunDef -- original definition for serialization deriving (Eq) @@ -269,9 +275,25 @@ ppProg (RawProgram atoms funs) = instance Show RawProgram where show = PP.render.ppProg -ppFunDef ( FunDef hfn consts insts _ ) +ppImps modules = + vcat $ map ppModule modules + where ppModule (Basics.ModName m, Basics.ModHash h) = + text "imports: " <+> hsep [text m, text "@", text h] + +ppReqs modules = + vcat $ map ppModule modules + where ppModule (Basics.ModName m, Basics.ModHash h) = + text "requires: " <+> hsep [text m, text "@", text h] + +ppConsts consts = + vcat $ map ppConst consts + where ppConst (x, lit) = hsep [ ppId x , text "=", ppLit lit ] + +ppFunDef ( FunDef hfn imps reqs consts insts _ ) = vcat [ text "func" <+> ppFunCall (ppId hfn) [] <+> text "{" - , nest 2 (ppConsts consts ) + , nest 2 (ppImps imps) + , nest 2 (ppReqs reqs) + , nest 2 (ppConsts consts) , nest 2 (ppBB insts) , text "}"] @@ -293,7 +315,8 @@ ppRawExpr (Const lit) = ppLit lit -- ppRawExpr (Base v) = if v == "$$authorityarg" -- special casing; hack; 2018-10-18: AA -- then text v -- else text v <> text "$base" -ppRawExpr (Lib (Basics.LibName l) v) = text l <> text "." <> text v +ppRawExpr (ImpBase (Basics.ModName m)) = text m +ppRawExpr (ReqBase (Basics.ModName m)) = text m ppRawExpr (Record fields) = PP.braces $ qqFields fields ppRawExpr (WithRecord x fields) = PP.braces $ PP.hsep[ ppId x, text "with", qqFields fields] ppRawExpr (ProjField x f) = @@ -341,7 +364,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 _) @@ -368,8 +391,4 @@ ppTr (Error va _) = (text "error ") <> (ppId va) ppBB (BB insts tr) = vcat $ (map ppIR insts) ++ [ppTr tr] -ppConsts consts = - vcat $ map ppConst consts - where ppConst (x, lit) = hsep [ ppId x , text "=", ppLit lit ] - diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index caf87c3b..733b7c21 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 @@ -216,7 +215,7 @@ trBB (Raw.BB insts tr) = do trFun :: Raw.FunDef -> Stack.FunDef -trFun fdef@(Raw.FunDef hfn consts bb ir) = +trFun fdef@(Raw.FunDef hfn imps reqs consts bb ir) = let defUseInfo = defUse fdef constMap = Map.fromList consts offsets = offsetMap constMap defUseInfo @@ -232,7 +231,7 @@ trFun fdef@(Raw.FunDef hfn consts bb ir) = Nothing -> insts Just ee -> (Stack.StoreStack Raw.Env ee) :insts frameSize = Map.size offsets - in Stack.FunDef hfn frameSize consts (Stack.BB insts_ bb_) ir + in Stack.FunDef hfn frameSize imps reqs consts (Stack.BB insts_ bb_) ir rawProg2Stack :: Raw.RawProgram -> Stack.StackProgram @@ -246,4 +245,4 @@ raw2Stack :: Raw.RawUnit -> Stack.StackUnit raw2Stack r = case r of Raw.FunRawUnit f -> Stack.FunStackUnit (trFun f) Raw.AtomRawUnit c -> Stack.AtomStackUnit c - Raw.ProgramRawUnit p -> Stack.ProgramStackUnit (rawProg2Stack p) \ No newline at end of file + Raw.ProgramRawUnit p -> Stack.ProgramStackUnit (rawProg2Stack p) diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index c6b7314f..bacddda3 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) @@ -206,7 +205,8 @@ instance Usable RawExpr b where Raw.List xs -> use xs Raw.ListCons x y -> use x >> use y Raw.Const _ -> return () - Raw.Lib _ _ -> return () + Raw.ImpBase _ -> return () + Raw.ReqBase _ -> return () Raw.Base _ -> return () Raw.ConstructLVal x y z -> do use x use [y,z] @@ -233,7 +233,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 @@ -318,8 +318,8 @@ class Trav a where defUse :: FunDef -> DefUse -defUse (FunDef _ consts bb _) = - let constVars = ( fst . unzip )consts +defUse (FunDef _ imps reqs consts bb _) = + let constVars = (fst . unzip) consts insertConsts = mapM define constVars (defUse, _) = execRWS (modify (__insertDefPure Env) >> insertConsts >> trav bb) diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 937dc8be..6c4c1d2c 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -22,7 +22,6 @@ import IR ( Identifier(..) import qualified Data.List import qualified Data.Ord -import Debug.Trace -------------------------------------------------- -- substitutions for Raw -------------------------------------------------- @@ -78,7 +77,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 @@ -155,8 +154,9 @@ instance MarkUsed RawExpr where ProjIdx x _ -> markUsed x List xs -> markUsed xs ListCons x y -> markUsed x >> markUsed y - Const _ -> return () - Lib _ _ -> return () + Const _ -> return () + ImpBase _ -> return () + ReqBase _ -> return () Base _ -> return () ConstructLVal x y z -> markUsed [x,y,z] @@ -258,7 +258,8 @@ guessType = \case ProjectState R0_Lev -> Just RawLevel ProjectState R0_TLev -> Just RawLevel ProjectState R0_Val -> Nothing - Lib _ _ -> Nothing + ImpBase _ -> Nothing + ReqBase _ -> Nothing Base _ -> Nothing ConstructLVal _ _ _ -> Nothing @@ -420,7 +421,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 +429,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 +471,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 +489,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,14 +539,14 @@ 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_ funopt :: FunDef -> FunDef -funopt (FunDef hfn consts bb ir) = +funopt (FunDef hfn imps reqs consts bb ir) = let (m_consts, m_subst) = foldl (\(m1, m2) (x,lit) -> @@ -580,7 +582,7 @@ funopt (FunDef hfn consts bb ir) = readenv = ReadEnv { readConsts = Map.fromList consts } (bb', _, (_, used_rvars)) = runRWS (peval bb) readenv pstate const_used = filter (\(x,_) -> Set.member x used_rvars) consts' - new = FunDef hfn const_used bb' ir + new = FunDef hfn imps reqs const_used bb' ir in if bb /= bb' then funopt new else new diff --git a/compiler/src/RetCPS.hs b/compiler/src/RetCPS.hs index 15cec1e4..791921b0 100644 --- a/compiler/src/RetCPS.hs +++ b/compiler/src/RetCPS.hs @@ -68,7 +68,8 @@ data SimpleTerm | List [VarName] | ListCons VarName VarName | Base Basics.VarName - | Lib Basics.LibName Basics.VarName + | ImpBase Basics.ModName + | ReqBase Basics.ModName deriving (Eq, Show, Ord) data KTerm @@ -86,7 +87,7 @@ data KTerm deriving (Eq, Ord) -data Prog = Prog C.Atoms KTerm +data Prog = Prog C.Modules C.Modules C.Atoms KTerm deriving (Eq, Show) -------------------------------------------------- @@ -103,13 +104,24 @@ instance ShowIndent Prog where -- ppProg :: Prog -> PP.Doc -ppProg (Prog (C.Atoms atoms) kterm) = +ppProg (Prog (C.Modules imps) (C.Modules reqs) (C.Atoms atoms) kterm) = let ppAtoms = if null atoms - then PP.empty - else (text "datatype Atoms = ") <+> - (hsep $ PP.punctuate (text " |") (map text atoms)) - in ppAtoms $$ ppKTerm 0 kterm + then PP.empty + else (text "datatype Atoms = ") <+> + (hsep $ PP.punctuate (text " |") (map text atoms)) + + ppImps = + if null imps + then PP.empty + else PP.hang (text "imports:") 3 (vcat $ map (\(Basics.ModName m, _) -> text m) imps) + + ppReqs = + if null reqs + then PP.empty + else PP.hang (text "imports:") 3 (vcat $ map (\(Basics.ModName m, _) -> text m) reqs) + + in ppAtoms $$ ppImps $$ ppReqs $$ ppKTerm 0 kterm ppKTerm :: Precedence -> KTerm -> PP.Doc @@ -148,7 +160,8 @@ ppSimpleTerm (List vars) = ppSimpleTerm (ListCons v1 v2) = PP.parens $ textv v1 PP.<> text "::" PP.<> textv v2 ppSimpleTerm (Base b) = text b PP.<> text "$base" -ppSimpleTerm (Lib (Basics.LibName lib) v) = text lib <+> text "." <+> text v +ppSimpleTerm (ImpBase (Basics.ModName mod)) = text mod +ppSimpleTerm (ReqBase (Basics.ModName mod)) = text mod ppSimpleTerm (Record fields) = PP.braces $ qqFields fields ppSimpleTerm (WithRecord x fields) = PP.braces $ PP.hsep [textv x, text "with", qqFields fields] @@ -264,4 +277,4 @@ termPrec (LetFun _ _) = 0 --termPrec (Case _ _) = 0 termPrec (LetRet _ _) = 0 termPrec (AssertElseError _ _ _ _) = 0 -termPrec (Error _ _) = 0 \ No newline at end of file +termPrec (Error _ _) = 0 diff --git a/compiler/src/RetDFCPS.hs b/compiler/src/RetDFCPS.hs index b7b6e64f..5da7fb24 100644 --- a/compiler/src/RetDFCPS.hs +++ b/compiler/src/RetDFCPS.hs @@ -32,8 +32,8 @@ transFunDecl (Core.FunDecl fname (Core.Nullary e)) = do return $ CPS.Fun (VN fname) (CPS.Nullary e') transProg :: Core.Prog -> CPS.Prog -transProg (Core.Prog imports atoms t) = - Prog atoms $ evalState (trans t (\z -> return $ Halt z)) 1 +transProg (Core.Prog imps reqs atoms t) = + Prog imps reqs atoms (evalState (trans t (\z -> return $ Halt z)) 1) transFields k fields context = @@ -63,9 +63,13 @@ transExplicit (Core.Var (Core.BaseName baseName)) = do x <- freshV return $ LetSimple x (Base baseName) (KontReturn x) -transExplicit (Core.Var (Core.LibVar lib v)) = do +transExplicit (Core.Var (Core.ImpVar mod)) = do x <- freshV - return $ LetSimple x (Lib lib v) (KontReturn x) + return $ LetSimple x (ImpBase mod) (KontReturn x) + +transExplicit (Core.Var (Core.ReqVar mod)) = do + x <- freshV + return $ LetSimple x (ReqBase mod) (KontReturn x) transExplicit (Core.Lit lit) = do x <- freshV @@ -183,11 +187,15 @@ trans (Core.Var (Core.BaseName baseName)) context = do return $ LetSimple x (Base baseName) kterm' -trans (Core.Var (Core.LibVar lib v)) context = do +trans (Core.Var (Core.ImpVar mod)) context = do x <- freshV kterm' <- context x - return $ LetSimple x (Lib lib v) kterm' + return $ LetSimple x (ImpBase mod) kterm' +trans (Core.Var (Core.ReqVar mod)) context = do + x <- freshV + kterm' <- context x + return $ LetSimple x (ReqBase mod) kterm' trans (Core.Lit i) context = do x <- freshV diff --git a/compiler/src/RetFreeVars.hs b/compiler/src/RetFreeVars.hs index ff24c221..911658e4 100644 --- a/compiler/src/RetFreeVars.hs +++ b/compiler/src/RetFreeVars.hs @@ -55,7 +55,8 @@ instance FreeNames SimpleTerm where freeVars (List vs) = FreeVars (Set.fromList vs) freeVars (ListCons v1 v2) = FreeVars (Set.fromList [v1, v2]) freeVars (Base _ ) = FreeVars $ Set.empty - freeVars (Lib _ _) = FreeVars $ Set.empty + freeVars (ImpBase _) = FreeVars $ Set.empty + freeVars (ReqBase _) = FreeVars $ Set.empty freeVars (Record fields) = unionMany $ map (\(f,x) -> FreeVars (if x == VN f then Set.empty else Set.singleton x)) fields diff --git a/compiler/src/RetRewrite.hs b/compiler/src/RetRewrite.hs index cb18eb73..c2775c7c 100644 --- a/compiler/src/RetRewrite.hs +++ b/compiler/src/RetRewrite.hs @@ -74,7 +74,8 @@ instance Substitutable SimpleTerm where ListCons v v' -> ListCons (fwd v) (fwd v') ValSimpleTerm sv -> ValSimpleTerm (apply subst sv) Base v -> Base v - Lib l v -> Lib l v + ImpBase m -> ImpBase m + ReqBase m -> ReqBase m where fwd x = Map.findWithDefault x x varmap fwdFields fields = map (\(f, x) -> (f, fwd x)) fields @@ -376,4 +377,4 @@ ktWalkFix kt = else ktWalkFix kt' rewrite :: Prog -> Prog -rewrite (Prog atoms kterm) = Prog atoms (ktWalkFix kterm) +rewrite (Prog imps reqs atoms kterm) = Prog imps reqs atoms (ktWalkFix kterm) diff --git a/compiler/src/Stack.hs b/compiler/src/Stack.hs index 6427a452..80bd88d0 100644 --- a/compiler/src/Stack.hs +++ b/compiler/src/Stack.hs @@ -16,7 +16,9 @@ import IR ( Identifier(..) ) import qualified IR (FunDef (..)) import Raw (RawExpr (..), RawType(..), RawVar (..), MonComponent(..), - ppRawExpr, Assignable (..), Consts, ppConsts, RTAssertion(..), ppRTAssertion) + ppRawExpr, Assignable (..), + Modules, ppImps, ppReqs, Consts, ppConsts, + RTAssertion(..), ppRTAssertion) import qualified Core as C import qualified RetCPS as CPS @@ -30,7 +32,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 +48,7 @@ data StackTerminator | If RawVar StackBBTree StackBBTree | LibExport VarAccess | Error RawVar PosInf - | Call StackBBTree StackBBTree + | StackExpand StackBBTree StackBBTree deriving (Eq, Show) @@ -78,9 +79,11 @@ data StackInst data FunDef = FunDef HFN -- name of the function Int -- frame size - Raw.Consts -- constant literars - StackBBTree -- body - IR.FunDef -- original definition for serialization + Raw.Modules -- imported module literals + Raw.Modules -- required module literals + Raw.Consts -- constant literals + StackBBTree -- body + IR.FunDef -- original definition for serialization deriving (Eq) -- An IR program is just a collection of atoms declarations @@ -102,8 +105,10 @@ ppProg (StackProgram atoms funs) = instance Show StackProgram where show = PP.render.ppProg -ppFunDef ( FunDef hfn _ consts insts _ ) +ppFunDef ( FunDef hfn _ imps reqs consts insts _ ) = vcat [ text "func" <+> ppFunCall (ppId hfn) [] <+> text "{" + , nest 2 (ppImps imps) + , nest 2 (ppReqs reqs) , nest 2 (ppConsts consts) , nest 2 (ppBB insts) , text "}"] @@ -150,7 +155,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..3edaac87 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -40,6 +40,7 @@ import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader import Data.List +import qualified Data.ByteString as BS import qualified Data.Text as T import Data.Text.Encoding import Data.ByteString.Lazy (ByteString) @@ -56,55 +57,51 @@ import Text.PrettyPrint.HughesPJ ( import Data.Aeson (ToJSON(toJSON), Value) import DCLabels (dcLabelExpToDCLabel) +-- TODO: Move (some of) these into a wrapper for 'Text.PrettyPrint.HughesPJ' +this = text "this" +rt = text "rt" +dot = text "." +(<.>) a b = a PP.<> dot PP.<> b -data LibAccess = LibAccess Basics.LibName Basics.VarName - deriving (Eq, Show,Generic) +indent = 2 +($$+) a b = a $$ (nest indent b) +semi t = t PP.<> PP.semi -data JSOutput = JSOutput { libs :: [LibAccess] +type Module = (Basics.ModName, Basics.ModHash) + +instance Aeson.ToJSON Basics.ModName +instance Aeson.ToJSON Basics.ModHash + +moduleDeps var xs = + var PP.<+> "= {" + $$+ (vcat $ map moduleDep $ nub xs) + $$ PP.text "};" + where moduleDep (Basics.ModName name, Basics.ModHash hash) = + let name' = PP.doubleQuotes $ PP.text name + hash' = PP.doubleQuotes $ PP.text hash + in (name' PP.<> (PP.text ":") PP.<+> hash') PP.<> PP.comma + +data JSOutput = JSOutput { imports :: [Module] + , requires :: [Module] , fname:: Maybe String , code :: String , atoms :: [Basics.AtomName] } deriving (Show, Generic) -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 - -addLibs xs = vcat $ nub (map addOneLib xs) - 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 = ([Module], [Module], [Basics.AtomName], [RetKontText]) +type W = RWS Bool WData TheState initState = TheState { freshCounter = 0 @@ -114,10 +111,6 @@ initState = TheState { freshCounter = 0 , stHFN = error "stHFN should not be accessed yet" } -a $$+ b = a $$ (nest 2 b) - - - class Identifier a where ppId :: a -> PP.Doc @@ -131,8 +124,8 @@ instance Identifier VarName where instance Identifier HFN where ppId (HFN n) = text n -instance Identifier Basics.LibName where - ppId (Basics.LibName s) = text s +instance Identifier Basics.ModName where + ppId (Basics.ModName s) = text s instance Identifier Basics.AtomName where ppId = text @@ -149,46 +142,48 @@ instance Identifier Raw.Assignable where class ToJS a where toJS :: a -> W PP.Doc - - -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 - - -stack2JSString :: StackUnit -> String -stack2JSString x = - let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState - in PP.render (addLibs libs $$ (vcat (inner:konts))) - - - -stack2JSON :: StackUnit -> ByteString -stack2JSON (ProgramStackUnit _) = error "needs to be ported" -stack2JSON x = - let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState - 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))) - } - +stack2PPDoc :: CompileMode -> Bool -> (BS.ByteString, BS.ByteString) -> StackUnit -> (PP.Doc, WData) + +stack2PPDoc compileMode debugMode (irSerialized, irHash) (ProgramStackUnit sp) = + let (fns, _, w@(imps, reqs, atoms, konts)) = runRWS (toJS sp) debugMode initState + ppDoc = + ("function Top (rt)" <+> PP.lbrace) + $$+ (vcat $ + [ moduleDeps (text "this.imports") imps + , moduleDeps (text "this.requires") reqs + ] + ++ (fns:konts) ++ + [ semi $ (this <.> "hash") <+> PP.equals <+> pickle irHash + , semi $ (this <.> "serialized") <+> PP.equals <+> pickle irSerialized + ]) + $$ PP.rbrace + $$ PP.text "module.exports = Top" + in (ppDoc, w) + +stack2PPDoc _ debugMode (_, _) su = + let (inner, _, w@(imps, reqs, _, konts)) = runRWS (toJS su) debugMode initState + ppDoc = vcat $ inner:konts + in (ppDoc, w) + + +stack2JSString :: CompileMode -> Bool -> (BS.ByteString, BS.ByteString) -> StackUnit -> String +stack2JSString compileMode debugMode ir su = + let (ppDoc, _) = stack2PPDoc compileMode debugMode ir su + in PP.render ppDoc + + +stack2JSON :: CompileMode -> Bool -> (BS.ByteString, BS.ByteString) -> StackUnit -> ByteString +stack2JSON compileMode debugMode ir su = + let (ppDoc, (imps, reqs, atoms, konts)) = stack2PPDoc compileMode debugMode ir su + fname = case su of FunStackUnit (FunDef (HFN n) _ _ _ _ _ _) -> Just n + AtomStackUnit _ -> Nothing + + in Aeson.encode $ JSOutput { imports = imps + , requires = reqs + , fname = fname + , atoms = atoms + , code = PP.render ppDoc + } instance ToJS StackUnit where toJS (FunStackUnit fdecl) = toJS fdecl @@ -203,33 +198,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 @@ -256,7 +229,7 @@ constsToJS consts = where toJsConst (x,lit) = hsep ["const", ppId x , text "=", lit2JS lit ] instance ToJS FunDef where - toJS fdef@(FunDef hfn stacksize consts bb irfdef) = do + toJS fdef@(FunDef hfn stacksize imps reqs consts bb irfdef) = do {-- | | | ... | | ^ ^ @@ -270,14 +243,25 @@ instance ToJS FunDef where let lits = constsToJS consts jj <- toJS bb debug <- ask - let (irdeps, libdeps, atomdeps ) = IR.ppDeps irfdef + + let (ffs, impRefs, reqRefs) = let (ffs, impRefs, reqRefs, _) = execWriter (IR.dependencies irfdef) + in (nub ffs, nub impRefs, nub reqRefs) + + let ffs'' = let tt = map (PP.doubleQuotes . ppId) ffs + in (PP.brackets . PP.hsep) (PP.punctuate PP.comma tt) + + let imps' = nub $ filter (\ (modName, _) -> elem modName impRefs) imps + let reqs' = nub $ filter (\ (modName, _) -> elem modName reqRefs) reqs + + tell (imps', reqs', [], []) + sparseSlotIdxPP <- ppSparseSlotIdx return $ vcat [text "this." PP.<> ppId hfn <+> text "=" <+> ppArgs ["$env"] <+> text "=> {" - , if debug then nest 2 $ text "rt.debug" <+> (PP.parens . PP.doubleQuotes. ppId) hfn + , if debug then nest indent $ text "rt.debug" <+> (PP.parens . PP.doubleQuotes. ppId) hfn else PP.empty - , nest 2 $ vcat $ [ + , nest indent $ vcat $ [ "let _T = rt.runtime.$t", "let _STACK = _T.callStack", "let _SP = _T._sp", @@ -290,10 +274,11 @@ instance ToJS FunDef where lits, jj] , text "}" - , semi $ text "this." PP.<> ppId hfn PP.<> text ".deps =" <+> irdeps - , semi $ text "this." PP.<> ppId hfn PP.<> text ".libdeps =" <+> libdeps - , semi $ text "this." PP.<> ppId hfn PP.<> text ".serialized =" <+> (pickle.serializeFunDef) irfdef - , semi $ text "this." PP.<> ppId hfn PP.<> text ".framesize =" <+> (PP.int stacksize) ] + , semi $ text "this" <.> ppId hfn <.> text "deps =" <+> ffs'' + , moduleDeps (text "this" <.> ppId hfn <.> text "imports") imps' + , moduleDeps (text "this" <.> ppId hfn <.> text "requires") reqs' + , semi $ text "this" <.> ppId hfn <.> text "serialized =" <+> (pickle.serializeFunDef) irfdef + , semi $ text "this" <.> ppId hfn <.> text "framesize =" <+> (PP.int stacksize) ] @@ -430,7 +415,7 @@ ir2js (LabelGroup ii) = do return $ vcat $ [ -- "if (! _T.getSparseBit()) {" -- Alternative, but involves extra call to RT "if (!" <+> sparseSlot <+> ") {" - , nest 2 (vcat ii') + , nest indent (vcat ii') , text "}" ] where ppLevelOp (AssignRaw tt vn e) = do @@ -452,7 +437,7 @@ ir2js InvalidateSparseBit = return $ {-- TERMINATORS --} -tr2js (Call bb bb2) = do +tr2js (StackExpand bb bb2) = do _frameSize <- gets frameSize _sparseSlot <- gets sparseSlot _consts <- gets consts @@ -467,7 +452,7 @@ tr2js (Call bb bb2) = do sparseSlotIdxPP <- ppSparseSlotIdx let jsKont = vcat ["this." PP.<> ppId kname <+> text "= () => {", - nest 2 $ + nest indent $ vcat [ "let _T = rt.runtime.$t", "let _STACK = _T.callStack", @@ -488,7 +473,7 @@ tr2js (Call bb bb2) = do ] - tell ([], [], [jsKont] ) + tell ([], [], [], [jsKont] ) return $ vcat [ "_SP_OLD = _SP; ", -- 2021-04-23; hack ! ;AA "_SP = _SP + " <+> text (show (_frameSize + 5)) <+> ";", @@ -512,9 +497,9 @@ tr2js (If va bb1 bb2) = do vcat [ -- jsFunCall (text "rt.branch") [ppId va], text "if" <+> PP.parens ( ppId va) <+> text "{", - nest 2 js1, + nest indent js1, text "} else {", - nest 2 js2, + nest indent js2, text "}" ] @@ -613,13 +598,15 @@ instance ToJS RawExpr where text "rt.mkV1Label" <> (PP.parens . PP.doubleQuotes) (text s) Const lit -> do case lit of - C.LAtom atom -> tell ([], [atom], []) + C.LAtom atom -> tell ([], [], [atom], []) _ -> return () return $ ppLit lit - Lib lib'@(Basics.LibName libname) varname -> do - tell ([LibAccess lib' varname], [], []) + Raw.ImpBase (Basics.ModName m) -> do return $ - text "rt.loadLib" <> PP.parens ((PP.doubleQuotes.text) libname <> text ", " <> (PP.doubleQuotes.text) varname <> text ", this") + (rt <.> text "getLocalModule") PP.<> PP.parens (PP.doubleQuotes (text m) PP.<> PP.comma PP.<+> this) + Raw.ReqBase (Basics.ModName m) -> do + return $ + (rt <.> text "getModule") PP.<> PP.parens (PP.doubleQuotes (text m) PP.<> PP.comma PP.<+> this) ConstructLVal r1 r2 r3 -> return $ ppFunCall (text "rt.constructLVal") (map ppId [r1,r2,r3]) Base b -> return $ text "rt." <+> text b -- Note: The "$$authorityarg" case is handled in IR2Raw @@ -632,9 +619,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]))))) @@ -644,7 +628,6 @@ jsClosure var env f = ppLet x = text "const" <+> ppId x <+> text "=" -semi t = t PP.<> text ";" jsFunCall a b = semi $ ppFunCall a b diff --git a/compiler/test/ir2raw-test/testcases/Expr.hs b/compiler/test/ir2raw-test/testcases/Expr.hs index 1cc519ae..434c634b 100644 --- a/compiler/test/ir2raw-test/testcases/Expr.hs +++ b/compiler/test/ir2raw-test/testcases/Expr.hs @@ -14,7 +14,7 @@ import Basics mkP :: IRExpr -> IRProgram -mkP e = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] body] +mkP e = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] [] [] body] where body = BB [Assign (VN "r") e] (LibExport (mkV "r")) -- need to use assigned variable so that it is not optimized away tcs :: [(String, IRProgram)] @@ -39,7 +39,8 @@ tcs = map (second mkP) $ , ("WithRecord2", WithRecord (mkV "x") [("field1", mkV "v1"), ("field2", mkV "v2")]) , ("ProjField", ProjField (mkV "x") "field1") , ("ProjIdx", ProjIdx (mkV "x") 123) - , ("Lib", Lib (LibName "string") "charAt") + , ("ImpBase", ImpBase (ModName "String")) + , ("ReqBase", ReqBase (ModName "pi")) ] deriving instance Enum BinOp diff --git a/compiler/test/ir2raw-test/testcases/Inst.hs b/compiler/test/ir2raw-test/testcases/Inst.hs index 9336d1a1..d84f8667 100644 --- a/compiler/test/ir2raw-test/testcases/Inst.hs +++ b/compiler/test/ir2raw-test/testcases/Inst.hs @@ -10,7 +10,7 @@ import qualified Basics mkP :: IRInst -> IRProgram -mkP inst = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] body] +mkP inst = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] [] [] body] where body = BB [inst] (LibExport (mkV "r")) tcs :: [(String, IRProgram)] diff --git a/compiler/test/ir2raw-test/testcases/TR.hs b/compiler/test/ir2raw-test/testcases/TR.hs index 4800b478..928794f3 100644 --- a/compiler/test/ir2raw-test/testcases/TR.hs +++ b/compiler/test/ir2raw-test/testcases/TR.hs @@ -9,7 +9,7 @@ import TroupePositionInfo mkP :: IRTerminator -> IRProgram -mkP tr = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] body] +mkP tr = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] [] [] body] where body = BB [] tr tcs :: [(String, IRProgram)] @@ -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/compiler/test/ir2raw-test/testcases/Tree.hs b/compiler/test/ir2raw-test/testcases/Tree.hs index d57f0a4a..a54412a3 100644 --- a/compiler/test/ir2raw-test/testcases/Tree.hs +++ b/compiler/test/ir2raw-test/testcases/Tree.hs @@ -11,7 +11,7 @@ import qualified Basics mkP :: IRBBTree -> IRProgram -mkP tree = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] tree] +mkP tree = IRProgram (Core.Atoms []) [FunDef (HFN "main") (VN "arg") [] [] [] tree] tcs :: [(String, IRProgram)] tcs = map (second mkP) 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..fad63d4c 100644 --- a/lib/List.trp +++ b/lib/List.trp @@ -167,35 +167,26 @@ let (* -- List Access -- *) in sort_inner (split xs []) end - (*--- 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 +in + { + head, + tail, + nth, + null, + elem, + length, + reverse, + append, + revAppend, + appendAt, + sublist, + map, + mapi, + foldl, + filter, + filteri, + partition, + range, + sort } - -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..b35ba43c 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) -m ./Number.trp + $(COMPILER) -m ./List.trp + $(COMPILER) -m ./ListPair.trp + $(COMPILER) -m ./String.trp + $(COMPILER) -m ./Hash.trp + $(COMPILER) -m ./Unit.trp + $(COMPILER) -m ./StencilVector.trp + $(COMPILER) -m ./HashMap.trp + $(COMPILER) -m ./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) -m ./nsuref.trp + $(COMPILER) -m ./printService.trp + $(COMPILER) -m ./timeout.trp + $(COMPILER) -m ./NetHealth.trp + $(COMPILER) -m ./declassifyutil.trp + $(COMPILER) -m ./stdio.trp + $(COMPILER) -m ./raft.trp + $(COMPILER) -m ./raft_debug.trp + $(COMPILER) -m ./bst.trp + $(COMPILER) -m ./localregistry.trp clean: rm -rf out diff --git a/lib/NetHealth.trp b/lib/NetHealth.trp index a5f234cd..5b83b5ec 100644 --- a/lib/NetHealth.trp +++ b/lib/NetHealth.trp @@ -12,7 +12,7 @@ let (* Standard test timeout with configurable duration and node name *) (* Uses timeout library to exit with code 124 after timeout *) fun spawnTestTimeout({print, auth, ..}, timeoutMs, nodeName) = - exitAfterTimeout auth timeoutMs 124 (nodeName ^ ": Timeout") + timeout.exitAfterTimeout auth timeoutMs 124 (nodeName ^ ": Timeout") (* Standard successful exit with message delivery delay *) (* Ensures P2P messages are delivered before process exits *) @@ -43,8 +43,8 @@ let fun reportTestSummary({print, auth, ..}, nodeName, results) = let (* Use List.filter to count passed tests *) val passedTests = List.filter (fn (name, passed) => passed) results - val total = length results - val passed = length passedTests + val total = List.length results + val passed = List.length passedTests val _ = print (nodeName ^ ": Test summary:") val _ = print (nodeName ^ ": Total tests: " ^ intToString(total)) @@ -147,15 +147,15 @@ let (* Count passed tests - simplified with lists library *) fun countPassedTests(results) = - length (List.filter (fn (name, passed) => passed) results) + List.length (List.filter (fn (name, passed) => passed) results) (* Count total tests - simplified with lists library *) fun countTotalTests(results) = - length results + List.length results (* Check if all tests passed - simplified *) fun allTestsPassed(results) = - let val total = length results + let val total = List.length results val passed = countPassedTests(results) in total > 0 andalso passed = total end diff --git a/lib/Number.trp b/lib/Number.trp index ad9b7527..2da2984d 100644 --- a/lib/Number.trp +++ b/lib/Number.trp @@ -91,27 +91,26 @@ let (** Largest (safe) possible integral value. Anything larger than this cannot *) val fromString = stringToInt - (*--- 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 +in + { + 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..ab479afe 100644 --- a/lib/String.trp +++ b/lib/String.trp @@ -68,19 +68,18 @@ let (** The maximum length of a string. (* TODO: `translateCode`/`translate'` where one maps over charCodes instead. *) - (*--- 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 +in + { + 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/lib/raft.trp b/lib/raft.trp index 4e584824..583857e6 100644 --- a/lib/raft.trp +++ b/lib/raft.trp @@ -40,7 +40,7 @@ let val DURATION = 500 else (sz, xs) fun log_add_new_entries (sz, xs) ys = - (sz + length ys, List.append ys xs) + (sz + List.length ys, List.append ys xs) (* Get all the entries after index n *) fun log_take_entries (sz, xs) n = @@ -95,7 +95,7 @@ let val DURATION = 500 end else let val log1 = log_discard log prevLogIndex val newLog = log_add_new_entries log1 entries - val newCommitIndex = new_commit_index commitIndex (prevLogIndex + length entries) leaderCommit + val newCommitIndex = new_commit_index commitIndex (prevLogIndex + List.length entries) leaderCommit val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, true)) in (newLog, newCommitIndex) end @@ -126,7 +126,7 @@ let val DURATION = 500 (* Takes the list of all machines present in the cluster represented by a list of pairs (number * process id) *) fun machine index machines apply_entry init_state print = - let val threshold = ((length machines) + 1) / 2 + let val threshold = ((List.length machines) + 1) / 2 val cluster = machines val print = fn term => fn string => print ("TERM " ^ (toString term) ^ ": " ^ string) @@ -177,10 +177,10 @@ let val DURATION = 500 decrement nextIndex and retry *) let val follower_index = index_of cluster from val _ = if result then - arraySet (matchIndex, follower_index - 1, prevLogIndex + (length entries)) + arraySet (matchIndex, follower_index - 1, prevLogIndex + (List.length entries)) else () val _ = if result then - arraySet (nextIndex, follower_index - 1, prevLogIndex + (length entries) + 1) + arraySet (nextIndex, follower_index - 1, prevLogIndex + (List.length entries) + 1) else arraySet (nextIndex, follower_index - 1, (arrayGet (nextIndex, follower_index - 1)) - 1) val commitIndex = if result then check_commitIndex cluster threshold log commitIndex matchIndex else commitIndex val (lastApplied, state) = if result andalso commitIndex > lastApplied then (lastApplied + 1, apply_entry true state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) @@ -248,7 +248,7 @@ let val DURATION = 500 (* print "wait for vote"; *) if votes > threshold then print currentTerm "*** elected as leader ***"; - leader 0 (currentTerm, self (), log, commitIndex, lastApplied, arrayCreate (`{}`, length cluster + 1, last_log_index log + 1), arrayCreate (`{}`, length cluster + 1, 0)) state + leader 0 (currentTerm, self (), log, commitIndex, lastApplied, arrayCreate (`{}`, List.length cluster + 1, last_log_index log + 1), arrayCreate (`{}`, List.length cluster + 1, 0)) state else receive [ hn (TIMEOUT, k) when k <> n => loop votes n diff --git a/lib/raft_debug.trp b/lib/raft_debug.trp index 03504ade..8c06b304 100644 --- a/lib/raft_debug.trp +++ b/lib/raft_debug.trp @@ -40,7 +40,7 @@ let val DURATION = 150 else (sz, xs) fun log_add_new_entries (sz, xs) ys = - (sz + length ys, List.append ys xs) + (sz + List.length ys, List.append ys xs) (* Get all the entries after index n *) fun log_take_entries (sz, xs) n = @@ -94,7 +94,7 @@ let val DURATION = 150 end else let val log1 = log_discard log prevLogIndex val newLog = log_add_new_entries log1 entries - val newCommitIndex = new_commit_index commitIndex (prevLogIndex + length entries) leaderCommit + val newCommitIndex = new_commit_index commitIndex (prevLogIndex + List.length entries) leaderCommit val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, true)) in (newLog, newCommitIndex) end @@ -125,7 +125,7 @@ let val DURATION = 150 (* Takes the list of all machines present in the cluster represented by a list of pairs (number * process id) *) fun machine index machines apply_entry init_state print = - let val threshold = ((length machines) + 1) / 2 + let val threshold = ((List.length machines) + 1) / 2 val cluster = machines fun leader m (currentTerm, votedFor, log, commitIndex, lastApplied, nextIndex, matchIndex) state = @@ -176,10 +176,10 @@ let val DURATION = 150 decrement nextIndex and retry *) let val follower_index = index_of cluster from val _ = if result then - arraySet (matchIndex, follower_index - 1, prevLogIndex + (length entries)) + arraySet (matchIndex, follower_index - 1, prevLogIndex + (List.length entries)) else () val _ = if result then - arraySet (nextIndex, follower_index - 1, prevLogIndex + (length entries) + 1) + arraySet (nextIndex, follower_index - 1, prevLogIndex + (List.length entries) + 1) else arraySet (nextIndex, follower_index - 1, (arrayGet (nextIndex, follower_index - 1)) - 1) val (lastApplied, state) = if result andalso commitIndex > lastApplied then (lastApplied + 1, apply_entry true state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) in loop n lastApplied state @@ -251,7 +251,7 @@ let val DURATION = 150 val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry false state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) fun loop votes n = if votes >= threshold then - leader 0 (currentTerm, self (), log, commitIndex, lastApplied, arrayCreate (`{}`, length cluster + 1, last_log_index log + 1), arrayCreate (`{}`, length cluster + 1, 0)) state + leader 0 (currentTerm, self (), log, commitIndex, lastApplied, arrayCreate (`{}`, List.length cluster + 1, last_log_index log + 1), arrayCreate (`{}`, List.length cluster + 1, 0)) state else receive [ hn (TIMEOUT, k) when k <> n => loop votes n diff --git a/local.sh b/local.sh index 838320ef..90d278cc 100755 --- a/local.sh +++ b/local.sh @@ -33,25 +33,55 @@ command -v mktemp >/dev/null 2>&1 || { echo "Error: 'mktemp' command not found" tmp=`mktemp`.js # Separate compiler and runtime arguments +input_file="" +keep_temp=false compiler_args="" runtime_args="" -keep_temp=false -for arg in "$@"; do - case "$arg" in - --no-color) - runtime_args="$runtime_args $arg" - ;; +while [[ $# -gt 0 ]]; do + case "$1" in + # Non runtime/compiler arguments --keep-temp) keep_temp=true + shift; + ;; + # Shared arguments + -i) + runtime_args="$runtime_args $1 $2" + compiler_args="$compiler_args $1 $2" + shift; + shift; + ;; + --include=*) + runtime_args="$runtime_args $1" + compiler_args="$compiler_args $1" + shift; + ;; + # Runtime arguments + --no-color) + runtime_args="$runtime_args $1" + shift; + ;; + # Compiler arguments + -o) # ignore -o <..> + shift; + shift; + ;; + --output=*) # --output=<..> + shift; + ;; + -*|--*) + compiler_args="$compiler_args $1" + shift; ;; *) - compiler_args="$compiler_args $arg" + input_file="$1" + shift; ;; esac done -"$TROUPE/bin/troupec" $compiler_args --output="$tmp" +"$TROUPE/bin/troupec" $input_file $compiler_args --output="$tmp" if [ $? -eq 0 ]; then eval "node --stack-trace-limit=1000 \"$TROUPE/rt/built/troupe.mjs\" -f=\"$tmp\" --localonly $runtime_args" diff --git a/rt/src/Asserts.mts b/rt/src/Asserts.mts index 88ed0081..cc21a4a0 100644 --- a/rt/src/Asserts.mts +++ b/rt/src/Asserts.mts @@ -16,7 +16,7 @@ import { TroupeAggregateRawValue, TroupeRawValue } from './TroupeRawValue.mjs'; // import { LVal } from './Lval'; function _thread() { - return getRuntimeObject().__sched.__currentThread + return getRuntimeObject().__sched.getCurrentThread() } function __stringRep (v) { @@ -253,13 +253,6 @@ export function assertIsAuthorityR3(x, lev, tlev) { } } -export function assertIsEnv(x: any) { - _thread().raiseBlockingThreadLev(x.tlev); - if (!(x.val._is_rt_env)) { - err("value " + __stringRep(x) + " is not an environment"); - } -} - export function assertNormalState(s: string) { if (!_thread().handlerState.isNormal()) { err("invalid handler state in " + s + " -- side effects are prohbited in handler pattern matching or sandboxed code") diff --git a/rt/src/LocalModules.mts b/rt/src/LocalModules.mts new file mode 100644 index 00000000..fb78650d --- /dev/null +++ b/rt/src/LocalModules.mts @@ -0,0 +1,206 @@ +'use strict' + +import assert from 'assert' +import path from 'path'; +import * as fs from 'node:fs' +const { stat, readFile } = fs.promises + +import { getCliArgs, TroupeCliArg, ParsedArgs } from './TroupeCliArgs.mjs'; +import { getRuntimeObject } from './SysState.mjs'; +import { Level, glb, flowsTo, BOT } from './Level.mjs'; +import { LVal } from './Lval.mjs' +import { __unit } from './UnitVal.mjs' +import { ThreadType, Scheduler } from './Scheduler.mjs' + +import { mkLogger } from './logger.mjs' + +const argv = getCliArgs(); + +const logLevel = argv[TroupeCliArg.Debug] ? 'debug': 'info'; +const logger = mkLogger('LocalModules', logLevel); + +/*************************************************************************************************\ + Types +\*************************************************************************************************/ + +/** Container for a module loaded from disk. + * + * @todo (`require`): Extend with `ir: string` and `level: Level`. + */ +export type Module = { + name: string, + hash: string, + value: LVal, +}; + +/** Unique module identifier. */ +export type ModuleID = { + name: string, + hash: string, +} + +/** Path to a potential match. + * + * @todo (`require`) Extend with `irFile: string` and `level: Level`. + */ +type LocalMatch = { + jsFile: string, + hashFile: string, +} + +/*************************************************************************************************\ + Local modules stored on disk +\*************************************************************************************************/ + +/** Map for initialized modules from the disk. */ +const localModules : { [hash: string]: Module } = {}; + +/** Whether a matching module has been loaded from disk. + * + * @param id The `name` and `hash` of the module. + * + * @todo (`require`) @param lvl The level of access. + */ +export function hasLocalModule(id: ModuleID): boolean +{ + return localModules[id.hash] !== undefined; +} + +/** Returns the matching module from disk, if it has been loaded and is accesible at that level. + * Otherwise, returns `undefined`. + * + * @param id The `name` and `hash` of the module. + * + * @todo (`require`) @param lvl The level of access. + */ +export function getLocalModule(id: ModuleID): Module | undefined +{ + return localModules[id.hash]; +} + +/** Stores the (local) module for later access. + * + * @param mod The module to be stored. + */ +function setLocalModule(mod: Module): void +{ + localModules[mod.hash] = mod; +} + +/** Obtain list of the matching file(s) on disk that match the desired module. + * + * @param id The `name` and `hash` of the module. + * + * @todo (`require`) @param lvl The level of access. + */ +async function findLocalModule({ name, hash }: ModuleID): Promise +{ + let includeDir = `${process.env.TROUPE}/lib/out/`; + if (!path.isAbsolute(includeDir)) { + includeDir = `${process.cwd()}/${includeDir}`; + } + + const jsFile = `${includeDir}${name}.js`; + const hashFile = `${includeDir}${name}.hash`; + + // Filter based on file name + if (!await stat(jsFile) || !await stat(hashFile)) { + return undefined; + } + + // Filter based on hash + if (await readFile(hashFile, 'utf8') !== hash) { + return undefined; + } + + // TODO: Filter files based on read access to each directory / file. + + return { jsFile, hashFile }; +} + +/** Evaluate module with given path. If it has any dependencies, then these are loaded first via + * mutual recursion with `loadLocalModules`. + * + * @param jsFile Path of the JavaScript file. + * + * @todo: @param lvl The initial level of execution. + */ +async function evalLocalModule(jsFile: string): Promise +{ + const rtObj = getRuntimeObject(); + + // 1. Load `jsFile` + const js = await import (jsFile); + const Top = js.default; + const top = new Top(rtObj.__userRuntime); + + // 2. Resolve dependencies first. + await loadLocalModules(top); + + // 3. Schedule new thread + const promise: Promise = new Promise((resolve, reject) => { + const scheduler = rtObj.__sched as Scheduler; + + scheduler.scheduleNewThread( + () => top.main({__dataLevel: BOT}) + , __unit + , BOT + , BOT + , ThreadType.Module + , resolve + ); + + // TODO: `guard` execution to enforce purity. + + scheduler.resumeLoopAsync(); + }); + + // 4. wait for the thread to finish + return await promise; +} + +/** Loads the module from the disk, if it exists. Returns `true` if succesful or if it has already + * been loaded previously. + * + * @param id The `name` and `hash` of the module. + * + * @todo: @param lvl The level of access. + */ +export async function loadLocalModule(id: ModuleID): Promise +{ + if (hasLocalModule(id)) { return true; } + + const fileMatch = await findLocalModule(id); + if (!fileMatch) { return false; } + + const { jsFile, hashFile } = fileMatch; + const value: any = await evalLocalModule(jsFile); + + const mod: Module = { name: id.name, hash: id.hash, value }; + setLocalModule(mod); + + return true; +} + +/** A troupe program as output by the compiler. + * + * @todo Move this type somewhere for reuse... + */ +type TroupeProgram = { + imports: {[x : string]: string}; + requires: {[x : string]: string}; + hash: string; +}; + +/** Loads all local modules dependencies of the given Troupe program. + * + * @param top jsProgram object as output by the *troupec* compiler. + */ +export async function loadLocalModules({ imports }: TroupeProgram): Promise +{ + const importsPromises = + Object.keys(imports).map(name => loadLocalModule({ name, hash: imports[name] })); + + return Promise.all(importsPromises).then((vals) => vals.reduce((x,y) => x && y, true), + (_) => false); +} diff --git a/rt/src/MailboxProcessor.mts b/rt/src/MailboxProcessor.mts index 8c7bd239..65a7f152 100644 --- a/rt/src/MailboxProcessor.mts +++ b/rt/src/MailboxProcessor.mts @@ -105,7 +105,7 @@ export class MailboxProcessor implements MailboxInterface { peek(lev: Level, index: number, lowb: Level, highb: Level) { - let theThread = this.sched.__currentThread + let theThread = this.sched.getCurrentThread() let mb = theThread.mailbox; debug (`peek index: ${index}`) debug (`peek interval: [${lowb.stringRep()}, ${highb.stringRep()}]`) @@ -138,7 +138,7 @@ export class MailboxProcessor implements MailboxInterface { } consume(lev: Level, index: number, lowb: Level, highb: Level) { - let theThread = this.sched.__currentThread + let theThread = this.sched.getCurrentThread() let mb = theThread.mailbox; debug (`consume index: ${index}`) debug (`consume interval: [${lowb.stringRep()} to ${highb.stringRep()}]`) diff --git a/rt/src/RuntimeInterface.mts b/rt/src/RuntimeInterface.mts index f212b8a2..c7b559c2 100644 --- a/rt/src/RuntimeInterface.mts +++ b/rt/src/RuntimeInterface.mts @@ -11,9 +11,10 @@ export interface RuntimeInterface { $t: Thread; $service: any; // todo 2021-06-13; identify what the right interface here should be debug(arg0: string); + __userRuntime: any __sched: SchedulerInterface __mbox : MailboxInterface - sendMessageNoChecks(toPid: any, message: import("./Lval.mjs").LVal, arg2?: boolean): any; + sendMessageNoChecks(toPid: any, message: LVal, arg2?: boolean): any; ret(arg0: any); // ret_raw () // tailcall(funclos: any, __unit: any); diff --git a/rt/src/Scheduler.mts b/rt/src/Scheduler.mts index e580e714..ad831a7f 100644 --- a/rt/src/Scheduler.mts +++ b/rt/src/Scheduler.mts @@ -1,321 +1,302 @@ 'use strict'; + import { v4 as uuidv4} from 'uuid' import { Thread } from './Thread.mjs'; import runId from './runId.mjs'; -import { __unit } from './UnitVal.mjs'; import { mkTuple } from './ValuesUtil.mjs'; import { SchedulerInterface } from './SchedulerInterface.mjs'; import { RuntimeInterface } from './RuntimeInterface.mjs'; import { LVal } from './Lval.mjs' +import { Level } from "./Level.mjs"; import {ProcessID, pid_equals} from './process.mjs' import SandboxStatus from './SandboxStatus.mjs' import {ThreadError, TroupeError} from './TroupeError.mjs' import {lub} from './Level.mjs' -import { getCliArgs, TroupeCliArg } from './TroupeCliArgs.mjs'; import {SYSTEM_PROCESS_STRING} from './Constants.mjs' -const argv = getCliArgs(); -const showStack = argv[TroupeCliArg.ShowStack] -import { mkLogger } from './logger.mjs' -const logger = mkLogger('scheduler'); -const info = x => logger.info(x) -const debug = x => logger.debug(x) +import { getCliArgs, TroupeCliArg } from './TroupeCliArgs.mjs'; +const argv = getCliArgs(); -const STACKDEPTH = 150; +/** Enum for termination statuses. */ +export enum ThreadType { + /** System service thread. */ + System = -1, + /** Main thread. */ + Main = 0, + /** Threads created as part of module initialisation. */ + Module = 1, + /** Other threads, spawned from 'Main' or 'System'. */ + Other = 2 +} -let TerminationStatus = { - OK: 0, - ERR: 1 +/** Enum for termination statuses. */ +enum TerminationStatus { + /** Thread finished its computation. */ + OK = 0, + /** Thread stopped early due to an error. */ + ERR = 1 } export class Scheduler implements SchedulerInterface { - rt_uuid: any; - __funloop: Thread[]; - __blocked: any[]; - __alive: {}; + // Current thread state + + /** Current thread alive */ __currentThread: Thread; - stackcounter: number; - __unit: any; - rtObj : RuntimeInterface - __node: any; - __stopWhenAllThreadsAreDone: boolean; - __stopRuntime: () => void; - constructor(rtObj:RuntimeInterface) { - this.rt_uuid = runId; - this.rtObj = rtObj - this.__funloop = new Array() - this.__blocked = new Array() - this.__alive = {} // new Set(); - - this.__currentThread = null; // current thread object - - this.stackcounter = 0; - - // the unit value - this.__unit = __unit - } + /** FIFO queue of all threads to evaluate */ + __funloop: Thread[]; - resetScheduler() { - // console.log (`The current length of __funloop is ${this.__funloop.length}`) - // console.log (`The number of active threads is ${Object.keys(this.__alive).length}`) - for (let x in this.__alive) { - if (this.currentThreadId.val.toString() == x) { - // console.log (x, "ACTIVE") - } else { - // console.log (x, "KILLING"); - delete this.__alive[x] - } - } - this.__blocked = [] - this.__funloop = [] - // console.log (`The number of active threads is ${Object.keys(this.__alive).length}`) - // console.log (`The number of blocked threads is ${this.__blocked.length}`) - } + /** Queue of blocked threads. */ + __blocked: { [tid in string]: Thread }; - done () { - this.notifyMonitors(); - // console.log (this.__currentThread.processDebuggingName, this.currentThreadId.val.toString(), "done") - delete this.__alive [this.currentThreadId.val.toString()]; - } + /** Map of alive threads from their stringified identifier, `tid`. */ + __alive: { [tid in string]: Thread }; + // Dependencies for unique thread identifier creation. + rt_uuid: any; + __node: any; - halt (persist=null) { - this.raiseCurrentThreadPCToBlockingLev(); - let retVal = new LVal (this.__currentThread.r0_val, - lub(this.__currentThread.bl, this.__currentThread.r0_lev), - lub(this.__currentThread.bl, this.__currentThread.r0_tlev)) + // Runtime dependencies + rtObj : RuntimeInterface + __stopWhenIdle: boolean; + __stopRuntime: () => void; - this.notifyMonitors (); + /*************************************************************************************************\ + Scheduler state + \*************************************************************************************************/ - delete this.__alive[this.currentThreadId.val.toString()]; - console.log(">>> Main thread finished with value:", retVal.stringRep()); - if (persist) { - this.rtObj.persist (retVal, persist ) - console.log ("Saved the result value in file", persist) - } - return null; - } - - notifyMonitors (status = TerminationStatus.OK, errstr = null) { - let mkVal = this.__currentThread.mkVal - let ids = Object.keys (this.__currentThread.monitors); - for ( let i = 0; i < ids.length; i ++ ) { - let id = ids[i]; - let toPid = this.__currentThread.monitors[id].pid; - let refUUID = this.__currentThread.monitors[id].uuid; - let thisPid = this.__currentThread.tid; - let statusVal = this.__currentThread.mkVal ( status ) ; - let reason = TerminationStatus.OK == status ? statusVal : - mkTuple ( [statusVal, mkVal (errstr)] ); - let message = mkVal (mkTuple ([ mkVal("DONE"), refUUID, thisPid, reason])) - this.rtObj.sendMessageNoChecks ( toPid, message , false) // false flag means no need to return in the process - } + /** */ + constructor(rtObj: RuntimeInterface) { + this.rt_uuid = runId; + this.rtObj = rtObj; + this.__funloop = []; + this.__blocked = {}; + this.__alive = {}; + this.__currentThread = null; + this.__stopWhenIdle = false; } - raiseCurrentThreadPC (l) { - this.__currentThread.raiseCurrentThreadPC(l); - } - - raiseCurrentThreadPCToBlockingLev () { - this.__currentThread.raiseCurrentThreadPCToBlockingLev() + /** Initialisation of the scheduler based on the p2p layer, e.g. the `node` identifier and + * the scheduler should proceed despite all threads being done. */ + initScheduler(node, stopRuntime) { + this.__node = node; + this.__stopRuntime = stopRuntime; } - - raiseBlockingThreadLev (l) { - this.__currentThread.raiseBlockingThreadLev(l); + /** Kill all threads except the current one, staying ready for spawning new threads. + * + * @note This does not notify the monitors. */ + resetScheduler() { + for (let x in this.__alive) { + if (this.__currentThread.tid.val.toString() !== x) { + delete this.__alive[x]; + } + } + this.__blocked = {}; + this.__funloop = []; } - - pinipush (l, cap) { - this.__currentThread.pcpinipush(l, cap) + /** Stop scheduler loop when all threads have ceased to run. */ + stopWhenIdle() { + this.__stopWhenIdle = true; } - pinipop (cap) { - return this.__currentThread.pinipop(cap); - } + /*************************************************************************************************\ + Thread creation + \*************************************************************************************************/ - mkVal(x) { - return this.__currentThread.mkVal (x); - } - - mkValPos (x,p) { - return this.__currentThread.mkValPos (x,p); + /** Add a thread `t` to the active function loop. */ + scheduleThread(t: Thread) { + this.__funloop.push(t); } - mkCopy (x) { - return this.__currentThread.mkCopy (x); - } + /** Create a new thread `t` for the given function to be evaluated and schedule it. + * + * NOTE (20-10-2025; SS): A hypothesis about the Javascript event loop: + * + * It would be a more clean design to return the thread identifier of type `LVal`, as we + * do right now, together with a `Promise` of the final returned value. But, since + * the Javascript event loop is a LIFO queue, i.e. a stack, this would bury resolving the + * termination of each thread (especially the *main* thread) beneath everything else. + */ + scheduleNewThread(f: () => any, + arg: any, + pc: Level, + block: Level, + tType: ThreadType = ThreadType.Other, + cb: (LVal) => void = (_) => {}) + { + // Create a new process ID at the given level. + const pid = tType === ThreadType.System ? SYSTEM_PROCESS_STRING : uuidv4(); + const tid = new LVal(new ProcessID(this.rt_uuid, pid, this.__node), pc); + + const halt = () => { + this.__currentThread.raiseCurrentThreadPCToBlockingLev(); + this.notifyMonitors(); + + const currT = this.__currentThread; + const retVal = new LVal (currT.r0_val, lub(currT.bl, currT.r0_lev), lub(currT.bl, currT.r0_tlev)); + + delete this.__alive[this.__currentThread.tid.val.toString()]; + + cb(retVal); + } + // New thread + const sStatus = new SandboxStatus.NORMAL(); + const t = new Thread(tid, halt, f, arg, pc, block, sStatus, this.rtObj, this); - initScheduler(node, stopWhenAllThreadsAreDone = false, stopRuntime = () => {}) { - this.__node = node; - this.__stopWhenAllThreadsAreDone = stopWhenAllThreadsAreDone; - this.__stopRuntime = stopRuntime - } - + this.__alive[tid.val.toString()] = t; + this.scheduleThread(t); - - get currentThreadId() { - return this.__currentThread.tid; + return tid as LVal; } - set handlerState (st) { - this.__currentThread.handlerState = st; - } + /*************************************************************************************************\ + Thread access + \*************************************************************************************************/ - get handlerState () { - return this.__currentThread.handlerState; + /** Whether the thread with identifier, `tid`, is alive. */ + isAlive(tid: LVal) { + return (this.__alive[tid.val.toString()] != null); } - resumeLoopAsync() { - setImmediate(() => {this.loop()}); + /** The thread object with the given identifier, `tid`. */ + getThread (tid: LVal) { + return this.__alive[tid.val.toString()]; } - - - scheduleThread(t) { - this.__funloop.push(t) + /** The currently scheduled thread */ + getCurrentThread() { + return this.__currentThread; } - - createNewProcessIDAtLevel(pcArg, isSystem = false) { - let pid = isSystem ? SYSTEM_PROCESS_STRING : uuidv4(); - let pidObj = new ProcessID(this.rt_uuid, pid, this.__node); - return new LVal(pidObj, pcArg); + /** Overwrites the current thread; the previously current thread is returned. */ + setCurrentThread(t: Thread) { + const prev = this.__currentThread + this.__currentThread = t; + return prev; } + /*************************************************************************************************\ + Thread blocking/unblocking + \*************************************************************************************************/ - - scheduleNewThreadAtLevel (thefun, arg, levpc, levblock, ismain = false, persist=null, isSystem = false) { - let newPid = this.createNewProcessIDAtLevel(levpc, isSystem); - - let halt = ismain ? ()=> { this.halt (persist) } : - () => { this.done () }; - - - let t = new Thread - ( newPid - , halt - , thefun - , arg - , levpc - , levblock - , new SandboxStatus.NORMAL() - , this.rtObj - , this ); - - - this.__alive[newPid.val.toString()] = t; - this.scheduleThread (t) - return newPid; - } - - schedule(thefun, args, nm) { - this.__currentThread.runNext (thefun, args, nm); - this.scheduleThread(this.__currentThread) + /** Block thread object `t`. */ + blockThread(t: Thread) { + this.__blocked[t.tid.val.toString()] = t; } + /** Unblock the thread with the given identifier, `pid`. */ + unblockThread(tid: LVal) { + if (!this.__blocked[tid.val.toString()]) { return; } - blockThread(t) { - this.__blocked.push(t) + this.scheduleThread(this.__blocked[tid.val.toString()]); + delete this.__blocked[tid.val.toString()]; } + /*************************************************************************************************\ + Thread Termination + \*************************************************************************************************/ - unblockThread(pid) { - for (let i = 0; i < this.__blocked.length; i++) { - if (pid_equals(this.__blocked[i].tid, pid)) { - this.scheduleThread(this.__blocked[i]); - this.__blocked.splice(i, 1); - break; - } + /** Notify monitors about thread termination. */ + notifyMonitors (status = TerminationStatus.OK, errstr = null) { + let mkVal = this.__currentThread.mkVal; + let ids = Object.keys(this.__currentThread.monitors); + for (let i = 0; i < ids.length; i++) { + let id = ids[i]; + let toPid = this.__currentThread.monitors[id].pid; + let refUUID = this.__currentThread.monitors[id].uuid; + let thisPid = this.__currentThread.tid; + let statusVal = this.__currentThread.mkVal( status ); + let reason = TerminationStatus.OK == status + ? statusVal + : mkTuple ([statusVal, mkVal (errstr)]); + let message = mkVal (mkTuple([ mkVal("DONE"), refUUID, thisPid, reason])); + // false flag means no need to return in the process + this.rtObj.sendMessageNoChecks( toPid, message, false); } } - - isAlive(tid) { - return (this.__alive[tid.val.toString()] != null); - } - - getThread (tid) { - return this.__alive[tid.val.toString()]; - } - - - stopThreadWithErrorMessage (t:Thread, s:string ) { - this.notifyMonitors(TerminationStatus.ERR, s) ; + /** Kill thread `t` with the error message `s` sent to its monitors. */ + stopThreadWithErrorMessage (t: Thread, errMsg: string) { + this.notifyMonitors(TerminationStatus.ERR, errMsg); delete this.__alive [t.tid.val.toString()]; } - /*****************************************************************************\ - - 2018-02-18: AA: a hypothesis about memory management in V8 - - It appears that V8's memory management is not very well suited for infinitely - running functions. In other words, functions are expected to eventually - terminate, and all long-running computations are expected to run through the - event loop. This is not surprising given the application where V8 is used. - This is why we periodically yield to the event loop; this hack appears to let - GC claim the objects allocated throughout the runtime of this function. Note - that without this hack, we are observing memory leaks for many "server"-like - programs; with the hack, we get a waivy memory consumption profile that reaches - around 50M on the low points of the wave. + /*************************************************************************************************\ + Scheduler loop + \*************************************************************************************************/ + + /** Start the main scheduler loop. + * + * HACK (2018-02-18: AA): a hypothesis about memory management in V8: + * + * It appears that V8's memory management is not very well suited for infinitely running + * functions. In other words, functions are expected to eventually terminate, and all + * long-running computations are expected to run through the event loop. This is not + * surprising given the application where V8 is used. This is why we periodically yield to + * the event loop; this hack appears to let GC claim the objects allocated throughout the + * runtime of this function. Note that without this hack, we are observing memory leaks for + * many "server"-like programs; with the hack, we get a waivy memory consumption profile + * that reaches around 50M on the low points of the wave. + */ + loop() { + const maxThreadsPerLoop = 500000; + const maxKontsPerThread = 1000; - \*****************************************************************************/ + let dest: () => any; + try { + for (let i = 0; i < maxThreadsPerLoop && this.__funloop.length > 0; ++i) { + // Pop front of function queue and set it to be the next thread. + this.__currentThread = this.__funloop.shift(); + if (!this.__alive[this.__currentThread.tid.val.toString()]) { continue; } + dest = this.__currentThread.next; - loop() { - const $$LOOPBOUND = 500000; - let _FUNLOOP = this.__funloop - let _curThread: Thread; - let dest; - try { - for (let $$loopiter = 0; $$loopiter < $$LOOPBOUND && _FUNLOOP.length > 0; $$loopiter ++ ) { - _curThread = _FUNLOOP.shift(); - this.__currentThread = _curThread; - dest = _curThread.next - let ttl = 1000; // magic constant; 2021-04-29 - while (dest && ttl -- ) { - // if (showStack) { // 2021-04-24; AA; TODO: profile the addition of this conditional in this tight loop - // this.__currentThread.showStack() - // } - // console.log (">>>>>>>>>>") - // console.log (dest.toString()) - // console.log ("<<<<<<<<<<") - // if (dest.debugname ) { - // console.log (" -- ", dest.debugname) - // } - dest = dest () + // Run thread for `maxKontsPerThread` continuations. + for (let j = 0; dest && j < maxKontsPerThread; ++j) { + dest = dest(); } + // If not done, push it back into the queue. if (dest) { - _curThread.handlerState.checkGuard() - - _curThread.next = dest ; - _FUNLOOP.push (_curThread); + this.__currentThread.handlerState.checkGuard(); + this.__currentThread.next = dest; + this.__funloop.push(this.__currentThread); } - } + } } catch (e) { if (e instanceof TroupeError) { e.handleError(this); } else { - console.log ("--- Schedule module caught an internal exception ---") - console.log ("--- The following output may help identify a bug in the runtime ---") - console.log ("Destination function\n" , dest) - this.__currentThread.showStack() + console.log("--- Schedule module caught an internal exception ---"); + console.log("--- The following output may help identify a bug in the runtime ---"); + console.log("Destination function\n", dest); + + if (argv[TroupeCliArg.ShowStack]) { + this.__currentThread.showStack(); + } throw e; } } - if (_FUNLOOP.length > 0) { - // we are not really done, but are just hacking around the V8's memory management + // If more work is to be done, then resume `loop` after the Javascript runtime has been able + // to run other tasks, e.g. garbage collection. + if (this.__funloop.length > 0) { this.resumeLoopAsync(); } - - if (this.__stopWhenAllThreadsAreDone && Object.keys(this.__alive).length == 0 ) { + + // If everything is done, and the node should not persist, then terminate. + if (this.__stopWhenIdle && Object.keys(this.__alive).length == 0) { this.__stopRuntime(); } } - -} \ No newline at end of file + + /** Add continuation of the main Troupe execution loop to the Javascript queue. In the meantime + * other code, e.g. the p2p and deserialization layers can run. */ + resumeLoopAsync() { + setImmediate(() => { this.loop(); }); + } +} diff --git a/rt/src/SchedulerInterface.mts b/rt/src/SchedulerInterface.mts index 742f3b81..b1f7475f 100644 --- a/rt/src/SchedulerInterface.mts +++ b/rt/src/SchedulerInterface.mts @@ -1,20 +1,22 @@ import { Thread } from "./Thread.mjs"; +import { LVal } from './Lval.mjs' +import { Level } from "./Level.mjs"; export interface SchedulerInterface { - // tailToTroupeFun(f: any, arg:any) - // tailToTroupeFun_raw(f: any) - // stepThread(); - resetScheduler(); - __alive: any; - scheduleNewThreadAtLevel(fun: any, arg: any, pc: any, blockingTopLev: any); - scheduleThread(theThread: any); - resumeLoopAsync(); - blockThread(__currentThread: Thread); - isAlive(toPid: any); - getThread(toPid: any); - unblockThread(toPid: any); - schedule(fun: any, args: any[], namespace: any); - __currentThread: Thread; - stopThreadWithErrorMessage (t:Thread, s:string) - -} \ No newline at end of file + resetScheduler(): void; + + scheduleNewThread(fun: () => any, arg: any, pc: Level, block: Level): LVal; + scheduleThread(t: Thread): void; + + blockThread(t: Thread): void; + unblockThread(tid: LVal): void; + + isAlive(tid: LVal): boolean; + getThread(tid: LVal): Thread; + getCurrentThread(): Thread; + setCurrentThread(t: Thread): Thread; + + stopThreadWithErrorMessage (t: Thread, errMsg: string): void + + resumeLoopAsync(): void; +} diff --git a/rt/src/TroupeCliArgs.mts b/rt/src/TroupeCliArgs.mts index c8eb4ca2..2dccdb76 100644 --- a/rt/src/TroupeCliArgs.mts +++ b/rt/src/TroupeCliArgs.mts @@ -19,6 +19,7 @@ export enum TroupeCliArg { RSpawn = 'rspawn', Relay = 'relay', NoColor = 'no-color', + Include = "include", } export interface ParsedArgs { @@ -39,6 +40,7 @@ export interface ParsedArgs { [TroupeCliArg.RSpawn]?: boolean; [TroupeCliArg.Relay]?: string | string[]; [TroupeCliArg.NoColor]?: boolean; + [TroupeCliArg.Include]?: string | string[]; [key: string]: any; } @@ -74,6 +76,11 @@ export function getCliArgs(): ParsedArgs { return process.argv.includes('--no-color'); } }) + .option(TroupeCliArg.Include, { + type: 'array', + default: [], + describe: 'folders to include for (local) modules resolution', + }) .parseSync(); if (rawArgs.f && !rawArgs.file) { diff --git a/rt/src/builtins/UserRuntimeZero.mts b/rt/src/builtins/UserRuntimeZero.mts index 1f34839c..51fa31aa 100644 --- a/rt/src/builtins/UserRuntimeZero.mts +++ b/rt/src/builtins/UserRuntimeZero.mts @@ -3,8 +3,8 @@ import { runtimeEquals } from '../EqualityChecker.mjs' import { isListFlagSet, isTupleFlagSet, mkTuple, mkList } from '../ValuesUtil.mjs' import { LVal, LValCopyAt, LCopyVal } from '../Lval.mjs' import { Nil, Cons, RawList } from '../RawList.mjs' -import { loadLibsAsync } from '../loadLibsAsync.mjs'; import * as levels from '../Level.mjs' +const {lub} = levels import { BaseFunctionWithExplicitArg, ServiceFunction } from '../BaseFunction.mjs' import { Atom } from '../Atom.mjs' import { __unit } from '../UnitVal.mjs' @@ -18,31 +18,12 @@ import { TroupeRawValue } from '../TroupeRawValue.mjs' import { RawTuple } from '../RawTuple.mjs' import { Level } from '../Level.mjs' import { rawAssertNotZero } from '../Asserts.mjs' +import { hasLocalModule, getLocalModule } from '../LocalModules.mjs' // import { builtin_sandbox } from './builtins/sandox' export type Constructor = new (...args: any[]) => T; - -const {lub} = levels - -class RtEnv { - _is_rt_env: boolean; - constructor() { - this._is_rt_env = true; - } -} - -class LibEnv { - ret: any; - _is_rt_env: boolean - constructor() { - this._is_rt_env = false; - this.ret = null; - } -} - - export function mkBase(f,name=null) { return BaseFunctionWithExplicitArg(f,name) } @@ -51,6 +32,10 @@ export function mkService(f, name = null) { return ServiceFunction(f, name) } +class RuntimeEnvironment { + constructor() {} +} + /** * Exposes functions available to generated code, used by the Stack2JS module. * (TODO: Categorize into assertions, special instructions and general instructions, e.g. using interfaces. @@ -75,7 +60,7 @@ export class UserRuntimeZero { sandbox: any sleep: any - Env = RtEnv + Env = RuntimeEnvironment RawClosure = RawClosure constructLVal = (x,y,z) => new LVal (x,y,z) mkVal : (x:any) => LVal = this.default_mkVal @@ -210,28 +195,29 @@ export class UserRuntimeZero { return levels.mkLevel(x); } - /** - * ComplexRT. - * Lookup a definition from a library. - * @param lib the library - * @param decl the declaration to look up - * @param obj the object to store the result in, under "libs["lib.decl"]" - * @returns the unlabelled value from the definition - */ - loadLib(lib: string, decl: string, obj: { libs: { [x: string]: any } }): any { - // load the lib from the linked data structure - let r = obj.libs[lib + "." + decl]; - // rt_debug("loading lib " + decl); - return r; + getLocalModule(name: string, obj: { imports: { [x : string]: string } }): any + { + const hash = obj.imports[name]; + if (hasLocalModule({name, hash})) { + // HACK: The final `.val` unwraps the `LVal` to the raw value. This is + // to get around the fact that the compiler (for now) does not + // treat modules as labelled values. + return getLocalModule({ name, hash: obj.imports[name] }).value.val; + } + throw "Resolving 'import' statements for non-lib not supported (yet)"; } + getModule(name: string, obj: { require: { [x : string]: string } }): LVal + { + throw "Resolving 'require' statements are not supported (yet)"; + } /* * ============================================================== * The remaining functions are not referred to by generated code. * ============================================================== */ - + branch = function (x) { this.runtime.$t.setBranchFlag() this.runtime.$t.raiseCurrentThreadPC(x.lev); @@ -257,25 +243,6 @@ export class UserRuntimeZero { return this.runtime.$t.mkCopy(x) } - - libLoadingPseudoThread = new Thread(null, null, null, __unit, levels.BOT, levels.BOT, null, this, null); - savedThread = null ;// this.runtime.__sched.__currentThread; - setLibloadMode() { - this.mkVal = (x) => new LVal(x, levels.BOT); - this.mkValPos = (x, pos) => new LVal(x, levels.BOT, levels.BOT, pos); - this.Env = LibEnv; - this.savedThread = this.runtime.__sched.__currentThread; - this.runtime.__sched.__currentThread = this.libLoadingPseudoThread; - } - - - setNormalMode() { - this.mkVal = this.default_mkVal; - this.mkValPos = this.default_mkValPos - this.Env = RtEnv; - this.runtime.__sched.__currentThread = this.savedThread; - } - // tailcall(lff, arg) { // this.runtime.tailcall (lff, arg) // } @@ -284,11 +251,6 @@ export class UserRuntimeZero { // this.runtime.__sched.tailToTroupeFun_raw (x); // } - - async linkLibs (f) { - await loadLibsAsync(f, this) - } - errorPos (x: { val: string }, pos: string) { if (pos != '') { this.runtime.$t.threadError(x.val + " at " + pos); diff --git a/rt/src/builtins/monitor.mts b/rt/src/builtins/monitor.mts index 2daf5d4a..9a0ff26d 100644 --- a/rt/src/builtins/monitor.mts +++ b/rt/src/builtins/monitor.mts @@ -14,12 +14,12 @@ export function BuiltinMonitors > (Ba // 1. find the thread corresponding to that tid - let t = this.runtime.__sched.__alive[tid.toString()]; + let t = this.runtime.__sched.getThread(tid); // 2. update the monitor state of that thread let r = this.runtime.rt_mkuuid(); if (t) { - t.addMonitor(this.runtime.__sched.__currentThread.tid, r); + t.addMonitor(this.runtime.__sched.getCurrentThread().tid, r); } return this.runtime.ret(r); diff --git a/rt/src/builtins/persist.mts b/rt/src/builtins/persist.mts index d36676a1..15fbc044 100644 --- a/rt/src/builtins/persist.mts +++ b/rt/src/builtins/persist.mts @@ -27,15 +27,19 @@ export function BuiltinPersist>(Base: let file = arg; (async () => { - let jsonStr = await fs.promises.readFile("./out/saved." + file.val + ".persist.json", 'utf8'); - let data = await deserialize(levels.TOP, JSON.parse(jsonStr)); - theThread.returnSuspended(data); - this.runtime.__sched.scheduleThread(theThread); - this.runtime.__sched.resumeLoopAsync(); - + try { + let jsonStr = await fs.promises.readFile(`./out/saved.${file.val}.persist.json`, 'utf8'); + let data = await deserialize(levels.TOP, JSON.parse(jsonStr)); + theThread.returnSuspended(data); + this.runtime.__sched.scheduleThread(theThread); + this.runtime.__sched.resumeLoopAsync(); + } catch (e) { + this.runtime.debug(`restore error: ${e.toString()}`); + throw e; + } })() }, "restore") } -} \ No newline at end of file +} diff --git a/rt/src/builtins/receive.mts b/rt/src/builtins/receive.mts index 0bbbc459..39796d89 100644 --- a/rt/src/builtins/receive.mts +++ b/rt/src/builtins/receive.mts @@ -133,7 +133,7 @@ export function BuiltinReceive>(Base: _blockThread = mkBase ((arg) => { assertIsUnit(arg) - this.runtime.__sched.blockThread(this.runtime.__sched.__currentThread); + this.runtime.__sched.blockThread(this.runtime.__sched.getCurrentThread()); return null; }) diff --git a/rt/src/builtins/self.mts b/rt/src/builtins/self.mts index 6b098337..5ff6d8b9 100644 --- a/rt/src/builtins/self.mts +++ b/rt/src/builtins/self.mts @@ -8,7 +8,7 @@ import { UserRuntimeZero, Constructor, mkBase } from './UserRuntimeZero.mjs' export function BuiltinSelf>(Base: TBase) { return class extends Base { self = mkBase((arg) => { - return this.runtime.ret(this.runtime.__sched.__currentThread.tid); + return this.runtime.ret(this.runtime.__sched.getCurrentThread().tid); }, "self"); } } \ No newline at end of file diff --git a/rt/src/builtins/spawn.mts b/rt/src/builtins/spawn.mts index 930b5244..b5750015 100644 --- a/rt/src/builtins/spawn.mts +++ b/rt/src/builtins/spawn.mts @@ -21,22 +21,13 @@ export function BuiltinSpawn>(Base: T // console.log ("SPAWN ARGS", larg) this.runtime.$t.raiseCurrentThreadPC(larg.lev); let arg = larg.val; - let __sched = this.runtime.__sched - - let spawnLocal = (arg) => { - // debug ("scheduled rt_spawn ", arg.fun); - - let newPid = __sched.scheduleNewThreadAtLevel( - arg, - __unit, // [arg.env, __unit], - // arg.namespace, - this.runtime.$t.pc, - this.runtime.$t.bl) - return this.runtime.$t.returnImmediateLValue(newPid) ; + const spawnLocal = (func) => { + const tid = this.runtime.__sched.scheduleNewThread( + func, __unit, this.runtime.$t.pc, this.runtime.$t.bl); + return this.runtime.$t.returnImmediateLValue(tid); } - if (Array.isArray(arg)) { if (__nodeManager.isLocalNode(arg[0].val)) { // check if we are at the same node or note // debug ("SAME NODE") @@ -55,4 +46,4 @@ export function BuiltinSpawn>(Base: T } }, "spawn"); } -} \ No newline at end of file +} diff --git a/rt/src/builtins/whereis.mts b/rt/src/builtins/whereis.mts index 12e33980..b2ccc259 100644 --- a/rt/src/builtins/whereis.mts +++ b/rt/src/builtins/whereis.mts @@ -96,6 +96,7 @@ export function BuiltinRegistry>(Base __sched.resumeLoopAsync(); } catch (err) { + // TODO: should we not only crash the thread, not the entire runtime? $r.debug("whereis error: " + err.toString()) throw err; } @@ -105,4 +106,4 @@ export function BuiltinRegistry>(Base }, "whereis") } -} \ No newline at end of file +} diff --git a/rt/src/deserialize.mts b/rt/src/deserialize.mts index 2c194875..4b897f62 100644 --- a/rt/src/deserialize.mts +++ b/rt/src/deserialize.mts @@ -1,6 +1,6 @@ "use strict"; import { strict as assert } from 'node:assert' -import {spawn} from 'child_process' +import { spawn, ChildProcess } from 'child_process' import * as Ty from './TroupeTypes.mjs' import { LVal } from './Lval.mjs'; import { mkTuple, mkList } from './ValuesUtil.mjs'; @@ -10,192 +10,242 @@ import { Atom } from './Atom.mjs'; import { __unitbase }from './UnitBase.mjs' import { glb, mkLevel } from './Level.mjs'; import { RuntimeInterface } from './RuntimeInterface.mjs'; -import { Level } from './Level.mjs'; import { Record } from './Record.mjs'; import { RawClosure } from './RawClosure.mjs'; -import * as levels from './Level.mjs'; - -let __compilerOsProcess = null; +import { Level, lub, BOT } from './Level.mjs'; +import { loadLocalModules } from './LocalModules.mjs'; + +// OBS: The variables below with `__` prefixes are all global! This is because the callback and +// deserializedJson changes all the time while the compiler process has been started. + +// ------------------------------------------------------------------------------------------------- +// Troupe Compiler +// +// We run the compiler in *interactive* mode. Since there is only one compiler process which is +// accessed via the lock below, we can guarantee a FIFO ordering on the compilation input/output +// pairs. + +/** Magic marker to identify when the compiler is done a single deserialization and compilation. */ +const MARKER = "/*-----*/"; + +// TODO: Add types for `jsonObj` and `compilerOutput` variables. + +type CompilerJob = { + /** The to be deserialized object. */ + jsonObj: any; + /** Trust level of the sender. The result should implicitly be declassified based on the (lack + * of) trust. */ + trustLevel: Level; + /** Callback to hand the final value back to be used at runtime. */ + callback: (LVal) => void; +}; + +type CompilerOutput = string | undefined; + +/** Forwards the compiler output (if any) for value reconstruction. */ +function onJobDone({ jsonObj, trustLevel, callback }: CompilerJob, + compilerOutput: CompilerOutput) + : void +{ + setImmediate( + () => reconstruct(jsonObj, compilerOutput, trustLevel).then(v => callback(v)) + ); +} -let __rtObj = null; +/** We spawn an instance of the Troupe compiler in its interactive IR mode. Through this, we + * pass the IR provided by other nodes. + */ +let __compilerOsProcess : ChildProcess | null = null; -// obs: these are global... -let __isCurrentlyUsingCompiler = false; // simple flag to make sure we handle one deserialization at a time -let __currentCallback = null; // a callback for synchronizing with the caller -let __currentDeserializedJson = null; -let __trustLevel = null; +/** Queue of to be done jobs that have been sent to the compiler. */ +let __compilerQueue : CompilerJob[] = []; +/** Push a deserialization job to the compiler. */ +function pushCompilerQueue(cj : CompilerJob): void +{ + // Skip the compiler, if it is a simple value and not a function. + if (cj.jsonObj.namespaces.length === 0) { + return onJobDone(cj, undefined); + } -export function setRuntimeObj(rt: RuntimeInterface) { - __rtObj = rt; -} + // Push each namespace object to the compiler + __compilerQueue.push(cj); -const HEADER:string = - "this.libSet = new Set () \n\ - this.libs = [] \n\ - this.addLib = function (lib, decl)\ - { if (!this.libSet.has (lib +'.'+decl)) { \ - this.libSet.add (lib +'.'+decl);\ - this.libs.push ({lib:lib, decl:decl})} }\n" + for (let i = 0; i < cj.jsonObj.namespaces.length; ++i) { + let ns = cj.jsonObj.namespaces[i]; + for (let j = 0; j < ns.length; ++j) { + __compilerOsProcess.stdin.write(ns[j][1]); + __compilerOsProcess.stdin.write("\n"); + } + } + __compilerOsProcess.stdin.write("!ECHO " + MARKER + "\n"); +}; -function startCompiler() { - __compilerOsProcess = spawn(process.env.TROUPE + '/bin/troupec', ['--json']); +function startCompiler(): void +{ + __compilerOsProcess = spawn(process.env.TROUPE + '/bin/troupec', ['--json-ir']); __compilerOsProcess.on('exit', (code: number) => { process.exit(code); }); - let marker = "/*-----*/\n\n" - - // accumulator of communication with the compiler; reset after - // each deserialization; needed because we have no guarantees about - // how the data coming back from the compiler is chunked - + let marker = MARKER + "\n\n"; + + // accumulator of communication with the compiler; reset after each + // deserialization; needed because we have no guarantees about how the data + // coming back from the compiler is chunked + // + // TODO: Only check the new data for the marker to not recheck the same + // substring again and again? But, what about the marker being split + // between two instances of `data`? + // + // TODO: Switch to an array of strings which are `join`ed at the end. This + // is ~4-10x faster. let accum = ""; __compilerOsProcess.stdout.on('data', (data: string) => { accum += data; - let j = accum.indexOf(marker); - if (j >= 0) { - constructCurrent(accum.slice(0, j)); - accum = accum.slice(j + marker.length); + let markerIdx = accum.indexOf(marker); + if (markerIdx >= 0) { + const cj : CompilerJob = __compilerQueue.shift(); + onJobDone(cj, accum.slice(0, markerIdx)); + accum = accum.slice(markerIdx + marker.length); } }); } - startCompiler(); export function stopCompiler() { __compilerOsProcess.stdin.end(); } +// ------------------------------------------------------------------------------------------------- +// Runtime Object -// -------------------------------------------------- - -// some rudimentary debugging mechanisms; probably should be rewritten -function debuglog(...s) { - let spaces = ""; - for (let j = 0; j < indentcounter; j++) { - spaces = " " + spaces; - } - - s.unshift("DEBUG:" + spaces) - console.log.apply(null, s) -} - -var indentcounter = 0; - -function indent() { - indentcounter++; -} +/** The runtime object to which we should be deserializing. + * + * @todo Fix this tight coupling. + */ +let __rtObj = null; -function unindent() { - indentcounter--; +export function setRuntimeObj(rt: RuntimeInterface) { + __rtObj = rt; } +// ------------------------------------------------------------------------------------------------- +// Error object - -function deserializationError() { - console.log("DESERIALIZATION ERROR HANDLING IS NOT IMPLEMENTED") - process.exit(1); +export class DeserializationError extends Error { + constructor(msg: string) { + super(msg); + this.name = "DeserializationError"; + } } -function constructCurrent(compilerOutput: string) { - // debuglog (deserializationObject) - - __isCurrentlyUsingCompiler = false; - let serobj = __currentDeserializedJson; - let desercb = __currentCallback; +// ------------------------------------------------------------------------------------------------- +// Value Reconstruction +async function reconstruct(jsonObj: any, compilerOutput: string | undefined, trustLevel: Level) + : Promise +{ // 1. reconstruct the namespaces - let snippets = compilerOutput.split("\n\n"); - let k = 0; - - - let ctxt = { // deserialization context - namespaces : new Array (serobj.namespaces.length), - closures : new Array (serobj.closures.length), - envs : new Array (serobj.envs.length) + let ctxt = { // deserialization context + namespaces : new Array (jsonObj.namespaces.length), + closures : new Array (jsonObj.closures.length), + envs : new Array (jsonObj.envs.length), } - for (let i = 0; i < serobj.namespaces.length; i++) { - let ns = serobj.namespaces[i] - let nsFun = HEADER + const snippets = compilerOutput ? compilerOutput.split("\n\n") : []; + let k = 0; + for (let i = 0; i < jsonObj.namespaces.length; i++) { + let ns = jsonObj.namespaces[i] + let nsFun = ""; let atomSet = new Set() - - // nsFun += "this.libSet = new Set () \n" - // nsFun += "this.libs = [] \n" - // nsFun += "this.addLib = function (lib, decl) " + - // " { if (!this.libSet.has (lib +'.'+decl)) { " + - // " this.libSet.add (lib +'.'+decl); " + - // " this.libs.push ({lib:lib, decl:decl})} } \n" - // nsFun += "this.loadlibs = function (cb) { rt.linkLibs (this.libs, this, cb) } \n" - + const imports = {}; + const requires = {}; for (let j = 0; j < ns.length; j++) { if (j > 0) { nsFun += "\n\n" // looks neater this way } let snippetJson = JSON.parse(snippets[k++]); - // console.log (snippetJson.libs); - // console.log (snippetJson.fname); nsFun += snippetJson.code; for (let atom of snippetJson.atoms) { - atomSet.add(atom) + atomSet.add(atom); + } + + for (let [name,hash] of snippetJson.imports) { + imports[name] = hash; + } + + for (let [name,hash] of snippetJson.requires) { + requires[name] = hash; } - // console.log (snippetJson.atoms) } - let argNames = Array.from(atomSet); - let argValues = argNames.map( argName => {return new Atom(argName)}) - argNames.unshift('rt') - argNames.push(nsFun) - // Observe that there is some serious level of - // reflection going on in here - // Arguments to Function are - // 'rt', ATOM1, ..., ATOMk, nsFun - // - // - let NS: any = Reflect.construct (Function, argNames) + + let argNames = Array.from(atomSet); + let argValues = argNames.map(argName => {return new Atom(argName)}) + argNames.unshift('rt'); + argNames.push(nsFun); + // Observe that there is some serious level of reflection going on in here. + // The arguments to `Function` are: 'rt', ATOM1, ..., ATOMk, nsFun + const NS: any = Reflect.construct (Function, argNames); // We now construct an instance of the newly constructed object // that takes the runtime object + atoms as its arguments + argValues.unshift(__rtObj); + ctxt.namespaces[i] = Reflect.construct (NS, argValues); + + // Add the merged imports and requires + ctxt.namespaces[i].imports = imports; + ctxt.namespaces[i].requires = requires; - // console.log (NS.toString()); // debugging - argValues.unshift(__rtObj) - ctxt.namespaces[i] = Reflect.construct (NS, argValues) - } - // 2. reconstruct the closures and environments - let sercloss = serobj.closures; + // 2. Load module dependencies + for (let i = 0; i < jsonObj.namespaces.length; i++) { + // Load standard library (`import` statements) + const loadedAllImports = await loadLocalModules(ctxt.namespaces[i]); + if (!loadedAllImports) { + throw new DeserializationError("Imported module missing"); + } - let serenvs = serobj.envs; + // Fail if there are any user modules (`require` statements) + const loadedAllRequires = Object.keys(ctxt.namespaces[i].requires).length === 0; + if (!loadedAllRequires) { + throw new DeserializationError("Required modules are not resolvable"); + } + } + + // 3. reconstruct the closures and environments + const sercloss = jsonObj.closures; + const serenvs = jsonObj.envs; function mkClosure(i: number) { - if (!ctxt.closures[i]) { - let nm = ctxt.namespaces[sercloss[i].namespacePtr.NamespaceID] - let fn = nm[sercloss[i].fun]; - let env = mkEnv(sercloss[i].envptr.EnvID, (env) => { + if (!ctxt.closures[i]) { + const nm = ctxt.namespaces[sercloss[i].namespacePtr.NamespaceID] + const fn = nm[sercloss[i].fun]; + const env = mkEnv(sercloss[i].envptr.EnvID, (env) => { ctxt.closures[i] = RawClosure(env, nm, fn); - }) - ctxt.closures[i].__dataLevel = env.__dataLevel; + }) + ctxt.closures[i].__dataLevel = env.__dataLevel; } return ctxt.closures[i]; } function mkEnv(i: number, post_init?: (any)=>void ) { - if (!ctxt.envs[i]) { - let env = {__dataLevel : levels.BOT}; + if (!ctxt.envs[i]) { + let env = { __dataLevel : BOT }; if (post_init) { - post_init (env) + post_init (env); } ctxt.envs[i] = env; for (var field in serenvs[i]) { - let v = mkValue(serenvs[i][field]); - env[field] = v - env.__dataLevel = levels.lub (env.__dataLevel, v.dataLevel) - } + const v = mkValue(serenvs[i][field]); + env[field] = v; + env.__dataLevel = lub (env.__dataLevel, v.dataLevel) + } } else { if (post_init) { post_init (ctxt.envs[i]); @@ -204,74 +254,58 @@ function constructCurrent(compilerOutput: string) { return ctxt.envs[i] } - function deserializeArray(x) { let a = []; for (let i = 0; i < x.length; i++) { a.push(mkValue(x[i])); } - return a + return a; } - /* - # # - # # # # # # ## # # # ###### - ## ## # # # # # # # # # # - # ## # #### # # # # # # # ##### - # # # # # # ###### # # # # - # # # # # # # # # # # # - # # # # # # # ###### #### ###### - - */ - function mkValue(arg: { val: any; lev: any; tlev: any; troupeType: Ty.TroupeType; }) { - // debuglog ("*** mkValue", arg); assert(Ty.isLVal(arg)); - let obj = arg.val; - let lev = mkLevel(arg.lev); - let tlev = mkLevel(arg.tlev); + const obj = arg.val; + const lev = mkLevel(arg.lev); + const tlev = mkLevel(arg.tlev); function _trustGLB(x: Level) { - return (glb(x, __trustLevel)) + return glb(x, trustLevel); } - let _tt = arg.troupeType - - - function value() { - switch (_tt) { + function value() { + switch (arg.troupeType) { case Ty.TroupeType.RECORD: - // for reords, the serialization format is [[key, value_json], ...] + // for records, the serialization format is [[key, value_json], ...] let a = []; for (let i = 0; i < obj.length; i++) { - a.push ([ obj[i][0], mkValue(obj[i][1]) ]) + a.push ([ obj[i][0], mkValue(obj[i][1]) ]); } return Record.mkRecord(a); case Ty.TroupeType.LIST: - return mkList(deserializeArray(obj)) + return mkList(deserializeArray(obj)); case Ty.TroupeType.TUPLE: - return mkTuple(deserializeArray(obj)) + return mkTuple(deserializeArray(obj)); case Ty.TroupeType.CLOSURE: - return mkClosure(obj.ClosureID) - case Ty.TroupeType.NUMBER: - case Ty.TroupeType.BOOLEAN: + return mkClosure(obj.ClosureID); + case Ty.TroupeType.NUMBER: + case Ty.TroupeType.BOOLEAN: case Ty.TroupeType.STRING: return obj; case Ty.TroupeType.PROCESS_ID: return new ProcessID(obj.uuid, obj.pid, obj.node) case Ty.TroupeType.AUTHORITY: - // 2018-10-18: AA: authority attenuation based on the trust level of the sender - return new Authority(_trustGLB(mkLevel(obj.authorityLevel))) + // Attenuate authority based on the trust level of the sender + return new Authority(_trustGLB(mkLevel(obj.authorityLevel))); case Ty.TroupeType.LEVEL: - return mkLevel(obj.lev) + return mkLevel(obj.lev); case Ty.TroupeType.LVAL: - return mkValue(obj) + return mkValue(obj); case Ty.TroupeType.ATOM: - return new Atom(obj.atom, obj.creation_uuid) + return new Atom(obj.atom, obj.creation_uuid); case Ty.TroupeType.UNIT: - return __unitbase + return __unitbase; default: - return obj; + return obj; } } @@ -286,62 +320,20 @@ function constructCurrent(compilerOutput: string) { mkEnv(i); } - let v = mkValue(serobj.value); - - // go over the namespaces we have generated - // and load all libraries before calling the last callback - - function loadLib(i: number, cb) { - if (i < ctxt.namespaces.length) { - __rtObj.linkLibs(ctxt.namespaces[i]).then(() => loadLib(i + 1, cb)) - } else { - cb(); - } - } - - loadLib(0, () => desercb(v)); + return mkValue(jsonObj.value); } -// 2018-11-30: AA: TODO: implement a proper deserialization queue instead of -// the coarse-grained piggybacking on the event loop - -function deserializeCb(lev: Level, jsonObj: any, cb: (body: LVal) => void) { - if (__isCurrentlyUsingCompiler) { - setImmediate(deserializeCb, lev, jsonObj, cb) // postpone; 2018-03-04;aa - } else { - __isCurrentlyUsingCompiler = true // prevent parallel deserialization attempts; important! -- leads to nasty - // race conditions otherwise; 2018-11-30; AA - __trustLevel = lev; - __currentCallback = cb; // obs: this is a global for this module; - // the access to it should be carefully controlled - - // we need to share this object with the callbacks - - __currentDeserializedJson = jsonObj; // obs: another global that we must be careful with - - if (jsonObj.namespaces.length > 0) { - for (let i = 0; i < jsonObj.namespaces.length; i++) { - let ns = jsonObj.namespaces[i]; - for (let j = 0; j < ns.length; j++) { - // debuglog("*s deserialize", ns[j]); - __compilerOsProcess.stdin.write(ns[j][1]); - __compilerOsProcess.stdin.write("\n") - // debuglog ("data out") - } - } - __compilerOsProcess.stdin.write("!ECHO /*-----*/\n") - } else { - // shortcutting the unnecessary interaction with the compiler - // 2018-09-20: AA - constructCurrent(""); - } - } -} +// ------------------------------------------------------------------------------------------------- -export function deserialize(lev: Level, jsonObj: any): Promise { +/** Deserialize the given `jsonObj` into a Troupe value. + * + * @param jsonObj Object to be deserialized. + * @param trustTevel Trust level to the origin of `jsonObj`. + * + * @todo Swap the order of the arguments? + */ +export async function deserialize(trustLevel: Level, jsonObj: any): Promise { return new Promise((resolve, reject) => { - deserializeCb(lev, jsonObj, (body: LVal) => { - resolve(body) - }) + pushCompilerQueue({ jsonObj, trustLevel, callback: (v: LVal) => resolve(v) }); }); } diff --git a/rt/src/loadLibs.mts b/rt/src/loadLibs.mts deleted file mode 100644 index 9ba07192..00000000 --- a/rt/src/loadLibs.mts +++ /dev/null @@ -1,101 +0,0 @@ -/* 2020-05-19: AA This code is deprecated */ - -'use strict' - -import * as fs from 'node:fs' - -import { mkLogger } from './logger.mjs' -const logger = mkLogger('lib') - -const info = x => logger.info(x) -const debug = x => logger.debug(x) - -const __libcache = {} - -export function loadLibsAsync(obj, rtObj, cb) { - let libs = obj.libs - obj.libs = {} - function iterateAsync(n) { - if (n < libs.length) { - let lib = libs[n].lib; - let decl = libs[n].decl; - - const key = lib +"." + decl - if (__libcache[key]) { - debug ('lib cache hit on: ' + key) - obj.libs[key]=__libcache[key]; - setImmediate(iterateAsync, n + 1); - return; - } - - // 1. Find the file -- note that we load all the libs from a default - // location - - let filename = process.env.TROUPE + "/lib/out/" + lib + ".js" - - - - // 2. Load the file -- note that this is an asynchronous operation - fs.readFile(filename, 'utf8', (err, input) => { - - // File read operation finished; we are now in the callbacak that has - // been asynchronously called by the node runtime - - // TODO: check for error! 2018-07-03: aa - - // 3. Create a JS class (function) from it - let Lib:any = new Function('rt', input); - - // 4. We create a "new" instance of the resulting class - - let libinstance = new Lib(rtObj); - - - // load dependent libraries?? - - // libinstance.loadlibs (() => - loadLibsAsync(libinstance, rtObj, () => { - // 5. Execute .export() function to obtain the table note - this is a - // regular JS function (generated by the compiler) that we just call - // here - - rtObj.setLibloadMode(); // 2019-01-03: AA; Hack - let table = libinstance.export().val.toArray(); - rtObj.setNormalMode(); // 2019-01-03: AA; EOH - - // 6. Lookup in the resulting table - - for (let i = 0; i < table.length; i++) { - let name = table[i].val[0].val; - let libf = table[i].val[1].val - if (name == decl) { - // We store the resulting function in the object that was provided - // to us as an argument - obj.libs[key] = libf; - __libcache [key] = libf; - break; - } - } - - // Next iteration - iterateAsync (n + 1); - }) - }) - - } else { - // We are done processing the lib files. Transferring control back to the - // callback. The callback is either - // - // a. The next thing in the initialization, if this is the first time we - // are loading libraries -- typically scheduler init, etc (see `start` - // function in the runtime), OR - // - // b. The next iteration in deserialization, which is more library loading - // when we have several namespaces, or whatever is the deserialization - // callback (see `mkValue` function in the serialize module). - - cb(); - } - } - iterateAsync (0); -} diff --git a/rt/src/loadLibsAsync.mts b/rt/src/loadLibsAsync.mts index 12adc2ca..54616a4b 100644 --- a/rt/src/loadLibsAsync.mts +++ b/rt/src/loadLibsAsync.mts @@ -1,72 +1,71 @@ 'use strict' import * as fs from 'node:fs' import * as levels from './Level.mjs'; -const { readFile } = fs.promises +const { readFile } = fs.promises; -import { mkLogger } from './logger.mjs' -const logger = mkLogger('lib') +import { mkLogger } from './logger.mjs'; +const logger = mkLogger('lib'); -const info = x => logger.info(x) -const debug = x => logger.debug(x) +const info = x => logger.info(x); +const debug = x => logger.debug(x); -const __libcache = {} +const __libcache = {}; export async function loadLibsAsync(obj, rtObj) { - let libs = obj.libs - obj.libs = {} + let libs = obj.libs; + obj.libs = {}; for (let n = 0; n < libs.length; n++) { let lib = libs[n].lib; let decl = libs[n].decl; - const key = lib + "." + decl + const key = lib + "." + decl; if (__libcache[key]) { - debug('lib cache hit on: ' + key) + debug('lib cache hit on: ' + key); obj.libs[key] = __libcache[key]; - continue + continue; } - // 1. Find the file -- note that we load all the libs from a default - // location + // 1. Find the file. Note, that we load all the libs from a default + // location. + let filename = process.env.TROUPE + "/lib/out/" + lib + ".js"; - let filename = process.env.TROUPE + "/lib/out/" + lib + ".js" - - // 2. Load the file -- note that this is an asynchronous operation - let input = await readFile(filename, 'utf8') + // 2. Load the file. Note, this is an asynchronous operation + let input = await readFile(filename, 'utf8'); // File read operation finished; we are now in the callbacak that has - // been asynchronously called by the node runtime + // been asynchronously called by the node runtime. - // TODO: check for error! 2018-07-03: aa + // TODO: check for error! 2018-07-03: AA // 3. Create a JS class (function) from it let Lib: any = new Function('rt', input); // 4. We create a "new" instance of the resulting class - let libinstance = new Lib(rtObj); + // load dependent libraries + await loadLibsAsync(libinstance, rtObj); - // load dependent libraries?? - - // libinstance.loadlibs (() => - await loadLibsAsync(libinstance, rtObj) - - // 5. Execute .export() function to obtain the table note - this is a + // 5. Execute `.export()` function to obtain the table note - this is a // regular JS function (generated by the compiler) that we just call - // here - - rtObj.setLibloadMode(); // 2019-01-03: AA; Hack + // here. + // + // 2019-01-03: AA; HACK + // We assume that the library merely exports values that require no + // computations. Hence, there are no continuations to be resolved and + // we can immediately extract the list of functions/values returned + // from the given function. + rtObj.setLibloadMode(); let table = libinstance.export({__dataLevel:levels.BOT}).val.toArray(); - rtObj.setNormalMode(); // 2019-01-03: AA; EOH - - // 6. Lookup in the resulting table + rtObj.setNormalMode(); + // 6. Lookup the desired value in the resulting table for (let i = 0; i < table.length; i++) { let name = table[i].val[0].val; - let libf = table[i].val[1].val + let libf = table[i].val[1].val; if (name == decl) { // We store the resulting function in the object that was provided - // to us as an argument + // to us as an argument. obj.libs[key] = libf; __libcache[key] = libf; break; diff --git a/rt/src/runId.mts b/rt/src/runId.mts index 0dbb125f..40c1f5f6 100644 --- a/rt/src/runId.mts +++ b/rt/src/runId.mts @@ -1,3 +1,3 @@ -import { v4 as uuidv4} from 'uuid' -let runId = uuidv4() +import { v4 as uuidv4 } from 'uuid' +const runId = uuidv4() export default runId diff --git a/rt/src/runtimeMonitored.mts b/rt/src/runtimeMonitored.mts index 1c54578c..d5ffceb3 100644 --- a/rt/src/runtimeMonitored.mts +++ b/rt/src/runtimeMonitored.mts @@ -4,13 +4,14 @@ import { v4 as uuidv4 } from 'uuid' import AggregateError from 'aggregate-error'; import { __unit } from './UnitVal.mjs' import { Authority } from './Authority.mjs' -import { Scheduler } from './Scheduler.mjs' +import { Scheduler, ThreadType } from './Scheduler.mjs' import { MailboxProcessor } from './MailboxProcessor.mjs' import { RuntimeInterface } from './RuntimeInterface.mjs' import { LVal, MbVal } from './Lval.mjs' import { ProcessID } from './process.mjs'; import { UserRuntime } from './UserRuntime.mjs' import * as levels from './Level.mjs' +const { flowsTo, lub, glb } = levels import * as DS from './deserialize.mjs' import { p2p } from './p2p/p2p.mjs' import { closeReadline } from './builtins/stdio.mjs'; @@ -22,49 +23,41 @@ import { setRuntimeObject } from './SysState.mjs'; import { initTrustMap, nodeTrustLevel, _trustMap } from './TrustManager.mjs'; import { serialize } from './serialize.mjs'; import { Thread } from './Thread.mjs'; - import { Console } from 'node:console' - -const { flowsTo, lub, glb } = levels import { getCliArgs, TroupeCliArg } from './TroupeCliArgs.mjs'; import { configureColors, isColorEnabled } from './colorConfig.mjs'; import { mkLogger } from './logger.mjs' import { Record } from './Record.mjs'; import { level } from 'winston'; +import { Module, loadLocalModules } from './LocalModules.mjs'; const readFile = fs.promises.readFile -const rt_uuid = runId const argv = getCliArgs(); // Configure colors before any chalk or logger usage configureColors(); -let logLevel = argv[TroupeCliArg.Debug] ? 'debug': 'info' +const logLevel = argv[TroupeCliArg.Debug] ? 'debug': 'info' const logger = mkLogger('RTM', logLevel); -const info = x => logger.info(x) -const debug = x => logger.debug(x) -const error = x => logger.error(x) - let __p2pRunning = false; - -let rt_xconsole = +const rt_xconsole = new Console({ stdout: process.stdout , stderr: process.stderr , colorMode: isColorEnabled() }); -function $t():Thread { return __sched.__currentThread }; // returns the current thread +/** Returns the current thread */ +function $t():Thread { return __sched.getCurrentThread() }; // -------------------------------------------------- async function spawnAtNode(nodeid, f) { - debug (`* rt spawnAtNode ${nodeid}`); + logger.debug(`* rt spawnAtNode ${nodeid}`); let node = __nodeManager.getNode(nodeid.val); - // debug ("XX", node); - // TODO: 2018-09-24: AA: do the information flow check + // TODO (2018-09-24: AA): do the information flow check let { data, level } = serialize(f, lub($t().pc, nodeid.lev)); @@ -74,27 +67,24 @@ async function spawnAtNode(nodeid, f) { if (!flowsTo(level, trustLevel)) { theThread.throwInSuspended("Illegal trust flow when spawning on a remote node\n" + ` | the trust level of the recepient node: ${trustLevel.stringRep()}\n` + - ` | the level of the information in spawn: ${level.stringRep()}`) + ` | the level of the information in spawn: ${level.stringRep()}`); __sched.scheduleThread(theThread); - __sched.resumeLoopAsync(); + __sched.resumeLoopAsync(); return; } // 0. we assume that the node is different from // the local node - // 1. we make a connection to the remote node // 2. we send the serialized version of f // 3. we wait for the reply (should be a pid) // 4. we return the obtained pid //-------------------------------------------------- - - try { let body1 = await p2p.spawnp2p(node.nodeId, data); - let body = await DS.deserialize(nodeTrustLevel(node.nodeId), body1) + let body = await DS.deserialize(nodeTrustLevel(node.nodeId), body1); let pid = new ProcessID(body.val.uuid, body.val.pid, body.val.node); theThread.returnSuspended(new LVal(pid, body.lev)); @@ -102,13 +92,13 @@ async function spawnAtNode(nodeid, f) { __sched.resumeLoopAsync(); } catch (err) { - error("error spawning remotely; this blocks current thread") + logger.error("error spawning remotely; this blocks current thread") if (err instanceof AggregateError) { for (let ie in err) { - error(`${ie}`) + logger.error(`${ie}`); } } else { - error(`${err}`) + logger.error(`${err}`); } } } @@ -136,29 +126,29 @@ function remoteSpawnOK() { * The identity of the node that initiates the spawning. */ async function spawnFromRemote(jsonObj, fromNode) { - debug ("spawn from remote") + logger.debug("* rt spawnFromRemote *"); // 2018-05-17: AA; note that this _only_ uses the lf.lev and // is completely independent of the current thread's pc; + const fromTrustLevel = nodeTrustLevel(fromNode); - let nodeLev = nodeTrustLevel(fromNode); - - let lf = await DS.deserialize(nodeLev, jsonObj) - let f = lf.val; - let newPid = - __sched.scheduleNewThreadAtLevel( - f - , __unit //[f.env, __unit] - // , f.namespace - , lf.lev - , lf.lev - ); + let f: LVal | undefined = undefined; + try { + f = await DS.deserialize(fromTrustLevel, jsonObj); + } catch (e) { + logger.debug(e); + return; + } + + // TODO: + // if (x._troupeType != TroupeType.CLOSURE) { ... } - // 2018-09-19: AA: because we need to send some info back, we have to invoke - // serialization. + // Schedule new thread with `f`. + const tid = __sched.scheduleNewThread(f.val, __unit, f.lev, f.lev); - let serObj = serialize(newPid, levels.BOT).data + // Serialize to send some info back, we have to invoke serialization. + const serObj = serialize(tid, levels.BOT).data; __sched.resumeLoopAsync(); - return (serObj); + return serObj; } @@ -173,18 +163,23 @@ async function spawnFromRemote(jsonObj, fromNode) { * The node identity of the sender node */ async function receiveFromRemote(pid, jsonObj, fromNode) { - debug(`* rt receiveFromremote * ${JSON.stringify(jsonObj)}`) - let data = await DS.deserialize(nodeTrustLevel(fromNode), jsonObj) - debug(`* rt receiveFromremote * ${fromNode} ${data.stringRep()}`); + // Deserialize the data to runtime values; we ignore messages that fail deserialization. + let data: LVal | undefined = undefined; - // TODO: 2018-07-23: do we need to do some more raising - // about the level of the fromNode?; AA + try { + data = await DS.deserialize(nodeTrustLevel(fromNode), jsonObj); + } catch (e) { + logger.debug(e); + return; + } - let fromNodeId = __sched.mkVal(fromNode); - let toPid = new LVal(new ProcessID(rt_uuid, pid, __nodeManager.getLocalNode()), data.lev); + // Add the deserialized message to the mailbox of said process. + // + // TODO (AA; 2018-07-23): do we need to do some more reasoning about the level of the fromNode? + const fromNodeId = $t().mkVal(fromNode); + const toPid = new LVal(new ProcessID(runId, pid, __nodeManager.getLocalNode()), data.lev); __theMailbox.addMessage(fromNodeId, toPid, data.val, data.lev); __sched.resumeLoopAsync(); - } @@ -198,33 +193,39 @@ async function receiveFromRemote(pid, jsonObj, fromNode) { * */ function sendMessageToRemote(toPid, message) { - let node = toPid.node.nodeId; - let pid = toPid.pid; - // debug (`* rt * ${toPid} ${message.stringRep()}`); + const node = toPid.node.nodeId; + const pid = toPid.pid; - let { data, level } = serialize(new MbVal(message, $t().pc), $t().pc); + const { data, level } = serialize(new MbVal(message, $t().pc), $t().pc); - // debug (`* rt * ${JSON.stringify(data)}`); - let trustLevel = nodeTrustLevel(node); - - // debug ("data level: " + level.stringRep()); - // debug ("remote trust level: " + trustLevel.stringRep()); + const trustLevel = nodeTrustLevel(node); if (!flowsTo(level, trustLevel)) { - threadError("Illegal trust flow when sending information to a remote node\n" + - ` | the trust level of the recepient node: ${trustLevel.stringRep()}\n` + - ` | the level of the information to send: ${level.stringRep()}`); + $t().threadError("Illegal trust flow when sending information to a remote node\n" + + ` | the trust level of the recepient node: ${trustLevel.stringRep()}\n` + + ` | the level of the information to send: ${level.stringRep()}`, + false); } else { + // we return unit to the call site at the thread level p2p.sendp2p(node, pid, data) - return $t().returnImmediateLValue(__unit); // we return unit to the call site at the thread level + return $t().returnImmediateLValue(__unit); + } +} + + +async function whereisFromRemote(k) { + __sched.resumeLoopAsync() + // TODO (AA; 2018-10-20): Make use of the levels as they were + // recorded during the registration (instead of the bottom here) + if (__theRegister[k]) { + return serialize(__theRegister[k], levels.BOT).data; } } -// TODO: AA; 2020-05-19; consider moving these two functions somewhere else +// TODO (AA; 2020-05-19): consider moving these two functions somewhere else function isLocalPid(pid) { - let x = pid.uuid.toString() == rt_uuid.toString(); - return (x); + return pid.uuid.toString() == runId.toString();; } function rt_mkuuid() { @@ -235,25 +236,22 @@ function rt_mkuuid() { function rt_sendMessageNochecks(lRecipientPid, message, ret = true) { let recipientPid = lRecipientPid.val; - // debug (`rt_sendMessageNoChecks ${message.stringRep()}`) if (isLocalPid(recipientPid)) { - let nodeId = __sched.mkVal(__nodeManager.getNodeId()); + let nodeId = $t().mkVal(__nodeManager.getNodeId()); __theMailbox.addMessage(nodeId, lRecipientPid, message, $t().pc); if (ret) { - return $t().returnImmediateLValue(__unit); + return $t().returnImmediateLValue(__unit); } } else { - debug ("* rt rt_send remote *"/*, recipientPid, message*/); + logger.debug ("* rt rt_send remote *"/*, recipientPid, message*/); return sendMessageToRemote(recipientPid, message) } } - - -let rt_debug = function (s) { +function rt_debug (s) { function formatToN(s, n) { if (s.length < n) { let j = s.length; @@ -264,196 +262,113 @@ let rt_debug = function (s) { return s; } - let tid = $t().tidErrorStringRep() - let pc = $t().pc.stringRep() - let bl = $t().bl.stringRep() - let handler_state = __sched.handlerState.toString() + const tid = $t().tidErrorStringRep(); + const pc = $t().pc.stringRep(); + const bl = $t().bl.stringRep(); + const handler_state = $t().handlerState.toString(); rt_xconsole.log( chalk.red(formatToN("PID:" + tid, 50)), chalk.red(formatToN("PC:" + pc, 20)), chalk.red(formatToN("BL:" + bl, 20)), chalk.red(formatToN("HN" + handler_state, 20)), chalk.red(formatToN("_sp:" + $t()._sp, 20)), - s + s ); } - - -async function whereisFromRemote(k) { - __sched.resumeLoopAsync() - // TODO: 2018-10-20: make use of the levels as they were - // recorded during the registration (instead of the bottom here ) - if (__theRegister[k]) { - let serObj = serialize(__theRegister[k], levels.BOT).data - return serObj - } -} - - - function rt_mkLabel(x) { - // debug ("mkLabel", x, x === "secret"); - - return new LVal(levels.fromSingleTag(x), $t().pc); - -} - - - - -function threadError(s, internal = false) { - return $t().threadError(s, internal); -} - -let rt_threadError = threadError; - -function rt_error(x) { - threadError(x.val); } -function rt_errorPos(x, pos) { - if (pos != '') { - threadError(x.val + " at " + pos); - } else { - threadError(x.val); - } +function rt_ret (arg) { + return $t().returnImmediateLValue(arg); } - -let rt_ret = (arg) => { return $t().returnImmediateLValue(arg); } -// let rt_ret_raw = () => __sched.returnInThread_raw(); - -// function tailcall(lff, arg) { -// assertIsFunction(lff); -// $t().raiseCurrentThreadPC(lff.lev); -// __sched.tailToTroupeFun(lff.val, arg); -// } - +// TODO: Clean up the mess below... let __sched: Scheduler let __theMailbox: MailboxProcessor let __userRuntime: any let __service:any = {} class RuntimeObject implements RuntimeInterface { - // tailcall = tailcall - xconsole = rt_xconsole - ret = rt_ret - // ret_raw = rt_ret_raw - debug = rt_debug - spawnAtNode = spawnAtNode - rt_mkuuid = rt_mkuuid - mkLabel = rt_mkLabel + xconsole = rt_xconsole; + ret = rt_ret; + debug = rt_debug; + spawnAtNode = spawnAtNode; + rt_mkuuid = rt_mkuuid; + mkLabel = rt_mkLabel; sendMessageNoChecks = rt_sendMessageNochecks; - cleanup = cleanupAsync + cleanup = cleanupAsync; persist(obj, path) { let jsonObj = serialize(obj, $t().pc).data; fs.writeFileSync(path, JSON.stringify(jsonObj)); } get $service () { - return __service + return __service; } - + get $t() { - return $t() + return $t(); } get __sched() { - return __sched + return __sched; } get __mbox() { - return __theMailbox + return __theMailbox; } get __userRuntime() { - return __userRuntime + return __userRuntime; } constructor() { - __sched = new Scheduler(this) - __theMailbox = new MailboxProcessor(this) - __userRuntime = new UserRuntime(this) + __sched = new Scheduler(this); + __theMailbox = new MailboxProcessor(this); + __userRuntime = new UserRuntime(this); } - } - let __rtObj = new RuntimeObject(); DS.setRuntimeObj(__rtObj.__userRuntime); setRuntimeObject(__rtObj) - - async function cleanupAsync() { closeReadline() DS.stopCompiler(); if (__p2pRunning) { try { - debug("stopping p2p") + logger.debug("stopping p2p") await p2p.stopp2p() - debug("p2p stop OK") + logger.debug("p2p stop OK") } catch (err) { - debug(`p2p stop failed ${err}`) + logger.debug(`p2p stop failed ${err}`) } } } - // 2020-02-09; AA; ugly ugly hack function bulletProofSigint() { - let listeners = process.listeners("SIGINT"); - // console.log (util.inspect(listeners)) - // for (let i = 0; i < listeners.length; i ++ ) { - // console.log (listeners[i].toString()); - // } - - // process.stdin.removeAllListeners("on"); process.removeAllListeners("SIGINT"); - // console.log ("sigint bulletproofing") process.on('SIGINT', () => { - debug("SIGINT"); + logger.debug("SIGINT"); (async () => { await cleanupAsync() process.exit(0); })() }) - // setTimeout (bulletProofSigint, 1000) } bulletProofSigint(); - -async function loadServiceCode() { - let input = await fs.promises.readFile(process.env.TROUPE + '/trp-rt/out/service.js', 'utf8') - let S: any = new Function('rt', input) - let service = new S(__userRuntime); - - await __userRuntime.linkLibs(service) - - __userRuntime.setLibloadMode() - let table = service.export({__dataLevel:levels.BOT}).val.toArray() - __userRuntime.setNormalMode() - - for (let i = 0; i < table.length; i++) { - let name = table[i].val[0].val - let ff = table[i].val[1].val - __service[name] = ff - } -} - - - async function getNetworkPeerId(rtHandlers) { const nodeIdFile = argv[TroupeCliArg.Id] as string; if (nodeIdFile) { try { let nodeIdObj = await readFile(nodeIdFile, 'utf-8') process.on('unhandledRejection', (e) => p2p.processExpectedNetworkErrors(e, "unhandledRejection")) - // process.on ('unhandledRejection', up => {console.log ("Unhandled rejection"); console.error (up)}) - // process.on ('uncaughtException', up => {console.log ("Uncaught exception"); console.error (up)}) process.on('uncaughtException', (e) => p2p.processExpectedNetworkErrors(e, "uncaughtException")) return await p2p.startp2p(JSON.parse(nodeIdObj), rtHandlers); } catch (err) { @@ -463,73 +378,134 @@ async function getNetworkPeerId(rtHandlers) { } else { try { if (argv[TroupeCliArg.LocalOnly] || argv[TroupeCliArg.Persist]) { - info("Skipping network creation. Observe that all external IO operations will yield a runtime error.") + logger.info("Skipping network creation. Observe that all external IO operations will yield a runtime error."); if (argv[TroupeCliArg.Persist]) { - info("Running with persist flag.") + logger.info("Running with persist flag."); } - return null// OBS: 2018-07-22: we are jumping over the network creation + // OBS: 2018-07-22: we are jumping over the network creation + return null; } else { return await p2p.startp2p(null, rtHandlers); } } catch (err) { - logger.error("uncaught exception in the runtime") - console.error(err.stack);; + logger.error("uncaught exception in the runtime"); + console.error(err.stack); process.exit(1); } } } +// TODO: Move all service initialisation and `__service` ownership into its own separate file. +async function loadServiceCode() { + const serviceFile = `${process.env.TROUPE}/trp-rt/out/service.js`; + let d = await import (serviceFile); + let Top: any = d.default; + let top = new Top(__userRuntime); + + await loadLocalModules(top); + + // Initialise Service as a separate program (compiled as any other Troupe program) + const res = await new Promise((resolve, reject) => { + __sched.scheduleNewThread( + () => top.main({__dataLevel: levels.BOT}) + , __unit + , levels.BOT + , levels.BOT + , ThreadType.Module + , resolve + ); + + __sched.resumeLoopAsync(); + }); + const table = (res as any).val.toArray(); + + // Populate `__service` with each name-function pair from the service thread. + for (let i = 0; i < table.length; i++) { + let name = table[i].val[0].val + let ff = table[i].val[1].val + __service[name] = ff + } +} + export async function start(f) { - await initTrustMap() + // Set up p2p network + await initTrustMap(); let peerid = await getNetworkPeerId({ remoteSpawnOK, spawnFromRemote, receiveFromRemote, whereisFromRemote - }) + }); if (peerid) { - __p2pRunning = true - debug("network ready") + __p2pRunning = true; + logger.debug("network ready"); } else { - debug("network not initialized") + logger.debug("network not initialized"); } __nodeManager.setLocalPeerId(peerid); - let stopWhenAllThreadsAreDone = !__p2pRunning - __sched.initScheduler(__nodeManager.getLocalNode() - , stopWhenAllThreadsAreDone - , cleanupAsync); + // --------------------------------------------------------------------------- + // Initialise 'scheduler' for Troupe code execution + __sched.initScheduler(__nodeManager.getLocalNode(), cleanupAsync); - await loadServiceCode() - await __userRuntime.linkLibs(f) - let mainAuthority = new LVal(new Authority(levels.ROOT), levels.BOT); + // --------------------------------------------------------------------------- + // Set up 'service' thread + + // HACK: Despite the fact that service code is only spawned, if `__p2pRunning`, + // we need to populate the runtime.$service object. + // + // TODO: Instead, treat these fields or the object itself as nullable in + // `builtins/receive.mts` and elsewhere. Best is to also put this into + // the typesystem. + await loadServiceCode(); if (__p2pRunning) { - let service_arg = - new LVal ( new Record([ ["authority", mainAuthority], - ["options", __unit]]), - levels.BOT); - __sched.scheduleNewThreadAtLevel(__service['service'] + const serviceAuthority = new LVal(new Authority(levels.ROOT), levels.BOT); + + let service_arg = + new LVal ( new Record([ ["authority", serviceAuthority], + ["options", __unit] + ]), + levels.BOT); + + __sched.scheduleNewThread(__service['service'] , service_arg , levels.TOP , levels.BOT - , false - , null - , true); + , ThreadType.System); } - __sched.scheduleNewThreadAtLevel( - () => f.main ({__dataLevel:levels.BOT}) + // --------------------------------------------------------------------------- + // Set up 'main' thread + await loadLocalModules(f); + + // Schedule thread + const mainAuthority = new LVal(new Authority(levels.ROOT), levels.BOT); + + const onTerminate = (retVal: LVal) => { + console.log(`>>> Main thread finished with value: ${retVal.stringRep()}`); + if (argv[TroupeCliArg.Persist]) { + this.rtObj.persist(retVal, argv[TroupeCliArg.Persist]); + console.log("Saved the result value in file", argv[TroupeCliArg.Persist]); + } + }; + + __sched.scheduleNewThread( + () => f.main({__dataLevel:levels.BOT}) , mainAuthority - // , f , levels.BOT , levels.BOT - , true - , argv[TroupeCliArg.Persist] - ) - __sched.loop() -} + , ThreadType.Main + , onTerminate + ); + // --------------------------------------------------------------------------- + // Start code execution + if (!__p2pRunning) { + __sched.stopWhenIdle(); + } + __sched.resumeLoopAsync(); +} diff --git a/rt/src/serialize.mts b/rt/src/serialize.mts index 75c9ee77..d6f5f920 100644 --- a/rt/src/serialize.mts +++ b/rt/src/serialize.mts @@ -114,7 +114,7 @@ export function serialize(w:LVal, pclev:Level) { envs.push(jsonEnv); for (let field in x.env) { - if (field != "ret" && field != "_is_rt_env" && field != "__dataLevel") { + if (field != "ret" && field != "__dataLevel") { let y = x.env[field]; jsonEnv[field] = walk(y); } diff --git a/rt/src/troupe.mts b/rt/src/troupe.mts index 981ac8c6..82079eee 100644 --- a/rt/src/troupe.mts +++ b/rt/src/troupe.mts @@ -19,9 +19,8 @@ if (!fs.existsSync(p)) { } (async () => { let d = await import (p); - let Top = d.default - let __userRuntime = (getRuntimeObject() as any).__userRuntime; - let top = new Top(__userRuntime); + let Top = d.default; + let top = new Top(getRuntimeObject().__userRuntime); start(top); }) () diff --git a/tests/rt/pos/core/fun-save-restore01.golden b/tests/rt/pos/core/fun-save-restore01.golden new file mode 100644 index 00000000..5dceb565 --- /dev/null +++ b/tests/rt/pos/core/fun-save-restore01.golden @@ -0,0 +1,2 @@ +2025-11-14T15:00:39.572Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: [2@{}%{}, 4@{}%{}, 3@{}%{}]@{}%{} diff --git a/tests/rt/pos/core/fun-save-restore01.trp b/tests/rt/pos/core/fun-save-restore01.trp new file mode 100644 index 00000000..344d9b93 --- /dev/null +++ b/tests/rt/pos/core/fun-save-restore01.trp @@ -0,0 +1,9 @@ +import List + +let val xs = [1, 3, 2] + + fun f ys = List.map (fn x => x+1) ys + val _ = save (authority, "testFunc", f) + val f1 = restore ("testFunc") +in f1 xs +end diff --git a/tests/rt/pos/core/fun-save-restore02.golden b/tests/rt/pos/core/fun-save-restore02.golden new file mode 100644 index 00000000..9af23b7d --- /dev/null +++ b/tests/rt/pos/core/fun-save-restore02.golden @@ -0,0 +1,2 @@ +2025-11-17T13:08:07.733Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: [2@{}%{}, 4@{}%{}, 3@{}%{}]@{}%{} diff --git a/tests/rt/pos/core/fun-save-restore02.trp b/tests/rt/pos/core/fun-save-restore02.trp new file mode 100644 index 00000000..eb6250fc --- /dev/null +++ b/tests/rt/pos/core/fun-save-restore02.trp @@ -0,0 +1,4 @@ +let val xs = [1, 3, 2] + val f = restore ("testFunc") +in f xs +end 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..6ec420d8 --- /dev/null +++ b/trp-rt/Makefile @@ -0,0 +1,9 @@ +COMPILER=../bin/troupec + +build: + mkdir -p out + # Standard Library + $(COMPILER) -m ./service.trp + +clean: + rm -rf out