path: root/lisp/thread.el

;;; 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-value (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)))

;;; Mutexes for variables

(defun make-symbol-mutex (symbol)
  "Create a mutex associated with SYMBOL."
  (unless (get symbol 'thread--mutex)
    (put symbol 'thread--mutex (make-mutex (symbol-name symbol)))))

(defmacro with-symbol-mutex (symbol &rest body)
  "Run BODY while holding the mutex for SYMBOL.
If another thread holds the mutex, block until it is released."
  (declare (indent 1)
           (debug (symbolp body)))
  (let ((g-mutex (gensym)))
    `(let ((,g-mutex (get ',symbol 'thread--mutex)))
       (if ,g-mutex
           (with-mutex ,g-mutex
             ,@body)
         (error "`%s' doesn't have a mutex" ',symbol)))))


(provide 'thread)
;;; thread.el ends here