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 +0,0 @@
-prevent readTree from creating entries for subdirs that don't contain an .nix files

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)))))))))

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;
+  };
+})

third_party/lisp/mime4cl/test/.skip-tree

@@ -0,0 +1 @@
+parent exposes tests