Automatized benchmarks (#1673)

.gitignore

@@ -87,3 +87,5 @@ docs/org/README.org
 # Binary files (produced by `make check`)
 examples/milestone/HelloWorld/HelloWorld
 hie.yaml
+/.shake/
+/.benchmark-results/

Makefile

@@ -234,3 +234,7 @@ test-shell : install
 changelog-updates :
 	@github_changelog_generator
 	@pandoc CHANGELOG.md --from markdown --to org -o UPDATES-FOR-CHANGELOG.org
+
+.PHONY : bench
+bench: runtime submodules
+	@stack bench

bench/Base.hs

@@ -0,0 +1,122 @@
+module Base where
+
+import Data.Colour
+import Data.Colour.SRGB
+import Development.Shake hiding ((<//>))
+import Juvix.Extra.Paths
+import Juvix.Prelude
+import Prelude (Show (show))
+
+root :: Path Abs Dir
+root = relToProject $(mkRelDir "tests/benchmark")
+
+resultsDir :: Path Abs Dir
+resultsDir = relToProject $(mkRelDir ".benchmark-results")
+
+resultDirs :: [Path Abs Dir]
+resultDirs = [binDir, plotDir, csvDir]
+
+binDir :: Path Abs Dir
+binDir = resultsDir <//> $(mkRelDir "bin")
+
+plotDir :: Path Abs Dir
+plotDir = resultsDir <//> $(mkRelDir "plot")
+
+csvDir :: Path Abs Dir
+csvDir = resultsDir <//> $(mkRelDir "csv")
+
+-- | e.g. 0xf0f8ff (format supported by gnuplot)
+showColour :: Colour Double -> Text
+showColour = pack . ("0x" <>) . dropExact 1 . sRGB24show
+
+data Lang
+  = Ocaml
+  | Haskell
+  | C
+  | Juvix
+  | Runtime
+  | Core
+  deriving stock (Eq)
+
+instance Show Lang where
+  show = \case
+    Ocaml -> "ocaml"
+    Haskell -> "haskell"
+    C -> "c"
+    Juvix -> "juvix"
+    Runtime -> "runtime"
+    Core -> "core"
+
+langPath :: Lang -> Path Rel Dir
+langPath = relDir . Prelude.show
+
+langFile :: Lang -> Path Rel File
+langFile = relFile . Prelude.show
+
+langExtension :: Lang -> String
+langExtension = \case
+  Ocaml -> ".ml"
+  Haskell -> ".hs"
+  C -> ".c"
+  Juvix -> ".juvix"
+  Runtime -> ".c"
+  Core -> ".jvc"
+
+data Variant = Variant
+  { _variantTitle :: Maybe String,
+    _variantLanguage :: Lang,
+    _variantExtensions :: [String],
+    _variantColor :: Colour Double,
+    _variantRun :: Path Abs File -> IO (),
+    _variantBuild :: BuildArgs -> Action ()
+  }
+
+data BuildArgs = BuildArgs
+  { _buildSrc :: Path Abs File,
+    _buildOutDir :: Path Abs Dir
+  }
+
+data Suite = Suite
+  { _suiteTitle :: String,
+    _suiteVariants :: [Variant]
+  }
+
+makeLenses ''Suite
+makeLenses ''BuildArgs
+makeLenses ''Variant
+
+gnuplotFile :: Path Abs File
+gnuplotFile = relToProject $(mkRelFile "gnuplot/bars.gp")
+
+suitePlotFile :: Suite -> Path Abs File
+suitePlotFile s = plotDir <//> suiteBaseFile s
+
+suitePdfFile :: Suite -> Path Abs File
+suitePdfFile s = addExtension' ".pdf" (suitePlotFile s)
+
+suiteSvgFile :: Suite -> Path Abs File
+suiteSvgFile s = addExtension' ".svg" (suitePlotFile s)
+
+suiteCsvFile :: Suite -> Path Abs File
+suiteCsvFile s = addExtension' ".csv" (csvDir <//> suiteBaseFile s)
+
+suiteSrcDir :: Suite -> Path Abs Dir
+suiteSrcDir s = root <//> relDir (s ^. suiteTitle)
+
+suiteBaseFile :: Suite -> Path Rel File
+suiteBaseFile s = relFile (s ^. suiteTitle)
+
+variantSrcDir :: Suite -> Variant -> Path Abs Dir
+variantSrcDir s v = suiteSrcDir s <//> langPath (v ^. variantLanguage)
+
+suitePath :: Suite -> Path Rel Dir
+suitePath s = relDir (s ^. suiteTitle)
+
+variantBinDir :: Suite -> Variant -> Path Abs Dir
+variantBinDir s v = binDir <//> suitePath s <//> langPath (v ^. variantLanguage)
+
+variantBinFile :: Suite -> Variant -> Path Abs File
+variantBinFile s v = variantBinDir s v <//> addExtensions' (v ^. variantExtensions) (suiteBaseFile s)
+
+binFile :: BuildArgs -> [String] -> Path Abs File
+binFile args ext = args ^. buildOutDir <//> replaceExtensions' ext (filename (args ^. buildSrc))

bench/Main.hs

@@ -0,0 +1,124 @@
+module Main where
+
+import Base
+import Criterion.Main
+import Criterion.Main.Options hiding (config)
+import Criterion.Types
+import Data.Text qualified as Text
+import Development.Shake hiding ((<//>))
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path as Path hiding (doesFileExist, (-<.>))
+import Juvix.Prelude.Path qualified as Path
+import Statistics.Types
+import Suites
+
+main :: IO ()
+main = shakeArgs opts compileRules
+  where
+    opts :: ShakeOptions
+    opts = shakeOptions
+
+compileRules :: Rules ()
+compileRules = do
+  phony "clean" $ do
+    putInfo ("Deleting " <> toFilePath resultsDir)
+    removePathForcibly resultsDir
+  forM_ suites suiteRules
+
+suiteRules :: Suite -> Rules ()
+suiteRules s = do
+  forM_ (s ^. suiteVariants) (variantRules s)
+  csvRules s
+  plotRules s
+
+multiRecipe :: [Path Abs File] -> Action () -> Rules ()
+multiRecipe out howto = map toFilePath out &%> const howto
+
+recipe :: Path Abs File -> Action () -> Rules ()
+recipe out howto = toFilePath out %> const howto
+
+variantRules :: Suite -> Variant -> Rules ()
+variantRules s v = do
+  action $ do
+    whenM
+      (doesFileExist (toFilePath srcFile))
+      (need [toFilePath exeFile])
+
+  recipe exeFile $ do
+    need [toFilePath srcFile]
+    ensureDir outDir
+    (v ^. variantBuild) args
+  where
+    args :: BuildArgs
+    args =
+      BuildArgs
+        { _buildSrc = srcFile,
+          _buildOutDir = outDir
+        }
+    lang :: Lang
+    lang = v ^. variantLanguage
+    srcFile :: Path Abs File
+    srcFile =
+      addExtension'
+        (langExtension lang)
+        (suiteSrcDir s <//> langPath lang <//> suiteBaseFile s)
+    exeFile :: Path Abs File
+    exeFile = outDir <//> replaceExtensions' (v ^. variantExtensions) (filename srcFile)
+    outDir :: Path Abs Dir
+    outDir = variantBinDir s v
+
+plotRules :: Suite -> Rules ()
+plotRules s = do
+  let csv :: Path Abs File = suiteCsvFile s
+      svg :: Path Abs File = suiteSvgFile s
+      out :: Path Abs File = suitePlotFile s
+  want [toFilePath svg]
+  multiRecipe [svg] $ do
+    need [toFilePath csv, toFilePath gnuplotFile]
+    ensureDir (parent svg)
+    command_
+      []
+      "gnuplot"
+      ( gpArg "name" (s ^. suiteTitle)
+          ++ gpArg "outfile" (toFilePath out)
+          ++ gpArg "csvfile" (toFilePath csv)
+          ++ [toFilePath gnuplotFile]
+      )
+  where
+    gpArg :: String -> String -> [String]
+    gpArg arg val = ["-e", arg <> "='" <> val <> "'"]
+
+csvRules :: Suite -> Rules ()
+csvRules s =
+  recipe csv $ do
+    need [toFilePath (variantBinFile s v) | v <- s ^. suiteVariants]
+    ensureDir (parent csv)
+    whenM (Path.doesFileExist csv) (removeFile csv)
+    liftIO (runMode (Run (config s) Glob []) (fromSuite s) >> addColorColumn)
+  where
+    csv :: Path Abs File = suiteCsvFile s
+    addColorColumn :: IO ()
+    addColorColumn = do
+      header :| rows <- nonEmpty' . Text.lines <$> readFile (toFilePath csv)
+      let rows' =
+            [ showColour (v ^. variantColor) <> "," <> r
+              | (v, r) <- zipExact (s ^. suiteVariants) rows
+            ]
+          header' = "Color," <> header
+      writeFile (toFilePath csv) (Text.unlines (header' : rows'))
+
+fromSuite :: Suite -> [Benchmark]
+fromSuite s = map go (s ^. suiteVariants)
+  where
+    go :: Variant -> Benchmark
+    go v = bench title (nfIO ((v ^. variantRun) (variantBinFile s v)))
+      where
+        title :: String
+        title = show (v ^. variantLanguage) <> maybe "" (" " <>) (v ^. variantTitle)
+
+config :: Suite -> Config
+config s =
+  defaultConfig
+    { csvFile = Just (toFilePath (suiteCsvFile s)),
+      confInterval = cl90
+    }

bench/Suites.hs

@@ -0,0 +1,28 @@
+module Suites where
+
+import Base
+import Juvix.Prelude
+import Variants
+
+suites :: [Suite]
+suites =
+  map
+    defaultSuite
+    [ "mergesort",
+      "fibonacci",
+      "maybe"
+    ]
+    <> [ Suite suiteName (allVariantsExcept [C] [CoreEval])
+         | suiteName <- ["fold", "mapfold"]
+       ]
+    <> [Suite "mapfun" (allVariantsExcept [C] [CoreEval, JuvixExe, JuvixWasm])]
+    <> [ Suite suiteName (allVariantsExcept [] [CoreEval, JuvixExe, JuvixWasm])
+         | suiteName <- ["ackermann", "combinations", "cps", "prime"]
+       ]
+
+defaultSuite :: String -> Suite
+defaultSuite title =
+  Suite
+    { _suiteTitle = title,
+      _suiteVariants = defaultVariants
+    }