Replace polysemy by effectful (#2663)

The following benchmark compares juvix 0.6.0 with polysemy and a new version (implemented in this pr) which replaces polysemy by effectful. # Typecheck standard library without caching ``` hyperfine --warmup 2 --prepare 'juvix-polysemy clean' 'juvix-polysemy typecheck Stdlib/Prelude.juvix' 'juvix-effectful typecheck Stdlib/Prelude.juvix' Benchmark 1: juvix-polysemy typecheck Stdlib/Prelude.juvix Time (mean ± σ): 3.924 s ± 0.143 s [User: 3.787 s, System: 0.084 s] Range (min … max): 3.649 s … 4.142 s 10 runs Benchmark 2: juvix-effectful typecheck Stdlib/Prelude.juvix Time (mean ± σ): 2.558 s ± 0.074 s [User: 2.430 s, System: 0.084 s] Range (min … max): 2.403 s … 2.646 s 10 runs Summary juvix-effectful typecheck Stdlib/Prelude.juvix ran 1.53 ± 0.07 times faster than juvix-polysemy typecheck Stdlib/Prelude.juvix ``` # Typecheck standard library with caching ``` hyperfine --warmup 1 'juvix-effectful typecheck Stdlib/Prelude.juvix' 'juvix-polysemy typecheck Stdlib/Prelude.juvix' --min-runs 20 Benchmark 1: juvix-effectful typecheck Stdlib/Prelude.juvix Time (mean ± σ): 1.194 s ± 0.068 s [User: 0.979 s, System: 0.211 s] Range (min … max): 1.113 s … 1.307 s 20 runs Benchmark 2: juvix-polysemy typecheck Stdlib/Prelude.juvix Time (mean ± σ): 1.237 s ± 0.083 s [User: 0.997 s, System: 0.231 s] Range (min … max): 1.061 s … 1.476 s 20 runs Summary juvix-effectful typecheck Stdlib/Prelude.juvix ran 1.04 ± 0.09 times faster than juvix-polysemy typecheck Stdlib/Prelude.juvix ```
anoma · Mar 21, 2024 · 3a4cbc7 · 3a4cbc7
1 parent 9234658
commit 3a4cbc7
Show file tree

Hide file tree

Showing 100 changed files with 897 additions and 833 deletions.
diff --git a/app/App.hs b/app/App.hs
@@ -15,7 +15,7 @@ import Juvix.Prelude.Pretty hiding
   )
 import System.Console.ANSI qualified as Ansi
 
-data App m a where
+data App :: Effect where
   ExitMsg :: ExitCode -> Text -> App m a
   ExitFailMsg :: Text -> App m a
   ExitJuvixError :: JuvixError -> App m a
@@ -60,15 +60,15 @@ reAppIO ::
   Sem (App ': r) a ->
   Sem (SCache Package ': r) a
 reAppIO args@RunAppIOArgs {..} =
-  reinterpret $ \case
+  interpretTop $ \case
     AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase])
     FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath)
     GetMainFile m -> getMainFile' m
     FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath))
     RenderStdOut t
       | _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return ()
-      | otherwise -> embed $ do
-          sup <- Ansi.hSupportsANSIColor stdout
+      | otherwise -> do
+          sup <- liftIO (Ansi.hSupportsANSIColor stdout)
           renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t
     AskGlobalOptions -> return _runAppIOArgsGlobalOptions
     AskPackage -> getPkg
@@ -87,7 +87,7 @@ reAppIO args@RunAppIOArgs {..} =
       exitFailure
     ExitMsg exitCode t -> exitMsg' (exitWith exitCode) t
     ExitFailMsg t -> exitMsg' exitFailure t
-    SayRaw b -> embed (ByteString.putStr b)
+    SayRaw b -> liftIO (ByteString.putStr b)
   where
     getPkg :: (Members '[SCache Package] r') => Sem r' Package
     getPkg = cacheSingletonGet
@@ -161,7 +161,7 @@ someBaseToAbs' f = do
 filePathToAbs :: (Members '[EmbedIO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir))
 filePathToAbs fp = do
   invokeDir <- askInvokeDir
-  embed (fromPreFileOrDir invokeDir fp)
+  fromPreFileOrDir invokeDir fp
 
 askGenericOptions :: (Members '[App] r) => Sem r GenericOptions
 askGenericOptions = project <$> askGlobalOptions

diff --git a/app/AsmInterpreter.hs b/app/AsmInterpreter.hs
@@ -34,4 +34,4 @@ runAsm bValidate tab =
       Asm.FunctionInfo ->
       Sem r (Either Asm.AsmError Asm.Val)
     doRun tab' funInfo =
-      embed $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo)
+      liftIO $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo)
diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs
@@ -160,7 +160,7 @@ runNockmaPipeline pa@PipelineArg {..} = do
   let code = Nockma.ppSerialize tab'
   writeFileEnsureLn nockmaFile code
 
-runAnomaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
+runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
 runAnomaPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa
   nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
@@ -173,7 +173,7 @@ runAnomaPipeline pa@PipelineArg {..} = do
   let code = Nockma.ppSerialize tab'
   writeFileEnsureLn nockmaFile code
 
-runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
+runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
 runCasmPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa
   casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile

diff --git a/app/Commands/Dev/Core/Repl.hs b/app/Commands/Dev/Core/Repl.hs
@@ -28,8 +28,8 @@ parseText = Core.runParser replPath defaultModuleId
 runRepl :: forall r. (Members '[EmbedIO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r ()
 runRepl opts tab = do
   putStr "> "
-  embed (hFlush stdout)
-  done <- embed isEOF
+  liftIO (hFlush stdout)
+  done <- liftIO isEOF
   unless done $ do
     s <- getLine
     case fromText (strip s) of

diff --git a/app/Commands/Dev/Geb/Repl.hs b/app/Commands/Dev/Geb/Repl.hs
@@ -41,17 +41,15 @@ runCommand replOpts = do
         gopts <- State.gets (^. replStateGlobalOptions)
         absInputFile :: Path Abs File <- replMakeAbsolute inputFile
         set entryPointTarget Backend.TargetGeb
-          <$> liftIO (runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts)))
-  embed
-    ( State.evalStateT
-        (replAction replOpts getReplEntryPoint)
-        ( ReplState
-            { _replContextEntryPoint = Nothing,
-              _replStateGlobalOptions = globalOptions,
-              _replStateInvokeDir = invokeDir
-            }
-        )
-    )
+          <$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts))
+  liftIO
+    . State.evalStateT
+      (replAction replOpts getReplEntryPoint)
+    $ ReplState
+      { _replContextEntryPoint = Nothing,
+        _replStateGlobalOptions = globalOptions,
+        _replStateInvokeDir = invokeDir
+      }
 
 loadEntryPoint :: EntryPoint -> Repl ()
 loadEntryPoint ep = do

diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs
@@ -173,7 +173,7 @@ replAction =
 runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaReplOptions -> Sem r ()
 runCommand opts = do
   mt :: Maybe (Term Natural) <- mapM iniStack (opts ^. nockmaReplOptionsStackFile)
-  embed . (`State.evalStateT` (iniState mt)) $ replAction
+  liftIO . (`State.evalStateT` (iniState mt)) $ replAction
   where
     iniStack :: AppPath File -> Sem r (Term Natural)
     iniStack af = do

diff --git a/app/Commands/Dev/Reg/Run.hs b/app/Commands/Dev/Reg/Run.hs
@@ -5,7 +5,7 @@ import Commands.Dev.Reg.Run.Options
 import Juvix.Compiler.Reg.Translation.FromSource qualified as Reg
 import RegInterpreter
 
-runCommand :: forall r. (Members '[Embed IO, App] r) => RegRunOptions -> Sem r ()
+runCommand :: forall r. (Members '[EmbedIO, App] r) => RegRunOptions -> Sem r ()
 runCommand opts = do
   afile :: Path Abs File <- fromAppPathFile file
   s <- readFile afile

diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs
@@ -117,7 +117,7 @@ runNockmaPipeline pa@PipelineArg {..} = do
   let code = Nockma.ppSerialize tab'
   writeFileEnsureLn nockmaFile code
 
-runAnomaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
+runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
 runAnomaPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa
   nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
@@ -130,7 +130,7 @@ runAnomaPipeline pa@PipelineArg {..} = do
   let code = Nockma.ppSerialize tab'
   writeFileEnsureLn nockmaFile code
 
-runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
+runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
 runCasmPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa
   casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile

diff --git a/app/Commands/Dev/Tree/Eval/Options.hs b/app/Commands/Dev/Tree/Eval/Options.hs
@@ -6,7 +6,6 @@ import Prelude (show)
 
 data Evaluator
   = EvalEffectful
-  | EvalSem
   | EvalRaw
   deriving stock (Eq, Bounded, Enum, Data)
 
@@ -16,7 +15,6 @@ defaultEvaluator = EvalEffectful
 instance Show Evaluator where
   show = \case
     EvalEffectful -> "effectful"
-    EvalSem -> "polysemy"
     EvalRaw -> "raw"
 
 instance Pretty Evaluator where

diff --git a/app/Commands/Dev/Tree/Repl.hs b/app/Commands/Dev/Tree/Repl.hs
@@ -128,7 +128,7 @@ replAction =
       }
 
 runCommand :: forall r. (Members '[EmbedIO, App] r) => TreeReplOptions -> Sem r ()
-runCommand _ = embed . (`State.evalStateT` iniState) $ replAction
+runCommand _ = liftIO . (`State.evalStateT` iniState) $ replAction
   where
     iniState :: ReplState
     iniState =

diff --git a/app/Commands/Doctor.hs b/app/Commands/Doctor.hs
@@ -82,7 +82,7 @@ checkWasmLd clangPath errMsg =
 checkClangTargetSupported :: (Members DoctorEff r) => Path Abs File -> String -> [Text] -> Sem r ()
 checkClangTargetSupported clangPath target errMsg = do
   (code, _, _) <-
-    embed
+    liftIO
       ( P.readProcessWithExitCode
           (toFilePath clangPath)
           ["-target", target, "--print-supported-cpus"]
@@ -92,14 +92,14 @@ checkClangTargetSupported clangPath target errMsg = do
 
 checkClangVersion :: (Members DoctorEff r) => Path Abs File -> Integer -> [Text] -> Sem r ()
 checkClangVersion clangPath expectedVersion errMsg = do
-  versionString <- embed (P.readProcess (toFilePath clangPath) ["-dumpversion"] "")
+  versionString <- liftIO (P.readProcess (toFilePath clangPath) ["-dumpversion"] "")
   case headMay (splitOn "." versionString) >>= readMaybe of
     Just majorVersion -> unless (majorVersion >= expectedVersion) (mapM_ warning errMsg)
     Nothing -> warning "Could not determine clang version"
 
 checkEnvVarSet :: (Members DoctorEff r) => String -> [Text] -> Sem r ()
 checkEnvVarSet var errMsg = do
-  whenM (isNothing <$> embed (E.lookupEnv var)) (mapM_ warning errMsg)
+  whenM (isNothing <$> liftIO (E.lookupEnv var)) (mapM_ warning errMsg)
 
 getLatestRelease :: (Members '[EmbedIO, Fail] r) => Sem r GithubRelease
 getLatestRelease = do
@@ -114,7 +114,7 @@ checkVersion = do
   let tagName = "v" <> V.versionDoc
   response <- runFail getLatestRelease
   case response of
-    Just release -> case release ^. githubReleaseTagName of
+    Just release' -> case release' ^. githubReleaseTagName of
       Just latestTagName -> unless (tagName == latestTagName) (warning ("Newer Juvix version is available from https://github.com/anoma/juvix/releases/tag/" <> latestTagName))
       Nothing -> warning "Tag name is not present in release JSON from Github API"
     Nothing -> warning "Network error when fetching data from Github API"

diff --git a/app/Commands/Eval.hs b/app/Commands/Eval.hs
@@ -11,15 +11,14 @@ runCommand opts@EvalOptions {..} = do
   gopts <- askGlobalOptions
   Core.CoreResult {..} <- runPipeline _evalInputFile upToCore
   let r =
-        run $
-          runReader (project gopts) $
-            runError @JuvixError $
-              (Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module)
+        run
+          . runReader (project gopts)
+          . runError @JuvixError
+          $ (Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module)
   tab <- Core.computeCombinedInfoTable <$> getRight r
-  let mevalNode =
-        if
-            | isJust _evalSymbolName -> getNode tab (selInfo tab)
-            | otherwise -> getNode tab (mainInfo tab)
+  let mevalNode
+        | isJust _evalSymbolName = getNode tab (selInfo tab)
+        | otherwise = getNode tab (mainInfo tab)
   case mevalNode of
     Just evalNode ->
       Eval.evalAndPrint gopts opts tab evalNode

diff --git a/app/Commands/Extra/Compile.hs b/app/Commands/Extra/Compile.hs
@@ -73,7 +73,7 @@ prepareRuntime buildDir o = do
 
     writeRuntime :: BS.ByteString -> Sem r ()
     writeRuntime =
-      embed
+      liftIO
         . BS.writeFile (toFilePath (buildDir <//> $(mkRelFile "libjuvix.a")))
 
     headersDir :: [(Path Rel File, BS.ByteString)]
@@ -83,7 +83,7 @@ prepareRuntime buildDir o = do
     includeDir = juvixIncludeDir buildDir
 
     writeHeader :: (Path Rel File, BS.ByteString) -> Sem r ()
-    writeHeader (filePath, contents) = embed $ do
+    writeHeader (filePath, contents) = liftIO $ do
       ensureDir (includeDir <//> parent filePath)
       BS.writeFile (toFilePath (includeDir <//> filePath)) contents
 
@@ -160,7 +160,7 @@ clangWasmWasiCompile inputFile o = do
     sysrootEnvVar :: Sem r (Path Abs Dir)
     sysrootEnvVar =
       absDir
-        <$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH"))
+        <$> fromMaybeM (throw msg) (liftIO (lookupEnv "WASI_SYSROOT_PATH"))
       where
         msg :: Text
         msg = "Missing environment variable WASI_SYSROOT_PATH"
@@ -240,7 +240,7 @@ findClangUsingEnvVar = do
   join <$> mapM checkExecutable p
   where
     checkExecutable :: Path Abs File -> Sem r (Maybe (Path Abs File))
-    checkExecutable p = whenMaybeM (embed (isExecutable p)) (return p)
+    checkExecutable p = whenMaybeM (liftIO (isExecutable p)) (return p)
 
     clangBinPath :: Sem r (Maybe (Path Abs File))
     clangBinPath = fmap (<//> $(mkRelFile "bin/clang")) <$> llvmDistPath
@@ -274,7 +274,7 @@ runClang ::
   Sem r ()
 runClang args = do
   cp <- clangBinPath
-  (exitCode, _, err) <- embed (P.readProcessWithExitCode cp args "")
+  (exitCode, _, err) <- liftIO (P.readProcessWithExitCode cp args "")
   case exitCode of
     ExitSuccess -> return ()
     _ -> throw (pack err)

diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs
@@ -45,7 +45,7 @@ targetFromOptions opts = do
                     "Use the --help option to display more usage information."
                   ]
 
-runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Resource, Files] r) => FormatOptions -> Sem r ()
+runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Files] r) => FormatOptions -> Sem r ()
 runCommand opts = do
   target <- targetFromOptions opts
   runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do
@@ -79,7 +79,7 @@ renderModeFromOptions target opts formattedInfo
       | formattedInfo ^. formattedFileInfoContentsModified = res
       | otherwise = NoEdit Silent
 
-renderFormattedOutput :: forall r. (Members '[EmbedIO, App, Resource, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r ()
+renderFormattedOutput :: forall r. (Members '[EmbedIO, App, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r ()
 renderFormattedOutput target opts fInfo = do
   let renderMode = renderModeFromOptions target opts fInfo
   outputResult renderMode

diff --git a/app/Commands/Html.hs b/app/Commands/Html.hs
@@ -19,7 +19,7 @@ runGenOnlySourceHtml HtmlOptions {..} = do
   res <- runPipeline _htmlInputFile upToScoping
   let m = res ^. Scoper.resultModule
   outputDir <- fromAppPathDir _htmlOutputDir
-  embed $
+  liftIO $
     Html.genSourceHtml
       GenSourceHtmlArgs
         { _genSourceHtmlArgsAssetsDir = _htmlAssetsPrefix,
@@ -80,13 +80,11 @@ runCommand HtmlOptions {..}
       when _htmlOpen $ case openCmd of
         Nothing -> say "Could not recognize the 'open' command for your OS"
         Just opencmd ->
-          embed
-            ( void
-                ( Process.spawnProcess
-                    opencmd
-                    [ toFilePath
-                        ( outputDir <//> Html.indexFileName
-                        )
-                    ]
-                )
-            )
+          liftIO
+            . void
+            $ Process.spawnProcess
+              opencmd
+              [ toFilePath
+                  ( outputDir <//> Html.indexFileName
+                  )
+              ]
diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs
@@ -519,7 +519,7 @@ runCommand opts = do
             _replStateGlobalOptions = globalOptions
           }
   e <-
-    embed
+    liftIO
       . Except.runExceptT
       . (`State.evalStateT` iniState)
       . (`Reader.runReaderT` env)
@@ -535,7 +535,7 @@ defaultPreludeEntryPoint = do
   let buildRoot = root ^. rootRootDir
       buildDir = resolveAbsBuildDir buildRoot (root ^. rootBuildDir)
   pkg <- Reader.asks (^. replPackage)
-  mstdlibPath <- liftIO (runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies))))
+  mstdlibPath <- runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies)))
   case mstdlibPath of
     Just stdlibPath ->
       Just
@@ -554,8 +554,7 @@ replExpressionUpToScopedAtoms :: Text -> Repl (Concrete.ExpressionAtoms 'Concret
 replExpressionUpToScopedAtoms txt = do
   ctx <- replGetContext
   x <-
-    liftIO
-      . runM
+    runM
       . runError
       . evalState (ctx ^. replContextArtifacts)
       . runReader (ctx ^. replContextEntryPoint)
@@ -566,8 +565,7 @@ replExpressionUpToTyped :: Text -> Repl Internal.TypedExpression
 replExpressionUpToTyped txt = do
   ctx <- replGetContext
   x <-
-    liftIO
-      . runM
+    runM
       . runError
       . evalState (ctx ^. replContextArtifacts)
       . runReader (ctx ^. replContextEntryPoint)

diff --git a/app/Main.hs b/app/Main.hs
@@ -16,9 +16,7 @@ main = do
   mbuildDir <- mapM (prepathToAbsDir invokeDir) (_runAppIOArgsGlobalOptions ^? globalBuildDir . _Just . pathPath)
   mainFile <- topCommandInputPath cli
   mapM_ checkMainFile mainFile
-  runFinal
-    . resourceToIOFinal
-    . embedToFinal @IO
+  runM
     . runTaggedLockPermissive
     $ do
       _runAppIOArgsRoot <- findRootAndChangeDir (containingDir <$> mainFile) mbuildDir invokeDir

diff --git a/app/RegInterpreter.hs b/app/RegInterpreter.hs
@@ -6,7 +6,7 @@ import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
 import Juvix.Compiler.Reg.Interpreter qualified as Reg
 import Juvix.Compiler.Reg.Pretty qualified as Reg
 
-runReg :: forall r. (Members '[Embed IO, App] r) => Reg.InfoTable -> Sem r ()
+runReg :: forall r. (Members '[EmbedIO, App] r) => Reg.InfoTable -> Sem r ()
 runReg tab =
   case tab ^. Reg.infoMainFunction of
     Just sym -> do

diff --git a/app/TopCommand.hs b/app/TopCommand.hs
@@ -25,7 +25,7 @@ showHelpText = do
       (msg, _) = renderFailure helpText progn
   putStrLn (pack msg)
 
-runTopCommand :: forall r. (Members '[EmbedIO, App, Resource, TaggedLock] r) => TopCommand -> Sem r ()
+runTopCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => TopCommand -> Sem r ()
 runTopCommand = \case
   DisplayVersion -> runDisplayVersion
   DisplayNumericVersion -> runDisplayNumericVersion