Ben / Nujel

#!/usr/bin/env nujel
#| This script generates JSON files to be used with the web-based benchmark viewer,
| any sort of analysis is deferred to the browser, here we just measure the date
| and capture as much data as possible. After a run a new file will be added to
| benchmarks/results/, which should then be uploaded to the server which can then
| use the benchmark-aggregate.nuj script to generate the single aggregate JSON
| file for the viewer.
|#

(import (blue green yellow) :ansi)
(import (serialize :as val->json) :serialization/json)


(def time-path (popen/trim "which time"))

(def single-runs 8)
(def nujel-runs  8)
(def git-head (popen/trim "git rev-parse HEAD"))
(def git-branch (popen/trim "git rev-parse --abbrev-ref HEAD"))
(def uname-a (popen/trim "uname -a"))
(def date (popen/trim "git show -s --format=%cI")) ; Would be nice if this could be done as easily in Nujel
(def rough-date (popen/trim "git show -s --format=%cs"))
(def hostname (popen/trim "uname -n"))

(defn bench/get-language (filename)
      (case (lower-case (path/extension filename))
            ("lisp" :common-lisp)
            ("newlisp" :newlisp)
            ("el" :emacs-lisp)
            ("be" :berry)
            ("c" :c)
            ("dart" :dart)
            ("erl" :erlang)
            ("jnt" :janet)
            ("js" :javascript)
            ("krk" :kuroko)
            ("lua" :lua)
            ("jl" :julia)
            ("nuj" :nujel)
            ("pl" :perl)
            ("php" :php)
            ("py" :python)
            ("rkt" :racket)
            ("zuo" :zuo)
            ("rby" :ruby)
            ("scm" :scheme)
            (otherwise #nil)))

(defn bench/get-language-runtimes (language)
      (case language
            (:c '("tcc -run"))
            (:berry '("berry"))
            (:common-lisp '("ecl --shell" "clisp" "sbcl --script" "ccl -n -l"))
            (:newlisp '("newlisp"))
            (:emacs-lisp '("emacs -Q --script"))
            (:dart '("dart"))
            (:erlang '("escript"))
            (:janet '("janet"))
            (:javascript '("node" "qjs" "deno run" "duk" "mujs" "js78" "js91" "bun"))
            (:kuroko '("kuroko"))
            (:lua '("lua" "luajit" "luau"))
            (:julia '("julia"))
            (:nujel '("./nujel"))
            (:perl '("perl"))
            (:php '("php"))
            (:python '("python" "pypy"))
            (:racket '("racket"))
            (:zuo '("zuo"))
            (:ruby '("ruby" "mruby"))
            (:scheme '("guile" "stklos -f" "chibi-scheme -q" "gosh" "chez --script" "scheme48" "s7" "mit-scheme-script"))
            (otherwise '())))

(defn bench/get-runtime-version (runtime)
      (case (car (split runtime " "))
            ("clisp" (popen/trim "bash -c \"clisp -q -norc --version 2>/dev/null\""))
            ("ecl" (popen/trim "bash -c \"ecl --version 2>&1\""))
            ("s9" (popen/trim "bash -c \"s9 -? 2>&1 | head -n 2\""))
            ("deno" (popen/trim "bash -c \"deno --version 2>&1\""))
            ("qjs" (popen/trim "bash -c \"qjs -h 2>&1\""))
            ("newlisp" (popen/trim "bash -c \"newlisp -v 2>&1\""))
            ("kuroko" (popen/trim "bash -c \"kuroko --version 2>&1\""))
            ("escript" (popen/trim "bash -c \"erl -version 2>&1\""))
            ("node" (popen/trim "bash -c \"node --version 2>&1\""))
            (("lua" "luajit") (popen/trim (fmt "bash -c \"{runtime} -v 2>&1\"")))
            ("perl" (popen/trim "bash -c \"perl --version 2>&1\""))
            ("php" (popen/trim "bash -c \"php --version 2>&1\""))
            ("python" (popen/trim "bash -c \"python --version 2>&1\""))
            ("pypy" (popen/trim "bash -c \"pypy --version 2>&1\""))
            ("racket" (popen/trim "bash -c \"racket --version 2>&1\""))
            ("ruby" (popen/trim "bash -c \"ruby --version 2>&1\""))
            ("guile" (popen/trim "bash -c \"guile --version 2>&1\""))
            ("chibi-scheme" (popen/trim "bash -c \"chibi-scheme --version 2>&1\""))
            ("gosh" (popen/trim "bash -c \"gosh -V 2>&1\""))
            ("berry" (popen/trim "bash -c \"berry - 2>&1\""))
            (otherwise (fmt "{runtime}-unknown"))))

(defn runtime/available? (runtime)
      (def executable (car (split runtime " ")))
      (zero? (car (popen (fmt "command -v {executable}")))))

(defn get-result (testcase)
      (case testcase
            ("for" "49999995000000")
            ("hello" "Hello")
            ("euler1" "23333331666668")
            ("euler4" "906609")
            ("md5" "47afad6ea7d0515701d2b63472530971")
            ("crc32" "0936343A")
            ("compile-stdlib" "Image built")
            ("adler32" "E50BA232")
            ("recfib" "832040")
            (otherwise "チーズスイートホーム")))

(def time-template "#@(:user %U :system %S :elapsed \\\"%E\\\" :cpu \\\"%P\\\" :text %X :data %D :max-resident %M :inputs %I :outputs %O :pagefaults-major %F :pagefaults-minor %R :swaps %W)")
(defn bench/single (filename runtime i)
      (def language (bench/get-language filename))
      (when-not (runtime/available? runtime)
                (when (zero? i)
                      (pfmt "{} {} Runtime not found"
                            (blue (pad-end language 14))
                            (yellow (pad-end runtime 20))))
                (return #nil))
      (when (zero? i)
            (def testname (cadr (split filename "/")))
            (pfmt "{} {} {}"
                  (blue (pad-end language 14))
                  (green (pad-end runtime 20))
                  (yellow (pad-end testname 20))))
      (when (>= i 0) (pfmt "{i} "))
      (when-not (file/file? filename)
                (exception :io-error "Can't open the following file to benchmark it:" filename))
      (def result-file "nujel-benchmark.tmp")
      (def measurements #nil)
      (def testcase (cadr (split filename "/")))
      (try (fn (err)
               (rm result-file)
             (print/error err)
             (throw err))
           (def ret (popen (fmt "{} -o {result-file} --format=\"{time-template}\" {runtime} {filename}" time-path)))
           (when-not (zero? (car ret))
                     (exception :benchmark-error "Benchmark returned non-zero exit code" (cons filename ret)))
           (when-not (>= (:index-of (cdr ret) (get-result testcase)) 0)
                     (exception :benchmark-error "Benchmark returned wrong result" (cons filename ret)))
           (set! measurements (:clone (read/single (file/read result-file))))
           (set! measurements :stdout (cdr ret))
           (rm result-file))
      (when-not measurements (return #nil))
      (-> measurements
          (set! :language (bench/get-language filename))
          (set! :git-head git-head)
          (set! :git-branch git-branch)
          (set! :uname uname-a)
          (set! :architecture System/Architecture)
          (set! :hostname hostname)
          (set! :os System/OS)
          (set! :time (time))
          (set! :triplet (fmt "{testcase}-{hostname}-{System/Architecture}"))
          (set! :testcase testcase)
          (set! :total (+ (ref measurements :user) (ref measurements :system)))
          (set! :date date)
          (set! :runtime runtime)
          (set! :runtime-version (bench/get-runtime-version runtime))
          (set! :filename filename)))

(defn bench/file (ret filename)
      (when-not filename (return ret))
      (def language (bench/get-language filename))
      (and (:has? init/options :only-nujel)
           (not= language :nujel)
           (return ret))
      (def cur-runs (if (= language :nujel)
                        nujel-runs
                        single-runs))
      (doseq (runtime (bench/get-language-runtimes language))
             (when-not runtime (return ret))
             (when (> cur-runs 0)
                   (bench/single filename runtime -1) ; Ignore the first run as a warm-up
                   (dotimes (i cur-runs)
                            (set! ret (cons (bench/single filename runtime i) ret)))
                   (println "")))
      ret)

(def res-name (fmt "{rough-date}-{hostname}-{git-head}"))
(def out-name (fmt "web/benchmark-results/{}.json" res-name))
(mkdir "web/benchmark-results")

(and (:has? init/options :no-overwrite)
     (file/file? out-name)
     (do (pfmtln "{out-name} exists already, exiting.")
         (exit 0)))

(-> (directory/read-recursive "benchmark")
    (sort)
    (reduce bench/file #nil)
    (val->json)
    (file/write out-name))