;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-

;; Copyright (C) 2018 Free Software Foundation, Inc.

;; Author: Gemini Lasswell <gazally@runbox.com>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: thread, tools

;; 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:

;;; Code:

(eval-when-compile (require 'cl-lib))
(require 'backtrace)
(eval-when-compile (require 'pcase))
(eval-when-compile (require 'subr-x))

;;;###autoload
(defun thread-handle-event (event)
  "Handle thread events, propagated by `thread-signal'.
An EVENT has the format
  (thread-event THREAD ERROR-SYMBOL DATA)"
  (interactive "e")
  (if (and (consp event)
           (eq (car event) 'thread-event)
	   (= (length event) 4))
      (let ((thread (cadr event))
            (err (cddr event)))
        (message "Error %s: %S" thread err))))

(make-obsolete 'thread-alive-p 'thread-live-p "27.1")

;;; The thread list buffer and list-threads command

(defcustom thread-list-refresh-seconds 0.5
  "Seconds between automatic refreshes of the *Threads* buffer."
  :group 'thread-list
  :type 'number
  :version "27.1")

(defvar thread-list-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map tabulated-list-mode-map)
    (define-key map "b" #'thread-list-pop-to-backtrace)
    (define-key map "s" nil)
    (define-key map "sq" #'thread-list-send-quit-signal)
    (define-key map "se" #'thread-list-send-error-signal)
    (easy-menu-define nil map ""
      '("Threads"
        ["Show backtrace" thread-list-pop-to-backtrace t]
	["Send Quit Signal" thread-list-send-quit-signal t]
        ["Send Error Signal" thread-list-send-error-signal t]))
    map)
  "Local keymap for `thread-list-mode' buffers.")

(define-derived-mode thread-list-mode tabulated-list-mode "Thread-List"
  "Major mode for monitoring Lisp threads."
  (setq tabulated-list-format
        [("Thread Name" 20 t)
         ("Status" 10 t)
         ("Blocked On" 30 t)])
  (setq tabulated-list-sort-key (cons (car (aref tabulated-list-format 0)) nil))
  (setq tabulated-list-entries #'thread-list--get-entries)
  (tabulated-list-init-header))

;;;###autoload
(defun list-threads ()
  "Display a list of threads."
  (interactive)
  ;; Threads may not exist, if Emacs was configured --without-threads.
  (unless (bound-and-true-p main-thread)
    (error "Threads are not supported in this configuration"))
  ;; Generate the Threads list buffer, and switch to it.
  (let ((buf (get-buffer-create "*Threads*")))
    (with-current-buffer buf
      (unless (derived-mode-p 'thread-list-mode)
        (thread-list-mode)
        (run-at-time thread-list-refresh-seconds nil
                     #'thread-list--timer-func buf))
      (revert-buffer))
    (switch-to-buffer buf)))
;; This command can be destructive if they don't know what they are
;; doing.  Kids, don't try this at home!
;;;###autoload (put 'list-threads 'disabled "Beware: manually canceling threads can ruin your Emacs session.")

(defun thread-list--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 thread-list-refresh-seconds nil
                 #'thread-list--timer-func buffer)))

(defun thread-list--get-entries ()
  "Return tabulated list entries for the currently live threads."
  (let (entries)
    (dolist (thread (all-threads))
      (pcase-let ((`(,status ,blocker) (thread-list--get-status thread)))
        (push `(,thread [,(thread-list--name thread)
                         ,status ,blocker])
              entries)))
    entries))

(defun thread-list--get-status (thread)
  "Describe the status of THREAD.
Return a list of two strings, one describing THREAD's status, the
other describing THREAD's blocker, if any."
  (cond
   ((not (thread-live-p thread)) '("Finished" ""))
   ((eq thread (current-thread)) '("Running" ""))
   (t (if-let ((blocker (thread--blocker thread)))
          `("Blocked" ,(prin1-to-string blocker))
        '("Yielded" "")))))

(defun thread-list-send-quit-signal ()
  "Send a quit signal to the thread at point."
  (interactive)
  (thread-list--send-signal 'quit))

(defun thread-list-send-error-signal ()
  "Send an error signal to the thread at point."
  (interactive)
  (thread-list--send-signal 'error))

(defun thread-list--send-signal (signal)
  "Send the specified SIGNAL to the thread at point.
Ask for user confirmation before signaling the thread."
  (let ((thread (tabulated-list-get-id)))
    (if (thread-live-p thread)
        (when (y-or-n-p (format "Send %s signal to %s? " signal thread))
          (if (thread-live-p thread)
              (thread-signal thread signal nil)
            (message "This thread is no longer alive")))
      (message "This thread is no longer alive"))))

(defvar-local thread-list-backtrace--thread nil
  "Thread whose backtrace is displayed in the current buffer.")

(defun thread-list-pop-to-backtrace ()
  "Display the backtrace for the thread at point."
  (interactive)
  (let ((thread (tabulated-list-get-id)))
    (if (thread-live-p thread)
        (let ((buffer (get-buffer-create "*Thread Backtrace*")))
          (pop-to-buffer buffer)
          (unless (derived-mode-p 'backtrace-mode)
            (backtrace-mode)
            (add-hook 'backtrace-revert-hook
                      #'thread-list-backtrace--revert-hook-function)
            (setq backtrace-insert-header-function
                  #'thread-list-backtrace--insert-header))
          (setq thread-list-backtrace--thread thread)
          (thread-list-backtrace--revert-hook-function)
          (backtrace-print)
          (goto-char (point-min)))
      (message "This thread is no longer alive"))))

(defun thread-list-backtrace--revert-hook-function ()
  (setq backtrace-frames
        (when (thread-live-p thread-list-backtrace--thread)
          (mapcar #'thread-list--make-backtrace-frame
                  (backtrace--frames-from-thread
                   thread-list-backtrace--thread)))))

(cl-defun thread-list--make-backtrace-frame ((evald fun &rest args))
  (backtrace-make-frame :evald evald :fun fun :args args))

(defun thread-list-backtrace--insert-header ()
  (let ((name (thread-list--name thread-list-backtrace--thread)))
    (if (thread-live-p thread-list-backtrace--thread)
        (progn
          (insert (substitute-command-keys "Backtrace for thread `"))
          (insert name)
          (insert (substitute-command-keys "':\n")))
      (insert (substitute-command-keys "Thread `"))
      (insert name)
      (insert (substitute-command-keys "' is no longer running\n")))))

(defun thread-list--name (thread)
  (or (thread-name thread)
      (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-run-mode-map>
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