>From 4b9e3ccb2376ea532051d5ff7d2d308df56576c9 Mon Sep 17 00:00:00 2001 From: Gemini Lasswell Date: Tue, 9 Oct 2018 09:27:54 -0700 Subject: [PATCH] Reproduce Bswitch segfault --- lisp/thread.el | 454 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 454 insertions(+) diff --git a/lisp/thread.el b/lisp/thread.el index 7974a2603c..9c4774e961 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -196,5 +196,459 @@ thread-list--name (and (eq thread main-thread) "Main") (prin1-to-string thread))) +;;; Thread-safe messages + +(cl-defstruct + (thread--message + (:constructor + thread-make-message (&optional name + &aux + (mutex (make-mutex name)) + (condition + (make-condition-variable mutex name))))) + name mutex value condition) + +(defun thread-message-available-p (message) + "Return the value of MESSAGE." + (thread--message-value message)) + +(defun thread-message-send (message value) + "Set the VALUE of MESSAGE, and awaken all threads waiting for it." + (with-mutex (thread--message-mutex message) + (setf (thread--message-value message) value) + (condition-notify (thread--message-condition message) t))) + +(defun thread-message-cancel (message) + "Cancel MESSAGE by setting its value to nil." + (with-mutex (thread--message-mutex message) + (setf (thread--message-value message) nil))) + +(defun thread-message-wait (message &optional cancel) + "If MESSAGE's value is nil, block until it is set to something else. +Return the value of MESSAGE. If CANCEL is non-nil, clear MESSAGE +by setting its value to nil. If multiple threads are waiting on +the same message, and all pass a non-nil CANCEL, then only one +thread will unblock and receive the message's value, and the +others will continue to block." + (with-mutex (thread--message-mutex message) + (while (not (thread--message-value message)) + (condition-wait (thread--message-condition message))) + (let ((value (thread--message-value message))) + (when cancel + (setf (thread--message-value message) nil)) + value))) + +;;; Thread-safe queues + +(cl-defstruct (thread--queue + (:constructor + thread-make-queue (&optional + size-limit + type + &aux + (fifo (eq type 'fifo)) + (limit (when (natnump size-limit) size-limit)) + (mutex (make-mutex)) + (not-full (make-condition-variable mutex)) + (not-empty (make-condition-variable mutex))))) + fifo + limit + items + mutex + not-full + not-empty) + +(defun thread-queue-empty-p (queue) + "Return non-nil if QUEUE is empty. +There is no guarantee that QUEUE will contain the same number of +items the next time you access it." + (with-mutex (thread--queue-mutex queue) + (null (thread--queue-items queue)))) + +(defun thread-queue-full-p (queue) + "Return non-nil if QUEUE is full. +There is no guarantee that QUEUE will contain the same number of +items the next time you access it." + (when (thread--queue-limit queue) + (with-mutex (thread--queue-mutex queue) + (= (length (thread--queue-items queue)) (thread--queue-limit queue))))) + +(defun thread-queue-length (queue) + "Return the number of items in QUEUE. +There is no guarantee that QUEUE will contain the same number of +items the next time you access it." + (with-mutex (thread--queue-mutex queue) + (length (thread--queue-items queue)))) + +(defun thread-queue-remove-all (queue) + "Discard any items in QUEUE." + (with-mutex (thread--queue-mutex queue) + (setf (thread--queue-items queue) nil) + (condition-notify (thread--queue-not-full queue)))) + +(defun thread-queue-put (item queue) + "Put ITEM into QUEUE. +If QUEUE was created with a size limit, and already contains that many items, +block until one is removed." + (with-mutex (thread--queue-mutex queue) + (while (and (thread--queue-limit queue) + (= (length (thread--queue-items queue)) (thread--queue-limit queue))) + (condition-wait (thread--queue-not-full queue))) + (if (thread--queue-fifo queue) + (setf (thread--queue-items queue) + (nconc (thread--queue-items queue) (list item))) + (push item (thread--queue-items queue))) + (condition-notify (thread--queue-not-empty queue)))) + +(defun thread-queue-get (queue) + "Remove an item from QUEUE and return it. +If there are no items in QUEUE, block until one is added." + (with-mutex (thread--queue-mutex queue) + (while (null (thread--queue-items queue)) + (condition-wait (thread--queue-not-empty queue))) + (let ((item (pop (thread--queue-items queue)))) + (condition-notify (thread--queue-not-full queue)) + item))) + +;;; Bswitch bug + +(require 'seq) + +(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-run--benchmarker'.") + +(defvar erb--status nil + "The state of the benchmark runner. +Possible values are `idle', `building', `benchmarking' and +`done'. Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-commits nil + "The commits being processed by the benchmark runner.") + +(defvar erb--status-waiting-to-build nil + "The list of commits that have not yet started building. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-building nil + "The list of commits that are currently being built. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-built nil + "The list of commits that have been built. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-failed-builds nil + "The list of commits that failed to build. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-waiting-to-benchmark nil + "The commits that are built and waiting to be benchmarked. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-benchmarking nil + "The commit that is currently being benchmarked. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-benchmark-failures nil + "The commits that had task failures during benchmarking. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb--status-finished nil + "The commits that are finished benchmarking. +Maintained by `erb-run--monitor' and used to update the +`erb-run' buffer.") + +(defvar erb-run--cancel-request (thread-make-message) + "Signal the user's request that a benchmark job be stopped. +Cleared when the benchmark job is cleaned up, by +`erb-run-benchmarker'.") + + +;;; ERB Run Benchmarks mode + +(defvar erb-run-refresh-seconds 0.2 + "Delay between updates of `erb-run' buffers.") + +;; Options settable in the erb-run-mode buffer. +(defvar-local erb-run--commit-range '("commitA" "commitB" "commitC")) +(defvar-local erb-run--count-to-select nil) + +(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 special-mode "ERB-run" + "Mode for configuring and running benchmarks. +\\ +ERB is documented in info node `(erb)'." + :group 'erb-mode + (setq-local revert-buffer-function #'erb-run-revert-buffer)) + +;; TODO make only one buffer? +(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) + (with-current-buffer buf + (eq major-mode 'erb-run-mode))) + (buffer-list)) + (erb-run-generate-new-buffer)))) + (switch-to-buffer buffer) + (erb-run-revert-buffer buffer))) + +(defun erb-run-revert-buffer (&rest _ignored) + (let ((inhibit-read-only t)) + (erase-buffer) + ;; (erb--update-config-cache) + (insert + (format "Commit range: %s\n" erb-run--commit-range) + (format "Number to select: %s\n" (if erb-run--count-to-select + erb-run--count-to-select "All")) + (if (memq erb--status '(idle done)) + "\nStart running benchmarks\n" + "\nCancel\n") + + "\n" + (format "Benchmarked: %s\n" (if erb--status-finished + (length erb--status-finished) "")) + (format "Build Failures: %s\n" (if (not (eq erb--status 'idle)) + (length erb--status-failed-builds) "")) + (format "Task Failures: %s\n" (if (not (eq erb--status 'idle)) + (length erb--status-benchmark-failures) "")) + "Total: %s/%s\n\n" + + "Started at: \n" + (cl-case erb--status + (building "Building.") + (benchmarking "Benchmarking.") + (idle "Ready.") + (done "Finished.") + (t (format "erb--status=%s" erb--status))) + "\nFinished at: \n\n") + + (unless (eq erb--status 'idle) + (dolist (commit erb--status-commits) + (insert + (cond + ((memq commit erb--status-finished) ".") + ((memq commit erb--status-building) "B") + ((memq commit erb--status-benchmark-failures) "F") + ((memq commit erb--status-failed-builds) "E") + ((memq commit erb--status-benchmarking) "@") + ((memq commit erb--status-built) "b") + (t "w")))) + (insert "\n")) + + (set-buffer-modified-p nil))) + +(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))) + +(defun erb-run-start () + "Start running benchmarks." + (interactive) + (when (thread-message-available-p erb--job) + (user-error "Benchmarks are already running")) + + (erb--start-benchmark-controller-thread) + (erb--start-builder-threads) + (erb--start-benchmark-monitor-thread) + + (unless erb-run--commit-range + (user-error "Choose a commit or range of commits to benchmark")) + + (erb--status-clear) + (thread-message-send erb--job erb-run--commit-range)) + +(defun erb-run-cancel () + "Stop running benchmarks." + (interactive) + (erb--status-clear)) + +;;; The benchmark runner: the controller thread + +(defvar erb-simultaneous-build-count 1 + "The number of builds to run simultaneously.") + +(defvar erb--builders nil + "The list of threads which have been created to run builds.") + +(defvar erb--unbuilt-commits (thread-make-queue) + "A thread-safe queue of commits waiting to be built.") +(defvar erb--built-commits (thread-make-queue) + "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 "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." + (while t + (condition-case err + (let* ((job (thread-message-wait erb--job)) + (count (length job)) + builds) + + ;; First, do all the builds. There may be more than one + ;; builder thread. + (erb--status-change 'erb--status 'building) + (dolist (commit job) + (erb--status-add commit 'erb--status-waiting-to-build) + (thread-queue-put commit erb--unbuilt-commits)) + + (while (> count 0) + (let ((build (thread-queue-get erb--built-commits))) + (push build builds)) + (cl-decf count)) + + (erb--status-change 'erb--status 'benchmarking) + ;; Then benchmark the build results, one at a time. + + (erb--status-change 'erb--status 'done) + (thread-message-cancel erb--job)) + ((error quit) (message "Error in ERB benchmark control thread: %s" err))))) + +;;; The benchmark runner: the builder threads + +;; TODO Watch for a signal to shut down + +(defun erb--start-builder-threads () + "Create the desired number of commit-building threads. +Get the number from `erb-run-simultaneous-build-count'. +TODO: adjust the number down as well as up." + (let ((needed (- erb-simultaneous-build-count + (length erb--builders)))) + (while (> needed 0) + (push (make-thread #'erb--builder-func + (format "builder %s" (length erb--builders))) + erb--builders) + (cl-decf needed)))) + +(defun erb--builder-func () + "Build commits from `erb-run--commmits-to-build'." + (while t + (condition-case err + (let ((commit (thread-queue-get erb--unbuilt-commits))) + (message "building %s" commit) + (erb--status-remove commit 'erb--status-waiting-to-build) + (erb--status-add commit 'erb--status-building) + + (unwind-protect + (sleep-for (random 10)) + + (erb--status-remove commit 'erb--status-building) + (erb--status-add commit 'erb--status-built) + (thread-queue-put commit erb--built-commits))) + + ((error quit) (message "Error in ERB benchmark build thread: %s" err))))) + +;;; The benchmark runner: the status monitor thread + +(defvar erb--benchmark-monitor nil + "The thread which keeps track of build and benchmark job status.") +(defvar erb--status-updates (thread-make-queue nil 'fifo) + "A thread-safe queue of status updates yet to be processed.") + +(defun erb--status-clear () + (thread-queue-put '(clear) erb--status-updates)) +(defun erb--status-change (symbol value) + (thread-queue-put `(change ,symbol ,value) erb--status-updates)) +(defun erb--status-add (value symbol) + (thread-queue-put `(add ,value ,symbol) erb--status-updates)) +(defun erb--status-remove (value symbol) + (thread-queue-put `(remove ,value ,symbol) erb--status-updates)) + +(defun erb--start-benchmark-monitor-thread () + "Start the benchmark monitor thread if it is not already started." + (unless erb--benchmark-monitor + (setq erb--benchmark-monitor + (make-thread #'erb--benchmark-monitor-func "monitor")))) + +(defvar erb--logging t) +(defun erb--benchmark-monitor-func () + "Process benchmark job status update. +Collect status update requests from `erb--status-updates' +and update the various global variables accordingly." + (while t + (condition-case err + (pcase (thread-queue-get erb--status-updates) + (`(clear) + (when erb--logging (message "** Clear **")) + (erb--clear-status)) + (`(add ,value ,variable) + (when erb--logging + (message "** Add %s to %s **" value variable)) + (push value (symbol-value variable))) + (`(remove ,value ,variable) + (when erb--logging + (message "** Remove %s from %s **" value variable)) + (setf (symbol-value variable) + (delq value (symbol-value variable)))) + (`(change ,variable ,value) + (when erb--logging + (message "** Set %s to %s **" variable value)) + (setf (symbol-value variable) value)) + (update (error "Unrecognized status update: %s" update))) + ((error quit) (message "Error in ERB benchmark control thread: %s" err))))) + +(defun erb--clear-status () + "Reset all the ERB benchmarking status variables to their initial state." + (setq erb--status 'idle + erb--status-waiting-to-build nil + erb--status-building nil + erb--status-built nil + erb--status-failed-builds nil + erb--status-waiting-to-benchmark nil + erb--status-benchmarking nil + erb--status-finished nil)) + + + (provide 'thread) ;;; thread.el ends here -- 2.16.4