procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'scratch/list-threads'

Browse source
This commit is contained in:
Gemini Lasswell 2018-09-09 08:19:54 -07:00
commit a704bad5e6
8 changed files with 418 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
doc/lispref/edebug.texi
View file

@ -445,6 +445,8 @@ Display a backtrace, excluding Edebug's own functions for clarity
@xref{Backtraces}, for a description of backtraces
and the commands which work on them.
@findex edebug-backtrace-show-instrumentation
@findex edebug-backtrace-hide-instrumentation
If you would like to see Edebug's functions in the backtrace,
use @kbd{M-x edebug-backtrace-show-instrumentation}. To hide them
again use @kbd{M-x edebug-backtrace-hide-instrumentation}.

4
doc/lispref/elisp.texi
View file

@ -655,7 +655,8 @@ The Lisp Debugger
* Function Debugging:: Entering it when a certain function is called.
* Variable Debugging:: Entering it when a variable is modified.
* Explicit Debug:: Entering it at a certain point in the program.
* Using Debugger:: What the debugger does; what you see while in it.
* Using Debugger:: What the debugger does.
* Backtraces:: What you see while in the debugger.
* Debugger Commands:: Commands used while in the debugger.
* Invoking the Debugger:: How to call the function @code{debug}.
* Internals of Debugger:: Subroutines of the debugger, and global variables.
@ -1345,6 +1346,7 @@ Threads
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
* The Thread List:: Show the active threads.
Processes

51
doc/lispref/threads.texi
View file

@ -45,6 +45,7 @@ closure are shared by any threads invoking the closure.
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
* The Thread List:: Show the active threads.
@end menu
@node Basic Thread Functions
@ -271,3 +272,53 @@ Return the name of @var{cond}, as passed to
Return the mutex associated with @var{cond}. Note that the associated
mutex cannot be changed.
@end defun
@node The Thread List
@section The Thread List
@cindex thread list
@cindex list of threads
@findex list-threads
The @code{list-threads} command lists all the currently alive threads.
In the resulting buffer, each thread is identified either by the name
passed to @code{make-thread} (@pxref{Basic Thread Functions}), or by
its unique internal identifier if it was not created with a name. The
status of each thread at the time of the creation or last update of
the buffer is shown, in addition to the object the thread was blocked
on at the time, if it was blocked.
@defvar thread-list-refresh-seconds
The @file{*Threads*} buffer will automatically update twice per
second. You can make the refresh rate faster or slower by customizing
this variable.
@end defvar
Here are the commands available in the thread list buffer:
@table @kbd
@cindex backtrace of thread
@cindex thread backtrace
@item b
Show a backtrace of the thread at point. This will show where in its
code the thread had yielded or was blocked at the moment you pressed
@kbd{b}. Be aware that the backtrace is a snapshot; the thread could
have meanwhile resumed execution, and be in a different state, or
could have exited.
You may use @kbd{g} in the thread's backtrace buffer to get an updated
backtrace, as backtrace buffers do not automatically update.
@xref{Backtraces}, for a description of backtraces and the other
commands which work on them.
@item s
Signal the thread at point. After @kbd{s}, type @kbd{q} to send a
quit signal or @kbd{e} to send an error signal. Threads may implement
handling of signals, but the default behavior is to exit on any
signal. Therefore you should only use this command if you understand
how to restart the target thread, because your Emacs session may
behave incorrectly if necessary threads are killed.
@item g
Update the list of threads and their statuses.
@end table

7
etc/NEWS
View file

@ -737,6 +737,13 @@ Instead, error messages are just printed in the main thread.
---
*** 'thread-alive-p' is now obsolete, use 'thread-live-p' instead.
+++
*** New command 'list-threads' shows Lisp threads.
See the current list of live threads in a tabulated-list buffer which
automatically updates. In the buffer, you can use 's q' or 's e' to
signal a thread with quit or error respectively, or get a snapshot
backtrace with 'b'.
---
** thingatpt.el supports a new "thing" called 'uuid'.
A symbol 'uuid' can be passed to thing-at-point and it returns the

44
lisp/emacs-lisp/thread.el
View file

@ -1,44 +0,0 @@
;;; thread.el --- List active threads in a buffer -*- lexical-binding: t -*-
;; Copyright (C) 2018 Free Software Foundation, Inc.
;; Author: Gemini Lasswell <gazally@runbox.com>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: lisp, tools, maint
;; 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:
;;;###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")
(provide 'thread)
;;; thread.el ends here

200
lisp/thread.el Normal file
View file

@ -0,0 +1,200 @@
;;; 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:
(require 'cl-lib)
(require 'backtrace)
(require 'pcase)
(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)))
(provide 'thread)
;;; thread.el ends here

59
src/eval.c
View file

@ -204,6 +204,10 @@ bool
backtrace_p (union specbinding *pdl)
{ return pdl >= specpdl; }
static bool
backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl)
{ return pdl >= tstate->m_specpdl; }
union specbinding *
backtrace_top (void)
{
@ -213,6 +217,15 @@ backtrace_top (void)
return pdl;
}
static union specbinding *
backtrace_thread_top (struct thread_state *tstate)
{
union specbinding *pdl = tstate->m_specpdl_ptr - 1;
while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
union specbinding *
backtrace_next (union specbinding *pdl)
{
@ -222,6 +235,15 @@ backtrace_next (union specbinding *pdl)
return pdl;
}
static union specbinding *
backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl)
{
pdl--;
while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
void
init_eval_once (void)
{
@ -3730,6 +3752,42 @@ Return the result of FUNCTION, or nil if no matching frame could be found. */)
return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
}
DEFUN ("backtrace--frames-from-thread", Fbacktrace_frames_from_thread,
Sbacktrace_frames_from_thread, 1, 1, NULL,
doc: /* Return the list of backtrace frames from current execution point in THREAD.
If a frame has not evaluated the arguments yet (or is a special form),
the value of the list element is (nil FUNCTION ARG-FORMS...).
If a frame has evaluated its arguments and called its function already,
the value of the list element is (t FUNCTION ARG-VALUES...).
A &rest arg is represented as the tail of the list ARG-VALUES.
FUNCTION is whatever was supplied as car of evaluated list,
or a lambda expression for macro calls. */)
(Lisp_Object thread)
{
struct thread_state *tstate;
CHECK_THREAD (thread);
tstate = XTHREAD (thread);
union specbinding *pdl = backtrace_thread_top (tstate);
Lisp_Object list = Qnil;
while (backtrace_thread_p (tstate, pdl))
{
Lisp_Object frame;
if (backtrace_nargs (pdl) == UNEVALLED)
frame = Fcons (Qnil,
Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
else
{
Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
frame = Fcons (Qt, Fcons (backtrace_function (pdl), tem));
}
list = Fcons (frame, list);
pdl = backtrace_thread_next (tstate, pdl);
}
return Fnreverse (list);
}
/* For backtrace-eval, we want to temporarily unwind the last few elements of
the specpdl stack, and then rewind them. We store the pre-unwind values
directly in the pre-existing specpdl elements (i.e. we swap the current
@ -4205,6 +4263,7 @@ alist of active lexical bindings. */);
DEFSYM (QCdebug_on_exit, ":debug-on-exit");
defsubr (&Smapbacktrace);
defsubr (&Sbacktrace_frame_internal);
defsubr (&Sbacktrace_frames_from_thread);
defsubr (&Sbacktrace_eval);
defsubr (&Sbacktrace__locals);
defsubr (&Sspecial_variable_p);

96
test/lisp/thread-tests.el Normal file
View file

@ -0,0 +1,96 @@
;;; thread-tests.el --- Test suite for thread.el -*- lexical-binding: t; -*-
;; Copyright (C) 2018 Free Software Foundation, Inc.
;; Author: Gemini Lasswell <gazally@runbox.com>
;; Keywords: threads
;; 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 'ert)
(require 'thread)
;; Declare the functions used here in case Emacs has been configured
;; --without-threads.
(declare-function make-mutex "thread.c" (&optional name))
(declare-function mutex-lock "thread.c" (mutex))
(declare-function mutex-unlock "thread.c" (mutex))
(declare-function make-thread "thread.c" (function &optional name))
(declare-function thread-join "thread.c" (thread))
(declare-function thread-yield "thread.c" ())
(defvar thread-tests-flag)
(defvar thread-tests-mutex (when (featurep 'threads) (make-mutex "mutex1")))
(defun thread-tests--thread-function ()
(setq thread-tests-flag t)
(with-mutex thread-tests-mutex
(sleep-for 0.01)))
(ert-deftest thread-tests-thread-list-send-error ()
"A thread can be sent an error signal from the *Thread List* buffer."
(skip-unless (featurep 'threads))
(cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)))
(with-mutex thread-tests-mutex
(setq thread-tests-flag nil)
(let ((thread (make-thread #'thread-tests--thread-function
"thread-tests-wait")))
(while (not thread-tests-flag)
(thread-yield))
(list-threads)
(goto-char (point-min))
(re-search-forward
"^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?")
(thread-list-send-error-signal)
(should-error (thread-join thread))
(list-threads)
(goto-char (point-min))
(should-error (re-search-forward "thread-tests"))))))
(ert-deftest thread-tests-thread-list-show-backtrace ()
"Show a backtrace for another thread from the *Thread List* buffer."
(skip-unless (featurep 'threads))
(let (thread)
(with-mutex thread-tests-mutex
(setq thread-tests-flag nil)
(setq thread
(make-thread #'thread-tests--thread-function "thread-tests-back"))
(while (not thread-tests-flag)
(thread-yield))
(list-threads)
(goto-char (point-min))
(re-search-forward
"^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?")
(thread-list-pop-to-backtrace)
(goto-char (point-min))
(re-search-forward "thread-tests-back")
(re-search-forward "mutex-lock")
(re-search-forward "thread-tests--thread-function"))
(thread-join thread)))
(ert-deftest thread-tests-list-threads-error-when-not-configured ()
"Signal an error running `list-threads' if threads are not configured."
(skip-unless (not (featurep 'threads)))
(should-error (list-threads)))
(provide 'thread-tests)
;;; thread-tests.el ends here