[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/benchmarks 52c7cc8 5/6: Add ERB, a tool for runnin
|
From: |
Gemini Lasswell |
|
Subject: |
[Emacs-diffs] scratch/benchmarks 52c7cc8 5/6: Add ERB, a tool for running historical benchmarks |
|
Date: |
Sun, 25 Nov 2018 20:11:15 -0500 (EST) |
branch: scratch/benchmarks
commit 52c7cc8621593dc9231ed8e84796d11b55e77dec
Author: Gemini Lasswell <address@hidden>
Commit: Gemini Lasswell <address@hidden>
Add ERB, a tool for running historical benchmarks
* lisp/emacs-lisp/erb-task.el: New file.
* lisp/emacs-lisp/erb.el: New file.
---
lisp/emacs-lisp/erb-task.el | 299 +++++++
lisp/emacs-lisp/erb.el | 2073 +++++++++++++++++++++++++++++++++++++++++++
2 files changed, 2372 insertions(+)
diff --git a/lisp/emacs-lisp/erb-task.el b/lisp/emacs-lisp/erb-task.el
new file mode 100644
index 0000000..e5041e5
--- /dev/null
+++ b/lisp/emacs-lisp/erb-task.el
@@ -0,0 +1,299 @@
+;;; erb-task.el --- Emacs Regression Benchmarking -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell
+;; Keywords: lisp, tools
+;; Version: 1.0
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; ERB is a tool for automated benchmarking in Emacs Lisp. This file
+;; implements defining and running benchmark tasks within an Emacs
+;; instance.
+
+;; See the file erb.el for the rest of ERB, which implements a user
+;; interface for building older versions of Emacs, running the
+;; benchmark tasks in them, managing a database of results, and
+;; presenting them.
+
+;; For usage information, see ERB's info manual.
+
+;; Significant changes to benchmark.el over the years:
+;; In Emacs 21 500ae43022, benchmark.el was added.
+;; In Emacs 23 e2bac5f625, benchmark-elapse was changed to use
+;; float-time and time-subtract.
+;; In Emacs 26 c7d2a0dd76, repetitions is allowed to be a symbol.
+
+;;; Code:
+
+;; Since it is necessary to load this file into older versions of
+;; Emacs in order to define benchmark tasks for them to run, the code
+;; in this file must avoid using features or libraries which are not
+;; present in those older versions.
+(require 'benchmark)
+
+;;; Define benchmark tasks
+
+(defmacro erb-deftask (name _arglist &rest docstring-keys-and-body)
+ "Define NAME (a symbol) as a benchmark task.
+
+BODY is evaluated as a `progn' when the task is run. It should
+contain a `erb-task-time' form wrapping the code to be
+benchmarked. Any setup or cleanup work done outside of the
+`erb-task-time' form will not be benchmarked.
+
+DOCSTRING-KEYS-AND-BODY may begin with an optional docstring and
+an optional plist. Valid keywords for use as properties in the
+plist are:
+
+:version
+
+ A version number for this task, which should be increased if the
+ task is changed sufficiently to invalidate previous measurements.
+
+:rev-list
+
+ A list of strings to use as arguments to git-rev-list(1) to get
+ the list of commits for which this task should be run.
+
+:discard-first-sample
+
+ If non-nil, discard the result of the first run of the task.
+ Use this if you notice the first sample is consistently much
+ larger than the following samples.
+
+:special
+
+ If this exists and the value is `startup' a body for the task
+ is not required, and the benchmark runner will instead time the
+ startup and shutdown of Emacs. If the value is `own-process',
+ run this task in its own process instead of a process shared
+ with other tasks."
+
+ (declare (indent 2)
+ (doc-string 3)
+ (debug (&define :name task
+ name sexp [&optional stringp]
+ [&optional (&rest keywordp sexp)]
+ def-body)))
+ (let ((documentation nil)
+ (keys nil))
+ (when (stringp (car-safe docstring-keys-and-body))
+ (setq documentation (car docstring-keys-and-body))
+ (pop docstring-keys-and-body))
+ (when (keywordp (car-safe (car-safe docstring-keys-and-body)))
+ (setq keys (car docstring-keys-and-body))
+ (pop docstring-keys-and-body))
+ `(progn
+ (erb-task--set ',name
+ (erb-task--create-task ',name ,documentation ',keys
+ (lambda ()
+ ,@docstring-keys-and-body)))
+ ',name)))
+
+(defun erb-task--key-plist-p (list)
+ "Return non-nil if LIST is a plist using keywords valid in ERB.
+Those are :version, :rev-list, :discard-first-sample, and
+:special."
+ (while (consp list)
+ (setq list (if (and (consp (cdr list))
+ (or (and (eq (car list) :version)
+ (stringp (cadr list)))
+ (and (eq (car list) :rev-list)
+ (listp (cadr list)))
+ (and (eq (car list) :special) (symbolp (cadr
list)))
+ (eq (car list) :discard-first-sample)))
+ (cddr list)
+ 'not-plist)))
+ (null list))
+
+(defvar erb-task--result nil)
+
+(defmacro erb-task-time (&rest body)
+ "Save timing results for BODY.
+Use this macro inside of a benchmark task defined by
+`benchmark-deftask' to define the code to be benchmarked. Only
+use it once per task."
+ ;; TODO should this collect gc statistics?
+ ;; as in (memory-use-counts) before and after,
+ ;; do subtraction and sum
+ `(progn
+ (garbage-collect)
+ (setq erb-task--result (benchmark-run ,@body))))
+
+;;; Internal representation of tasks
+
+;; Use an alist so as not to have to worry about what
+;; cl-defstruct was called in old versions of Emacs.
+(defun erb-task--create-task (name doc keys body)
+ (unless (erb-task--key-plist-p keys)
+ (error "Keyword plist for %s contains unexpected keys"
+ name))
+ `((:name . ,name)
+ (:documentation . ,doc)
+ (:key-plist . ,keys)
+ (:body . ,body)
+ ,(cons :results nil)
+ ,(cons :messages nil)))
+
+(defsubst erb-task--name (task)
+ (alist-get :name task))
+(defsubst erb-task--documentation (task)
+ (alist-get :documentation task))
+(defsubst erb-task--body (task)
+ (alist-get :body task))
+(defsubst erb-task--key-plist (task)
+ (alist-get :key-plist task))
+(defsubst erb-task--results (task)
+ (alist-get :results task))
+(defsubst erb-task--add-result (result task)
+ (push result (alist-get :results task)))
+(defsubst erb-task--discard-result (task)
+ (pop (alist-get :results task)))
+(defsubst erb-task--messages (task)
+ (alist-get :messages task))
+(defsubst erb-task--add-message (message task)
+ (push message (alist-get :messages task)))
+
+(defun erb-task--boundp (symbol)
+ "Return non-nil if SYMBOL names a task."
+ (and (get symbol 'erb-task) t))
+
+(defun erb-task--get-task (symbol)
+ "If SYMBOL names a task, return that. Signal an error otherwise."
+ (unless (erb-task--boundp symbol)
+ (error "No task named `%S'" symbol))
+ (get symbol 'erb-task))
+
+(defun erb-task--all-symbols ()
+ (apropos-internal "" #'erb-task--boundp))
+
+(defun erb-task--version (task)
+ (plist-get (erb-task--key-plist task) :version))
+
+(defun erb-task--rev-list (task)
+ (plist-get (erb-task--key-plist task) :rev-list))
+
+(defun erb-task--set (symbol definition)
+ "Make SYMBOL name the task DEFINITION, and return DEFINITION."
+ (when (eq symbol 'nil)
+ (error "Attempt to define a task named nil"))
+ (put symbol 'erb-task definition)
+ definition)
+
+(defun erb-task--make-unbound (symbol)
+ "Make SYMBOL name no task.
+Return SYMBOL."
+ (put symbol 'erb-task nil)
+ symbol)
+
+(defun erb-delete-all-tasks ()
+ "Make all symbols in `obarray' name no task."
+ (interactive)
+ (when (called-interactively-p 'any)
+ (unless (y-or-n-p "Delete all tasks? ")
+ (user-error "Aborted")))
+ (mapc #'erb-task--make-unbound (erb-task--all-symbols)))
+
+;;; Running tasks
+
+(defvar erb-task-repetitions 10
+ "Number of times to run each task.")
+
+(defun erb-task-run-batch (symbols output-file)
+ "Run defined benchmark tasks in batch mode.
+SYMBOLS is a list of the names of the tasks. Run each one
+`erb-repetitions' times. Write to OUTPUT-FILE an list of
+results. Each entry of the list will be of the form:
+
+ ((name . NAME)
+ (version . VERSION)
+ (samples . SAMPLES-LIST)
+ (messages . MESSAGES))
+
+where NAME is the name of the task, VERSION is its version as
+defined in the optional plist given to `erb-deftask',
+SAMPLES-LIST is a list of the return values of benchmark-run, and
+MESSAGES is a list of strings containing the messages issued
+while the task was running.
+
+If there were errors while running the task,
+elements of SAMPLES-LIST will be of the form (error ERROR-INFO)
+instead. This function is used as a command-line entry point
+into the target Emacs by `erb-run-start'."
+ (let ((print-level nil)
+ (print-length nil))
+ (dolist (symbol symbols)
+ (let* ((task (erb-task--get-task symbol))
+ (key-plist (erb-task--key-plist task))
+ (discard-first (plist-get key-plist :discard-first-sample)))
+ (unless noninteractive
+ (message "Running %s" symbol))
+ (dotimes (i (+ erb-task-repetitions (if discard-first 1 0)))
+ (erb-task--run symbol)
+ (when (and discard-first (zerop i))
+ (erb-task--discard-result task)))))
+
+ (with-temp-file output-file
+ (let ((results
+ (mapcar (lambda (symbol)
+ (let ((task (erb-task--get-task symbol)))
+ `((name . ,symbol)
+ (version . ,(erb-task--version task))
+ (samples ,@(reverse (erb-task--results task)))
+ (messages ,@(reverse (erb-task--messages task))))))
+ symbols)))
+
+ (insert (with-temp-buffer
+ (prin1 results (current-buffer))
+ (pp-buffer)
+ (buffer-string)))))))
+
+(defun erb-task-run-all (&optional repetitions)
+ "Run all defined benchmark tasks REPETITIONS times and message the results.
+REPETITIONS defaults to 1."
+ (interactive "p")
+ (unless (natnump repetitions) (setq repetitions 1))
+ (dotimes (_i repetitions)
+ (mapc #'erb-task--run (erb-task--all-symbols)))
+ (message "Results:")
+ (mapc #'erb-task--message-results (erb-task--all-symbols)))
+
+(defun erb-task--run (symbol)
+ "Run the benchmark task associated with SYMBOL."
+ (let ((task (erb-task--get-task symbol))
+ (message-marker (with-current-buffer (messages-buffer)
+ (point-max-marker))))
+ (condition-case err
+ (progn
+ (setq erb-task--result nil)
+ (funcall (erb-task--body task)))
+ (error (setq erb-task--result err)))
+ (erb-task--add-result erb-task--result task)
+ (erb-task--add-message (with-current-buffer (messages-buffer)
+ (buffer-substring message-marker (point-max)))
+ task)))
+
+(defun erb-task--message-results (symbol)
+ (message "%s: " symbol)
+ (dolist (item (reverse (erb-task--results (erb-task--get-task symbol))))
+ (message " %s" item)))
+
+(provide 'erb-task)
+;;; erb-task.el ends here
diff --git a/lisp/emacs-lisp/erb.el b/lisp/emacs-lisp/erb.el
new file mode 100644
index 0000000..5327f67
--- /dev/null
+++ b/lisp/emacs-lisp/erb.el
@@ -0,0 +1,2073 @@
+;;; erb.el --- Emacs Regression Benchmarks -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell
+;; Keywords: lisp, tools
+;; Version: 0.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; ERB is a tool for automated benchmarking in Emacs Lisp.
+
+;; ERB implements a user interface for building older versions of
+;; Emacs, running the benchmark tasks in them, managing a database of
+;; results, and presenting the results.
+
+;; TODO define erb-hostname which defaults to system-name, and allow
+;; changing it.
+;;
+;; TODO abbreviate commits to 12 characters or whatever.
+;;
+;; It would be nice to have filenames like:
+;; 201811012312-47ccee220a49.eld
+;; 201811021014-f05e930ca9ca.eld
+;; because then they could be easily seen in date order in dired.
+;; Or maybe it would be easy to extend dired to sort by date and
+;; show the date.
+
+;; For usage information, see ERB's info manual.
+;;; Code:
+(require 'ansi-color)
+(require 'cl-lib)
+(require 'cl-macs) ;; TODO eval-when-compile
+(require 'erb-task)
+(require 'find-func)
+(require 'generator)
+(require 'map)
+(eval-when-compile (require 'pcase))
+(require 'seq)
+;; TODO (eval-when-compile (require 'subr-x))
+(require 'subr-x)
+(require 'thread)
+
+(defgroup erb nil
+ "ERB, the Emacs regression performance testing tool."
+ :prefix "erb-"
+ :group 'lisp)
+
+'(defcustom erb-hostname-translation nil
+ "Mapping from system names to machine names in ERB.
+The keys of this alist should be system names as returned by
+`system-name', and the values should be strings containing the
+names to use for those systems in the benchmark results."
+ :type (alist :key-type 'string :value-type 'string)
+ :group 'erb
+ :version "27.1")
+
+(defconst erb-version "0.1")
+
+;; TODO Alternatively, look in load-history?
+(eval-and-compile
+ (defvar erb-task-el-filename
+ (expand-file-name
+ "erb-task.el"
+ (file-name-directory (or (bound-and-true-p byte-compile-current-file)
+ load-file-name
+ buffer-file-name)))
+ "Location of erb.el (or erb.el.gz) for this installation of Emacs."))
+
+;;; Buffer-local variables used by all ERB buffers
+
+(defvar-local erb-suite-directory nil
+ "Benchmark suite directory for the current `erb-mode' buffer.")
+
+;; TODO allow a URL for the project, and create
+;; a customize alist that points to a local clone.
+;; If no local clone, clone it into a temp directory.
+(defvar-local erb--config nil
+ "Benchmark suite configuration for the current `erb-mode' buffer.")
+(defvar-local erb--config-err nil
+ "If non-nil, the error which occurred reading the benchmark configuration.")
+
+;; TODO add a configurable cooldown time between building and benchmarking.
+(defvar-local erb--machine-config nil
+ "Machine configuration for the current `erb-mode' buffer.")
+(defvar-local erb--machine-config-err nil
+ "If non-nil, the error which occurred reading the machine configuration.")
+
+;;; ERB directory configuration
+
+;; TODO implement refusing to read newer configs
+(defconst erb-default-config
+ `((project-name
+ "The name of the project."
+ "GNU Emacs")
+ (project-repo
+ "The path to the git repository for the project to be benchmarked."
+ "/path/to/your/project/git/repo")
+ (benchmark-directory
+ "The directory containing Lisp files declaring benchmark
+tasks, relative to the project's git repository."
+ "path/to/benchmark/tasks")
+ (tags
+ "A list of git tags or commits (as strings) to label on the
+x-axis of benchmark plots."
+ ("release-1.0" "release-2.0"))
+ (erb-version
+ "The ERB version which created this file."
+ ,erb-version)))
+
+(defun erb-initialize ()
+ "Initialize `erb-suite-directory' to store benchmark results.
+Write the default ERB configuration file to \"config.eld\" at the
+top level of `erb-suite-directory'. You should hand-edit
+the file as desired."
+ (interactive)
+ ;; TODO prompt to overwrite if file exists
+ (erb--write-formatted-alist-to-file
+ erb-default-config
+ (expand-file-name "config.eld" erb-suite-directory))
+ (erb-summary-revert-buffer))
+
+(defun erb--write-formatted-alist-to-file (alist filename)
+ "Write ALIST to FILENAME in a human-friendly format.
+Each element of ALIST should be (KEY DOC VALUE). Write the ALIST
+with DOC converted to comments so that when read back in by the
+Lisp reader each element will become (KEY VALUE)."
+ (let ((first t))
+ (with-temp-file filename
+ (let ((standard-output (current-buffer)))
+ (princ "(")
+ (pcase-dolist (`(,key ,doc ,value) alist)
+ (if first
+ (setq first nil)
+ (princ "\n"))
+ (princ "\n ;; ")
+ (seq-doseq (char doc)
+ (princ (if (eq char ?\n) "\n ;; " (string char))))
+ (princ (format "\n (%s . %S)" key value)))
+ (princ ")\n")))))
+
+(defun erb--read-config (suite-dir)
+ "Read the configuration file \"config.eld\" from SUITE-DIR."
+ (let* ((filename (expand-file-name "config.eld" suite-dir)))
+ (unless (file-readable-p filename)
+ (error "%s has not been initialized to store benchmark results"
suite-dir))
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (read (current-buffer)))
+ ;; TODO check that required keys are present,
+ ;; and that it wasn't written by a newer version.
+ ))
+
+(defun erb--update-config-cache ()
+ ;; TODO check alist structure, keys, value types?
+ (setq erb--config-err nil)
+ (setq erb--config
+ (condition-case err
+ (erb--read-config erb-suite-directory)
+ (error (setq erb--config-err (format "%s" err))
+ nil)))
+ (unless (or erb--config erb--config-err)
+ (setq erb--config-err "Unable to read benchmark configuration")))
+
+;;; Machine Configuration
+
+(defconst erb-default-machine-config
+ `((build-script
+ "Where to look for the build script. This may be an absolute
+or relative path. If it is a relative path, see the value
+associated with `build-script-location'."
+ "path/to/build-script")
+ (build-script-location
+ "If the value associated with `build-script' is a relative
+path, look for the build script in the project directory if this
+is `project', or in the ERB directory if this is `ERB'."
+ ERB)
+ (system-info-script
+ "Where to look for the system info script. This may be an
+absolute or relative path. If it is a relative path, see the
+value associated with `system-info-script-location'."
+ "path/to/system-info-script")
+ (system-info-script-location
+ "If the value associated with `system-info-script' is a
+relative path, look for the system info script in the project
+directory if this is `project', or in the ERB directory if this
+is `ERB'."
+ ERB)
+ (simultaneous-builds
+ "Number of builds to do at the same time." 1)
+ (emacs-arguments
+ "List of arguments to pass to the benchmarked Emacs executable."
+ ("-Q" "--batch"))
+ (erb-version
+ "The ERB version which created this file."
+ ,erb-version)))
+
+(defun erb-initialize-machine-config ()
+ "Write a machine configuration file for the current system.
+Write the file to the `config' subdirectory of
+`erb-suite-directory', as \"HOSTNAME.eld\"."
+ (interactive)
+ (unless erb--config
+ (user-error "Use `erb-initialize' to create a benchmark configuration
first"))
+ ;; TODO prompt to overwrite if file exists
+ (let* ((hostname (system-name))
+ (filename (erb--machine-config-filename hostname))
+ (machines-dir (expand-file-name "machines" erb-suite-directory)))
+ (unless (file-directory-p machines-dir)
+ (make-directory machines-dir))
+ (erb--write-formatted-alist-to-file erb-default-machine-config filename))
+ (erb-summary-revert-buffer)
+ (erb-update-saved-machine-info))
+
+(defun erb--read-machine-config (hostname)
+ "Return the contents of the machine configuration file for HOSTNAME.
+If the machine information file is empty or not present signal an
+error."
+ (let* ((filename (erb--machine-config-filename hostname))
+ (config (when (file-readable-p filename)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (read (current-buffer))))))
+ (unless config
+ (error "Machine configuration not found in \"%s\"" filename))
+ config))
+
+(defun erb--machine-config-filename (hostname)
+ (thread-last erb-suite-directory
+ (expand-file-name "machines")
+ (expand-file-name (concat hostname ".eld"))))
+
+(defun erb--update-machine-config-cache ()
+ ;; TODO check alist structure, keys, value types?
+ (setq erb--machine-config-err nil)
+ (setq erb--machine-config
+ (condition-case err
+ (erb--read-machine-config (system-name))
+ (error (setq erb--machine-config-err (format "%s" err))
+ nil)))
+ (unless (or erb--machine-config erb--machine-config-err)
+ (setq erb--machine-config-err
+ "Unable to read machine configuration")))
+
+(defun erb-update-saved-machine-info ()
+ "Update the information ERB keeps on file about this machine.
+Use this command to see operating system updates reflected in the
+benchmark results report."
+ ;; TODO prompt to confirm.
+ ;; TODO allow adding a note (such as "Replaced hard drive with SSD.")
+ ;; TODO save the configuration too? (emacs-arguments)
+ (interactive)
+ (erb--update-machine-config-cache)
+ (when erb--machine-config-err
+ (error "%s" erb--machine-config-err))
+ (let* ((hostname (system-name))
+ (info-file (erb--machine-info-file-name hostname))
+ (old-info (erb--read-saved-machine-info hostname))
+ (info (erb--get-this-machine-info
+ hostname (erb--get-script-filename 'system-info))))
+ (make-directory (file-name-directory info-file) t)
+ (with-temp-file info-file
+ (let ((standard-output (current-buffer)))
+ (cl-prin1 (cons info old-info))
+ (pp-buffer)))))
+
+(defun erb--read-saved-machine-info (machine)
+ "Read the saved list of system information about MACHINE.
+Returns a list of alists, the most recent first."
+ (let ((info-file (erb--machine-info-file-name machine)))
+ (when (file-readable-p info-file)
+ (with-temp-buffer
+ (insert-file-contents info-file)
+ (goto-char (point-min))
+ (read (current-buffer))))))
+
+(defun erb--machine-info-file-name (machine)
+ (let* ((info-dir (thread-last erb-suite-directory
+ (expand-file-name "machines")
+ (expand-file-name "info")))
+ (info-file (expand-file-name (format "%s.eld" machine)
+ info-dir)))
+ info-file))
+
+;; TODO hostname no longer used
+(defun erb--get-this-machine-info (_hostname system-info-script)
+ "Return an alist of information about this machine.
+Use strings for the informational keys of the alist, and include
+a timestamp and the ERB version using keyword keys."
+ (let ((lines (mapcar #'ansi-color-filter-apply
+ (process-lines system-info-script)))
+ (machine-info `((:time . ,(truncate (time-to-seconds (current-time))))
+ (:erb-version . ,erb-version))))
+ (dolist (line lines)
+ (when (string-match "[A-Za-z]+: " line)
+ (let ((key (substring line 0 (- (match-end 0) 2)))
+ (value (substring line (match-end 0))))
+ (push (cons key value) machine-info))))
+ machine-info))
+
+(defun erb--get-script-filename (script-type)
+ "Locate the build script for the machine.
+It could be at some absolute path, in the project repo, or in the
+ERB directory. The script type can be either `build' or
+`system-info'."
+ (let ((script-location (map-elt erb--machine-config
+ (intern (format "%s-script-location"
+ script-type))))
+ (script (map-elt erb--machine-config
+ (intern (format "%s-script" script-type)))))
+ (if (file-name-absolute-p script)
+ script
+ (expand-file-name
+ script
+ (cl-case script-location
+ ((ERB) erb-suite-directory)
+ ((project) (map-elt erb--config 'project-repo))
+ (t (error
+ (concat
+ "In the ERB configuration, the value of `%s-script-location' "
+ "should be either `project' or `ERB'")
+ script-type)))))))
+
+;;; Benchmark tasks and their metadata
+
+(cl-defstruct erb--metadata
+ name ; Name of task defined by erb-deftask.
+ filename ; Relative pathname of file in which task was defined.
+ version ; Version of this task from keyword plist in definition.
+ rev-list ; Arguments to git rev-list.
+ discard-first-sample ; Flag from task definition.
+ documentation ; Docstring from task definition.
+ special ; From keyword plist in definition.
+ )
+
+(defvar erb--benchmark-tasks nil
+ "Information about the benchmark tasks found in the project.
+A list of `erb--metadata' structures.")
+
+(defun erb--read-benchmark-metadata ()
+ "Extract benchmark task metadata from the project.
+Save the results in `erb--benchmark-tasks' as an alist mapping
+task names to `erb--metadata' structures. This works by
+evaluating the code in the benchmark task files in the project,
+so it will have whatever side effects are caused by that code.
+As a side effect, and by way of partial cleanup, delete all
+defined benchmark tasks."
+ ;; TODO error handling
+ (let ((benchmark-task-files (directory-files-recursively
+ (erb--benchmark-dir) "\\-tasks.el$")))
+ (setq erb--benchmark-tasks nil)
+ (erb-delete-all-tasks)
+ (dolist (filename benchmark-task-files)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (eval-buffer))
+ (dolist (symbol (erb-task--all-symbols))
+ (let ((task (erb-task--get-task symbol)))
+ (push (apply #'make-erb--metadata
+ (append
+ `(:filename ,filename :name ,symbol)
+ `(:documentation ,(erb-task--documentation task))
+ (erb-task--key-plist task)))
+ erb--benchmark-tasks)))
+ (erb-delete-all-tasks)))
+ erb--benchmark-tasks)
+
+(defun erb--benchmark-dir ()
+ (map-let (project-repo benchmark-directory) erb--config
+ (expand-file-name benchmark-directory project-repo)))
+
+;;; Summary mode definition
+
+(defvar erb-summary-mode-map
+ (let ((map (copy-keymap special-mode-map)))
+ (set-keymap-parent map button-buffer-map)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "C" 'erb-initialize)
+ (define-key map "M" 'erb-initialize-machine-config)
+ (define-key map "U" 'erb-update-saved-machine-info)
+ (define-key map "r" 'erb-summary-run)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'mouse-select-window)
+
+ map)
+ "Local keymap for `erb-summary-mode' buffers.")
+
+(define-derived-mode erb-mode special-mode "ERB-base"
+ "Parent major mode from which ERB major modes inherit.
+
+ERB is documented in info node `(erb)'."
+ :group 'erb
+ (buffer-disable-undo)
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (setq show-trailing-whitespace nil)
+ (setq-local line-move-visual t)
+ (setq list-buffers-directory (abbreviate-file-name default-directory))
+ (hack-dir-local-variables-non-file-buffer)
+ (make-local-variable 'text-property-default-nonsticky)
+ (push (cons 'keymap t) text-property-default-nonsticky)
+ ;; (add-hook 'post-command-hook #'magit-section-update-highlight t t)
+ ;; (setq-local redisplay-highlight-region-function 'magit-highlight-region)
+ ;; (setq-local redisplay-unhighlight-region-function
'magit-unhighlight-region)
+ (when (bound-and-true-p global-linum-mode)
+ (linum-mode -1))
+ (when (and (fboundp 'nlinum-mode)
+ (bound-and-true-p global-nlinum-mode))
+ (nlinum-mode -1))
+ (setq-local erb-suite-directory default-directory))
+
+(define-derived-mode erb-summary-mode erb-mode "ERB"
+ "Summarize information contained in an ERB benchmark suite directory.
+\\<erb-summary-mode-map>
+ERB is documented in info node `(erb)'."
+ :group 'erb
+ (setq-local revert-buffer-function #'erb-summary-revert-buffer))
+
+(defun erb-summary-generate-new-buffer ()
+ (let* ((name (format "*ERB: %s*" (file-name-nondirectory
+ (directory-file-name default-directory))))
+ (buffer (generate-new-buffer name)))
+ (with-current-buffer buffer
+ (erb-summary-mode)
+ (add-to-list 'uniquify-list-buffers-directory-modes 'erb-summary-mode)
+ (setq erb-suite-directory default-directory)
+ (setq list-buffers-directory (abbreviate-file-name default-directory)))
+ buffer))
+
+;;;###autoload
+(defun erb-summary ()
+ "Show an overview of the benchmark suite in the current directory."
+ ;; TODO prompt for directory with prefix argument.
+ ;; OR look for config.eld in current directory and prompt
+ ;; if not found
+ (interactive)
+ (let* ((dir default-directory)
+ (buffer (or (seq-find (lambda (buf)
+ (and (eq major-mode 'erb-summary-mode)
+ (with-current-buffer buf
+ (equal dir erb-suite-directory))))
+ (buffer-list))
+ (erb-summary-generate-new-buffer))))
+ (switch-to-buffer buffer)
+ (erb-summary-revert-buffer buffer)))
+
+(defun erb-summary-revert-buffer (&rest _ignored)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (erb-summary--display-configuration)
+ (when erb--config
+ (erb-summary--display-machine-configuration)
+ (erb-summary--display-results))
+ (set-buffer-modified-p nil)))
+
+(defun erb-summary--display-configuration ()
+ (erb--update-config-cache)
+ (if erb--config
+ (let ((fmt " %-30s%s\n"))
+ (map-let (project-repo benchmark-directory) erb--config
+ (insert
+ (format "Benchmark configuration in %s:\n"
+ (abbreviate-file-name
+ (expand-file-name "config.eld" erb-suite-directory)))
+ (format fmt "Project location:"
+ (abbreviate-file-name project-repo))
+ (format fmt "Benchmark tasks subdirectory:" benchmark-directory)
+
+ ;; TODO make this a link
+ "\n Edit Configuration\n\n")))
+ (insert
+ (substitute-command-keys
+ (if (file-readable-p (expand-file-name "config.eld" erb-suite-directory))
+ (format "Could not read the `config.eld' file in %s: %s\n"
+ erb-suite-directory erb--config-err)
+ (format "No file named `config.eld' found in %s\n"
+ erb-suite-directory)))
+ (substitute-command-keys
+ "\nUse `erb-initialize' to create a new file `config.eld'
+containing a sample configuration for benchmarking.\n")))
+ erb--config)
+
+(defun erb-summary--display-machine-configuration ()
+ ;; TODO it would be nice to use remote machine if benchmark
+ ;; directory is remote
+ (erb--update-machine-config-cache)
+ (if erb--machine-config
+ (let ((fmt " %-30s%s\n"))
+ (map-let (build-script build-script-location cpu-cores
+ system-info-script system-info-script-location
+ emacs-arguments)
+ erb--machine-config
+ (insert
+ (substitute-command-keys
+ (format "Configuration for `%s':\n" (system-name)))
+ (format fmt "Build script:" build-script)
+ (if (file-name-absolute-p build-script)
+ ""
+ (format fmt "Build script location:"
+ (cl-case build-script-location
+ ((ERB) "In the benchmark directory")
+ ((project) "In the project"))))
+ (format fmt "System info script:" system-info-script)
+ (if (file-name-absolute-p system-info-script)
+ ""
+ (format fmt "System info script location:"
+ (cl-case system-info-script-location
+ ((ERB) "In the benchmark directory")
+ ((project) "In the project"))))
+ (format fmt "CPU cores to use:" cpu-cores)
+ (format fmt "Emacs arguments:"
+ (mapconcat #'identity emacs-arguments " "))
+ "\n Change build script\n\n")))
+
+ (insert
+ (substitute-command-keys
+ (format "Could not read `%s': %s\n"
+ (erb--machine-config-filename (system-name))
+ erb--machine-config-err))
+ (substitute-command-keys
+ (format "\nUse `erb-initialize-machine-config' to create a
+new file `config/%s.eld' containing configuration for this
+machine.\n\n" (system-name))))))
+
+(defun erb-summary--display-results ()
+ (let* ((machines-dirs (erb--machine-results-dirs)))
+ (if machines-dirs
+ (dolist (machine-dir machines-dirs)
+ (let* ((machine-name (file-name-nondirectory machine-dir))
+ (runs-dir (expand-file-name "measurements" machine-dir))
+ (runs (directory-files runs-dir nil ".+\\.eld$" ))
+ (failed-runs-dir (erb--failed-runs-dir machine-name))
+ (failed-runs
+ (ignore-errors
+ (directory-files failed-runs-dir nil ".+\\.eld$")))
+ (failed-builds-dir (erb--failed-builds-dir machine-name))
+ (failed-builds
+ (ignore-errors
+ (directory-files failed-builds-dir nil ".+\\.log$"))))
+ (insert (substitute-command-keys
+ (format "Results for `%s':\n" machine-name)))
+ (insert (format " %-25s%5d\n %-25s%5d\n %-25s%5d\n\n"
+ "Commits benchmarked:" (length runs)
+ "Commits with errors:" (length failed-runs)
+ "Build failures:" (length failed-builds)))))
+ (insert (substitute-command-keys
+ "No results yet. Use `r' to start running benchmarks.\n")))))
+
+;;; State variables for the benchmark runner
+
+(cl-defstruct erb--job
+ buffer
+ commits)
+
+(defvar erb--job (thread-make-message)
+ "This contains all the information needed about what benchmark job to run.
+It is created by `erb-run-start' and cleared when the benchmark job is
+finished by `erb--benchmark-control-func'.
+
+`erb-run-cancel' sets this to the symbol `cancel', which will
+cause ERB's threads to stop any job they are working on and clean
+up.")
+
+;;; Run mode definition
+
+(defcustom erb-run-refresh-seconds 0.2
+ "Delay between updates of `erb-run' buffers."
+ :type 'number
+ :group 'erb
+ :version "27.1")
+
+;; Options settable in the erb-run-mode buffer.
+;; TODO "settable"
+(defvar-local erb-run--commit-range "emacs-25.1..bd013a448b")
+(defvar-local erb-run--number-to-select 8)
+(defvar-local erb-run--skip-building-previous-failures t)
+
+(defvar erb-run-mode-map
+ (let ((map (copy-keymap special-mode-map)))
+ (set-keymap-parent map button-buffer-map)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "s" 'erb-run-start)
+ (define-key map "c" 'erb-run-cancel)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'mouse-select-window)
+
+ map)
+ "Local keymap for `erb-run-mode' buffers.")
+
+(define-derived-mode erb-run-mode erb-mode "ERB-run"
+ "Mode for configuring and running benchmarks.
+\\<erb-run-mode-map>
+ERB is documented in info node `(erb)'."
+ :group 'erb
+ (setq-local revert-buffer-function #'erb-run-revert-buffer))
+
+;; TODO make only one buffer? Since there is ony one set of worker threads
+;; What happens if you try to switch directory while a job is running?
+(defun erb-run-generate-new-buffer ()
+ (let* ((name (format "*ERB-run: %s*" (file-name-nondirectory
+ (directory-file-name
default-directory))))
+ (buffer (generate-new-buffer name)))
+ (with-current-buffer buffer
+ (erb-run-mode)
+ (run-at-time erb-run-refresh-seconds nil
+ #'erb-run--timer-func buffer)
+ (add-to-list 'uniquify-list-buffers-directory-modes 'erb-run-mode))
+ buffer))
+
+;; TODO autoload is just for now
+;;;###autoload
+(defun erb-summary-run ()
+ "Switch to or create an `erb-run-mode' buffer for running benchmarks."
+ (interactive)
+ (let* ((dir default-directory)
+ (buffer (or (seq-find (lambda (buf)
+ (and (eq major-mode 'erb-run-mode)
+ (with-current-buffer buf
+ (equal dir erb-suite-directory))))
+ (buffer-list))
+ (erb-run-generate-new-buffer))))
+ (switch-to-buffer buffer)
+ (erb-run-revert-buffer buffer)))
+
+(defun erb-run-revert-buffer (&rest _ignored)
+ ;; TODO put all these status variables into a structure or alist so
+ ;; they can be copied, and then only update the buffer if something
+ ;; has changed.
+ ;; TODO save and restore cursor position.
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (erb--update-config-cache)
+ (if (not erb--config)
+ (insert (format "Error reading `config.eld': \n %s\n"
erb--config-err))
+ (map-let (project-repo) erb--config
+ (insert
+ (format "Project: %s\n" project-repo)
+ (format "Commit range: %s\n" erb-run--commit-range)
+ (format "Commits in range: %s\n"
+ (if-let ((count (erb--vc-get-commit-range-count
+ erb-run--commit-range)))
+ count "Version control error"))
+ "\n"
+
+ (format "Number to select: %s\n" (if erb-run--number-to-select
+ erb-run--number-to-select "All"))
+ (format "Skip building previous failures: %s\n"
+ (if erb-run--skip-building-previous-failures "Yes" "No"))
+ "\n"
+
+ (let* ((done (length (erb--status 'finished)))
+ (built (length (erb--status 'built)))
+ (commits (length (erb--status 'commits)))
+ (failed-builds (length (erb--status 'failed-builds)))
+ (failed-runs (length (erb--status 'failed-runs))))
+ (concat
+ (format "Built: %s\n" (if (> built 0) built ""))
+ (format "Benchmarked: %s\n" (if (> done 0) done ""))
+ (format "Build Failures: %s\n" (if (erb--status 'state)
+ failed-builds ""))
+ (format "Run Failures: %s\n" (if (erb--status 'state)
+ failed-runs ""))
+ (format "Total: %s/%s\n" done commits)))
+ "\n"
+
+ (format "Started at: %s\n"
+ (if (erb--status 'start-time)
+ (format-time-string "%Y-%m-%d %T%z" (erb--status
'start-time))
+ ""))
+ ;; TODO Building and Benchmarking, cycle through 0 and 5 .'s
+ (cl-case (erb--status 'state)
+ (building (concat "Building." (erb--dots)))
+ (benchmarking (concat "Benchmarking." (erb--dots)))
+ ((nil) "Ready.")
+ (done "Finished.")
+ (cancelled "Cancelled.")
+ (t (format "State: %s" (erb--status 'state))))
+
+ (format (if (eq (erb--status 'state) 'cancelled)
+ "\nCancelled at: %s\n"
+ "\nFinished at: %s\n")
+ (if (erb--status 'stop-time)
+ (format-time-string "%Y-%m-%d %T%z" (erb--status
'stop-time))
+ ""))))
+
+ ;; TODO make these all buttons which go to the WIP buffer
+ (unless (null (erb--status 'state))
+ (insert "\n")
+ (dolist (commit (erb--status 'commits))
+ (insert
+ (cond
+ ((memq commit (erb--status 'finished)) ".")
+ ((memq commit (erb--status 'building)) "B")
+ ((memq commit (erb--status 'failed-runs)) "F")
+ ((memq commit (erb--status 'failed-builds)) "E")
+ ((memq commit (erb--status 'benchmarking)) "R")
+ ((memq commit (erb--status 'built)) "b")
+ (t "-"))))
+ (insert "\n")))
+
+ (set-buffer-modified-p nil)))
+
+
+(defvar erb--status-dot-count 0)
+(defvar erb--status-last-update (time-to-seconds (current-time)))
+(defvar erb--status-interval 1.0)
+(defconst erb--status-dot-max 5)
+(defun erb--dots ()
+ (prog1
+ (make-string erb--status-dot-count ?.)
+ (when (> (- (time-to-seconds (current-time)) erb--status-last-update)
+ erb--status-interval)
+ (setq erb--status-dot-count (% (1+ erb--status-dot-count)
+ erb--status-dot-max)
+ erb--status-last-update (time-to-seconds (current-time))))))
+
+(defun erb-run--timer-func (buffer)
+ "Revert BUFFER and set a timer to do it again."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (revert-buffer))
+ (run-at-time erb-run-refresh-seconds nil
+ #'erb-run--timer-func buffer)))
+
+;;; Run mode commands
+
+(defun erb-run-start ()
+ "Start running benchmarks."
+ (interactive)
+ (when (thread-message-value erb--job)
+ (user-error "Benchmarks are already running"))
+
+ (unless erb-run--commit-range
+ (user-error "Choose a commit or range of commits to benchmark"))
+
+ (erb--update-config-cache)
+ (unless erb--config
+ (user-error "Error reading benchmark configuration: %s" erb--config-err))
+ (erb--update-machine-config-cache)
+ (unless erb--config
+ (user-error "Error reading machine configuration: %s"
+ erb--machine-config-err))
+
+ (erb--start-benchmark-controller-thread)
+ (erb--adjust-builder-threads)
+ (erb--read-benchmark-metadata)
+
+ (erb--clear-status)
+ (thread-message-send
+ erb--job
+ (make-erb--job :commits (erb--vc-get-commits erb-run--commit-range
+ erb-run--number-to-select)
+ :buffer (current-buffer))))
+
+(defun erb-run-cancel ()
+ "Stop running benchmarks."
+ (interactive)
+ (thread-message-send erb--job 'cancel))
+
+(defun erb--cancel-now-p ()
+ (eq (thread-message-value erb--job) 'cancel))
+
+;;; The benchmark runner
+;;;; Controller thread
+
+(defvar erb--unbuilt-commits (thread-make-queue nil 'fifo)
+ "A thread-safe queue of commits waiting to be built.")
+(defvar erb--built-commits (thread-make-queue nil 'fifo)
+ "A thread-safe queue of commits which have been built.")
+
+(defvar erb--benchmark-controller nil)
+
+(defun erb--start-benchmark-controller-thread ()
+ "Start the benchmark controller thread if it is not already started."
+ (unless erb--benchmark-controller
+ (setq erb--benchmark-controller
+ (make-thread #'erb--benchmark-control-func "ERB control"))))
+
+(defun erb--benchmark-control-func ()
+ "Process benchmark jobs.
+Watch for incoming jobs arriving by a thread-safe message in
+`erb--job'. When a job becomes available, build and
+benchmark all the commits and then clear the message."
+ ;; If erb--job is set to the symbol `stop',
+ ;; exit. This is meant for development and debugging.
+ (catch 'stop
+ (while t
+ (condition-case-unless-debug err
+ (let* ((job (thread-message-wait erb--job))
+ (commits (when (erb--job-p job) (erb--job-commits job)))
+ (count (length commits))
+ (runbuf (when (erb--job-p job) (erb--job-buffer job)))
+ builds)
+ (when (eq job 'stop)
+ (message "ERB control thread stopping")
+ (setq erb--benchmark-controller nil)
+ (thread-message-cancel erb--job)
+ (throw 'stop nil))
+
+ (catch 'cancelled
+ (unless (eq job 'cancel)
+ (with-current-buffer runbuf
+ ;; First give all the commits to the builder thread(s).
+ (erb--status-set 'start-time (current-time))
+ (erb--status-set 'state 'building)
+ (erb--status-set 'commits commits)
+ (dolist (commit commits)
+ (erb--status-add commit 'waiting-to-build)
+ (thread-queue-put commit erb--unbuilt-commits))
+
+ ;; Collect all the build results, to make sure they
+ ;; are all finished before benchmarking starts.
+ (while (> count 0)
+ (let ((build (thread-queue-get erb--built-commits)))
+ (push build builds))
+ (cl-decf count))
+
+ ;; Reverse the list of finished builds to make the
+ ;; benchmarking order make a little more sense to the
+ ;; user watching the progress indicator.
+ (setq builds (nreverse builds))
+
+ ;; TODO customizable processor cooldown delay
+ ;; before running benchmarks.
+
+ ;; Then benchmark the build results, one at a time.
+ (erb--status-set 'state 'benchmarking)
+ (pcase-dolist (`(,commit ,result) builds)
+ (when (erb--cancel-now-p)
+ (throw 'cancelled nil))
+
+ (when result
+ (message "Benchmarking %s" commit)
+ (erb--status-set 'benchmarking (list commit))
+ (erb--cache-commit-time commit)
+ (erb--benchmark-one-commit commit result)
+ (erb--status-add commit 'finished)
+ (with-demoted-errors (delete-directory result t))))
+ (erb--status-set 'benchmarking nil))))
+
+ (erb--status-set 'stop-time (current-time))
+ (erb--status-set 'state (if (erb--cancel-now-p)
+ 'cancelled 'done))
+ (thread-message-cancel erb--job)
+ '(pcase-dolist (`(,_ ,result) builds)
+ (when result
+ (ignore-errors (delete-directory result t)))))
+ ((error quit)
+ (message "Error in ERB benchmark control thread: %s" err)
+ (thread-message-cancel erb--job))))))
+
+;;;; Builder threads
+
+(defvar erb--builders 0
+ "The number of threads which have been created to run builds.")
+(defvar erb--builder-number 0
+ "Used to make a unique identifier for each ERB build thread.
+For debugging.")
+
+(defun erb--adjust-builder-threads ()
+ "Create the desired number of commit-building threads.
+Get the number from the machine configuration. If there are too
+many threads already running, tell the extra ones to stop."
+ (map-let (cpu-cores) erb--machine-config
+
+ (unless (natnump cpu-cores)
+ (user-error "The value of `cpu-cores' in the configuration for `%s'
+must be a positive integer" (system-name)))
+
+ (while (< erb--builders cpu-cores)
+ (make-thread #'erb--builder-func
+ (format "ERB build %s" erb--builder-number))
+ (cl-incf erb--builder-number)
+ (cl-incf erb--builders))
+
+ (while (> erb--builders cpu-cores)
+ (thread-queue-put 'stop erb--unbuilt-commits)
+ (cl-decf erb--builders))))
+
+(defun erb--builder-func ()
+ "Build commits from `erb--unbuilt-commits'."
+ (catch 'stop
+ (while t
+ (condition-case-unless-debug err
+ (let ((commit (thread-queue-get erb--unbuilt-commits))
+ build-result)
+ (when (eq commit 'stop)
+ (message "ERB builder thread stopping")
+ (throw 'stop nil))
+
+ (erb--status-remove commit 'waiting-to-build)
+ (erb--status-add commit 'building)
+
+ (unwind-protect
+ (let ((job (thread-message-value erb--job)))
+ (unless (eq job 'cancel)
+ (with-current-buffer (erb--job-buffer job)
+ (setq build-result (erb--build commit)))))
+
+ (erb--status-remove commit 'building)
+ (if build-result
+ (erb--status-add commit 'built)
+ (erb--status-add commit 'failed-builds))
+ (thread-queue-put (list commit build-result)
+ erb--built-commits)))
+ ;; TODO in the event of an error, need to put commit on built-commmits.
+ ((error quit) (message "Error in ERB benchmark build thread: %s"
err))))))
+
+(defun erb--build (commit)
+ "Build Emacs from COMMIT.
+Run the build in an asynchonous process in a temporary directory.
+Save the directory name if the build is successful. If the build
+fails, save the output of the build script in the file COMMIT.log
+in the results/MACHINE/failed-builds directory of
+`erb-suite-directory'."
+ ;; TODO make temp file on same machine as build script
+ (let* ((temp-dir (file-name-as-directory (make-temp-file "erb" t)))
+ (default-directory temp-dir)
+ (name (format "ERB-build-%s" commit))
+ (outbuf (generate-new-buffer name))
+ (build-script (erb--get-script-filename 'build))
+ process success)
+
+ (unwind-protect
+ (unless (and erb-run--skip-building-previous-failures
+ (erb--failure-log-exists-p commit))
+ (map-let (project-repo) erb--config
+ (setq project-repo (expand-file-name project-repo))
+ (setq process
+ (condition-case _err
+ (start-file-process name outbuf build-script project-repo
+ commit)
+ ((error quit) nil)))
+ (if (null process)
+ (progn
+ (message "Failed to start build process for commit `%s'"
+ commit)
+ (erb-run--record-failure commit "Failed to start build
process"))
+ (catch 'quit
+ (while (process-live-p process)
+ ;; TODO narrow conditions to repro the EBADF heisenbug
+ ;; at process.c 5510. Has happened whether passing
+ ;; process or nil to accept-process-output. Attempt
+ ;; at standalone code sample in emacs/misc/apo.el, but
+ ;; it won't repro.
+ (accept-process-output nil 0.5)
+ (when (erb--cancel-now-p)
+ (delete-process process)
+ (throw 'quit nil)))
+ (if (= (process-exit-status process) 0)
+ (progn
+ (setq success temp-dir)
+ (erb-run--remove-old-failure commit))
+ (message "Building commit `%s' failed" commit)
+ (erb-run--record-failure commit outbuf))))))
+ (unless success
+ ;; Delete temp directory.
+ (delete-directory temp-dir t))
+ (kill-buffer outbuf))
+ success))
+
+(defun erb-run--record-failure (commit explanation)
+ "Record a failed build of COMMIT.
+EXPLANATION may be a string containing an error message or a
+buffer containing a log of the failed build. Write EXPLANATION
+to the file COMMIT.log in the results/MACHINE/failed-builds
+directory of `erb-suite-directory', where MACHINE is the
+current system."
+ (let ((failures-dir (erb--failed-builds-dir))
+ (text (if (stringp explanation)
+ (concat explanation "\n")
+ (with-current-buffer explanation
+ (if (= (point-min) (point-max))
+ "Build failed without producing any output\n"
+ (buffer-string))))))
+ (make-directory failures-dir t)
+ (with-temp-file (erb-run--failure-log-file-name commit)
+ (insert text))))
+
+(defun erb--failure-log-exists-p (commit)
+ "Return non-nil if a build failure log exists for COMMIT."
+ (file-readable-p (erb-run--failure-log-file-name commit)))
+
+(defun erb-run--remove-old-failure (commit)
+ "Remove any old failure log which may be present for COMMIT.
+If COMMIT.log exists in the results/MACHINE/failed-builds
+directory of `erb-suite-directory', where MACHINE is the current
+system, remove it."
+ (ignore-errors
+ (delete-file (erb-run--failure-log-file-name commit))))
+
+(defun erb-run--failure-log-file-name (commit)
+ (expand-file-name (format "%s.log" commit) (erb--failed-builds-dir)))
+
+;;;; Run benchmarks
+
+(defun erb--benchmark-one-commit (commit target-emacs)
+ "Run the benchmark tasks for one COMMIT and record the results.
+The executable to run should be found in the subdirectory
+'result' of the directory TARGET-EMACS."
+ (let* ((tasks (erb--vc-tasks-for-commmit commit))
+ (benchmark-task-files (directory-files-recursively
+ (erb--benchmark-dir) "\\.el$"))
+ (all-run-results (make-erb--run-results)))
+ (when tasks
+ (dolist (file benchmark-task-files)
+ (when-let* ((selected-tasks (erb--filter-by-file tasks file)))
+ (let* ((this-run-results (erb--run-tasks target-emacs
+ file selected-tasks)))
+ (setq all-run-results
+ (erb--merge-run-results all-run-results
+ this-run-results))
+ (thread-yield)))))
+ (erb--record-run-results commit (system-name) all-run-results)))
+
+(defun erb--filter-by-file (tasks file)
+ "Return the list of TASKS which can be found in FILE.
+TASKS should be a list of `erb--metadata' structures."
+ (seq-filter (lambda (task)
+ (string= (erb--metadata-filename task) file))
+ tasks))
+
+(defun erb--run-tasks (target-emacs file tasks)
+ "Run the TASKS in FILE in TARGET-EMACS.
+Return the benchmark results, messages, errors and process output
+in `erb-run-result' structures.
+
+TARGET-EMACS should be a directory, and the Emacs executable
+should be in \"result/bin/emacs\" within that directory. TASKS
+should be a list of `erb--metadata' structures."
+ (let* ((filename (file-relative-name file (erb--benchmark-dir)))
+ (special-tasks (seq-filter #'erb--metadata-special tasks))
+ (regular-tasks (cl-set-difference tasks special-tasks))
+ results outputs failures messages)
+
+ (when regular-tasks
+ (let ((target-output
+ (erb--run-target-emacs target-emacs file regular-tasks
+ erb-task-repetitions)))
+ (setq results (erb--get-successful-results target-output)
+ outputs (erb--get-outputs target-output)
+ failures (erb--get-failures target-output))
+ messages (erb--get-messages target-output)))
+
+ ;; TODO consider making a way to define and dispatch special
+ ;; tasks instead of putting them all into this cl-case. What
+ ;; other special tasks might be interesting?
+ (dolist (task special-tasks)
+ (cl-case (erb--metadata-special task)
+
+ ;; Don't load ERB or tasks, just see how long the target Emas
+ ;; takes to start up and shut down.
+ (startup
+ (let (samples)
+ (catch 'break
+ (dotimes (_ erb-task-repetitions)
+ ;; TODO quit early if no results are returned (which means
error)
+ (let* (target-output
+ (sample (benchmark-run
+ (setq target-output
+ (erb--run-target-emacs target-emacs
+ file nil 1))))
+ (startup-outputs (erb--get-outputs target-output))
+ (startup-failures (erb--get-failures target-output)))
+ (setq failures (nconc failures startup-failures)
+ outputs (nconc outputs startup-outputs))
+ (if startup-failures
+ (throw 'break nil)
+ (push sample samples)))))
+ (when (= erb-task-repetitions (length samples))
+ (push (make-erb--result :name (erb--metadata-name task)
+ :version (erb--metadata-version task)
+ :file filename
+ :time (truncate (time-to-seconds
+ (current-time)))
+ :samples samples)
+ results))))
+
+ ;; Run the task in its own process, and invoke multiple processes
+ ;; to get multiple samples.
+ (own-process
+ (let (single-process-samples)
+ (catch 'break
+ (dotimes (_ erb-task-repetitions)
+ (let* ((target-output
+ (erb--run-target-emacs target-emacs file
+ (list task) 1))
+ (sp-failures (erb--get-failures target-output))
+ (sp-outputs (erb--get-outputs target-output))
+ (sp-messages (erb--get-messages target-output))
+ (sp-results (erb--get-successful-results target-output))
+ (sample
+ (when sp-results
+ (car (erb--result-samples (car sp-results))))))
+ (setq failures (nconc failures sp-failures)
+ messages (nconc messages sp-messages)
+ outputs (nconc outputs sp-outputs))
+ (if sp-failures
+ (throw 'break nil)
+ (push sample single-process-samples)))))
+ (when (= erb-task-repetitions (length single-process-samples))
+ (push (make-erb--result :name (erb--metadata-name task)
+ :version (erb--metadata-version task)
+ :file filename
+ :time (truncate (time-to-seconds
+ (current-time)))
+ :samples single-process-samples)
+ results))))
+ (t (message "Unknown special task type %s used in %s"
+ (erb--metadata-special task)
+ (erb--metadata-name task)))))
+
+ (make-erb--run-results :results results :messages messages
+ :outputs outputs :failures failures)))
+
+(cl-defstruct erb--target-output
+ file ; Filename of file containing tasks
+ ; (relative to benchmark dir).
+ tasks ; Task name symbol or list of them.
+ exit-code ; Process exit code.
+ output ; Process stdout+stderr.
+ results ; Lisp object read from results file, or nil.
+ results-string ; Text read from results file.
+ time) ; Unix timestamp.
+
+;; TODO should this copy erb.el to the Emacs directory, what if it is remote?
+;; Ditto for file with benchmarks.
+(defun erb--run-target-emacs (target-emacs file tasks repetitions)
+ "Invoke a target Emacs to run TASKS from FILE, REPETITIONS times.
+TARGET-EMACS is the directory in which the target Emacs was
+built, and the executable should be in \"result/bin/emacs\"
+relative to TARGET-EMACS.
+
+Return an `erb--target-output' structure containing the results
+of running the process, including exit code, benchmark results
+and output. If TASKS is nil, do not load ERB in the target Emacs
+process."
+ (let* ((filename (file-relative-name file (erb--benchmark-dir)))
+ (tasks-file (when tasks
+ (erb--compile-tasks-file target-emacs file)))
+ (results-file (expand-file-name "results.eld" target-emacs))
+ ;; TODO wrap loads and evals with with-demoted-errors
+ ;; to guarantee we always get to kill-emacs, even when running
+ ;; interactively.
+ (executable (expand-file-name "result/bin/emacs" target-emacs))
+ (invoke-emacs-args (map-elt erb--machine-config 'emacs-arguments))
+ (load-erb-and-task-args (when tasks
+ `("-l" ,erb-task-el-filename
+ "-l" ,tasks-file)))
+ (repetitions-args
+ `("--eval" ,(format "(setq erb-task-repetitions %s)" repetitions)))
+ (task-names (mapcar #'erb--metadata-name tasks))
+ (task-list (mapconcat #'symbol-name task-names " "))
+ (invoke-erb-args
+ (when tasks
+ `("--eval" ,(format "(erb-task-run-batch '(%s) %S)"
+ task-list results-file))))
+ (kill-emacs-args '("--eval" "(kill-emacs)"))
+ (args (append invoke-emacs-args
+ repetitions-args
+ load-erb-and-task-args
+ invoke-erb-args
+ kill-emacs-args))
+ (target-output (erb--call-process-read-results executable args
+ results-file)))
+ (setf (erb--target-output-file target-output) filename
+ (erb--target-output-tasks target-output) task-names)
+ target-output))
+
+(defun erb--call-process-read-results (executable args file &optional _async)
+ "Invoke EXECUTABLE with ARGS.
+Return the results of the process in an `erb--target-output'
+structure.
+
+FILE should be a filename. If the file exists after the process
+finishes, read a Lisp object from it and put it in the `results'
+slot of the returned structure."
+ (with-temp-buffer
+ ;; TODO asynchronicity
+ (let* ((outbuf (generate-new-buffer "ERB-task"))
+ (exit-code (apply #'call-process
+ (append `(,executable nil ,outbuf nil) args)))
+ (retval (make-erb--target-output
+ :exit-code exit-code
+ :output (with-current-buffer outbuf (buffer-string))
+ :time (truncate (time-to-seconds (current-time))))))
+ (kill-buffer outbuf)
+ (with-temp-buffer
+ (when (file-readable-p file)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (condition-case err
+ (setf (erb--target-output-results retval)
+ (read (current-buffer)))
+ (error
+ (message "Invalid Lisp object in ERB: %s (%s)" err args)
+ (setf (erb--target-output-results-string retval)
+ (buffer-string))))))
+ retval)))
+
+(defun erb--compile-tasks-file (target-emacs file)
+ ;; TODO make a benchmark subdirectory in target-emacs and compile there
+ (let ((dest (expand-file-name (file-name-nondirectory file) target-emacs)))
+ (copy-file file dest t)
+ (with-temp-buffer
+ (let ((exit-code (call-process
+ (expand-file-name "result/bin/emacs" target-emacs)
+ nil t nil
+ "-Q" "--batch"
+ "-l" erb-task-el-filename
+ "-f" "batch-byte-compile" dest)))
+ (when (> (point-max) (point-min))
+ (message "%s" (buffer-string)))
+ (unless (equal 0 exit-code)
+ (message "Failed to byte-compile %s" file))
+ ;; TODO log this somehow
+ (format "%s%s" dest (if (equal 0 exit-code) "c" ""))))))
+
+;;;; Benchmark runner status
+
+;; TODO make this a cl-defstruct and implement clear with
+;; introspection
+(defconst erb--status-fields
+ '(state ; nil, building, benchmarking or done
+ waiting-to-build ; The commits which have not yet been built.
+ commits ; All the commits in the job.
+ building ; The commits currently being built.
+ built ; Commits which have been successfully built.
+ failed-builds ; Commits we tried and failed to build.
+ waiting-to-benchmark ; Built and waiting to be benchmarked.
+ benchmarking ; Commits currently being benchmarked.
+ failed-runs ; Commits with errors during benchmarking.
+ finished ; Commits done benchmarking.
+ start-time ; Time stamp when run started (see `current-time').
+ stop-time)) ; Time stamp when run stopped.
+
+(defvar erb--status (mapcar #'list erb--status-fields)
+ "An alist containing the status of the ERB benchmark runner.")
+(make-symbol-mutex 'erb--status)
+
+(defun erb--clear-status ()
+ "Reset all the ERB benchmarking status variables to their initial state."
+ (with-symbol-mutex erb--status
+ (setq erb--status (mapcar #'list erb--status-fields))))
+
+(defun erb--status-set (field value)
+ (with-symbol-mutex erb--status
+ (setf (map-elt erb--status field) value)))
+
+(defun erb--status-add (value field)
+ (with-symbol-mutex erb--status
+ (push value (map-elt erb--status field))))
+
+(defun erb--status-remove (value field)
+ (with-symbol-mutex erb--status
+ (setf (map-elt erb--status field)
+ (remove value (map-elt erb--status field)))))
+
+(defun erb--status (field)
+ (with-symbol-mutex erb--status
+ (map-elt erb--status field)))
+
+;;;; Store and retrieve benchmark results
+
+;;;;; Benchmark result data structures
+
+(cl-defstruct erb--result
+ machine commit name version file time samples)
+
+(defun erb--result< (a b)
+ "Return non-nil if A should be sorted before B.
+A and B should be `erb--result' structures."
+ (catch 'done
+ (let ((slots '(file name version machine commit)))
+ (dolist (slot slots)
+ (let ((a-val (cl-struct-slot-value 'erb--result slot a))
+ (b-val (cl-struct-slot-value 'erb--result slot b)))
+ (unless (string= a-val b-val)
+ (throw 'done (string< a-val b-val)))))
+ (< (erb--result-time a) (erb--result-time b)))))
+
+(defun erb--struct-match-p (type slots a b)
+ "Return non-nil if the SLOTS in A and B are the same (using `equal').
+SLOTS should be a list of symbols which are slot names in
+TYPE (as defined by `cl-defstruct'), and A and B should be
+instances of TYPE."
+ (catch 'result
+ (dolist (slot slots)
+ (unless (equal (cl-struct-slot-value type slot a)
+ (cl-struct-slot-value type slot b))
+ (throw 'result nil)))
+ t))
+
+(iter-defun erb--chunk-list (type slots structs)
+ "Yield lists of entries from STRUCTS in which the values of SLOTS match.
+STRUCTS should be a list of instances of TYPE (as defined by
+`cl-defstruct') and SLOTS should be a list of symbols
+corresponding to slots in TYPE. Yield a list containing the
+first remaining element of STRUCTS plus those elements immediately
+following it which have the same slot values."
+ (while structs
+ (let ((first (car structs))
+ matching)
+ (while (and structs (erb--struct-match-p type slots first (car structs)))
+ (push (pop structs) matching))
+ (iter-yield (nreverse matching)))))
+
+(cl-defstruct erb--failure
+ machine ; Hostname the target Emacs was run on.
+ commit ; Commit the target Emacs was built from.
+ file ; Name of the benchmark task definition file, relative to the
+ ; benchmark directory.
+ tasks ; Single task or list of tasks provided to Emacs (as symbols).
+ error ; (SYMBOL MESSAGE)
+ time ; Integer Unix timestamp.
+ )
+
+(cl-defstruct erb--output
+ machine commit file tasks output time)
+
+(cl-defstruct erb--messages
+ machine commit file name messages time)
+
+(cl-defstruct erb--run-results
+ results ; A list of `erb--result's.
+ messages ; A list of `erb--messages'.
+ outputs ; A list of `erb--output's.
+ failures ; A list of `erb--failure's.
+ )
+
+(defun erb--merge-run-results (a b)
+ "Return an `erb--run-results' structure by combining A and B.
+A and B should be `erb--run-results' structures. Destructively
+modify A."
+ (make-erb--run-results
+ :results
+ (nconc (erb--run-results-results a) (erb--run-results-results b))
+ :messages
+ (nconc (erb--run-results-messages a) (erb--run-results-messages b))
+ :outputs
+ (nconc (erb--run-results-outputs a) (erb--run-results-outputs b))
+ :failures
+ (nconc (erb--run-results-failures a) (erb--run-results-failures b))))
+
+(defconst erb--run-result-dir-names-alist
+ '((results "measurements")
+ (messages "logs" "messages")
+ (outputs "logs" "process-output")
+ (failures "task-errors"))
+ "Directories in which to save the components of `erb--run-results'.
+An alist mapping `erb--run-results' slot names to lists of strings,
+which are used to construct directory names.")
+
+(defun erb--run-result-dir-name (slot)
+ "Return the directory name used by SLOT of `erb--run-result.'"
+ (let ((names (alist-get slot erb--run-result-dir-names-alist))
+ (dirname (erb--results-dir)))
+ (dolist (name names)
+ (setq dirname (expand-file-name name dirname)))
+ dirname))
+
+(defun erb--record-run-results (commit machine run-result)
+ "Add the contents of RUN-RESULT to the data saved for COMMIT and MACHINE."
+ (dolist (slot (mapcar #'car erb--run-result-dir-names-alist))
+ (when-let ((entries (cl-struct-slot-value 'erb--run-results slot
run-result))
+ (directory (erb--run-result-dir-name slot))
+ (file (expand-file-name (format "%s.eld" commit) directory)))
+ (make-directory directory t)
+ (let ((table (if (file-readable-p file)
+ (erb--table-read file)
+ (make-erb--table-for-type
+ (type-of (car entries))
+ :constants (list :commit commit :machine machine)))))
+ (erb--table-insert table entries)
+ (erb--table-write table file)))))
+
+;;;;; Detect errors
+
+(defun erb--get-failures (target-output)
+ "Return a list of failure conditions found in TARGET-OUTPUT.
+Return a list of `erb-failure' structures for the following
+conditions: nonzero process exit code, results that were entirely
+missing, missing or invalid samples, errors recorded in samples,
+and tasks without results."
+ (let* (failures
+ (file (erb--target-output-file target-output))
+ (tasks (erb--target-output-tasks target-output))
+ (results (erb--target-output-results target-output))
+ (results-string (erb--target-output-results-string target-output))
+ (exit-code (erb--target-output-exit-code target-output))
+ (time (erb--target-output-time target-output))
+ (filename (file-relative-name file (erb--benchmark-dir))))
+ (cl-flet ((add-failure (task err)
+ (push (make-erb--failure :file filename :tasks task
+ :error err :time time)
+ failures)))
+ (cond
+ ((not (equal 0 exit-code))
+ (add-failure tasks `(erb--process-failed
+ ,(format "Process exit code: %s" exit-code))))
+ ((and tasks (null results))
+ (add-failure tasks `(erb--invalid-results
+ ,(format "Contents of results file: %S"
+ results-string))))
+ (t (let (found)
+ (dolist (result results)
+ (map-let (name samples) result
+ (push name found)
+ (if (null samples)
+ (add-failure name '(erb--no-samples "No samples
collected"))
+ (catch 'break
+ (dolist (sample samples)
+ (cond
+ ((and sample
+ (= (length sample) 2)
+ (symbolp (nth 0 sample))
+ (stringp (nth 1 sample)))
+ (add-failure name sample)
+ (throw 'break))
+ ((not (erb--valid-sample-p sample))
+ (add-failure name `(erb--invalid-sample
+ ,(format "Invalid sample: %s"
+ sample)))
+ (throw 'break))))))))
+ (dolist (not-found (cl-set-difference (if (listp tasks)
+ tasks (list tasks))
+ found))
+ (add-failure not-found
+ `(erb--missing-task
+ ,(format "No samples created for task"))))))))
+ failures))
+
+(defun erb--valid-sample-p (sample)
+ "Return non-nil if SAMPLE resembles a return value of `benchmark-run'."
+ (and (listp sample)
+ (= (length sample) 3)
+ (floatp (nth 0 sample))
+ (integerp (nth 1 sample))
+ (floatp (nth 2 sample))))
+
+;;;;; Extract structured data from output of target process
+
+(defun erb--get-messages (target-output)
+ "Make all the messages in TARGET-OUTPUT into `erb-message' structures.
+Return a list."
+ (let (message-structs
+ (file (erb--target-output-file target-output))
+ (results (erb--target-output-results target-output))
+ (exit-code (erb--target-output-exit-code target-output))
+ (time (erb--target-output-time target-output)))
+ (when (equal 0 exit-code)
+ (dolist (result results)
+ (map-let (name messages) result
+ (let* ((unique-messages
+ (cl-remove-duplicates (remove "" messages)
+ :test #'string=)))
+ (when unique-messages
+ (push (make-erb--messages :file file :name name
+ :messages unique-messages :time time)
+ message-structs))))))
+ message-structs))
+
+(defun erb--get-outputs (target-output)
+ "Return the process output from TARGET-OUTPUT, if there was any.
+Return it as a list containing a single `erb--output' structure, or
+nil if there was no output."
+ (let ((file (erb--target-output-file target-output))
+ (tasks (erb--target-output-tasks target-output))
+ (output (erb--target-output-output target-output))
+ (time (erb--target-output-time target-output)))
+ (unless (string= output "")
+ (list
+ (make-erb--output :file file :tasks tasks :output output :time time)))))
+
+(defun erb--get-successful-results (target-output)
+ "Return only those results in TARGET-OUTPUT representing successful runs.
+Returns a list of `erb--result' structures."
+ (let (result-structs
+ (file (erb--target-output-file target-output))
+ (results (erb--target-output-results target-output))
+ (exit-code (erb--target-output-exit-code target-output))
+ (time (erb--target-output-time target-output)))
+ (when (equal 0 exit-code)
+ (dolist (result results)
+ (map-let (name version samples) result
+ (when (and samples
+ (seq-every-p #'erb--valid-sample-p samples))
+ (push (make-erb--result :file file :name name :version version
+ :samples samples :time time)
+ result-structs)))))
+ result-structs))
+
+;;;;; Filenames and directories for benchmark results
+
+(defun erb--failed-runs-dir (&optional machine)
+ (expand-file-name "task-errors" (erb--results-dir machine)))
+
+(defun erb--failed-builds-dir (&optional machine)
+ (expand-file-name "build-errors" (erb--results-dir machine)))
+
+(defun erb--results-dir (&optional machine)
+ (unless machine (setq machine (system-name)))
+ (thread-last erb-suite-directory
+ (expand-file-name "results")
+ (expand-file-name machine)))
+
+(defun erb--machine-results-dirs ()
+ (let ((files (directory-files
+ (expand-file-name "results" erb-suite-directory) t
+ "[^.].*")))
+ (seq-filter #'file-directory-p files)))
+
+;;; Minimal database API
+
+(cl-defstruct (erb--table
+ (:constructor make-erb--table)
+ (:constructor make-erb--table-for-type
+ (type
+ &key (constants nil)
+ &aux
+ ;; Only those keys not in `constants'
+ (keys (erb--table-find-keys type constants)))))
+ type keys constants rows)
+
+(defun erb--table-find-keys (type constants)
+ "Return the list of keys to be saved in the file.
+Return the list of slot names for TYPE converted to keywords,
+and without any keywords found in the plist CONSTANTS."
+ (let* ((slots (cdr (mapcar #'car (cl-struct-slot-info type))))
+ (keywords (mapcar (lambda (slot)
+ (intern (format ":%s" (symbol-name slot))))
+ slots))
+ (constants (cl-loop for k in constants by #'cddr
+ collect k)))
+ (cl-set-difference keywords constants)))
+
+(defun erb--table-insert (table rows)
+ "Insert ROWS into TABLE.
+ROWS may be a single object or a list."
+ (unless (listp rows)
+ (setq rows (list rows)))
+ (let ((type (erb--table-type table)))
+ (mapc (lambda (rec) (cl-assert (eq (type-of rec) type))) rows))
+ (setf (erb--table-rows table) (nconc (erb--table-rows table) rows))
+ table)
+
+(defun erb--table-read (filename)
+ "Read a `erb--table' from FILENAME."
+ (let (table)
+ (condition-case err
+ (when (file-readable-p filename)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (setq table (read (current-buffer)))))
+ (error "Error reading %s: %s" filename err))
+ (unless (and table
+ (null (cl-set-exclusive-or (map-keys table)
+ '(erb-version type keys
+ constants rows))))
+ ;; TODO the right thing about older/newer ERB versions
+ ;; have an argument to the constructor for that
+ (error "Incorrect keys in ERB data file: %s" filename))
+ (map-let (erb-version type keys constants rows) table
+ (let ((constructor (apply-partially #'erb--make-record
+ type keys constants)))
+ (make-erb--table :type type
+ :keys keys
+ :constants constants
+ :rows (mapcar constructor rows))))))
+
+(defun erb--make-record (type keys constants values)
+ "Return a new structure of TYPE initialized by VALUES.
+The slots corresponding to KEYS will be set to the respective values in
+VALUES. The plist CONSTANTS will be included in the arguments
+passed to the constructor."
+ (let* ((kv-pairs (cl-mapcar #'list keys values))
+ (kv-args (apply #'append kv-pairs))
+ (args (append constants kv-args))
+ (constructor (intern-soft (format "make-%s" (symbol-name type)))))
+ (apply constructor args)))
+
+(defun erb--table-write (table filename)
+ "Write TABLE to FILENAME."
+ (let* ((rows (erb--table-rows table))
+ (values (mapcar (apply-partially #'erb--get-record-values table)
rows))
+ (alist `((erb-version . ,erb-version)
+ (type . ,(erb--table-type table))
+ (keys . ,(erb--table-keys table))
+ (constants . ,(erb--table-constants table))
+ (rows . ,values))))
+ (with-temp-file filename
+ (let ((standard-output (current-buffer)))
+ (cl-prin1 alist)
+ (pp-buffer)))))
+
+(defun erb--get-record-values (table record)
+ "Return a list of the values corresponding to KEYS in RECORD."
+ (mapcar (lambda (key)
+ (cl-struct-slot-value (erb--table-type table)
+ (intern (substring (symbol-name key) 1))
+ record))
+ (erb--table-keys table)))
+
+
+(defun erb--table-select (table func)
+ "Return all rows in TABLE for which FUNC returns non-nil."
+ (let (results)
+ (dolist (row (erb--table-rows table))
+ (when (funcall func row)
+ (push row results)))
+ (nreverse results)))
+
+(defun erb--table-update (table select-func update-func)
+ "Update selected rows in TABLE.
+Call SELECT-FUNC on each row in TABLE. If it returns non-nil,
+call UPDATE-FUNC on the row."
+ (dolist (row (erb--table-rows table))
+ (when (funcall select-func row)
+ (funcall update-func row))))
+
+;;; Cache commit times
+
+(cl-defstruct erb--commit
+ commit time)
+
+(defun erb--cache-commit-time (commit)
+ "Get the time of COMMIT from git if that has not yet been done.
+Save it in a database in the \"commits\" subdirectory of the
+machine results directory. These could be combined into a single
+file instead of one file per machine, but that would make
+git-merging results harder."
+ ;; TODO function to generate filename
+ (let* ((dirname (expand-file-name "cache" (erb--results-dir)))
+ (filename (progn (make-directory dirname t)
+ (expand-file-name "commits.eld" dirname)))
+ (commit-db
+ (if (file-readable-p filename)
+ (erb--table-read filename)
+ (make-erb--table-for-type 'erb--commit)))
+ (select-func (lambda (rec) (string= commit (erb--commit-commit
rec)))))
+ (unless (erb--table-select commit-db select-func)
+ (erb--table-insert commit-db
+ (make-erb--commit :commit commit
+ :time (erb--vc-get-commit-time
+ commit)))
+ (erb--table-write commit-db filename))))
+
+(defun erb--read-commit-cache ()
+ "Read all the cached commit times and return them in a hash table."
+ (let ((all-commits (make-hash-table :test 'equal)))
+ (dolist (machine (erb--machine-results-dirs))
+ (when-let ((commit-file (thread-last machine
+ (expand-file-name "cache")
+ (expand-file-name "commits.eld")))
+ (table (with-demoted-errors "Error: %s"
+ (erb--table-read commit-file))))
+ (dolist (row (erb--table-rows table))
+ (puthash (erb--commit-commit row) (erb--commit-time row)
+ all-commits))))
+ all-commits))
+
+;;; Communication with version control
+
+(defun erb--vc-get-commit-time (commit)
+ "Get the UNIX timestamp for COMMIT."
+ (let ((default-directory (map-elt erb--config 'project-repo)))
+ (with-temp-buffer
+ (call-process "git" nil t nil
+ "log" "-1" "--format=%ct" commit)
+ (string-to-number (buffer-string)))))
+
+(defun erb--vc-tasks-for-commmit (commit)
+ "Return the list of tasks which should be run for COMMIT."
+ (map-let (project-repo) erb--config
+ (seq-filter (lambda (task)
+ (erb--vc-commit-appropriate-p task project-repo commit))
+ erb--benchmark-tasks)))
+
+;; TODO
+(defun erb--vc-commit-appropriate-p (_task _src-repo _commit)
+ "Return non-nil if TASK should be run for a build of COMMIT."
+ t)
+
+(defvar erb--commit-range-count-cache (make-hash-table :test 'equal))
+
+(defun erb--vc-get-commit-range-count (range)
+ "Return the number of commits in RANGE.
+If there is an error trying to determine that, return nil."
+ (if-let ((cached (gethash range erb--commit-range-count-cache)))
+ cached
+ (let ((default-directory (map-elt erb--config 'project-repo)))
+ (with-temp-buffer
+ (when (= (call-process "git" nil t nil "rev-list" "--count" range) 0)
+ (let ((result (string-to-number (buffer-string))))
+ (puthash range result erb--commit-range-count-cache)
+ result))))))
+
+(defun erb--vc-get-commits (range &optional select-count)
+ "Return the list of commits in RANGE, ordered oldest to newest.
+If SELECT-COUNT is provided, limit the number of commits returned
+to that number, choosing them at intervals spaced out over the
+entire list of commits."
+ (let* ((default-directory (map-elt erb--config 'project-repo))
+ (lines (process-lines "git" "rev-list" "--first-parent" range))
+ (count (length lines))
+ (num (or select-count count))
+ (gap (max 1 (/ (- count 1) (if (> num 1) (- num 1.0) 1.0))))
+ (indices (let ((index 0)
+ result)
+ (while (and (< index count) (< (length result) num))
+ (push (truncate index) result)
+ (cl-incf index gap))
+ (when (< (length result) num)
+ (push (1- count) result))
+ (cl-remove-duplicates result :test #'=))))
+ (mapcar (lambda (index) (nth index lines)) indices)))
+
+;;; Publish results
+
+;;;; Customize which results are used and shown
+
+(defcustom erb--include-older-samples nil
+ "When non-nil, average the results of all the runs of each task."
+ :type 'boolean
+ :group 'erb
+ :version "27.1")
+
+(defcustom erb--show-all-task-versions nil
+ "When non-nil, show results for older versions of tasks.
+Otherwise only the results of the newest version of the task will
+be shown."
+ :type 'boolean
+ :group 'erb
+ :version "27.1")
+
+;;;; Data structure for summarized results
+
+(cl-defstruct erb--summary
+ name ; from erb--result
+ file ; from erb--result
+ version-values ; ((VERSION . COMMIT-VALUES) ...)
+ ; COMMIT-VALUES is list (commit VALUES)
+ ; VALUES is an array of floats indexed by machine number
+ )
+
+;;;; Read and summarize benchmark results
+
+(defun erb--read-all-results ()
+ "Read all the benchmarking results from all the machines.
+Return a sorted list of `erb-result' structures."
+ (let ((machine-dirs (erb--machine-results-dirs))
+ all-results
+ (all-commits (make-hash-table :test 'equal)))
+
+ ;; Collect all results from all machines into one list.
+ (dolist (machine machine-dirs)
+ (let ((measurements-dir (expand-file-name "measurements" machine)))
+ (dolist (commit-file (directory-files measurements-dir t ".+\\.eld$"))
+ (when-let ((commit (substring (file-name-nondirectory commit-file)
+ 0 (- (length ".eld"))))
+ (commit-time (gethash commit all-commits 0))
+ (table (erb--table-read commit-file)))
+ (dolist (row (erb--table-rows table))
+ (push row all-results))))))
+
+ (sort all-results #'erb--result<)))
+
+(defun erb--calculate-result-averages (results)
+ "Calculate average times for each benchmark task.
+RESULTS should be a sorted list of `erb--result' structures, one
+for each task run. Calculate the averages of all the samples for
+each task run for each commit on each machine, and return a list
+of `erb-result' structures, with the `samples' slot containing
+the calculated average time."
+ (let (averaged-results)
+ (iter-do (matching (erb--chunk-list 'erb--result
+ '(machine commit name file version)
+ results))
+ (let* ((newest (car (last matching)))
+ (copy (copy-erb--result newest)))
+ (setf (erb--result-samples copy)
+ (erb--average-of-samples
+ (if erb--include-older-samples
+ (let ((all-samples (apply #'append
+ (mapcar #'erb--result-samples
+ matching))))
+ all-samples)
+ (erb--result-samples newest))))
+ (push copy averaged-results)))
+ (nreverse averaged-results)))
+
+(defun erb--average-of-samples (samples)
+ (/ (seq-reduce #'+ (mapcar #'car samples) 0.0) (length samples)))
+
+(defun erb--summarize-task-results (machines averaged-results)
+ "Collect results for each task into `erb--summary' structures.
+MACHINES is a list of machine names. AVERAGED-RESULTS should be
+a sorted list of `erb--result' structures. Collect all the
+results for all the runs of each task into one `erb--summary'
+structure per task."
+ (let (summaries last-machine last-machine-index)
+
+ ;; Since the list of results is sorted by machine, avoid
+ ;; calls to cl-position by caching it.
+ (cl-flet ((machine-index (machine)
+ (unless (equal last-machine machine)
+ (setq last-machine machine
+ last-machine-index (cl-position machine machines
+ :test 'equal)))
+ last-machine-index))
+
+ (iter-do (task-results (erb--chunk-list 'erb--result '(name file)
+ averaged-results))
+ (let* ((first (car task-results))
+ (summary (make-erb--summary :name (erb--result-name first)
+ :file (erb--result-file first))))
+
+ (iter-do (version-results (erb--chunk-list 'erb--result
+ '(version)
+ task-results))
+ ;; Now we have a list where all entries have the same
+ ;; file, task, name and version but different machines and
+ ;; commits. Make an alist where the keys are commits and
+ ;; the values are arrays of measurements indexed by machines.
+ ;; All commits are not necessarily present on all machines.
+ (let ((commit-values-ht (make-hash-table :test 'equal))
+ (version (erb--result-version (car version-results))))
+ (dolist (result version-results)
+ (let ((existing (gethash (erb--result-commit result)
+ commit-values-ht)))
+ (unless existing
+ (setq existing (make-vector (length machines) nil)))
+ (aset existing (machine-index (erb--result-machine result))
+ (erb--result-samples result))
+ (puthash (erb--result-commit result) existing
+ commit-values-ht)))
+
+ ;; Convert the hash table to an alist.
+ (let (commit-values)
+ (maphash #'(lambda (c v) (push (cons c v) commit-values))
+ commit-values-ht)
+ (push (cons version commit-values)
+ (erb--summary-version-values summary)))))
+ (setf (erb--summary-version-values summary)
+ (nreverse (erb--summary-version-values summary)))
+ (push summary summaries))))
+ (nreverse summaries)))
+
+;;; Write org file containing results with gnuplot graphs
+
+;; Todo something like sockeye (nixos) and rainbow (darwin) in graph keys
+(defun erb-write-result-org-file ()
+ (interactive)
+ (erb--update-config-cache)
+ (unless erb--config
+ (insert (format "Error reading `config.eld': \n %s\n" erb--config-err)))
+ (unless erb--benchmark-tasks
+ (erb--read-benchmark-metadata))
+ (let* ((report-dir (expand-file-name "report" erb-suite-directory))
+ (report-file (progn (make-directory report-dir t)
+ (expand-file-name "report.org" report-dir)))
+ (machines (sort (mapcar #'file-name-nondirectory
+ (erb--machine-results-dirs))
+ #'string<))
+ (results (erb--read-all-results))
+ (averages (erb--calculate-result-averages results))
+ (summaries (erb--summarize-task-results machines averages))
+ (commit-cache (erb--read-commit-cache))
+ (title (format "#+TITLE: %s Benchmarks\n"
+ (map-elt erb--config 'project-name)))
+ (xtics (format "set xtics rotate by -45 \\\n (%s)\n"
+ (mapconcat (lambda (commit)
+ (format "\"%s\" %s" commit
+ (erb--vc-get-commit-time commit)))
+ (map-elt erb--config 'tags) ", \\\n ")))
+ (this-buffer (current-buffer)))
+ ;; TODO what does gnuplot do with empty list?
+
+ (make-directory (expand-file-name "plots" report-dir) t)
+ (with-temp-file report-file
+ (insert
+ title
+ "#+OPTIONS: toc:2 num:2 author:nil\n"
+ "#+LATEX_HEADER: \usepackage[margin=0.5in]{geometry}\n"
+ "* Benchmark results\n")
+ (iter-do (file-summaries (erb--chunk-list 'erb--summary
+ '(file) summaries))
+ (let ((file (erb--summary-file (car file-summaries))))
+ (insert
+ (format "** %s\n" (with-current-buffer this-buffer
+ (erb--benchmark-file-description file)))
+ (format "=%s=\n" file)))
+
+ (dolist (summary file-summaries)
+ (let* ((name (erb--summary-name summary))
+ (vv-alist (erb--summary-version-values summary))
+ (multiple-versions (> (length vv-alist) 1))
+ (versions (mapcar #'car
+ (if erb--show-all-task-versions
+ vv-alist
+ (last vv-alist))))
+ (data-tables ""))
+ (insert
+ (format "*** %s\n" name)
+ (if-let ((metadata
+ (seq-find (lambda (m)
+ (equal name (erb--metadata-name m)))
+ erb--benchmark-tasks)))
+ (format "%s\n" (substitute-command-keys
+ (erb--metadata-documentation metadata)))
+ ""))
+ (dolist (version versions)
+ (let* ((data-table-name (format "%s-%s" name version))
+ (measurements (erb--summary-measurements
+ commit-cache version summary))
+ (x-axis (erb--analyze-x-axis measurements))
+ (y-axis (erb--analyze-y-axis measurements)))
+ (insert
+ "#+BEGIN_SRC gnuplot "
+ (format ":var data=%1$s() :file plots/%1$s.png :noweb yes\n"
+ data-table-name)
+ "reset\n"
+ "set terminal png size 800, 600\n"
+ (format "set title \"%s%s\"\n" name
+ (if multiple-versions (format "-%s" version) ""))
+ "set xlabel \"Commit\"\n"
+ (format "set xrange [%s:%s]\n"
+ (map-elt x-axis 'actual-min)
+ (map-elt x-axis 'actual-max))
+ "<<xtics>>\n"
+ "set ylabel \"Run time (seconds)\"\n"
+ (format "set yrange [%s:%s]\n"
+ 0 (* 1.1 (map-elt y-axis 'actual-max)))
+ "set key right bottom\n"
+ "plot "
+ (mapconcat (lambda (mach-index)
+ (format "data u 2:%d w lp lw 2 title '%s'"
+ (+ mach-index 3)
+ (nth mach-index machines)))
+ (number-sequence 0 (1- (length machines)))
+ ", \\\n ")
+ "\n"
+
+ "#+END_SRC\n\n")
+ ;; Because of the :noexport: tags, the data tables
+ ;; have to come after the plots. Print them to a
+ ;; string now and insert them after the version loop,
+ ;; to avoid having to recalculate `measurements'.
+ (setq data-tables
+ (concat data-tables
+ (format "*** Measurements for %s :noexport:\n"
+ data-table-name)
+ (format "#+NAME: %s\n" data-table-name)
+ "#+BEGIN_SRC emacs-lisp\n"
+ (with-temp-buffer
+ (let ((standard-output (current-buffer)))
+ (princ "'")
+ (cl-prin1 measurements))
+ (pp-buffer)
+ (buffer-string))
+ "#+END_SRC\n\n"))))
+ (insert data-tables))))
+ (insert "* Benchmark machine information\n")
+ (dolist (machine machines)
+ (let ((config (with-demoted-errors "Error: %s"
+ (erb--read-machine-config machine)))
+ (info (with-demoted-errors "Error: %s"
+ (car-safe (erb--read-saved-machine-info machine))))
+ (important '("OS" "Kernel" "CPU" "GPU" "Memory")))
+ (insert
+ (format "** %s\n" machine)
+ "*** Configuration\n"
+ (format "Arguments used to invoke Emacs: =%s=\n"
+ (mapconcat #'identity (map-elt config 'emacs-arguments) "
"))
+ "*** System information\n"
+ "#+OPTIONS: ^:nil\n")
+ (if (null info)
+ (insert "Unavailable\n")
+ (insert
+ "#+BEGIN_SRC emacs-lisp :results value table :exports results\n"
+ (with-temp-buffer
+ (let ((standard-output (current-buffer))
+ cleaned-info)
+ (dolist (key important)
+ (when-let ((value (map-elt info key nil #'equal)))
+ (push (list key value) cleaned-info)))
+ (dolist (key (cl-set-difference (mapcar #'car info) important
+ :test #'equal))
+ (when-let ((is-string (stringp key))
+ (value (map-elt info key nil #'equal)))
+ (push (list key value) cleaned-info)))
+ (princ "'")
+ (cl-prin1 (nreverse cleaned-info)))
+ (pp-buffer)
+ (buffer-string))
+ "#+END_SRC\n\n"
+ (format-time-string
+ "System information last updated: %Y-%m-%d %a %H:%M\n"
+ (map-elt info :time))
+ "* Xtics :noexport:\n"
+ "#+BEGIN_SRC gnuplot :export none\n"
+ xtics
+ "#+END_SRC\n")))))))
+
+(defun erb--benchmark-file-description (file)
+ (let ((filename (expand-file-name file (erb--benchmark-dir))))
+ (condition-case _err
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (re-search-forward ";+ .+? --- \\(.+?\\)\\( -*-.+?\\)$"
+ (save-excursion (forward-line) (point)))
+ (match-string 1))
+ (error "Failed to find description in first line"))))
+
+(defun erb--analyze-x-axis (measurements)
+ (erb--analyze-axis (mapcar #'cadr measurements)))
+
+(defun erb--analyze-y-axis (measurements)
+ (let* ((count (- (length (car measurements)) 2))
+ (y-values (mapcar (lambda (measurement)
+ (last measurement count))
+ measurements)))
+ (erb--analyze-axis (apply #'append y-values))))
+
+;; TODO cl-defstruct
+(defun erb--analyze-axis (numbers)
+ (setq numbers (remq nil numbers))
+ (let* ((actual-min (seq-reduce #'min numbers (car numbers)))
+ (actual-max (seq-reduce #'max numbers (car numbers)))
+ (range (- actual-max actual-min))
+ (padded-min (max 0 (- actual-min (* 0.2 range))))
+ (padded-max (+ actual-max (* 0.2 range))))
+ `((actual-min . ,actual-min)
+ (actual-max . ,actual-max)
+ (range . ,range)
+ (padded-min . ,padded-min)
+ (padded-max . ,padded-max))))
+
+(defun erb--summary-measurements (commit-time-cache version summary)
+ (let* ((values (map-elt (erb--summary-version-values summary) version
+ nil #'equal))
+ (measurements
+ (mapcar
+ (pcase-lambda (`(,commit . ,machine-values))
+ (let ((commit-time (gethash commit commit-time-cache 0)))
+ (append (list commit commit-time) machine-values nil)))
+ values)))
+ ;; Return list sorted by commit time.
+ (sort measurements (lambda (a b) (< (nth 1 a) (nth 1 b))))))
+
+(provide 'erb)
+;;; erb.el ends here
- [Emacs-diffs] branch scratch/benchmarks created (now e2b5f51), Gemini Lasswell, 2018/11/25
- [Emacs-diffs] scratch/benchmarks ef44d4b 2/6: Add per-symbol mutexes, Gemini Lasswell, 2018/11/25
- [Emacs-diffs] scratch/benchmarks b2f0a4e 4/6: Bug#31671 band-aid, Gemini Lasswell, 2018/11/25
- [Emacs-diffs] scratch/benchmarks 632a12d 1/6: Add thread-safe messages and thread-safe queues, Gemini Lasswell, 2018/11/25
- [Emacs-diffs] scratch/benchmarks 40f179e 3/6: Instrument file descriptor mask code (bug#33198), Gemini Lasswell, 2018/11/25
- [Emacs-diffs] scratch/benchmarks e2b5f51 6/6: Create benchmark directory and add some benchmark tasks, Gemini Lasswell, 2018/11/25
- [Emacs-diffs] scratch/benchmarks 52c7cc8 5/6: Add ERB, a tool for running historical benchmarks,
Gemini Lasswell <=