Merge branch 'main' into nockma-no-duplication

anoma · Oct 7, 2024 · 7150bd5 · 7150bd5
2 parents f8bd3af + 40b71b9
commit 7150bd5
Show file tree

Hide file tree

Showing 7 changed files with 49 additions and 28 deletions.
diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs
@@ -358,7 +358,6 @@ evalProfile inistack initerm =
             OpReplace -> goOpReplace
             OpHint -> goOpHint
             OpScry -> goOpScry
-            OpTrace -> goOpTrace
           where
             crumb crumbTag =
               EvalCrumbOperator $
@@ -388,20 +387,19 @@ evalProfile inistack initerm =
                 TermCell {} -> nockTrue
                 TermAtom {} -> nockFalse
 
-            goOpTrace :: Sem r (Term a)
-            goOpTrace = do
-              Cell' tr a _ <- withCrumb (crumb crumbDecodeFirst) (asCell (c ^. operatorCellTerm))
-              tr' <- evalArg crumbEvalFirst stack tr
-              output tr'
-              evalArg crumbEvalSecond stack a
-
             goOpHint :: Sem r (Term a)
             goOpHint = do
               Cell' l r _ <- withCrumb (crumb crumbDecodeFirst) (asCell (c ^. operatorCellTerm))
               case l of
                 TAtom {} -> evalArg crumbEvalFirst stack r
-                TCell _t1 t2 -> do
-                  void (evalArg crumbEvalFirst stack t2)
+                TCell t1 t2 -> do
+                  t2' <- evalArg crumbEvalFirst stack t2
+                  putsHint <- fromNatural (nockHintValue NockHintPuts)
+                  case t1 of
+                    TAtom a
+                      | a == putsHint ->
+                          output t2'
+                    _ -> return ()
                   evalArg crumbEvalSecond stack r
 
             goOpPush :: Sem r (Term a)

diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs
@@ -144,7 +144,6 @@ data NockOp
   | OpReplace
   | OpHint
   | OpScry
-  | OpTrace
   deriving stock (Bounded, Enum, Eq, Generic)
 
 instance Hashable NockOp
@@ -164,7 +163,9 @@ instance Pretty NockOp where
     OpReplace -> "replace"
     OpHint -> "hint"
     OpScry -> "scry"
-    OpTrace -> "trace"
+
+data NockHint = NockHintPuts
+  deriving stock (Show, Eq, Enum, Bounded)
 
 textToStdlibFunctionMap :: HashMap Text StdlibFunction
 textToStdlibFunctionMap =
@@ -267,7 +268,6 @@ serializeOp = \case
   OpReplace -> 10
   OpHint -> 11
   OpScry -> 12
-  OpTrace -> 100
 
 class (NockmaEq a) => NockNatural a where
   type ErrNockNatural a :: Type
@@ -325,6 +325,22 @@ nockBoolLiteral b
   | b = nockTrueLiteral
   | otherwise = nockFalseLiteral
 
+nockHintName :: NockHint -> Text
+nockHintName = \case
+  NockHintPuts -> "puts"
+
+nockHintValue :: NockHint -> Natural
+nockHintValue = \case
+  NockHintPuts -> 0x73747570
+
+nockHintAtom :: NockHint -> Term Natural
+nockHintAtom hint =
+  TermAtom
+    Atom
+      { _atomInfo = emptyAtomInfo,
+        _atom = nockHintValue hint
+      }
+
 instance NockNatural Natural where
   type ErrNockNatural Natural = NockNaturalNaturalError
   nockNatural a = return (a ^. atom)

diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs
@@ -151,10 +151,18 @@ atomStringLiteral = do
           }
   return (Atom (textToNatural s) info)
 
+atomNockHint :: Maybe Tag -> Parser (Atom Natural)
+atomNockHint mtag = do
+  symbol Str.percent
+  let hints :: [NockHint] = enumerate
+  val <- choice (map (\hnt -> symbol (nockHintName hnt) >> return (nockHintValue hnt)) hints)
+  return (Atom val emptyAtomInfo {_atomInfoTag = mtag})
+
 patom :: Parser (Atom Natural)
 patom = do
   mtag <- optional pTag
   atomOp mtag
+    <|> atomNockHint mtag
     <|> atomNat mtag
     <|> atomPath mtag
     <|> atomBool

diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs
@@ -96,14 +96,11 @@ data BuiltinFunctionId
 
 instance Hashable BuiltinFunctionId
 
-newtype CompilerOptions = CompilerOptions
-  {_compilerOptionsEnableTrace :: Bool}
+data CompilerOptions = CompilerOptions
 
 fromEntryPoint :: EntryPoint -> CompilerOptions
-fromEntryPoint EntryPoint {..} =
+fromEntryPoint EntryPoint {} =
   CompilerOptions
-    { _compilerOptionsEnableTrace = _entryPointDebug
-    }
 
 data FunctionInfo = FunctionInfo
   { _functionInfoPath :: Path,
@@ -731,7 +728,7 @@ compile = \case
           | enabled ->
               withTemp arg $ \ref -> do
                 val <- addressTempRef ref
-                return $ OpTrace # val # val
+                return $ OpHint # (nockHintAtom NockHintPuts # val) # val
           | otherwise -> return arg
 
     goBinop :: Tree.NodeBinop -> Sem r (Term Natural)
@@ -971,8 +968,7 @@ runCompilerWith opts constrs moduleFuns mainFun =
     compilerCtx =
       emptyCompilerCtx
         { _compilerFunctionInfos = functionInfos,
-          _compilerConstructorInfos = constrs,
-          _compilerOptions = opts
+          _compilerConstructorInfos = constrs
         }
 
     mainClosure :: Term Natural

diff --git a/src/Juvix/Extra/Strings.hs b/src/Juvix/Extra/Strings.hs
@@ -803,6 +803,9 @@ tagTag = "tag@"
 stdlibTag :: (IsString s) => s
 stdlibTag = "stdlib@"
 
+percent :: (IsString s) => s
+percent = "%"
+
 instrSub :: (IsString s) => s
 instrSub = "sub"
 

diff --git a/test/Anoma/Compilation/Positive.hs b/test/Anoma/Compilation/Positive.hs
@@ -40,8 +40,8 @@ mkAnomaCallTest' enableDebug _testProgramStorage _testName relRoot mainFile args
           <$> testDefaultEntryPointIO testRootDir (testRootDir <//> mainFile)
       (^. pipelineResult) . snd <$> testRunIO entryPoint upToAnoma
 
-mkAnomaCallTestNoTrace :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> [Term Natural] -> Check () -> TestTree
-mkAnomaCallTestNoTrace = mkAnomaCallTest' False emptyStorage
+mkAnomaCallTestNoDebug :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> [Term Natural] -> Check () -> TestTree
+mkAnomaCallTestNoDebug = mkAnomaCallTest' False emptyStorage
 
 mkAnomaCallTest :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> [Term Natural] -> Check () -> TestTree
 mkAnomaCallTest = mkAnomaCallTest' True emptyStorage
@@ -78,12 +78,12 @@ allTests =
         $(mkRelFile "test003.juvix")
         []
         (checkNatOutput [1, 4, 2, 4, 0]),
-      mkAnomaCallTestNoTrace
-        "Test003: Integer arithmetic - no trace"
+      mkAnomaCallTestNoDebug
+        "Test003: Integer arithmetic - no debug"
         $(mkRelDir ".")
         $(mkRelFile "test003.juvix")
         []
-        (checkNatOutput [0]),
+        (checkNatOutput [1, 4, 2, 4, 0]),
       mkAnomaCallTest
         "Test005: Higher-order functions"
         $(mkRelDir ".")

diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs
@@ -138,7 +138,7 @@ anomaTest n mainFun args _testCheck _evalInterceptStdlibCalls =
         | _evalInterceptStdlibCalls = n <> " - intercept stdlib"
         | otherwise = n
 
-      opts = CompilerOptions {_compilerOptionsEnableTrace = False}
+      opts = CompilerOptions
 
       res :: AnomaResult = runCompilerWith opts mempty [] f
       _testProgramSubject = res ^. anomaClosure
@@ -302,7 +302,7 @@ unitTests =
     test "push" [nock| [0 1] |] [nock| [push [[suc [@ L]] [@ S]]] |] (eqNock [nock| [1 0 1] |]),
     test "call" [nock| [quote 1] |] [nock| [call [S [@ S]]] |] (eqNock [nock| 1 |]),
     test "replace" [nock| [0 1] |] [nock| [replace [[L [quote 1]] [@ S]]] |] (eqNock [nock| [1 1] |]),
-    test "hint" [nock| [0 1] |] [nock| [hint [nil [trace [quote 2] [quote 3]]] [quote 1]] |] (eqTraces [[nock| 2 |]] >> eqNock [nock| 1 |]),
+    test "hint" [nock| [0 1] |] [nock| [hint [1937012080 [quote 2]] [quote 1]] |] (eqTraces [[nock| 2 |]] >> eqNock [nock| 1 |]),
     testWithStorage [([nock| 111 |], [nock| 222 |])] "scry" [nock| nil |] [nock| [scry [quote nil] [quote 111]] |] (eqNock [nock| 222 |]),
     withAssertErrKeyNotInStorage $ testWithStorage [([nock| 333 |], [nock| 222 |]), ([nock| 3 |], [nock| 222 |])] "scry" [nock| nil |] [nock| [scry [quote nil] [quote 111]] |] (eqNock [nock| 222 |])
   ]