[Emacs-diffs] master a704bad 12/12: Merge branch 'scratch/list-threads'

[Gemini Lasswell]

branch: master
commit a704bad5e69e278086ea895061be496287b5c277
Merge: e489685 b7719f0
Author: Gemini Lasswell <address@hidden>
Commit: Gemini Lasswell <address@hidden>

    Merge branch 'scratch/list-threads'
---
 doc/lispref/edebug.texi   |   2 +
 doc/lispref/elisp.texi    |   4 +-
 doc/lispref/threads.texi  |  51 ++++++++++++
 etc/NEWS                  |   7 ++
 lisp/emacs-lisp/thread.el |  44 ----------
 lisp/thread.el            | 200 ++++++++++++++++++++++++++++++++++++++++++++++
 src/eval.c                |  59 ++++++++++++++
 test/lisp/thread-tests.el |  96 ++++++++++++++++++++++
 8 files changed, 418 insertions(+), 45 deletions(-)

diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 54200b9..b1a6511 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -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.
 
address@hidden edebug-backtrace-show-instrumentation
address@hidden 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}.
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 7ac9198..0a445a3 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -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
 
diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
index 9cdeb79..c9d5f79 100644
--- a/doc/lispref/threads.texi
+++ b/doc/lispref/threads.texi
@@ -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
+
address@hidden The Thread List
address@hidden The Thread List
+
address@hidden thread list
address@hidden list of threads
address@hidden 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.
+
address@hidden 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.
address@hidden defvar
+
+Here are the commands available in the thread list buffer:
+
address@hidden @kbd
+
address@hidden backtrace of thread
address@hidden thread backtrace
address@hidden 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
address@hidden  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.
address@hidden, for a description of backtraces and the other
+commands which work on them.
+
address@hidden 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.
+
address@hidden g
+Update the list of threads and their statuses.
address@hidden table
diff --git a/etc/NEWS b/etc/NEWS
index 61b6d4e..ff65a55 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -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
diff --git a/lisp/emacs-lisp/thread.el b/lisp/emacs-lisp/thread.el
deleted file mode 100644
index 5d7b90c..0000000
--- a/lisp/emacs-lisp/thread.el
+++ /dev/null
@@ -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 <address@hidden>
-;; Maintainer: address@hidden
-;; 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
diff --git a/lisp/thread.el b/lisp/thread.el
new file mode 100644
index 0000000..1c5dccf
--- /dev/null
+++ b/lisp/thread.el
@@ -0,0 +1,200 @@
+;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <address@hidden>
+;; Maintainer: address@hidden
+;; 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
diff --git a/src/eval.c b/src/eval.c
index 1011fc8..60dd6f1 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -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);
diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el
new file mode 100644
index 0000000..0d57d38
--- /dev/null
+++ b/test/lisp/thread-tests.el
@@ -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 <address@hidden>
+;; 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