thread.el 7.23 KB
Newer Older
1
;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-
2 3 4 5 6

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

;; Author: Gemini Lasswell <gazally@runbox.com>
;; Maintainer: emacs-devel@gnu.org
7
;; Keywords: thread, tools
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28

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

(require 'cl-lib)
29
(require 'backtrace)
30
(require 'pcase)
31
(eval-when-compile (require 'subr-x))
32

33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
;;;###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

50 51 52 53 54 55 56 57 58
(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)
59
    (define-key map "b" #'thread-list-pop-to-backtrace)
60 61 62 63 64
    (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"
65
        ["Show backtrace" thread-list-pop-to-backtrace t]
66 67 68 69 70 71 72 73
	["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
74
        [("Thread Name" 20 t)
75 76 77 78 79 80 81 82 83 84
         ("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)
85 86 87
  ;; 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"))
88 89 90 91 92
  ;; 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)
93 94 95
        (run-at-time thread-list-refresh-seconds nil
                     #'thread-list--timer-func buf))
      (revert-buffer))
96 97 98 99 100
    (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.")

101 102 103 104
(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
105 106
      (revert-buffer))
    (run-at-time thread-list-refresh-seconds nil
107
                 #'thread-list--timer-func buffer)))
108 109

(defun thread-list--get-entries ()
110
  "Return tabulated list entries for the currently live threads."
111 112 113
  (let (entries)
    (dolist (thread (all-threads))
      (pcase-let ((`(,status ,blocker) (thread-list--get-status thread)))
114
        (push `(,thread [,(thread-list--name thread)
115 116 117 118 119 120
                         ,status ,blocker])
              entries)))
    entries))

(defun thread-list--get-status (thread)
  "Describe the status of THREAD.
121 122
Return a list of two strings, one describing THREAD's status, the
other describing THREAD's blocker, if any."
123
  (cond
124
   ((not (thread-live-p thread)) '("Finished" ""))
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
   ((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))

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

151 152 153 154 155 156 157
(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)))
158
    (if (thread-live-p thread)
159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
        (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
175
        (when (thread-live-p thread-list-backtrace--thread)
176 177 178 179 180 181 182 183 184
          (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)))
185
    (if (thread-live-p thread-list-backtrace--thread)
186 187 188 189 190 191 192 193 194 195 196 197 198
        (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)))

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