Effectful Juvix tree evaluator (#2623)

This pr implements two additional versions of the Juvix Tree evaluator. Now we have 1. The raw implementation that does not use effects. It throws Haskell exceptions for errors. It uses `unsafePerformIO` for traces. It relies on bang patterns to force strictness and guarantee the expected order of execution (for traces). Avoiding effects allows for improved execution efficiency. 2. [`polysemy`](https://hackage.haskell.org/package/polysemy-1.9.1.3) based implementation. 3. [`effectful-core`](https://hackage.haskell.org/package/effectful-core) based implementation. One can specify which evaluator to use thus: ``` juvix dev tree eval --evaluator XXX test.jvt ``` where XXX is one of `raw`, `polysemy`, `effectful`. # Preliminary benchmarks More thorough benchmarks should be run, but here are some preliminary results: ## Test032 (Fibonacci 20) I've adapted test032 so that it main is a single call to fibonacci of 20. Command: ``` hyperfine --warmup 2 --runs 10 'juvix dev tree eval test032.jvt --evaluator polysemy' 'juvix dev tree eval test032.jvt --evaluator raw' 'juvix dev tree eval test032.jvt --evaluator e ffectful' ``` Output: ``` Benchmark 1: juvix dev tree eval test032.jvt --evaluator polysemy Time (mean ± σ): 2.133 s ± 0.040 s [User: 2.113 s, System: 0.016 s] Range (min … max): 2.088 s … 2.227 s 10 runs Benchmark 2: juvix dev tree eval test032.jvt --evaluator raw Time (mean ± σ): 308.7 ms ± 13.8 ms [User: 293.6 ms, System: 14.1 ms] Range (min … max): 286.5 ms … 330.1 ms 10 runs Benchmark 3: juvix dev tree eval test032.jvt --evaluator effectful Time (mean ± σ): 366.0 ms ± 2.8 ms [User: 345.4 ms, System: 19.4 ms] Range (min … max): 362.5 ms … 372.6 ms 10 runs Summary juvix dev tree eval test032.jvt --evaluator raw ran 1.19 ± 0.05 times faster than juvix dev tree eval test032.jvt --evaluator effectful 6.91 ± 0.34 times faster than juvix dev tree eval test032.jvt --evaluator polysemy ``` ## Test034 (Higher-order function composition) A modified version of test034 where main defined as `call[exp](3, 12)` Command: ``` hyperfine --warmup 2 --runs 10 'juvix dev tree eval test034.jvt --evaluator polysemy' 'juvix dev tree eval test034.jvt --evaluator raw' 'juvix dev tree eval test034.jvt --evaluator effectful' ``` Output: ``` Benchmark 1: juvix dev tree eval test034.jvt --evaluator polysemy Time (mean ± σ): 7.025 s ± 0.184 s [User: 6.518 s, System: 0.469 s] Range (min … max): 6.866 s … 7.327 s 10 runs Benchmark 2: juvix dev tree eval test034.jvt --evaluator raw Time (mean ± σ): 835.6 ms ± 7.4 ms [User: 757.2 ms, System: 75.9 ms] Range (min … max): 824.7 ms … 847.4 ms 10 runs Benchmark 3: juvix dev tree eval test034.jvt --evaluator effectful Time (mean ± σ): 1.578 s ± 0.010 s [User: 1.427 s, System: 0.143 s] Range (min … max): 1.563 s … 1.595 s 10 runs Summary juvix dev tree eval test034.jvt --evaluator raw ran 1.89 ± 0.02 times faster than juvix dev tree eval test034.jvt --evaluator effectful 8.41 ± 0.23 times faster than juvix dev tree eval test034.jvt --evaluator polysemy ``` ## Test036 (Streams without memoization) A modified version of test036 where main defined as `call[nth](700, call[primes]())` Command: ``` hyperfine --warmup 2 --runs 5 'juvix dev tree eval test036.jvt --evaluator polysemy' 'juvix dev tree eval test036.jvt --evaluator raw' 'juvix dev tree eval test036.jvt --evaluator effectful' ``` Output: ``` Benchmark 1: juvix dev tree eval test036.jvt --evaluator polysemy Time (mean ± σ): 1.993 s ± 0.026 s [User: 1.946 s, System: 0.043 s] Range (min … max): 1.969 s … 2.023 s 5 runs Benchmark 2: juvix dev tree eval test036.jvt --evaluator raw Time (mean ± σ): 137.5 ms ± 7.1 ms [User: 127.5 ms, System: 8.9 ms] Range (min … max): 132.8 ms … 149.8 ms 5 runs Benchmark 3: juvix dev tree eval test036.jvt --evaluator effectful Time (mean ± σ): 329.0 ms ± 7.3 ms [User: 289.3 ms, System: 37.4 ms] Range (min … max): 319.9 ms … 336.0 ms 5 runs Summary juvix dev tree eval test036.jvt --evaluator raw ran 2.39 ± 0.13 times faster than juvix dev tree eval test036.jvt --evaluator effectful 14.50 ± 0.77 times faster than juvix dev tree eval test036.jvt --evaluator polysemy ```
anoma · Feb 8, 2024 · 8dfe2ba · 8dfe2ba
1 parent 652c0e8
commit 8dfe2ba
Show file tree

Hide file tree

Showing 9 changed files with 827 additions and 18 deletions.
diff --git a/app/Commands/Dev/Tree/Eval.hs b/app/Commands/Dev/Tree/Eval.hs
@@ -11,7 +11,7 @@ runCommand opts = do
   s <- readFile (toFilePath afile)
   case Tree.runParser (toFilePath afile) s of
     Left err -> exitJuvixError (JuvixError err)
-    Right tab -> evalTree tab
+    Right tab -> evalTree (opts ^. treeEvalEvaluator) tab
   where
     file :: AppPath File
     file = opts ^. treeEvalInputFile
diff --git a/app/Commands/Dev/Tree/Eval/Options.hs b/app/Commands/Dev/Tree/Eval/Options.hs
@@ -1,9 +1,57 @@
 module Commands.Dev.Tree.Eval.Options where
 
 import CommonOptions
+import Juvix.Prelude.Pretty
+import Prelude (show)
 
-newtype TreeEvalOptions = TreeEvalOptions
-  { _treeEvalInputFile :: AppPath File
+data Evaluator
+  = EvalEffectful
+  | EvalSem
+  | EvalRaw
+  deriving stock (Eq, Bounded, Enum, Data)
+
+defaultEvaluator :: Evaluator
+defaultEvaluator = EvalEffectful
+
+instance Show Evaluator where
+  show = \case
+    EvalEffectful -> "effectful"
+    EvalSem -> "polysemy"
+    EvalRaw -> "raw"
+
+instance Pretty Evaluator where
+  pretty = CommonOptions.show
+
+optEvaluator :: Parser Evaluator
+optEvaluator =
+  option
+    (eitherReader parseEvaluator)
+    ( long "evaluator"
+        <> value defaultEvaluator
+        <> metavar "EVALUATOR_NAME"
+        <> completer (mkCompleter (return . compl))
+        <> help "hint: use autocomplete"
+    )
+  where
+    compl :: String -> [String]
+    compl s = filter (isPrefixOf s) (map Prelude.show (allElements @Evaluator))
+
+    parseEvaluator :: String -> Either String Evaluator
+    parseEvaluator s =
+      maybe
+        (Left err)
+        Right
+        ( lookup
+            s
+            [(Prelude.show e, e) | e :: Evaluator <- allElements]
+        )
+      where
+        err :: String
+        err = "Invalid evaluator name. The available names are: " <> Prelude.show (allElements @Evaluator)
+
+data TreeEvalOptions = TreeEvalOptions
+  { _treeEvalInputFile :: AppPath File,
+    _treeEvalEvaluator :: Evaluator
   }
   deriving stock (Data)
 
@@ -12,4 +60,5 @@ makeLenses ''TreeEvalOptions
 parseTreeEvalOptions :: Parser TreeEvalOptions
 parseTreeEvalOptions = do
   _treeEvalInputFile <- parseInputFile FileExtJuvixTree
+  _treeEvalEvaluator <- optEvaluator
   pure TreeEvalOptions {..}
diff --git a/app/Commands/Dev/Tree/Read.hs b/app/Commands/Dev/Tree/Read.hs
@@ -32,5 +32,5 @@ runCommand opts = do
           putStrLn "--------------------------------"
           putStrLn "|            Eval              |"
           putStrLn "--------------------------------"
-          Eval.evalTree tab'
+          Eval.evalTree Eval.defaultEvaluator tab'
       | otherwise = return ()
diff --git a/app/Commands/Dev/Tree/Repl.hs b/app/Commands/Dev/Tree/Repl.hs
@@ -102,7 +102,7 @@ evalNode node = do
             _functionArgNames = [],
             _functionType = TyDynamic
           }
-  et <- Eval.doEval tab fi
+  et <- Eval.doEvalDefault tab fi
   case et of
     Left e -> error (show e)
     Right v ->

diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs
@@ -1,18 +1,25 @@
-module TreeEvaluator where
+module TreeEvaluator
+  ( module TreeEvaluator,
+    module Commands.Dev.Tree.Eval.Options,
+  )
+where
 
 import App
+import Commands.Dev.Tree.Eval.Options
 import CommonOptions
 import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
 import Juvix.Compiler.Tree.Error qualified as Tree
 import Juvix.Compiler.Tree.Evaluator qualified as Tree
+import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff
+import Juvix.Compiler.Tree.EvaluatorSem qualified as TreeSem
 import Juvix.Compiler.Tree.Language.Value qualified as Tree
 import Juvix.Compiler.Tree.Pretty qualified as Tree
 
-evalTree :: forall r. (Members '[Embed IO, App] r) => Tree.InfoTable -> Sem r ()
-evalTree tab =
+evalTree :: forall r. (Members '[Embed IO, App] r) => Evaluator -> Tree.InfoTable -> Sem r ()
+evalTree ev tab =
   case tab ^. Tree.infoMainFunction of
     Just sym -> do
-      r <- liftIO $ doEval tab (Tree.lookupFunInfo tab sym)
+      r <- doEval ev tab (Tree.lookupFunInfo tab sym)
       case r of
         Left err ->
           exitJuvixError (JuvixError err)
@@ -24,10 +31,41 @@ evalTree tab =
     Nothing ->
       exitMsg (ExitFailure 1) "no 'main' function"
 
+doEvalDefault ::
+  (MonadIO m) =>
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEvalDefault = doEval defaultEvaluator
+
 doEval ::
+  (MonadIO m) =>
+  Evaluator ->
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEval = \case
+  EvalEffectful -> doEvalEff
+  EvalRaw -> doEvalRaw
+  EvalSem -> doEvalSem
+
+doEvalRaw ::
+  (MonadIO m) =>
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEvalRaw tab' = liftIO . Tree.catchEvalErrorIO . liftIO . Tree.hEvalIO stdin stdout tab'
+
+doEvalEff ::
+  (MonadIO m) =>
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEvalEff tab' funInfo = Eff.hEvalIOEither stdin stdout tab' funInfo
+
+doEvalSem ::
   (MonadIO m) =>
   Tree.InfoTable ->
   Tree.FunctionInfo ->
   m (Either Tree.TreeError Tree.Value)
-doEval tab' funInfo =
-  liftIO $ Tree.catchEvalErrorIO (liftIO $ Tree.hEvalIO stdin stdout tab' funInfo)
+doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo
diff --git a/package.yaml b/package.yaml
@@ -54,6 +54,9 @@ dependencies:
   - directory == 1.3.*
   - dlist == 1.0.*
   - edit-distance == 0.2.*
+  - effectful == 2.3.*
+  - effectful-core == 2.3.*
+  - effectful-th == 1.0.*
   - exceptions == 0.10.*
   - extra == 1.7.*
   - file-embed == 0.0.*

diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs
@@ -94,7 +94,7 @@ hEval hout tab = eval' [] mempty
         goUnop NodeUnop {..} =
           let !v = eval' args temps _nodeUnopArg
            in case _nodeUnopOpcode of
-                OpShow -> ValString (printValue v)
+                OpShow -> ValString (printValue tab v)
                 OpStrToInt -> goStringUnop strToInt v
                 OpTrace -> goTrace v
                 OpFail -> goFail v
@@ -113,7 +113,7 @@ hEval hout tab = eval' [] mempty
           _ -> evalError "expected a string argument"
 
         goFail :: Value -> Value
-        goFail v = evalError ("failure: " <> printValue v)
+        goFail v = evalError ("failure: " <> printValue tab v)
 
         goArgsNum :: Value -> Value
         goArgsNum = \case
@@ -126,7 +126,7 @@ hEval hout tab = eval' [] mempty
             evalError "expected a closure"
 
         goTrace :: Value -> Value
-        goTrace v = unsafePerformIO (hPutStrLn hout (printValue v) >> return v)
+        goTrace v = unsafePerformIO (hPutStrLn hout (printValue tab v) >> return v)
 
         goConstant :: NodeConstant -> Value
         goConstant NodeConstant {..} = case _nodeConstant of
@@ -260,10 +260,10 @@ hEval hout tab = eval' [] mempty
           let !v = eval' args temps _nodeSaveArg
            in eval' args (BL.cons v temps) _nodeSaveBody
 
-        printValue :: Value -> Text
-        printValue = \case
-          ValString s -> s
-          v -> ppPrint tab v
+printValue :: InfoTable -> Value -> Text
+printValue tab = \case
+  ValString s -> s
+  v -> ppPrint tab v
 
 valueToNode :: Value -> Node
 valueToNode = \case