From b981405e45b70c0291e4b5bbfa2dd2ac35f53e39 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Fri, 22 Mar 2024 22:03:38 +0000 Subject: [PATCH] Support compilation of Anoma transactions in nockma backend (#2693) When we first implemented the Nockma backend we wrongly assumed that the only entry point for Juvix compiled Nockma modules would be the main function. Using this assumption we could add a setup step in the main function that put the Anoma stdlib and compiled functions from the Juvix module in a static place in the Nockma subject. References to the Anoma stdlib and functions in the module could then be resolved statically. However, one of the use cases for Juvix -> Nockma compilation is for Anoma to run logic functions that are fields of a transaction. So the user writes a Juvix program with main function that returns a transaction. The result of the main function is passed to Anoma. When Anoma calls the logic function on a field of the transaction, the setup part of the main function is not run so the subject is not in the required state. In fact, the logic function is not even callable by Anoma because non-main functions in the Juvix module use a calling convention that assumes the subject has a particular shape. This PR solves the problem by making all functions in the Juvix module use the Anoma calling convention. We make all compiled closures (including, for example, the logic functions stored on resources in a transaction) self contained, i.e they contain the functions library and anoma standard library. Modules that contain many closures produce large nockma output files which slows down the evaluator. This will need to be fixed in the future either with Nockma compression ([jam serialization](https://developers.urbit.org/reference/hoon/stdlib/2p)) or otherwise. But it does not block the compilation and execution of Anoma transactions. Other fixes / additions: * Extra tracing. You can now annotate output cells with a tag that will be displayed in the output * Unittests for listToTuple, appendRights helper functions * Fixes for the nockma parser when parsing 'pretty nockma', specifically stdlib calls, tags and functions_library atom. * Adds `juvix dev nock run` command that can run a program output with the `anoma` target. * Remove the `nockma` target. As described above we always use the Anoma calling convention so there's no need for a separate target for the 'juvix calling convention' * Adds a `--profile` flag to `juvix dev nock run` which outputs a count of Nockma ops used in the evaluation * In tests we no longer serialise the compiled program to force full evaluation of the compiled code. We added a negative test to check that strings are not allowed in Nockma/Anoma programs, it is output in a file `OUTPUT.profile` and has the following form: ``` quote : 15077 apply : 0 isCell : 0 suc : 0 = : 4517 if : 5086 seq : 5086 push : 0 call : 4896 replace : 1 hint : 8 scry : 0 trace : 0 ``` --------- Co-authored-by: Jan Mas Rovira --- app/Commands/Compile.hs | 1 - app/Commands/Dev/Asm/Compile.hs | 1 - app/Commands/Dev/Core/Compile.hs | 1 - app/Commands/Dev/Core/Compile/Base.hs | 21 +- app/Commands/Dev/Nockma.hs | 2 + app/Commands/Dev/Nockma/Eval.hs | 9 +- app/Commands/Dev/Nockma/Eval/Options.hs | 10 +- app/Commands/Dev/Nockma/Options.hs | 14 +- app/Commands/Dev/Nockma/Run.hs | 37 ++ app/Commands/Dev/Nockma/Run/Options.hs | 32 ++ app/Commands/Dev/Reg/Compile.hs | 1 - app/Commands/Dev/Tree/Compile.hs | 1 - app/Commands/Dev/Tree/Compile/Base.hs | 25 +- app/Commands/Dev/Tree/Compile/Options.hs | 4 +- app/Commands/Extra/Compile.hs | 4 - app/Commands/Extra/Compile/Options.hs | 2 - src/Juvix/Compiler/Backend.hs | 3 - src/Juvix/Compiler/Nockma/Anoma.hs | 24 + src/Juvix/Compiler/Nockma/EvalCompiled.hs | 4 +- src/Juvix/Compiler/Nockma/Evaluator.hs | 85 +++- src/Juvix/Compiler/Nockma/Evaluator/Crumbs.hs | 4 +- src/Juvix/Compiler/Nockma/Evaluator/Error.hs | 23 + src/Juvix/Compiler/Nockma/Language.hs | 57 ++- src/Juvix/Compiler/Nockma/Pretty.hs | 5 +- src/Juvix/Compiler/Nockma/Pretty/Base.hs | 41 +- src/Juvix/Compiler/Nockma/Pretty/Options.hs | 20 +- .../Nockma/Translation/FromSource/Base.hs | 39 +- .../Compiler/Nockma/Translation/FromTree.hs | 448 +++++++++++------- src/Juvix/Compiler/Pipeline.hs | 26 +- src/Juvix/Extra/Strings.hs | 6 + test/Anoma/Compilation.hs | 3 +- test/Anoma/Compilation/Negative.hs | 47 ++ test/Anoma/Compilation/Positive.hs | 12 +- test/Nockma/Base.hs | 11 - test/Nockma/Compile/Tree/Positive.hs | 13 +- test/Nockma/Eval/Positive.hs | 65 ++- tests/Anoma/Compilation/negative/String.juvix | 5 + 37 files changed, 752 insertions(+), 354 deletions(-) create mode 100644 app/Commands/Dev/Nockma/Run.hs create mode 100644 app/Commands/Dev/Nockma/Run/Options.hs create mode 100644 src/Juvix/Compiler/Nockma/Anoma.hs create mode 100644 test/Anoma/Compilation/Negative.hs delete mode 100644 test/Nockma/Base.hs create mode 100644 tests/Anoma/Compilation/negative/String.juvix diff --git a/app/Commands/Compile.hs b/app/Commands/Compile.hs index cf0dfee626..4fec7a28f3 100644 --- a/app/Commands/Compile.hs +++ b/app/Commands/Compile.hs @@ -27,7 +27,6 @@ runCommand opts@CompileOptions {..} = do TargetTree -> Compile.runTreePipeline arg TargetAsm -> Compile.runAsmPipeline arg TargetReg -> Compile.runRegPipeline arg - TargetNockma -> Compile.runNockmaPipeline arg TargetAnoma -> Compile.runAnomaPipeline arg TargetCasm -> Compile.runCasmPipeline arg diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs index c49073c7bc..77c3dcafa6 100644 --- a/app/Commands/Dev/Asm/Compile.hs +++ b/app/Commands/Dev/Asm/Compile.hs @@ -70,7 +70,6 @@ runCommand opts = do TargetNative64 -> return Backend.TargetCNative64 TargetReg -> return Backend.TargetReg TargetCasm -> return Backend.TargetCairo - TargetNockma -> err "Nockma" TargetAnoma -> err "Anoma" TargetTree -> err "JuvixTree" TargetGeb -> err "GEB" diff --git a/app/Commands/Dev/Core/Compile.hs b/app/Commands/Dev/Core/Compile.hs index 9455c0c897..cb02b06af1 100644 --- a/app/Commands/Dev/Core/Compile.hs +++ b/app/Commands/Dev/Core/Compile.hs @@ -21,7 +21,6 @@ runCommand opts = do TargetAsm -> runAsmPipeline arg TargetReg -> runRegPipeline arg TargetTree -> runTreePipeline arg - TargetNockma -> runNockmaPipeline arg TargetAnoma -> runAnomaPipeline arg TargetCasm -> runCasmPipeline arg where diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs index d25399f103..dfda9b3e50 100644 --- a/app/Commands/Dev/Core/Compile/Base.hs +++ b/app/Commands/Dev/Core/Compile/Base.hs @@ -2,6 +2,7 @@ module Commands.Dev.Core.Compile.Base where import Commands.Base import Commands.Dev.Core.Compile.Options +import Commands.Dev.Tree.Compile.Base (outputAnomaResult) import Commands.Extra.Compile qualified as Compile import Juvix.Compiler.Asm.Pretty qualified as Asm import Juvix.Compiler.Backend qualified as Backend @@ -12,7 +13,6 @@ import Juvix.Compiler.Casm.Data.Result qualified as Casm import Juvix.Compiler.Casm.Pretty qualified as Casm import Juvix.Compiler.Core.Data.Module qualified as Core import Juvix.Compiler.Core.Data.TransformationId qualified as Core -import Juvix.Compiler.Nockma.Pretty qualified as Nockma import Juvix.Compiler.Reg.Pretty qualified as Reg import Juvix.Compiler.Tree.Pretty qualified as Tree import Juvix.Prelude.Pretty @@ -46,7 +46,6 @@ getEntry PipelineArg {..} = do TargetAsm -> Backend.TargetAsm TargetReg -> Backend.TargetReg TargetTree -> Backend.TargetTree - TargetNockma -> Backend.TargetNockma TargetAnoma -> Backend.TargetAnoma TargetCasm -> Backend.TargetCairo @@ -147,19 +146,6 @@ runTreePipeline pa@PipelineArg {..} = do let code = Tree.ppPrint tab' tab' writeFileEnsureLn treeFile code -runNockmaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runNockmaPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile - r <- - runReader entryPoint - . runError @JuvixError - . coreToNockma - $ _pipelineArgModule - tab' <- getRight r - let code = Nockma.ppSerialize tab' - writeFileEnsureLn nockmaFile code - runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runAnomaPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa @@ -169,9 +155,8 @@ runAnomaPipeline pa@PipelineArg {..} = do . runError @JuvixError . coreToAnoma $ _pipelineArgModule - tab' <- getRight r - let code = Nockma.ppSerialize tab' - writeFileEnsureLn nockmaFile code + res <- getRight r + outputAnomaResult nockmaFile res runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runCasmPipeline pa@PipelineArg {..} = do diff --git a/app/Commands/Dev/Nockma.hs b/app/Commands/Dev/Nockma.hs index fba8fbb8e8..67e8dbe974 100644 --- a/app/Commands/Dev/Nockma.hs +++ b/app/Commands/Dev/Nockma.hs @@ -5,9 +5,11 @@ import Commands.Dev.Nockma.Eval as Eval import Commands.Dev.Nockma.Format as Format import Commands.Dev.Nockma.Options import Commands.Dev.Nockma.Repl as Repl +import Commands.Dev.Nockma.Run as Run runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaCommand -> Sem r () runCommand = \case NockmaRepl opts -> Repl.runCommand opts NockmaEval opts -> Eval.runCommand opts NockmaFormat opts -> Format.runCommand opts + NockmaRun opts -> Run.runCommand opts diff --git a/app/Commands/Dev/Nockma/Eval.hs b/app/Commands/Dev/Nockma/Eval.hs index 65979e6b17..e196fa373f 100644 --- a/app/Commands/Dev/Nockma/Eval.hs +++ b/app/Commands/Dev/Nockma/Eval.hs @@ -3,7 +3,7 @@ module Commands.Dev.Nockma.Eval where import Commands.Base hiding (Atom) import Commands.Dev.Nockma.Eval.Options import Juvix.Compiler.Nockma.EvalCompiled -import Juvix.Compiler.Nockma.Evaluator.Options +import Juvix.Compiler.Nockma.Evaluator import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma @@ -14,11 +14,14 @@ runCommand opts = do case parsedTerm of Left err -> exitJuvixError (JuvixError err) Right (TermCell c) -> do - res <- - runReader defaultEvalOptions + (counts, res) <- + runOpCounts + . runReader defaultEvalOptions . runOutputSem @(Term Natural) (say . ppTrace) $ evalCompiledNock' (c ^. cellLeft) (c ^. cellRight) putStrLn (ppPrint res) + let statsFile = replaceExtension' ".profile" afile + writeFileEnsureLn statsFile (prettyText counts) Right TermAtom {} -> exitFailMsg "Expected nockma input to be a cell" where file :: AppPath File diff --git a/app/Commands/Dev/Nockma/Eval/Options.hs b/app/Commands/Dev/Nockma/Eval/Options.hs index 942ab51981..0c6353704a 100644 --- a/app/Commands/Dev/Nockma/Eval/Options.hs +++ b/app/Commands/Dev/Nockma/Eval/Options.hs @@ -2,8 +2,9 @@ module Commands.Dev.Nockma.Eval.Options where import CommonOptions -newtype NockmaEvalOptions = NockmaEvalOptions - { _nockmaEvalFile :: AppPath File +data NockmaEvalOptions = NockmaEvalOptions + { _nockmaEvalFile :: AppPath File, + _nockmaEvalProfile :: Bool } deriving stock (Data) @@ -12,4 +13,9 @@ makeLenses ''NockmaEvalOptions parseNockmaEvalOptions :: Parser NockmaEvalOptions parseNockmaEvalOptions = do _nockmaEvalFile <- parseInputFile FileExtNockma + _nockmaEvalProfile <- + switch + ( long "profile" + <> help "Report evaluator profiling statistics" + ) pure NockmaEvalOptions {..} diff --git a/app/Commands/Dev/Nockma/Options.hs b/app/Commands/Dev/Nockma/Options.hs index 2f8bfd81c2..4b4f87431d 100644 --- a/app/Commands/Dev/Nockma/Options.hs +++ b/app/Commands/Dev/Nockma/Options.hs @@ -3,12 +3,14 @@ module Commands.Dev.Nockma.Options where import Commands.Dev.Nockma.Eval.Options import Commands.Dev.Nockma.Format.Options import Commands.Dev.Nockma.Repl.Options +import Commands.Dev.Nockma.Run.Options import CommonOptions data NockmaCommand = NockmaRepl NockmaReplOptions | NockmaEval NockmaEvalOptions | NockmaFormat NockmaFormatOptions + | NockmaRun NockmaRunOptions deriving stock (Data) parseNockmaCommand :: Parser NockmaCommand @@ -17,9 +19,19 @@ parseNockmaCommand = mconcat [ commandRepl, commandFromAsm, - commandFormat + commandFormat, + commandRun ] where + commandRun :: Mod CommandFields NockmaCommand + commandRun = command "run" runInfo + where + runInfo :: ParserInfo NockmaCommand + runInfo = + info + (NockmaRun <$> parseNockmaRunOptions) + (progDesc "Run an Anoma program. It should be used with artefacts obtained from compilation with the anoma target.") + commandFromAsm :: Mod CommandFields NockmaCommand commandFromAsm = command "eval" fromAsmInfo where diff --git a/app/Commands/Dev/Nockma/Run.hs b/app/Commands/Dev/Nockma/Run.hs new file mode 100644 index 0000000000..7fa7299c98 --- /dev/null +++ b/app/Commands/Dev/Nockma/Run.hs @@ -0,0 +1,37 @@ +module Commands.Dev.Nockma.Run where + +import Commands.Base hiding (Atom) +import Commands.Dev.Nockma.Run.Options +import Juvix.Compiler.Nockma.Anoma +import Juvix.Compiler.Nockma.EvalCompiled +import Juvix.Compiler.Nockma.Evaluator +import Juvix.Compiler.Nockma.Pretty +import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma +import Juvix.Parser.Error + +runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaRunOptions -> Sem r () +runCommand opts = do + afile <- fromAppPathFile inputFile + argsFile <- mapM fromAppPathFile (opts ^. nockmaRunArgs) + parsedArgs <- mapM (Nockma.parseTermFile >=> checkParsed) argsFile + parsedTerm <- Nockma.parseTermFile afile >>= checkParsed + case parsedTerm of + t@(TermCell {}) -> do + let formula = anomaCallTuple parsedArgs + (counts, res) <- + runOpCounts + . runReader defaultEvalOptions + . runOutputSem @(Term Natural) (say . ppTrace) + $ evalCompiledNock' t formula + putStrLn (ppPrint res) + let statsFile = replaceExtension' ".profile" afile + writeFileEnsureLn statsFile (prettyText counts) + TermAtom {} -> exitFailMsg "Expected nockma input to be a cell" + where + inputFile :: AppPath File + inputFile = opts ^. nockmaRunFile + + checkParsed :: Either MegaparsecError (Term Natural) -> Sem r (Term Natural) + checkParsed = \case + Left err -> exitJuvixError (JuvixError err) + Right tm -> return tm diff --git a/app/Commands/Dev/Nockma/Run/Options.hs b/app/Commands/Dev/Nockma/Run/Options.hs new file mode 100644 index 0000000000..2133bedb87 --- /dev/null +++ b/app/Commands/Dev/Nockma/Run/Options.hs @@ -0,0 +1,32 @@ +module Commands.Dev.Nockma.Run.Options where + +import CommonOptions + +data NockmaRunOptions = NockmaRunOptions + { _nockmaRunFile :: AppPath File, + _nockmaRunProfile :: Bool, + _nockmaRunArgs :: Maybe (AppPath File) + } + deriving stock (Data) + +makeLenses ''NockmaRunOptions + +parseNockmaRunOptions :: Parser NockmaRunOptions +parseNockmaRunOptions = do + _nockmaRunFile <- parseInputFile FileExtNockma + _nockmaRunArgs <- optional $ do + _pathPath <- + option + somePreFileOpt + ( long "args" + <> metavar "ARGS_FILE" + <> help "Path to file containing args" + <> action "file" + ) + pure AppPath {_pathIsInput = True, ..} + _nockmaRunProfile <- + switch + ( long "profile" + <> help "Report evaluator profiling statistics" + ) + pure NockmaRunOptions {..} diff --git a/app/Commands/Dev/Reg/Compile.hs b/app/Commands/Dev/Reg/Compile.hs index d9ab12c49f..a0ed74e40b 100644 --- a/app/Commands/Dev/Reg/Compile.hs +++ b/app/Commands/Dev/Reg/Compile.hs @@ -59,7 +59,6 @@ runCommand opts = do TargetNative64 -> return Backend.TargetCNative64 TargetCasm -> return Backend.TargetCairo TargetReg -> err "JuvixReg" - TargetNockma -> err "Nockma" TargetAnoma -> err "Anoma" TargetTree -> err "JuvixTree" TargetGeb -> err "GEB" diff --git a/app/Commands/Dev/Tree/Compile.hs b/app/Commands/Dev/Tree/Compile.hs index b8ca4577f2..658d5e3f84 100644 --- a/app/Commands/Dev/Tree/Compile.hs +++ b/app/Commands/Dev/Tree/Compile.hs @@ -20,7 +20,6 @@ runCommand opts = do TargetAsm -> runAsmPipeline arg TargetReg -> runRegPipeline arg TargetTree -> return () - TargetNockma -> runNockmaPipeline arg TargetAnoma -> runAnomaPipeline arg TargetCasm -> runCasmPipeline arg where diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs index 7a2c3425cd..2c68d3a6f7 100644 --- a/app/Commands/Dev/Tree/Compile/Base.hs +++ b/app/Commands/Dev/Tree/Compile/Base.hs @@ -9,6 +9,7 @@ import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Casm.Data.Result qualified as Casm import Juvix.Compiler.Casm.Pretty qualified as Casm import Juvix.Compiler.Nockma.Pretty qualified as Nockma +import Juvix.Compiler.Nockma.Translation.FromTree qualified as Nockma import Juvix.Compiler.Reg.Pretty qualified as Reg import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Prelude.Pretty @@ -41,7 +42,6 @@ getEntry PipelineArg {..} = do TargetAsm -> Backend.TargetAsm TargetReg -> Backend.TargetReg TargetTree -> Backend.TargetTree - TargetNockma -> Backend.TargetNockma TargetAnoma -> Backend.TargetAnoma TargetCasm -> Backend.TargetCairo @@ -104,19 +104,6 @@ runRegPipeline pa@PipelineArg {..} = do let code = Reg.ppPrint tab' tab' writeFileEnsureLn regFile code -runNockmaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runNockmaPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile - r <- - runReader entryPoint - . runError @JuvixError - . treeToNockma - $ _pipelineArgTable - tab' <- getRight r - let code = Nockma.ppSerialize tab' - writeFileEnsureLn nockmaFile code - runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runAnomaPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa @@ -126,9 +113,15 @@ runAnomaPipeline pa@PipelineArg {..} = do . runError @JuvixError . treeToAnoma $ _pipelineArgTable - tab' <- getRight r - let code = Nockma.ppSerialize tab' + res <- getRight r + outputAnomaResult nockmaFile res + +outputAnomaResult :: (Members '[EmbedIO, App] r) => Path Abs File -> Nockma.AnomaResult -> Sem r () +outputAnomaResult nockmaFile Nockma.AnomaResult {..} = do + let code = Nockma.ppSerialize _anomaClosure + prettyNockmaFile = replaceExtensions' [".pretty", ".nockma"] nockmaFile writeFileEnsureLn nockmaFile code + writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure) runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runCasmPipeline pa@PipelineArg {..} = do diff --git a/app/Commands/Dev/Tree/Compile/Options.hs b/app/Commands/Dev/Tree/Compile/Options.hs index ccb3b71b6b..ba3f0bb969 100644 --- a/app/Commands/Dev/Tree/Compile/Options.hs +++ b/app/Commands/Dev/Tree/Compile/Options.hs @@ -14,8 +14,8 @@ treeSupportedTargets = TargetNative64, TargetAsm, TargetReg, - TargetNockma, - TargetCasm + TargetCasm, + TargetAnoma ] parseTreeCompileOptions :: Parser CompileOptions diff --git a/app/Commands/Extra/Compile.hs b/app/Commands/Extra/Compile.hs index f3c1a03f2d..0dabffd9fc 100644 --- a/app/Commands/Extra/Compile.hs +++ b/app/Commands/Extra/Compile.hs @@ -35,7 +35,6 @@ runCompile inputFile o = do TargetAsm -> return (Right ()) TargetReg -> return (Right ()) TargetTree -> return (Right ()) - TargetNockma -> return (Right ()) TargetAnoma -> return (Right ()) TargetCasm -> return (Right ()) @@ -55,7 +54,6 @@ prepareRuntime buildDir o = do TargetAsm -> return () TargetReg -> return () TargetTree -> return () - TargetNockma -> return () TargetAnoma -> return () TargetCasm -> return () where @@ -119,8 +117,6 @@ outputFile opts inputFile = replaceExtension' juvixRegFileExt baseOutputFile TargetTree -> replaceExtension' juvixTreeFileExt baseOutputFile - TargetNockma -> - replaceExtension' nockmaFileExt baseOutputFile TargetAnoma -> replaceExtension' nockmaFileExt baseOutputFile TargetCasm -> diff --git a/app/Commands/Extra/Compile/Options.hs b/app/Commands/Extra/Compile/Options.hs index dbcdba6c8c..1318743405 100644 --- a/app/Commands/Extra/Compile/Options.hs +++ b/app/Commands/Extra/Compile/Options.hs @@ -13,7 +13,6 @@ data CompileTarget | TargetAsm | TargetReg | TargetTree - | TargetNockma | TargetAnoma | TargetCasm deriving stock (Eq, Data, Bounded, Enum) @@ -28,7 +27,6 @@ instance Show CompileTarget where TargetAsm -> "asm" TargetReg -> "reg" TargetTree -> "tree" - TargetNockma -> "nockma" TargetAnoma -> "anoma" TargetCasm -> "casm" diff --git a/src/Juvix/Compiler/Backend.hs b/src/Juvix/Compiler/Backend.hs index 1e5c6c95c8..94d92c268a 100644 --- a/src/Juvix/Compiler/Backend.hs +++ b/src/Juvix/Compiler/Backend.hs @@ -12,7 +12,6 @@ data Target | TargetAsm | TargetReg | TargetTree - | TargetNockma | TargetAnoma | TargetCairo deriving stock (Data, Eq, Show) @@ -94,8 +93,6 @@ getLimits tgt debug = case tgt of } TargetTree -> defaultLimits - TargetNockma -> - defaultLimits TargetAnoma -> defaultLimits TargetCairo -> diff --git a/src/Juvix/Compiler/Nockma/Anoma.hs b/src/Juvix/Compiler/Nockma/Anoma.hs new file mode 100644 index 0000000000..32d879ef31 --- /dev/null +++ b/src/Juvix/Compiler/Nockma/Anoma.hs @@ -0,0 +1,24 @@ +module Juvix.Compiler.Nockma.Anoma where + +import Juvix.Compiler.Nockma.Language +import Juvix.Compiler.Nockma.Translation.FromTree +import Juvix.Prelude + +-- | Call a function at the head of the subject using the Anoma calling convention +anomaCall :: [Term Natural] -> Term Natural +anomaCall args = anomaCallTuple (foldTerms <$> nonEmpty args) + +anomaCallTuple :: Maybe (Term Natural) -> Term Natural +anomaCallTuple = \case + Just args -> helper (Just (opReplace "anomaCall-args" (closurePath ArgsTuple) args)) + Nothing -> helper Nothing + where + helper replaceArgs = + opCall + "anomaCall" + (closurePath WrapperCode) + (repArgs (OpAddress # emptyPath)) + where + repArgs x = case replaceArgs of + Nothing -> x + Just r -> r x diff --git a/src/Juvix/Compiler/Nockma/EvalCompiled.hs b/src/Juvix/Compiler/Nockma/EvalCompiled.hs index 52272ae7ae..3e5c2e7972 100644 --- a/src/Juvix/Compiler/Nockma/EvalCompiled.hs +++ b/src/Juvix/Compiler/Nockma/EvalCompiled.hs @@ -5,13 +5,13 @@ import Juvix.Compiler.Nockma.Language import Juvix.Compiler.Nockma.Pretty (ppTrace) import Juvix.Prelude -evalCompiledNock' :: (Members '[Reader EvalOptions, Output (Term Natural)] r) => Term Natural -> Term Natural -> Sem r (Term Natural) +evalCompiledNock' :: (Members '[State OpCounts, Reader EvalOptions, Output (Term Natural)] r) => Term Natural -> Term Natural -> Sem r (Term Natural) evalCompiledNock' stack mainTerm = do evalT <- runError @(ErrNockNatural Natural) . runError @(NockEvalError Natural) . runReader @(Storage Natural) emptyStorage - $ eval stack mainTerm + $ evalProfile stack mainTerm case evalT of Left e -> error (show e) Right ev -> case ev of diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 59b57f8aed..4207f09cbb 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -12,6 +12,37 @@ import Juvix.Compiler.Nockma.Evaluator.Options import Juvix.Compiler.Nockma.Evaluator.Storage import Juvix.Compiler.Nockma.Language import Juvix.Prelude hiding (Atom, Path) +import Juvix.Prelude.Pretty + +newtype OpCounts = OpCounts + { _opCountsMap :: HashMap NockOp Int + } + +makeLenses ''OpCounts + +initOpCounts :: OpCounts +initOpCounts = OpCounts mempty + +ignoreOpCounts :: Sem (State OpCounts ': r) a -> Sem r a +ignoreOpCounts = evalState initOpCounts + +countOp :: (Members '[State OpCounts] r) => NockOp -> Sem r () +countOp op = + modify + ( over + (opCountsMap . at op) + ( \case + Nothing -> Just 1 + Just n -> Just (n + 1) + ) + ) + +runOpCounts :: Sem (State OpCounts ': r) a -> Sem r (OpCounts, a) +runOpCounts = runState initOpCounts + +instance Pretty OpCounts where + pretty :: OpCounts -> Doc a + pretty (OpCounts m) = vsepHard [pretty op <+> ":" <+> pretty (fromMaybe 0 (m ^. at op)) | op <- allElements] asAtom :: (Members '[Reader EvalCtx, Error (NockEvalError a)] r) => Term a -> Sem r (Atom a) asAtom = \case @@ -55,16 +86,16 @@ subTerm term pos = Nothing -> throwInvalidPath term pos Just t -> return t -setSubTerm :: forall a r. (Members '[Error (NockEvalError a)] r) => Term a -> Path -> Term a -> Sem r (Term a) +setSubTerm :: forall a r. (Members '[Error (NockEvalError a), Reader EvalCtx] r) => Term a -> Path -> Term a -> Sem r (Term a) setSubTerm term pos repTerm = let (old, new) = setAndRemember (subTermT' pos) repTerm term in if - | isNothing (getFirst old) -> throw @(NockEvalError a) (error "") + | isNothing (getFirst old) -> throwInvalidPath term pos | otherwise -> return new parseCell :: forall r a. - (Members '[Error (NockEvalError a), Error (ErrNockNatural a)] r, NockNatural a) => + (Members '[Reader EvalCtx, Error (NockEvalError a), Error (ErrNockNatural a)] r, NockNatural a) => Cell a -> Sem r (ParsedCell a) parseCell c = case c ^. cellLeft of @@ -83,10 +114,13 @@ parseCell c = case c ^. cellLeft of parseOperatorCell :: Atom a -> Term a -> Sem r (OperatorCell a) parseOperatorCell a t = do - op <- nockOp a + op <- catch @(ErrNockNatural a) (nockOp a) $ \e -> + let atm :: Atom a = errGetAtom e + in throwInvalidNockOp atm return OperatorCell { _operatorCellOp = op, + _operatorCellTag = c ^. cellTag, _operatorCellTerm = t } @@ -132,7 +166,15 @@ eval :: Term a -> Term a -> Sem s (Term a) -eval inistack initerm = +eval initstack initterm = ignoreOpCounts (evalProfile initstack initterm) + +evalProfile :: + forall s a. + (Hashable a, Integral a, Members '[Reader (Storage a), State OpCounts, Reader EvalOptions, Output (Term a), Error (NockEvalError a), Error (ErrNockNatural a)] s, NockNatural a) => + Term a -> + Term a -> + Sem s (Term a) +evalProfile inistack initerm = topEvalCtx $ recEval inistack initerm where @@ -200,26 +242,29 @@ eval inistack initerm = return (TermCell (Cell l' r')) goOperatorCell :: OperatorCell a -> Sem r (Term a) - goOperatorCell c = case c ^. operatorCellOp of - OpAddress -> goOpAddress - OpQuote -> return goOpQuote - OpApply -> goOpApply - OpIsCell -> goOpIsCell - OpInc -> goOpInc - OpEq -> goOpEq - OpIf -> goOpIf - OpSequence -> goOpSequence - OpPush -> goOpPush - OpCall -> goOpCall - OpReplace -> goOpReplace - OpHint -> goOpHint - OpScry -> goOpScry - OpTrace -> goOpTrace + goOperatorCell c = do + countOp (c ^. operatorCellOp) + case c ^. operatorCellOp of + OpAddress -> goOpAddress + OpQuote -> return goOpQuote + OpApply -> goOpApply + OpIsCell -> goOpIsCell + OpInc -> goOpInc + OpEq -> goOpEq + OpIf -> goOpIf + OpSequence -> goOpSequence + OpPush -> goOpPush + OpCall -> goOpCall + OpReplace -> goOpReplace + OpHint -> goOpHint + OpScry -> goOpScry + OpTrace -> goOpTrace where crumb crumbTag = EvalCrumbOperator $ CrumbOperator { _crumbOperatorOp = c ^. operatorCellOp, + _crumbOperatorCellTag = c ^. operatorCellTag, _crumbOperatorTag = crumbTag, _crumbOperatorLoc = loc } diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Crumbs.hs b/src/Juvix/Compiler/Nockma/Evaluator/Crumbs.hs index be608d2703..060ba51207 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator/Crumbs.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator/Crumbs.hs @@ -54,6 +54,7 @@ data CrumbAutoCons = CrumbAutoCons data CrumbOperator = CrumbOperator { _crumbOperatorOp :: NockOp, _crumbOperatorTag :: CrumbTag, + _crumbOperatorCellTag :: Maybe Tag, _crumbOperatorLoc :: Maybe Interval } @@ -91,7 +92,8 @@ instance PrettyCode CrumbOperator where tag <- ppCode _crumbOperatorTag loc <- ppLoc _crumbOperatorLoc op <- ppCode _crumbOperatorOp - return (loc <+> tag <+> "for" <+> op) + celltag <- mapM ppCode _crumbOperatorCellTag + return (loc <+> tag <+> "for" <+> op <+?> celltag) instance PrettyCode CrumbAutoCons where ppCode CrumbAutoCons {..} = do diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs index 77689ae0e7..cdaf228ed8 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs @@ -14,6 +14,7 @@ import Juvix.Prelude hiding (Atom, Path) data NockEvalError a = ErrInvalidPath (InvalidPath a) + | ErrInvalidNockOp (InvalidNockOp a) | ErrExpectedAtom (ExpectedAtom a) | ErrExpectedCell (ExpectedCell a) | -- TODO perhaps this should be a repl error type @@ -50,8 +51,23 @@ data KeyNotInStorage a = KeyNotInStorage _keyNotInStorageStorage :: Storage a } +data InvalidNockOp a = InvalidNockOp + { _invalidNockOpCtx :: EvalCtx, + _invalidNockOp :: Atom a + } + data NoStack = NoStack +throwInvalidNockOp :: (Members '[Error (NockEvalError a), Reader EvalCtx] r) => Atom a -> Sem r x +throwInvalidNockOp a = do + ctx <- ask + throw $ + ErrInvalidNockOp + InvalidNockOp + { _invalidNockOpCtx = ctx, + _invalidNockOp = a + } + throwInvalidPath :: (Members '[Error (NockEvalError a), Reader EvalCtx] r) => Term a -> Path -> Sem r x throwInvalidPath tm p = do ctx <- ask @@ -110,6 +126,12 @@ instance (PrettyCode a, NockNatural a) => PrettyCode (ExpectedAtom a) where let atm = annotate AnnImportant "atom" return (ctx <> "Expected an" <+> atm <+> "but got:" <> line <> cell) +instance (PrettyCode a, NockNatural a) => PrettyCode (InvalidNockOp a) where + ppCode InvalidNockOp {..} = do + atm <- ppCode _invalidNockOp + ctx <- ppCtx _invalidNockOpCtx + return (ctx <> "Invalid nockOp or path: " <+> atm) + instance (PrettyCode a, NockNatural a) => PrettyCode (ExpectedCell a) where ppCode ExpectedCell {..} = do atm <- ppCode _expectedCellAtom @@ -133,6 +155,7 @@ instance (PrettyCode a, NockNatural a) => PrettyCode (KeyNotInStorage a) where instance (PrettyCode a, NockNatural a) => PrettyCode (NockEvalError a) where ppCode = \case ErrInvalidPath e -> ppCode e + ErrInvalidNockOp e -> ppCode e ErrExpectedAtom e -> ppCode e ErrExpectedCell e -> ppCode e ErrNoStack e -> ppCode e diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index d80c3eb1a5..ec78c994d9 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -59,8 +59,16 @@ data StdlibCall a = StdlibCall instance (Hashable a) => Hashable (StdlibCall a) +newtype Tag = Tag + { _unTag :: Text + } + deriving stock (Show, Eq, Lift, Generic) + +instance Hashable Tag + data CellInfo a = CellInfo { _cellInfoLoc :: Irrelevant (Maybe Interval), + _cellInfoTag :: Maybe Tag, _cellInfoCall :: Maybe (StdlibCall a) } deriving stock (Show, Eq, Lift, Generic) @@ -78,6 +86,7 @@ instance (Hashable a) => Hashable (Cell a) data AtomInfo = AtomInfo { _atomInfoHint :: Maybe AtomHint, + _atomInfoTag :: Maybe Tag, _atomInfoLoc :: Irrelevant (Maybe Interval) } deriving stock (Show, Eq, Lift, Generic) @@ -98,6 +107,7 @@ data AtomHint | AtomHintBool | AtomHintNil | AtomHintVoid + | AtomHintFunctionsPlaceholder deriving stock (Show, Eq, Lift, Generic) instance Hashable AtomHint @@ -157,6 +167,7 @@ data StdlibCallCell a = StdlibCallCell data OperatorCell a = OperatorCell { _operatorCellOp :: NockOp, + _operatorCellTag :: Maybe Tag, _operatorCellTerm :: Term a } @@ -179,6 +190,7 @@ encodedPathAppendRightN n (EncodedPath p) = EncodedPath (f p) f x = (2 ^ n) * (x + 1) - 1 makeLenses ''Cell +makeLenses ''Tag makeLenses ''StdlibCallCell makeLenses ''StdlibCall makeLenses ''Atom @@ -201,9 +213,15 @@ termLoc f = \case cellLoc :: Lens' (Cell a) (Maybe Interval) cellLoc = cellInfo . cellInfoLoc . unIrrelevant +cellTag :: Lens' (Cell a) (Maybe Tag) +cellTag = cellInfo . cellInfoTag + cellCall :: Lens' (Cell a) (Maybe (StdlibCall a)) cellCall = cellInfo . cellInfoCall +atomTag :: Lens' (Atom a) (Maybe Tag) +atomTag = atomInfo . atomInfoTag + atomLoc :: Lens' (Atom a) (Maybe Interval) atomLoc = atomInfo . atomInfoLoc . unIrrelevant @@ -242,9 +260,14 @@ class (NockmaEq a) => NockNatural a where errInvalidOp :: Atom a -> ErrNockNatural a errInvalidPath :: Atom a -> ErrNockNatural a + errGetAtom :: ErrNockNatural a -> Atom a nockOp :: (Member (Error (ErrNockNatural a)) r) => Atom a -> Sem r NockOp nockOp atm = do + case atm ^. atomHint of + Just h + | h /= AtomHintOp -> throw (errInvalidOp atm) + _ -> return () n <- nockNatural atm failWithError (errInvalidOp atm) (parseOp n) @@ -264,8 +287,11 @@ nockBool = \case True -> nockTrue False -> nockFalse -nockNil' :: Term Natural -nockNil' = TermAtom nockNil +nockNilTagged :: Text -> Term Natural +nockNilTagged txt = TermAtom (set atomTag (Just (Tag txt)) nockNil) + +nockNilUntagged :: Term Natural +nockNilUntagged = TermAtom nockNil data NockNaturalNaturalError = NaturalInvalidPath (Atom Natural) @@ -289,6 +315,9 @@ instance NockNatural Natural where nockTrue = Atom 0 (atomHintInfo AtomHintBool) nockFalse = Atom 1 (atomHintInfo AtomHintBool) nockNil = Atom 0 (atomHintInfo AtomHintNil) + errGetAtom = \case + NaturalInvalidPath a -> a + NaturalInvalidOp a -> a nockSucc = over atom succ nockVoid = Atom 0 (atomHintInfo AtomHintVoid) errInvalidOp atm = NaturalInvalidOp atm @@ -331,6 +360,16 @@ instance IsNock Path where instance IsNock EncodedPath where toNock = toNock . decodePath' +infixr 1 @. + +(@.) :: Text -> Cell Natural -> Cell Natural +tag @. c = set cellTag (Just (Tag tag)) c + +infixr 1 @ + +(@) :: Text -> Cell Natural -> Term Natural +tag @ c = TermCell (set cellTag (Just (Tag tag)) c) + infixr 5 #. (#.) :: (IsNock x, IsNock y) => x -> y -> Cell Natural @@ -351,6 +390,18 @@ infixl 1 >># (>>#) :: (IsNock x, IsNock y) => x -> y -> Term Natural a >># b = TermCell (a >>#. b) +opCall :: Text -> Path -> Term Natural -> Term Natural +opCall txt p t = txt @ (OpCall #. (p # t)) + +opReplace :: Text -> Path -> Term Natural -> Term Natural -> Term Natural +opReplace txt p t1 t2 = txt @ OpReplace #. ((p #. t1) #. t2) + +opAddress :: Text -> Path -> Term Natural +opAddress txt p = txt @ OpAddress #. p + +opQuote :: (IsNock x) => Text -> x -> Term Natural +opQuote txt p = txt @ OpQuote #. p + {-# COMPLETE Cell #-} pattern Cell :: Term a -> Term a -> Cell a @@ -374,6 +425,7 @@ emptyCellInfo :: CellInfo a emptyCellInfo = CellInfo { _cellInfoCall = Nothing, + _cellInfoTag = Nothing, _cellInfoLoc = Irrelevant Nothing } @@ -381,6 +433,7 @@ emptyAtomInfo :: AtomInfo emptyAtomInfo = AtomInfo { _atomInfoHint = Nothing, + _atomInfoTag = Nothing, _atomInfoLoc = Irrelevant Nothing } diff --git a/src/Juvix/Compiler/Nockma/Pretty.hs b/src/Juvix/Compiler/Nockma/Pretty.hs index fc6730e79f..7686b8ac89 100644 --- a/src/Juvix/Compiler/Nockma/Pretty.hs +++ b/src/Juvix/Compiler/Nockma/Pretty.hs @@ -28,7 +28,10 @@ ppSerialize :: (PrettyCode c) => c -> Text ppSerialize = ppPrintOpts serializeOptions ppPrint :: (PrettyCode c) => c -> Text -ppPrint = ppPrintOpts defaultOptions +ppPrint = toPlainText . ppOut defaultOptions + +ppTest :: (PrettyCode c) => c -> Text +ppTest = toPlainText . ppOut testOptions ppPrintOpts :: (PrettyCode c) => Options -> c -> Text ppPrintOpts opts = renderStrict . toTextStream . ppOut opts diff --git a/src/Juvix/Compiler/Nockma/Pretty/Base.hs b/src/Juvix/Compiler/Nockma/Pretty/Base.hs index cb5e916bb2..0eb8915156 100644 --- a/src/Juvix/Compiler/Nockma/Pretty/Base.hs +++ b/src/Juvix/Compiler/Nockma/Pretty/Base.hs @@ -24,20 +24,25 @@ runPrettyCode :: (PrettyCode c) => Options -> c -> Doc Ann runPrettyCode opts = run . runReader opts . ppCode instance (PrettyCode a, NockNatural a) => PrettyCode (Atom a) where - ppCode atm = runFailDefaultM (annotate (AnnKind KNameFunction) <$> ppCode (atm ^. atom)) - . failFromError @(ErrNockNatural a) - $ do - whenM (asks (^. optIgnoreHints)) fail - h' <- failMaybe (atm ^. atomHint) - case h' of - AtomHintOp -> nockOp atm >>= ppCode - AtomHintPath -> nockPath atm >>= ppCode - AtomHintBool - | nockmaEq atm nockTrue -> return (annotate (AnnKind KNameInductive) "true") - | nockmaEq atm nockFalse -> return (annotate (AnnKind KNameAxiom) "false") - | otherwise -> fail - AtomHintNil -> return (annotate (AnnKind KNameConstructor) "nil") - AtomHintVoid -> return (annotate (AnnKind KNameAxiom) "void") + ppCode atm = do + t <- runFail $ do + failWhenM (asks (^. optIgnoreTags)) + failMaybe (atm ^. atomTag) >>= ppCode + let def = fmap (t ) (annotate (AnnKind KNameFunction) <$> ppCode (atm ^. atom)) + fmap (t ) . runFailDefaultM def . failFromError @(ErrNockNatural a) $ + do + whenM (asks (^. optIgnoreHints)) fail + h' <- failMaybe (atm ^. atomHint) + case h' of + AtomHintOp -> nockOp atm >>= ppCode + AtomHintPath -> nockPath atm >>= ppCode + AtomHintBool + | nockmaEq atm nockTrue -> return (annotate (AnnKind KNameInductive) Str.true_) + | nockmaEq atm nockFalse -> return (annotate (AnnKind KNameAxiom) Str.false_) + | otherwise -> fail + AtomHintNil -> return (annotate (AnnKind KNameConstructor) Str.nil) + AtomHintVoid -> return (annotate (AnnKind KNameAxiom) Str.void) + AtomHintFunctionsPlaceholder -> return (annotate (AnnKind KNameAxiom) Str.functionsPlaceholder) instance PrettyCode Interval where ppCode = return . pretty @@ -69,9 +74,15 @@ instance (PrettyCode a, NockNatural a) => PrettyCode (StdlibCall a) where args <- ppCode (c ^. stdlibCallArgs) return (Str.stdlibTag <> fun <+> Str.argsTag <> args) +instance PrettyCode Tag where + ppCode (Tag txt) = return (annotate AnnKeyword Str.tagTag <> pretty txt) + instance (PrettyCode a, NockNatural a) => PrettyCode (Cell a) where ppCode c = do m <- asks (^. optPrettyMode) + label <- runFail $ do + failWhenM (asks (^. optIgnoreTags)) + failMaybe (c ^. cellTag) >>= ppCode stdlibCall <- runFail $ do failWhenM (asks (^. optIgnoreHints)) failMaybe (c ^. cellCall) >>= ppCode @@ -81,7 +92,7 @@ instance (PrettyCode a, NockNatural a) => PrettyCode (Cell a) where r' <- ppCode (c ^. cellRight) return (l' <+> r') MinimizeDelimiters -> sep <$> mapM ppCode (unfoldCell c) - let inside = stdlibCall components + let inside = label stdlibCall components return (oneLineOrNextBrackets inside) unfoldCell :: Cell a -> NonEmpty (Term a) diff --git a/src/Juvix/Compiler/Nockma/Pretty/Options.hs b/src/Juvix/Compiler/Nockma/Pretty/Options.hs index 0914bc67e6..0f01770f0b 100644 --- a/src/Juvix/Compiler/Nockma/Pretty/Options.hs +++ b/src/Juvix/Compiler/Nockma/Pretty/Options.hs @@ -11,26 +11,38 @@ defaultOptions :: Options defaultOptions = Options { _optPrettyMode = MinimizeDelimiters, - _optIgnoreHints = False + _optIgnoreHints = False, + _optIgnoreTags = False } data Options = Options { _optPrettyMode :: PrettyMode, - _optIgnoreHints :: Bool + _optIgnoreHints :: Bool, + _optIgnoreTags :: Bool } serializeOptions :: Options serializeOptions = Options { _optPrettyMode = MinimizeDelimiters, - _optIgnoreHints = True + _optIgnoreHints = True, + _optIgnoreTags = True + } + +testOptions :: Options +testOptions = + Options + { _optPrettyMode = MinimizeDelimiters, + _optIgnoreHints = False, + _optIgnoreTags = True } traceOptions :: Options traceOptions = Options { _optPrettyMode = MinimizeDelimiters, - _optIgnoreHints = False + _optIgnoreHints = False, + _optIgnoreTags = False } makeLenses ''Options diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index 71bc32c6fa..4ba2118d74 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -7,7 +7,7 @@ import Juvix.Compiler.Nockma.Language import Juvix.Extra.Paths import Juvix.Extra.Strings qualified as Str import Juvix.Parser.Error -import Juvix.Parser.Lexer (onlyInterval, withLoc) +import Juvix.Parser.Lexer (isWhiteSpace, onlyInterval, withLoc) import Juvix.Prelude hiding (Atom, Path, many, some) import Juvix.Prelude qualified as Prelude import Juvix.Prelude.Parsing hiding (runParser) @@ -75,22 +75,24 @@ dottedNatural = lexeme $ do digit :: Parser Char digit = satisfy isDigit -atomOp :: Parser (Atom Natural) -atomOp = do +atomOp :: Maybe Tag -> Parser (Atom Natural) +atomOp mtag = do WithLoc loc op' <- withLoc (choice [symbol opName $> op | (opName, op) <- HashMap.toList atomOps]) let info = AtomInfo { _atomInfoHint = Just AtomHintOp, + _atomInfoTag = mtag, _atomInfoLoc = Irrelevant (Just loc) } return (Atom (serializeNockOp op') info) -atomPath :: Parser (Atom Natural) -atomPath = do +atomPath :: Maybe Tag -> Parser (Atom Natural) +atomPath mtag = do WithLoc loc path <- withLoc pPath let info = AtomInfo { _atomInfoHint = Just AtomHintPath, + _atomInfoTag = mtag, _atomInfoLoc = Irrelevant (Just loc) } return (Atom (serializePath path) info) @@ -105,12 +107,13 @@ pPath = symbol "S" $> [] <|> NonEmpty.toList <$> some direction -atomNat :: Parser (Atom Natural) -atomNat = do +atomNat :: Maybe Tag -> Parser (Atom Natural) +atomNat mtag = do WithLoc loc n <- withLoc dottedNatural let info = AtomInfo { _atomInfoHint = Nothing, + _atomInfoTag = mtag, _atomInfoLoc = Irrelevant (Just loc) } return (Atom n info) @@ -133,21 +136,32 @@ atomNil = symbol Str.nil $> nockNil atomVoid :: Parser (Atom Natural) atomVoid = symbol Str.void $> nockVoid +atomFunctionsPlaceholder :: Parser (Atom Natural) +atomFunctionsPlaceholder = symbol Str.functionsPlaceholder $> nockNil + patom :: Parser (Atom Natural) -patom = - atomOp - <|> atomNat - <|> atomPath +patom = do + mtag <- optional pTag + atomOp mtag + <|> atomNat mtag + <|> atomPath mtag <|> atomBool <|> atomNil <|> atomVoid + <|> atomFunctionsPlaceholder iden :: Parser Text -iden = lexeme (takeWhile1P (Just "") isAlphaNum) +iden = lexeme (takeWhile1P (Just "") (isAscii .&&. not . isWhiteSpace)) + +pTag :: Parser Tag +pTag = do + void (chunk Str.tagTag) + Tag <$> iden cell :: Parser (Cell Natural) cell = do lloc <- onlyInterval lsbracket + lbl <- optional pTag c <- optional stdlibCall firstTerm <- term restTerms <- some term @@ -156,6 +170,7 @@ cell = do info = CellInfo { _cellInfoCall = c, + _cellInfoTag = lbl, _cellInfoLoc = Irrelevant (Just (lloc <> rloc)) } return (set cellInfo info r) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 8dc11b65e0..e0ffda5226 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -1,23 +1,34 @@ module Juvix.Compiler.Nockma.Translation.FromTree - ( runCompilerWithAnoma, - runCompilerWithJuvix, - fromEntryPoint, + ( fromEntryPoint, fromTreeTable, - ProgramCallingConvention (..), + AnomaResult (..), + anomaClosure, + compilerFunctionName, + AnomaCallablePathId (..), CompilerOptions (..), CompilerFunction (..), + FunctionCtx (..), FunctionId (..), + closurePath, + foldTermsOrNil, add, dec, mul, sub, pow2, nockNatLiteral, + nockIntegralLiteral, callStdlib, appendRights, foldTerms, pathToArg, makeList, + listToTuple, + appendToTuple, + append, + opAddress', + replaceSubterm', + runCompilerWith, ) where @@ -31,9 +42,9 @@ import Juvix.Compiler.Tree.Language qualified as Tree import Juvix.Compiler.Tree.Language.Rep import Juvix.Prelude hiding (Atom, Path) -data ProgramCallingConvention - = ProgramCallingConventionJuvix - | ProgramCallingConventionAnoma +newtype AnomaResult = AnomaResult + { _anomaClosure :: Term Natural + } nockmaMemRep :: MemRep -> NockmaMemRep nockmaMemRep = \case @@ -86,6 +97,10 @@ data FunctionInfo = FunctionInfo _functionInfoArity :: Natural } +data FunctionCtx = FunctionCtx + { _functionCtxArity :: Natural + } + data CompilerCtx = CompilerCtx { _compilerFunctionInfos :: HashMap FunctionId FunctionInfo, _compilerConstructorInfos :: ConstructorInfos, @@ -102,14 +117,22 @@ type ConstructorInfos = HashMap Tree.Tag ConstructorInfo data CompilerFunction = CompilerFunction { _compilerFunctionName :: FunctionId, _compilerFunctionArity :: Natural, - _compilerFunction :: Sem '[Reader CompilerCtx] (Term Natural) + _compilerFunction :: Sem '[Reader CompilerCtx, Reader FunctionCtx] (Term Natural) } -data StackId - = Args +-- The Code and Args constructors must be first and second respectively. This is +-- because the stack must have the structure of a Nock function, +-- i.e [code args env] +data AnomaCallablePathId + = WrapperCode + | ArgsTuple + | FunctionsLibrary + | RawCode | TempStack | StandardLibrary - | FunctionsLibrary + | ClosureTotalArgsNum + | ClosureArgsNum + | ClosureArgs deriving stock (Enum, Bounded, Eq, Show) -- | A closure has the following structure: @@ -120,13 +143,6 @@ data StackId -- 3. argsNum is the number of arguments that have been applied to the closure. -- 4. args is the list of args that have been applied. -- The length of the list should be argsNum. -data ClosurePathId - = ClosureCode - | ClosureTotalArgsNum - | ClosureArgsNum - | ClosureArgs - deriving stock (Bounded, Enum) - pathFromEnum :: (Enum a) => a -> Path pathFromEnum = indexStack . fromIntegral . fromEnum @@ -138,14 +154,7 @@ data ConstructorPathId constructorPath :: ConstructorPathId -> Path constructorPath = pathFromEnum -data FunctionPathId - = FunctionCode - -functionPath :: FunctionPathId -> Path -functionPath = \case - FunctionCode -> [] - -stackPath :: StackId -> Path +stackPath :: AnomaCallablePathId -> Path stackPath s = indexStack (fromIntegral (fromEnum s)) indexTuple :: Natural -> Natural -> Path @@ -160,29 +169,40 @@ indexTuple len idx indexStack :: Natural -> Path indexStack idx = replicate idx R ++ [L] -indexInStack :: StackId -> Natural -> Path +indexInStack :: AnomaCallablePathId -> Natural -> Path indexInStack s idx = stackPath s ++ indexStack idx -pathToArg :: Natural -> Path -pathToArg = indexInStack Args - makeLenses ''CompilerOptions +makeLenses ''AnomaResult makeLenses ''CompilerFunction makeLenses ''CompilerCtx +makeLenses ''FunctionCtx makeLenses ''ConstructorInfo makeLenses ''FunctionInfo +runCompilerFunction :: CompilerCtx -> CompilerFunction -> Term Natural +runCompilerFunction ctx fun = + run + . runReader (FunctionCtx (fun ^. compilerFunctionArity)) + . runReader ctx + $ fun ^. compilerFunction + +pathToArg :: (Members '[Reader FunctionCtx] r) => Natural -> Sem r Path +pathToArg n = do + ari <- asks (^. functionCtxArity) + return (stackPath ArgsTuple <> indexTuple ari n) + termFromParts :: (Bounded p, Enum p) => (p -> Term Natural) -> Term Natural termFromParts f = remakeList [f pi | pi <- allElements] -makeClosure :: (ClosurePathId -> Term Natural) -> Term Natural +makeClosure :: (AnomaCallablePathId -> Term Natural) -> Term Natural makeClosure = termFromParts makeConstructor :: (ConstructorPathId -> Term Natural) -> Term Natural makeConstructor = termFromParts -makeFunction :: (FunctionPathId -> Term Natural) -> Term Natural -makeFunction f = f FunctionCode +foldTermsOrNil :: [Term Natural] -> Term Natural +foldTermsOrNil = maybe (OpQuote # nockNilTagged "foldTermsOrNil") foldTerms . nonEmpty foldTerms :: NonEmpty (Term Natural) -> Term Natural foldTerms = foldr1 (#) @@ -209,14 +229,14 @@ supportsListNockmaRep tab ci = case allConstructors tab ci of _ -> Nothing -- | Use `Tree.toNockma` before calling this function -fromTreeTable :: (Members '[Error JuvixError, Reader CompilerOptions] r) => ProgramCallingConvention -> Tree.InfoTable -> Sem r (Cell Natural) -fromTreeTable cc t = case t ^. Tree.infoMainFunction of +fromTreeTable :: (Members '[Error JuvixError, Reader CompilerOptions] r) => Tree.InfoTable -> Sem r AnomaResult +fromTreeTable t = case t ^. Tree.infoMainFunction of Just mainFun -> do opts <- ask return (fromTree opts mainFun t) Nothing -> throw @JuvixError (error "TODO missing main") where - fromTree :: CompilerOptions -> Tree.Symbol -> Tree.InfoTable -> Cell Natural + fromTree :: CompilerOptions -> Tree.Symbol -> Tree.InfoTable -> AnomaResult fromTree opts mainSym tab@Tree.InfoTable {..} = let funs = map compileFunction allFunctions mkConstructorInfo :: Tree.ConstructorInfo -> ConstructorInfo @@ -236,7 +256,7 @@ fromTreeTable cc t = case t ^. Tree.infoMainFunction of getInductiveInfo :: Symbol -> Tree.InductiveInfo getInductiveInfo s = _infoInductives ^?! at s . _Just - in runCompilerWith cc opts constrs funs mainFun + in runCompilerWith opts constrs funs mainFun where mainFun :: CompilerFunction mainFun = compileFunction (_infoFunctions ^?! at mainSym . _Just) @@ -266,7 +286,22 @@ fromTreeTable cc t = case t ^. Tree.infoMainFunction of fromOffsetRef :: Tree.OffsetRef -> Natural fromOffsetRef = fromIntegral . (^. Tree.offsetRefOffset) -compile :: forall r. (Members '[Reader CompilerCtx] r) => Tree.Node -> Sem r (Term Natural) +anomaCallableClosureWrapper :: Term Natural +anomaCallableClosureWrapper = + let closureArgsNum :: Term Natural = getClosureFieldInSubject ClosureArgsNum + closureTotalArgsNum :: Term Natural = getClosureFieldInSubject ClosureTotalArgsNum + appendAndReplaceArgsTuple = + replaceArgsWithTerm $ + appendToTuple + (getClosureFieldInSubject ClosureArgs) + closureArgsNum + (getClosureFieldInSubject ArgsTuple) + (sub closureTotalArgsNum closureArgsNum) + closureArgsIsEmpty = isZero closureArgsNum + adjustArgs = OpIf # closureArgsIsEmpty # (opAddress "wrapperSubject" emptyPath) # appendAndReplaceArgsTuple + in opCall "closureWrapper" (closurePath RawCode) adjustArgs + +compile :: forall r. (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Sem r (Term Natural) compile = \case Tree.Binop b -> goBinop b Tree.Unop b -> goUnop b @@ -290,27 +325,32 @@ compile = \case goMemRef :: Tree.MemRef -> Sem r (Term Natural) goMemRef = \case - Tree.DRef d -> return (goDirectRef d) + Tree.DRef d -> goDirectRef d Tree.ConstrRef Tree.Field {..} -> do info <- getConstructorInfo _fieldTag let memrep = info ^. constructorInfoMemRep argIx = fromIntegral _fieldOffset arity = info ^. constructorInfoArity - path = case memrep of - NockmaMemRepConstr -> - directRefPath _fieldRef - ++ constructorPath ConstructorArgs - ++ indexStack argIx - NockmaMemRepTuple -> - directRefPath _fieldRef - ++ indexTuple arity argIx - NockmaMemRepList constr -> case constr of - NockmaMemRepListConstrNil -> impossible - NockmaMemRepListConstrCons -> directRefPath _fieldRef ++ indexTuple 2 argIx - return (OpAddress # path) + path :: Sem r Path + path = do + fr <- directRefPath _fieldRef + return $ case memrep of + NockmaMemRepConstr -> + fr + ++ constructorPath ConstructorArgs + ++ indexStack argIx + NockmaMemRepTuple -> + fr + ++ indexTuple arity argIx + NockmaMemRepList constr -> case constr of + NockmaMemRepListConstrNil -> impossible + NockmaMemRepListConstrCons -> fr ++ indexTuple 2 argIx + (opAddress "constrRef") <$> path where - goDirectRef :: Tree.DirectRef -> Term Natural - goDirectRef dr = OpAddress # directRefPath dr + goDirectRef :: Tree.DirectRef -> Sem r (Term Natural) + goDirectRef dr = do + p <- directRefPath dr + return (opAddress "directRef" p) goConstant :: Tree.Constant -> Term Natural goConstant = \case @@ -373,7 +413,7 @@ compile = \case Tree.OpFieldToInt -> fieldErr goAnomaGet :: Term Natural -> Sem r (Term Natural) - goAnomaGet arg = return (OpScry # (OpQuote # nockNil') # arg) + goAnomaGet arg = return (OpScry # (OpQuote # nockNilTagged "OpScry-typehint") # arg) goTrace :: Term Natural -> Sem r (Term Natural) goTrace arg = do @@ -389,7 +429,7 @@ compile = \case arg2 <- compile _nodeBinopArg2 case _nodeBinopOpcode of Tree.PrimBinop op -> goPrimBinop op [arg1, arg2] - Tree.OpSeq -> return (OpHint # (nockNil' # arg1) # arg2) + Tree.OpSeq -> return (OpHint # (nockNilTagged "OpSeq-OpHint-annotation" # arg1) # arg2) where goPrimBinop :: Tree.BinaryOp -> [Term Natural] -> Sem r (Term Natural) goPrimBinop op args = case op of @@ -414,7 +454,12 @@ compile = \case farity <- getFunctionArity fun args <- mapM compile _nodeAllocClosureArgs return . makeClosure $ \case - ClosureCode -> OpAddress # fpath + WrapperCode -> OpQuote # anomaCallableClosureWrapper + ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" + RawCode -> opAddress "allocClosureFunPath" (fpath <> closurePath RawCode) + TempStack -> remakeList [] + StandardLibrary -> OpQuote # stdlib + FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder ClosureTotalArgsNum -> nockNatLiteral farity ClosureArgsNum -> nockIntegralLiteral (length args) ClosureArgs -> remakeList args @@ -428,32 +473,64 @@ compile = \case case _nodeCallType of Tree.CallFun fun -> callFunWithArgs (UserFunction fun) newargs Tree.CallClosure f -> do - f' <- compile f - let argsNum = getClosureField ClosureArgsNum f' - oldArgs = getClosureField ClosureArgs f' - fcode = getClosureField ClosureCode f' - posOfArgsNil = appendRights emptyPath argsNum - allArgs = replaceSubterm' oldArgs posOfArgsNil (remakeList newargs) - return (OpApply # replaceArgsWithTerm allArgs # fcode) + closure <- compile f + let argsNum = getClosureField ClosureArgsNum closure + oldArgs = getClosureField ClosureArgs closure + allArgs = appendToTuple oldArgs argsNum (foldTermsOrNil newargs) (nockIntegralLiteral (length newargs)) + newSubject = replaceSubject $ \case + WrapperCode -> Just (getClosureField RawCode closure) -- We Want RawCode because we already have all args. + ArgsTuple -> Just allArgs + RawCode -> Just (OpQuote # nockNilTagged "callClosure-RawCode") + TempStack -> Just (OpQuote # nockNilTagged "callClosure-TempStack") + FunctionsLibrary -> Nothing + StandardLibrary -> Nothing + ClosureArgs -> Nothing + ClosureTotalArgsNum -> Nothing + ClosureArgsNum -> Nothing + return $ (opCall "callClosure" (closurePath WrapperCode) newSubject) + +isZero :: Term Natural -> Term Natural +isZero a = OpEq # a # nockNatLiteral 0 + +opAddress' :: Term Natural -> Term Natural +opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x + +-- [a [b [c 0]]] -> [a [b c]] +-- len = quote 3 +-- TODO lst is being evaluated three times! +listToTuple :: Term Natural -> Term Natural -> Term Natural +listToTuple lst len = + -- posOfLast uses stdlib so when it is evaulated the stdlib must be in the + -- subject lst must also be evaluated against the standard subject. We achieve + -- this by evaluating `lst #. posOfLastOffset` in `t1`. The address that + -- posOfLastOffset now points to must be shifted by [L] to make it relative to + -- `lst`. + let posOfLastOffset = appendRights [L] (dec len) + posOfLast = appendRights emptyPath (dec len) + t1 = (lst #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) + in OpIf # isZero len # lst # (replaceSubterm' lst posOfLast t1) + +argsTuplePlaceholder :: Text -> Term Natural +argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt) appendRights :: Path -> Term Natural -> Term Natural appendRights path n = dec (mul (pow2 n) (OpInc # OpQuote # path)) -pushTemp :: Term Natural -> Term Natural -pushTemp toBePushed = - remakeList - [ let p = OpAddress # stackPath s - in if - | TempStack == s -> toBePushed # p - | otherwise -> p - | s <- allElements - ] - withTemp :: Term Natural -> Term Natural -> Term Natural withTemp toBePushed body = - OpSequence # pushTemp toBePushed # body - -testEq :: (Members '[Reader CompilerCtx] r) => Tree.Node -> Tree.Node -> Sem r (Term Natural) + OpSequence # pushTemp # body + where + pushTemp :: Term Natural + pushTemp = + remakeList + [ let p = opAddress "pushTemp" (stackPath s) + in if + | TempStack == s -> toBePushed # p + | otherwise -> p + | s <- allElements + ] + +testEq :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Tree.Node -> Sem r (Term Natural) testEq a b = do a' <- compile a b' <- compile b @@ -465,8 +542,20 @@ nockNatLiteral = nockIntegralLiteral nockIntegralLiteral :: (Integral a) => a -> Term Natural nockIntegralLiteral = (OpQuote #) . toNock @Natural . fromIntegral +-- | xs must be a list. +-- ys is a (possibly empty) tuple. +-- the result is a tuple. +appendToTuple :: Term Natural -> Term Natural -> Term Natural -> Term Natural -> Term Natural +appendToTuple xs lenXs ys lenYs = + OpIf # isZero lenYs # listToTuple xs lenXs # append xs lenXs ys + +append :: Term Natural -> Term Natural -> Term Natural -> Term Natural +append xs lenXs ys = + let posOfXsNil = appendRights emptyPath lenXs + in replaceSubterm' xs posOfXsNil ys + extendClosure :: - (Members '[Reader CompilerCtx] r) => + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.NodeExtendClosure -> Sem r (Term Natural) extendClosure Tree.NodeExtendClosure {..} = do @@ -474,15 +563,18 @@ extendClosure Tree.NodeExtendClosure {..} = do closure <- compile _nodeExtendClosureFun let argsNum = getClosureField ClosureArgsNum closure oldArgs = getClosureField ClosureArgs closure - fcode = getClosureField ClosureCode closure - posOfArgsNil = appendRights emptyPath argsNum - allArgs = replaceSubterm' oldArgs posOfArgsNil (remakeList args) + allArgs = append oldArgs argsNum (remakeList args) newArgsNum = add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) return . makeClosure $ \case - ClosureCode -> fcode + WrapperCode -> getClosureField WrapperCode closure + RawCode -> getClosureField RawCode closure ClosureTotalArgsNum -> getClosureField ClosureTotalArgsNum closure ClosureArgsNum -> newArgsNum ClosureArgs -> allArgs + ArgsTuple -> getClosureField ArgsTuple closure + FunctionsLibrary -> getClosureField FunctionsLibrary closure + TempStack -> getClosureField TempStack closure + StandardLibrary -> getClosureField StandardLibrary closure -- Calling convention for Anoma stdlib -- @@ -494,21 +586,21 @@ extendClosure Tree.NodeExtendClosure {..} = do -- [replace [RL :: edit at axis RL -- [seq [@ R] :: evaluate the a formula in the original context without f on it -- a]] :: the formula giving a goes here --- @ L] :: this whole replace is editing what's at axis L, i.e. what was +-- @ L] :: this whole replace is editing what's at axis L, i.e. what was pushed -- ] -- ] callStdlib :: StdlibFunction -> [Term Natural] -> Term Natural callStdlib fun args = let fPath = stdlibPath fun - getFunCode = OpAddress # stackPath StandardLibrary >># fPath + getFunCode = opAddress "callStdlibFunCode" (stackPath StandardLibrary) >># fPath adjustArgs = case nonEmpty args of - Just args' -> OpReplace # ([R, L] # ((OpAddress # [R]) >># foldTerms args')) # (OpAddress # [L]) - Nothing -> OpAddress # [L] - callFn = OpCall # [L] # adjustArgs + Just args' -> opReplace "callStdlib-args" (closurePath ArgsTuple) ((opAddress "stdlibR" [R]) >># foldTerms args') (opAddress "stdlibL" [L]) + Nothing -> opAddress "adjustArgsNothing" [L] + callFn = opCall "callStdlib" (closurePath WrapperCode) adjustArgs callCell = set cellCall (Just meta) (OpPush #. (getFunCode # callFn)) meta = StdlibCall - { _stdlibCallArgs = maybe nockNil' foldTerms (nonEmpty args), + { _stdlibCallArgs = foldTermsOrNil args, _stdlibCallFunction = fun } in TermCell callCell @@ -519,13 +611,15 @@ constUnit = constVoid constVoid :: Term Natural constVoid = TermAtom nockVoid -directRefPath :: Tree.DirectRef -> Path +directRefPath :: forall r. (Members '[Reader FunctionCtx] r) => Tree.DirectRef -> Sem r Path directRefPath = \case Tree.ArgRef a -> pathToArg (fromOffsetRef a) Tree.TempRef Tree.RefTemp {..} -> - tempRefPath - (fromIntegral (fromJust _refTempTempHeight)) - (fromOffsetRef _refTempOffsetRef) + return + ( tempRefPath + (fromIntegral (fromJust _refTempTempHeight)) + (fromOffsetRef _refTempOffsetRef) + ) tempRefPath :: Natural -> Natural -> Path tempRefPath tempHeight off = indexInStack TempStack (tempHeight - off - 1) @@ -572,43 +666,14 @@ fieldErr = unsupported "the field type" sub :: Term Natural -> Term Natural -> Term Natural sub a b = callStdlib StdlibSub [a, b] -makeList :: [Term Natural] -> Term Natural -makeList ts = foldTerms (ts `prependList` pure (TermAtom nockNil)) +makeList :: (Foldable f) => f (Term Natural) -> Term Natural +makeList ts = foldTerms (toList ts `prependList` pure (nockNilTagged "makeList")) remakeList :: (Foldable l) => l (Term Natural) -> Term Natural -remakeList ts = foldTerms (toList ts `prependList` pure (OpQuote # nockNil')) +remakeList ts = foldTerms (toList ts `prependList` pure (OpQuote # nockNilTagged "remakeList")) --- | Initialize the stack. The resulting term is intended to be evaulated --- against a subject that contains function arguments. -initStackWithArgs :: [Term Natural] -> [Term Natural] -> Term Natural -initStackWithArgs defs getArgs = remakeList (initSubStack <$> allElements) - where - initSubStack :: StackId -> Term Natural - initSubStack = \case - Args -> remakeList getArgs - TempStack -> OpQuote # nockNil' - StandardLibrary -> OpQuote # stdlib - FunctionsLibrary -> OpQuote # makeList defs - --- | Initialize the stack. Populate the FunctionsLibrary with the passed terms. -initStack :: [Term Natural] -> Term Natural -initStack defs = makeList (initSubStack <$> allElements) - where - initSubStack :: StackId -> Term Natural - initSubStack = \case - Args -> nockNil' - TempStack -> nockNil' - StandardLibrary -> stdlib - FunctionsLibrary -> makeList defs - -runCompilerWithAnoma :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> Cell Natural -runCompilerWithAnoma = runCompilerWith ProgramCallingConventionAnoma - -runCompilerWithJuvix :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> Cell Natural -runCompilerWithJuvix = runCompilerWith ProgramCallingConventionJuvix - -runCompilerWith :: ProgramCallingConvention -> CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> Cell Natural -runCompilerWith callingConvention opts constrs libFuns mainFun = run . runReader compilerCtx $ mkEntryPoint +runCompilerWith :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> AnomaResult +runCompilerWith opts constrs libFuns mainFun = makeAnomaFun where allFuns :: NonEmpty CompilerFunction allFuns = mainFun :| libFuns ++ (builtinFunction <$> allElements) @@ -623,14 +688,26 @@ runCompilerWith callingConvention opts constrs libFuns mainFun = run . runReader compiledFuns :: NonEmpty (Term Natural) compiledFuns = - makeFunction' - <$> ( run . runReader compilerCtx . (^. compilerFunction) - <$> allFuns + makeLibraryFunction + <$> ( runCompilerFunction compilerCtx <$> allFuns ) - makeFunction' :: Term Natural -> Term Natural - makeFunction' c = makeFunction $ \case - FunctionCode -> c + exportEnv :: Term Natural + exportEnv = makeList compiledFuns + + makeLibraryFunction :: Term Natural -> Term Natural + makeLibraryFunction c = makeClosure $ \p -> + let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p) + in case p of + WrapperCode -> c + ArgsTuple -> argsTuplePlaceholder "libraryFunction" + FunctionsLibrary -> functionsLibraryPlaceHolder + RawCode -> c + TempStack -> nockNilHere + StandardLibrary -> stdlib + ClosureTotalArgsNum -> nockNilHere + ClosureArgsNum -> nockNilHere + ClosureArgs -> nockNilHere functionInfos :: HashMap FunctionId FunctionInfo functionInfos = hashMap (run (runInputNaturals (toList <$> userFunctions))) @@ -646,34 +723,39 @@ runCompilerWith callingConvention opts constrs libFuns mainFun = run . runReader } ) - makeAnomaFun :: (Members '[Reader CompilerCtx] r) => Sem r (Cell Natural) - makeAnomaFun = do - entryTerm <- callFun (mainFun ^. compilerFunctionName) - - let mainArity :: Natural - mainArity = mainFun ^. compilerFunctionArity - - args :: [Term Natural] - args = [OpAddress # [R, L] ++ indexTuple mainArity (pred i) | i <- [1 .. mainArity]] - - wrapperCode :: Term Natural - wrapperCode = OpApply # (initStackWithArgs (toList compiledFuns) args) # (OpQuote # entryTerm) - - argsPlaceholder :: Term Natural - argsPlaceholder = nockNil' - - env :: Term Natural - env = nockNil' - return (wrapperCode #. (argsPlaceholder # env)) - - makeJuvixFun :: (Members '[Reader CompilerCtx] r) => Sem r (Cell Natural) - makeJuvixFun = do - entryTerm <- callFunWithArgs (mainFun ^. compilerFunctionName) [] - return (initStack (toList compiledFuns) #. entryTerm) - - mkEntryPoint = case callingConvention of - ProgramCallingConventionAnoma -> makeAnomaFun - ProgramCallingConventionJuvix -> makeJuvixFun + makeAnomaFun :: AnomaResult + makeAnomaFun = + let mainClosure :: Term Natural + mainClosure = head compiledFuns + in AnomaResult + { _anomaClosure = substEnv mainClosure + } + where + -- Replaces all instances of functionsLibraryPlaceHolder by the actual + -- functions library. Note that the functions library will have + -- functionsLibraryPlaceHolders, but this is not an issue because they + -- are not directly accessible from anoma so they'll never be entrypoints. + substEnv :: Term Natural -> Term Natural + substEnv = \case + TermAtom a + | a ^. atomHint == Just AtomHintFunctionsPlaceholder -> exportEnv + | otherwise -> TermAtom a + TermCell (Cell' l r i) -> + -- note that we do not need to recurse into terms inside the CellInfo because those terms will never be an entry point from anoma + TermCell (Cell' (substEnv l) (substEnv r) i) + +functionsLibraryPlaceHolder :: Term Natural +functionsLibraryPlaceHolder = + TermAtom + Atom + { _atomInfo = + AtomInfo + { _atomInfoLoc = Irrelevant Nothing, + _atomInfoTag = Nothing, + _atomInfoHint = Just AtomHintFunctionsPlaceholder + }, + _atom = 0 :: Natural + } builtinFunction :: BuiltinFunctionId -> CompilerFunction builtinFunction = \case @@ -684,15 +766,19 @@ builtinFunction = \case _compilerFunction = return crash } --- | Call a function. Arguments to the function are assumed to be in the Args stack +closurePath :: AnomaCallablePathId -> Path +closurePath = stackPath + +-- | Call a function. Arguments to the function are assumed to be in the ArgsTuple stack +-- TODO what about temporary stack? callFun :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r (Term Natural) callFun fun = do fpath <- getFunctionPath fun - let p' = fpath ++ functionPath FunctionCode - return (OpCall # p' # (OpAddress # emptyPath)) + let p' = fpath ++ closurePath WrapperCode + return (opCall "callFun" p' (opAddress "callFunSubject" emptyPath)) -- | Call a function with the passed arguments callFunWithArgs :: @@ -702,29 +788,29 @@ callFunWithArgs :: Sem r (Term Natural) callFunWithArgs fun args = (replaceArgs args >>#) <$> callFun fun -replaceArgsWithTerm :: Term Natural -> Term Natural -replaceArgsWithTerm term = +replaceSubject :: (AnomaCallablePathId -> Maybe (Term Natural)) -> Term Natural +replaceSubject f = remakeList - [ if - | Args == s -> term - | otherwise -> OpAddress # stackPath s + [ case f s of + Nothing -> opAddress "replaceSubject" (closurePath s) + Just t' -> t' | s <- allElements ] +replaceArgsWithTerm :: Term Natural -> Term Natural +replaceArgsWithTerm term = + replaceSubject $ \case + ArgsTuple -> Just term + _ -> Nothing + replaceArgs :: [Term Natural] -> Term Natural -replaceArgs args = - remakeList - [ if - | Args == s -> remakeList args - | otherwise -> OpAddress # stackPath s - | s <- allElements - ] +replaceArgs = replaceArgsWithTerm . foldTermsOrNil getFunctionPath :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r Path getFunctionPath funName = asks (^?! compilerFunctionInfos . at funName . _Just . functionInfoPath) evaluated :: Term Natural -> Term Natural -evaluated t = OpApply # (OpAddress # emptyPath) # t +evaluated t = OpApply # (opAddress "evaluated" emptyPath) # t -- | obj[eval(relPath)] := newVal -- relPath is relative to obj @@ -832,20 +918,26 @@ getFunctionArity s = asks (^?! compilerFunctionInfos . at s . _Just . functionIn getConstructorInfo :: (Members '[Reader CompilerCtx] r) => Tree.Tag -> Sem r ConstructorInfo getConstructorInfo tag = asks (^?! compilerConstructorInfos . at tag . _Just) -getClosureField :: ClosurePathId -> Term Natural -> Term Natural +getClosureField :: AnomaCallablePathId -> Term Natural -> Term Natural getClosureField = getField +getClosureFieldInSubject :: AnomaCallablePathId -> Term Natural +getClosureFieldInSubject = getFieldInSubject + getConstructorField :: ConstructorPathId -> Term Natural -> Term Natural getConstructorField = getField getField :: (Enum field) => field -> Term Natural -> Term Natural -getField field t = t >># (OpAddress # pathFromEnum field) +getField field t = t >># getFieldInSubject field + +getFieldInSubject :: (Enum field) => field -> Term Natural +getFieldInSubject field = opAddress "getFieldInSubject" (pathFromEnum field) getConstructorMemRep :: (Members '[Reader CompilerCtx] r) => Tree.Tag -> Sem r NockmaMemRep getConstructorMemRep tag = (^. constructorInfoMemRep) <$> getConstructorInfo tag crash :: Term Natural -crash = (OpAddress # OpAddress # OpAddress) +crash = ("crash" @ OpAddress #. OpAddress # OpAddress) mul :: Term Natural -> Term Natural -> Term Natural mul a b = callStdlib StdlibMul [a, b] diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index e19030096e..5047538352 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -27,7 +27,6 @@ import Juvix.Compiler.Core.Transformation import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped import Juvix.Compiler.Internal qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker -import Juvix.Compiler.Nockma.Language qualified as Nockma import Juvix.Compiler.Nockma.Translation.FromTree qualified as NockmaTree import Juvix.Compiler.Pipeline.Artifacts import Juvix.Compiler.Pipeline.EntryPoint @@ -130,8 +129,8 @@ upToGeb spec = upToAnoma :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) => - Sem r (Nockma.Term Natural) -upToAnoma = upToStoredCore >>= \Core.CoreResult {..} -> Nockma.TermCell <$> storedCoreToAnoma _coreResultModule + Sem r NockmaTree.AnomaResult +upToAnoma = upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToAnoma _coreResultModule upToCoreTypecheck :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) => @@ -150,7 +149,7 @@ storedCoreToTree checkId md = do >=> return . Tree.fromCore . Stripped.fromCore fsize . Core.computeCombinedInfoTable $ md -storedCoreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r (Nockma.Cell Natural) +storedCoreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r NockmaTree.AnomaResult storedCoreToAnoma = storedCoreToTree Core.CheckAnoma >=> treeToAnoma storedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable @@ -190,10 +189,7 @@ coreToReg = Core.toStored >=> storedCoreToReg coreToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Casm.Result coreToCasm = Core.toStored >=> storedCoreToCasm -coreToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r (Nockma.Cell Natural) -coreToNockma = coreToTree Core.CheckAnoma >=> treeToNockma - -coreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r (Nockma.Cell Natural) +coreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r NockmaTree.AnomaResult coreToAnoma = coreToTree Core.CheckAnoma >=> treeToAnoma coreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult @@ -221,11 +217,8 @@ treeToCairoAsm = Tree.toCairoAsm >=> return . Asm.fromTree treeToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Reg.InfoTable treeToReg = treeToAsm >=> asmToReg -treeToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural) -treeToNockma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree.fromTreeTable NockmaTree.ProgramCallingConventionJuvix - -treeToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural) -treeToAnoma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree.fromTreeTable NockmaTree.ProgramCallingConventionAnoma +treeToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r (NockmaTree.AnomaResult) +treeToAnoma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree.fromTreeTable treeToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r C.MiniCResult treeToMiniC = treeToAsm >=> asmToMiniC @@ -251,11 +244,8 @@ regToMiniC tab = do regToCasm :: Reg.InfoTable -> Sem r Casm.Result regToCasm = Reg.toCasm >=> return . Casm.fromReg -treeToNockma' :: (Members '[Error JuvixError, Reader NockmaTree.CompilerOptions] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural) -treeToNockma' = Tree.toNockma >=> NockmaTree.fromTreeTable NockmaTree.ProgramCallingConventionJuvix - -treeToAnoma' :: (Members '[Error JuvixError, Reader NockmaTree.CompilerOptions] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural) -treeToAnoma' = Tree.toNockma >=> NockmaTree.fromTreeTable NockmaTree.ProgramCallingConventionAnoma +treeToAnoma' :: (Members '[Error JuvixError, Reader NockmaTree.CompilerOptions] r) => Tree.InfoTable -> Sem r NockmaTree.AnomaResult +treeToAnoma' = Tree.toNockma >=> NockmaTree.fromTreeTable asmToMiniC' :: (Members '[Error JuvixError, Reader Asm.Options] r) => Asm.InfoTable -> Sem r C.MiniCResult asmToMiniC' = mapError (JuvixError @Asm.AsmError) . Asm.toReg' >=> regToMiniC' . Reg.fromAsm diff --git a/src/Juvix/Extra/Strings.hs b/src/Juvix/Extra/Strings.hs index c7a2c1b3a9..c0fc49bf27 100644 --- a/src/Juvix/Extra/Strings.hs +++ b/src/Juvix/Extra/Strings.hs @@ -689,6 +689,9 @@ instrAdd = "add" argsTag :: (IsString s) => s argsTag = "args@" +tagTag :: (IsString s) => s +tagTag = "tag@" + stdlibTag :: (IsString s) => s stdlibTag = "stdlib@" @@ -982,3 +985,6 @@ package = "package" version :: (IsString s) => s version = "version" + +functionsPlaceholder :: (IsString s) => s +functionsPlaceholder = "functions_placeholder" diff --git a/test/Anoma/Compilation.hs b/test/Anoma/Compilation.hs index 2013fcb7fd..aaa0697f66 100644 --- a/test/Anoma/Compilation.hs +++ b/test/Anoma/Compilation.hs @@ -1,7 +1,8 @@ module Anoma.Compilation where +import Anoma.Compilation.Negative qualified as N import Anoma.Compilation.Positive qualified as P import Base allTests :: TestTree -allTests = testGroup "Compilation to Anoma" [P.allTests] +allTests = testGroup "Compilation to Anoma" [P.allTests, N.allTests] diff --git a/test/Anoma/Compilation/Negative.hs b/test/Anoma/Compilation/Negative.hs new file mode 100644 index 0000000000..4749e996b1 --- /dev/null +++ b/test/Anoma/Compilation/Negative.hs @@ -0,0 +1,47 @@ +module Anoma.Compilation.Negative where + +import Base +import Juvix.Compiler.Backend (Target (TargetAnoma)) +import Juvix.Compiler.Core.Error +import Juvix.Prelude qualified as Prelude + +root :: Prelude.Path Abs Dir +root = relToProject $(mkRelDir "tests/Anoma/Compilation/negative") + +type CheckError = JuvixError -> IO () + +mkAnomaNegativeTest :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> CheckError -> TestTree +mkAnomaNegativeTest testName' relRoot mainFile testCheck = + testCase (unpack testName') mkTestIO + where + mkTestIO :: IO () + mkTestIO = do + merr <- withRootCopy compileMain + case merr of + Nothing -> assertFailure "expected compilation to fail" + Just err -> testCheck err + + withRootCopy :: (Prelude.Path Abs Dir -> IO a) -> IO a + withRootCopy action = withSystemTempDir "test" $ \tmpRootDir -> do + copyDirRecur root tmpRootDir + action tmpRootDir + + compileMain :: Prelude.Path Abs Dir -> IO (Maybe JuvixError) + compileMain rootCopyDir = do + let testRootDir = rootCopyDir relRoot + entryPoint <- + set entryPointTarget TargetAnoma + <$> testDefaultEntryPointIO testRootDir (testRootDir mainFile) + either Just (const Nothing) <$> testRunIOEither entryPoint upToAnoma + +checkCoreError :: CheckError +checkCoreError e = + unless + (isJust (fromJuvixError @CoreError e)) + (assertFailure ("Expected core error got: " <> unpack (renderTextDefault e))) + +allTests :: TestTree +allTests = + testGroup + "Anoma negative tests" + [mkAnomaNegativeTest "Use of Strings" $(mkRelDir ".") $(mkRelFile "String.juvix") checkCoreError] diff --git a/test/Anoma/Compilation/Positive.hs b/test/Anoma/Compilation/Positive.hs index 17e8a922f6..5629873b84 100644 --- a/test/Anoma/Compilation/Positive.hs +++ b/test/Anoma/Compilation/Positive.hs @@ -3,13 +3,12 @@ module Anoma.Compilation.Positive where import Base import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Backend (Target (TargetAnoma)) +import Juvix.Compiler.Nockma.Anoma import Juvix.Compiler.Nockma.Evaluator import Juvix.Compiler.Nockma.Language -import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Translation.FromSource.QQ import Juvix.Compiler.Nockma.Translation.FromTree import Juvix.Prelude qualified as Prelude -import Nockma.Base import Nockma.Eval.Positive root :: Prelude.Path Abs Dir @@ -21,12 +20,9 @@ mkAnomaCallTest' enableDebug _testProgramStorage _testName relRoot mainFile args where mkTestIO :: IO Test mkTestIO = do - _testProgramSubject <- withRootCopy $ \tmpDir -> do - compiledMain <- compileMain tmpDir - -- Write out the nockma function to force full evaluation of the compiler - writeFileEnsureLn (tmpDir $(mkRelFile "test.nockma")) (ppSerialize compiledMain) - return compiledMain + anomaRes <- withRootCopy compileMain let _testProgramFormula = anomaCall args + _testProgramSubject = anomaRes ^. anomaClosure _testEvalOptions = defaultEvalOptions _testAssertEvalError :: Maybe (NockEvalError Natural -> Assertion) = Nothing return Test {..} @@ -36,7 +32,7 @@ mkAnomaCallTest' enableDebug _testProgramStorage _testName relRoot mainFile args copyDirRecur root tmpRootDir action tmpRootDir - compileMain :: Prelude.Path Abs Dir -> IO (Term Natural) + compileMain :: Prelude.Path Abs Dir -> IO AnomaResult compileMain rootCopyDir = do let testRootDir = rootCopyDir relRoot entryPoint <- diff --git a/test/Nockma/Base.hs b/test/Nockma/Base.hs deleted file mode 100644 index 3ea0814ee6..0000000000 --- a/test/Nockma/Base.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Nockma.Base where - -import Base -import Juvix.Compiler.Nockma.Language -import Juvix.Compiler.Nockma.Translation.FromTree - --- | Call a function at the head of the subject using the Anoma calling convention -anomaCall :: [Term Natural] -> Term Natural -anomaCall args = case nonEmpty args of - Just args' -> OpCall # [L] # OpReplace # ([R, L] # foldTerms args') # (OpAddress # emptyPath) - Nothing -> OpCall # [L] # (OpAddress # emptyPath) diff --git a/test/Nockma/Compile/Tree/Positive.hs b/test/Nockma/Compile/Tree/Positive.hs index 5458bc6277..26ec03f1aa 100644 --- a/test/Nockma/Compile/Tree/Positive.hs +++ b/test/Nockma/Compile/Tree/Positive.hs @@ -1,6 +1,7 @@ module Nockma.Compile.Tree.Positive where import Base +import Juvix.Compiler.Nockma.Anoma import Juvix.Compiler.Nockma.EvalCompiled import Juvix.Compiler.Nockma.Evaluator qualified as NockmaEval import Juvix.Compiler.Nockma.Language @@ -13,20 +14,20 @@ import Tree.Eval.Positive qualified as Tree runNockmaAssertion :: Handle -> Symbol -> InfoTable -> IO () runNockmaAssertion hout _main tab = do - Nockma.Cell nockSubject nockMain <- + anomaRes :: AnomaResult <- runM . runErrorIO' @JuvixError . runReader opts - $ treeToNockma' tab + $ treeToAnoma' tab res <- runM . runOutputSem @(Term Natural) - (hPutStrLn hout . Nockma.ppPrint) + (hPutStrLn hout . Nockma.ppTest) . runReader NockmaEval.defaultEvalOptions - . evalCompiledNock' nockSubject - $ nockMain + . NockmaEval.ignoreOpCounts + $ evalCompiledNock' (anomaRes ^. anomaClosure) (anomaCall []) let ret = getReturn res - whenJust ret (hPutStrLn hout . Nockma.ppPrint) + whenJust ret (hPutStrLn hout . Nockma.ppTest) where opts :: CompilerOptions opts = diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index f0402a68df..4ffb3ebfff 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -3,12 +3,12 @@ module Nockma.Eval.Positive where import Base hiding (Path, testName) import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Core.Language.Base (defaultSymbol) +import Juvix.Compiler.Nockma.Anoma import Juvix.Compiler.Nockma.Evaluator import Juvix.Compiler.Nockma.Language import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Translation.FromSource.QQ import Juvix.Compiler.Nockma.Translation.FromTree -import Nockma.Base type Check = Sem '[Reader [Term Natural], Reader (Term Natural), EmbedIO] @@ -87,21 +87,7 @@ eqTraces expected = do compilerTest :: Text -> Term Natural -> Check () -> Bool -> Test compilerTest n mainFun _testCheck _evalInterceptStdlibCalls = - let f = - CompilerFunction - { _compilerFunctionName = UserFunction (defaultSymbol 0), - _compilerFunctionArity = 0, - _compilerFunction = return mainFun - } - _testName :: Text - | _evalInterceptStdlibCalls = n <> " - intercept stdlib" - | otherwise = n - opts = CompilerOptions {_compilerOptionsEnableTrace = False} - Cell _testProgramSubject _testProgramFormula = runCompilerWithJuvix opts mempty [] f - _testEvalOptions = EvalOptions {..} - _testProgramStorage :: Storage Natural = emptyStorage - _testAssertEvalError :: Maybe (NockEvalError Natural -> Assertion) = Nothing - in Test {..} + anomaTest n mainFun [] _testCheck _evalInterceptStdlibCalls withAssertErrKeyNotInStorage :: Test -> Test withAssertErrKeyNotInStorage Test {..} = @@ -127,7 +113,8 @@ anomaTest n mainFun args _testCheck _evalInterceptStdlibCalls = opts = CompilerOptions {_compilerOptionsEnableTrace = False} - _testProgramSubject = TermCell (runCompilerWithAnoma opts mempty [] f) + res :: AnomaResult = runCompilerWith opts mempty [] f + _testProgramSubject = res ^. anomaClosure _testProgramFormula = anomaCall args _testProgramStorage :: Storage Natural = emptyStorage @@ -146,7 +133,15 @@ anomaCallingConventionTests = [True, False] <**> [ anomaTest "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) [] (eqNock [nock| 3 |]), anomaTest "stdlib add with arg" (add (nockNatLiteral 1) (nockNatLiteral 2)) [nockNatLiteral 1] (eqNock [nock| 3 |]), - anomaTest "stdlib sub args" (sub (OpAddress # pathToArg 0) (OpAddress # pathToArg 1)) [nockNatLiteral 3, nockNatLiteral 1] (eqNock [nock| 2 |]) + let args = [nockNatLiteral 3, nockNatLiteral 1] + fx = + FunctionCtx + { _functionCtxArity = fromIntegral (length args) + } + in run . runReader fx $ do + p0 <- pathToArg 0 + p1 <- pathToArg 1 + return (anomaTest "stdlib sub args" (sub (OpAddress # p0) (OpAddress # p1)) args (eqNock [nock| 2 |])) ] juvixCallingConventionTests :: [Test] @@ -163,7 +158,39 @@ juvixCallingConventionTests = compilerTest "stdlib pow2" (pow2 (nockNatLiteral 3)) (eqNock [nock| 8 |]), compilerTest "stdlib nested" (dec (dec (nockNatLiteral 20))) (eqNock [nock| 18 |]), compilerTest "append rights - empty" (appendRights emptyPath (nockNatLiteral 3)) (eqNock (toNock [R, R, R])), - compilerTest "append rights" (appendRights [L, L] (nockNatLiteral 3)) (eqNock (toNock [L, L, R, R, R])) + compilerTest "append rights" (appendRights [L, L] (nockNatLiteral 3)) (eqNock (toNock [L, L, R, R, R])), + compilerTest "opAddress" ((OpQuote # (foldTerms (toNock @Natural <$> (5 :| [6, 1])))) >># opAddress' (OpQuote # [R, R])) (eqNock (toNock @Natural 1)), + compilerTest "foldTermsOrNil (empty)" (foldTermsOrNil []) (eqNock (nockNilTagged "expected-result")), + let l :: NonEmpty Natural = 1 :| [2] + l' :: NonEmpty (Term Natural) = nockNatLiteral <$> l + in compilerTest "foldTermsOrNil (non-empty)" (foldTermsOrNil (toList l')) (eqNock (foldTerms (toNock @Natural <$> l))), + let l :: NonEmpty (Term Natural) = toNock <$> nonEmpty' [1 :: Natural .. 3] + in compilerTest "list to tuple" (listToTuple (OpQuote # makeList (toList l)) (nockIntegralLiteral (length l))) $ + eqNock (foldTerms l), + let l :: Term Natural = OpQuote # foldTerms (toNock @Natural <$> (1 :| [2, 3])) + in compilerTest "replaceSubterm'" (replaceSubterm' l (OpQuote # toNock [R]) (OpQuote # (toNock @Natural 999))) (eqNock (toNock @Natural 1 # toNock @Natural 999)), + let lst :: [Term Natural] = toNock @Natural <$> [1, 2, 3] + len = nockIntegralLiteral (length lst) + l :: Term Natural = OpQuote # makeList lst + in compilerTest "append" (append l len l) (eqNock (makeList (lst ++ lst))), + let l :: [Natural] = [1, 2] + r :: NonEmpty Natural = 3 :| [4] + res :: Term Natural = foldTerms (toNock <$> prependList l r) + lenL :: Term Natural = nockIntegralLiteral (length l) + lenR :: Term Natural = nockIntegralLiteral (length r) + lstL = OpQuote # makeList (map toNock l) + tupR = OpQuote # foldTerms (toNock <$> r) + in compilerTest "appendToTuple (left non-empty, right non-empty)" (appendToTuple lstL lenL tupR lenR) (eqNock res), + let l :: NonEmpty Natural = 1 :| [2] + res :: Term Natural = foldTerms (toNock <$> l) + lenL :: Term Natural = nockIntegralLiteral (length l) + lstL = OpQuote # makeList (toNock <$> (toList l)) + in compilerTest "appendToTuple (left non-empty, right empty)" (appendToTuple lstL lenL (OpQuote # nockNilTagged "appendToTuple") (nockNatLiteral 0)) (eqNock res), + let r :: NonEmpty Natural = 3 :| [4] + res :: Term Natural = foldTerms (toNock <$> r) + lenR :: Term Natural = nockIntegralLiteral (length r) + tupR = OpQuote # foldTerms (toNock <$> r) + in compilerTest "appendToTuple (left empty, right-nonempty)" (appendToTuple (OpQuote # nockNilTagged "test-appendtotuple") (nockNatLiteral 0) tupR lenR) (eqNock res) ] unitTests :: [Test] diff --git a/tests/Anoma/Compilation/negative/String.juvix b/tests/Anoma/Compilation/negative/String.juvix new file mode 100644 index 0000000000..c76ee3ea2d --- /dev/null +++ b/tests/Anoma/Compilation/negative/String.juvix @@ -0,0 +1,5 @@ +module String; + +import Stdlib.Prelude open; + +main : String := "boom";