1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 2018-2023 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))
(declare-function thread-name "thread.c")
(declare-function thread-signal "thread.c")
(declare-function thread--blocker "thread.c")
(declare-function current-thread "thread.c")
(declare-function thread-live-p "thread.c")
(declare-function all-threads "thread.c")
;;;###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))))
;;; 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-keymap thread-list-mode-map
:doc "Local keymap for `thread-list-mode' buffers."
:parent tabulated-list-mode-map
"b" #'thread-list-pop-to-backtrace
"s" nil
"s q" #'thread-list-send-quit-signal
"s e" #'thread-list-send-error-signal
:menu
'("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]))
(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)))
(provide 'thread)
;;; thread.el ends here
|
