From bfb27b7caaab60ff40d3a651e6bcaa7c6c630db8 Mon Sep 17 00:00:00 2001
From: sterni <sternenseemann@systemli.org>
Date: Tue, 3 Dec 2024 23:26:39 +0100
Subject: [PATCH] feat(3p/lisp/mime4cl): add benchmark script

This is far from comprehensive, mainly covering stuff I'm interested for
mblog currently. I should extend it as I go. The cases I've added reveal
something I've noticed recently: The worst performing part of mime4cl
seems to be the initial parsing of the message. My current theory is
that this is due to the use of READ-LINE in DO-MULTIPART-PARTS which
seems to ultimately dispatch to READ-CHAR internally due to the way our
streams are set up. We should look into fixing this soon.

It may be interesting to add this to windtunnel at some point, but I'd
rather not burden a runner with this given that mime4cl is only worked
on once every blue moon and I'm the only user.

Change-Id: I001de3aac01f8aa7ea923b43b2db29cf66a4aac3
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12864
Reviewed-by: sterni <sternenseemann@systemli.org>
Autosubmit: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
---
 third_party/lisp/mime4cl/.skip-subtree        |  1 -
 third_party/lisp/mime4cl/benchmark/bench.lisp | 30 ++++++++
 .../lisp/mime4cl/benchmark/default.nix        | 69 +++++++++++++++++++
 third_party/lisp/mime4cl/test/.skip-tree      |  1 +
 4 files changed, 100 insertions(+), 1 deletion(-)
 delete mode 100644 third_party/lisp/mime4cl/.skip-subtree
 create mode 100644 third_party/lisp/mime4cl/benchmark/bench.lisp
 create mode 100644 third_party/lisp/mime4cl/benchmark/default.nix
 create mode 100644 third_party/lisp/mime4cl/test/.skip-tree

diff --git a/third_party/lisp/mime4cl/.skip-subtree b/third_party/lisp/mime4cl/.skip-subtree
deleted file mode 100644
index 5051f60d6..000000000
--- a/third_party/lisp/mime4cl/.skip-subtree
+++ /dev/null
@@ -1 +0,0 @@
-prevent readTree from creating entries for subdirs that don't contain an .nix files
diff --git a/third_party/lisp/mime4cl/benchmark/bench.lisp b/third_party/lisp/mime4cl/benchmark/bench.lisp
new file mode 100644
index 000000000..1a25f2010
--- /dev/null
+++ b/third_party/lisp/mime4cl/benchmark/bench.lisp
@@ -0,0 +1,30 @@
+(defpackage :mime4cl-bench
+  (:use :common-lisp :mime4cl)
+  (:export :main))
+
+(in-package :mime4cl-bench)
+
+;; Write to /dev/null so that I/O is less (?) of a factor
+(defparameter *output-path* (pathname "/dev/null"))
+
+(defun parse-message (path)
+  (let ((msg (mime-message path)))
+    ;; to prove we are doing something, print the subject
+    (format t "Subject: ~A~%" (car (mime-message-header-values "Subject" msg :decode t)))
+    msg))
+
+(defun main ()
+  (destructuring-bind (bench-name message-path) (uiop:command-line-arguments)
+    (let ((action (intern (string-upcase bench-name) :mime4cl-bench))
+          (message-path (pathname message-path)))
+      (ccase action
+        ((parse) (parse-message message-path))
+        ((extract) (do-parts (part (parse-message message-path))
+                     (format t "Content-Type: ~A~%" (mime-type-string part))
+                     (let ((in (mime-body-stream part)))
+                       (with-open-file (output-stream (pathname *output-path*)
+                                                      :direction :output
+                                                      :if-does-not-exist :create
+                                                      :element-type (stream-element-type in)
+                                                      :if-exists :overwrite)
+                         (redirect-stream in output-stream)))))))))
diff --git a/third_party/lisp/mime4cl/benchmark/default.nix b/third_party/lisp/mime4cl/benchmark/default.nix
new file mode 100644
index 000000000..b201ede74
--- /dev/null
+++ b/third_party/lisp/mime4cl/benchmark/default.nix
@@ -0,0 +1,69 @@
+{ depot, pkgs, lib, ... }:
+
+let
+  # Example email that's going to push the parser due to its big attachment
+  # of almost 200MB. We are using a GHC bindist since it's quite big and a
+  # fixed output derivation that's already part of nixpkgs, so whitby only
+  # needs to download it once (and it won't change).
+  message = pkgs.runCommand "huge.mime"
+    {
+      nativeBuildInputs = [ pkgs.buildPackages.mblaze ];
+    }
+    ''
+      mmime > $out <<EOF
+      Subject: Test message with a big attachment
+
+      Henlo world!
+
+      #application/gzip#base64 ${pkgs.haskell.compiler.ghc963Binary.src}
+      EOF
+    '';
+
+  inherit (depot.nix) buildLisp getBins;
+
+  benchmark-program = buildLisp.program {
+    name = "mime4cl-benchmark-program";
+
+    deps = [
+      {
+        sbcl = buildLisp.bundled "uiop";
+        default = buildLisp.bundled "asdf";
+      }
+      depot.third_party.lisp.mime4cl
+    ];
+
+    srcs = [
+      ./bench.lisp
+    ];
+
+    main = "mime4cl-bench:main";
+  };
+
+  commands = bench: {
+    mime4cl-message-parsing = "${bench} parse ${message}";
+    mime4cl-attachment-extraction = "${bench} extract ${message}";
+  };
+
+  # TODO(sterni): expose this information from //nix/buildLisp and generate automatically
+  lispImplementations = [ "sbcl" /* "ccl" "ecl" */ ];
+in
+
+(pkgs.writeShellScriptBin "mime4cl-benchmark" ''
+  exec ${pkgs.hyperfine}/bin/hyperfine \
+    ${
+      lib.escapeShellArgs (
+        lib.concatMap (impl:
+          lib.concatLists (
+            lib.mapAttrsToList (name: cmd:
+              [ "-n" "${impl}-${name}" cmd ]
+            ) (commands (let b = benchmark-program.${impl}; in "${b}/bin/${b.name}"))
+          )
+        ) lispImplementations
+      )
+    } \
+    "$@"
+'').overrideAttrs (oldAttrs: {
+  passthru = oldAttrs.passthru or  { } // {
+    inherit benchmark-program;
+  };
+})
diff --git a/third_party/lisp/mime4cl/test/.skip-tree b/third_party/lisp/mime4cl/test/.skip-tree
new file mode 100644
index 000000000..28023cca5
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/.skip-tree
@@ -0,0 +1 @@
+parent exposes tests