Show backtraces of threads from thread list buffer

* src/eval.c (backtrace_thread_p, backtrace_thread_top)
(backtrace_thread_next, Fbacktrace_frames_from_thread): New functions.
* lisp/thread.el (thread-list-mode-map): Add keybinding and
menu item for 'thread-list-pop-to-backtrace'.
(thread-list-mode): Make "Thread Name" column wide enough
for the result of printing a thread with no name with 'prin1'.
(thread-list--get-entries): Use 'thread-list--name'.
(thread-list--send-signal): Remove unnecessary calls to 'threadp'.
(thread-list-backtrace--thread): New variable.
(thread-list-pop-to-backtrace): New command.
(thread-list-backtrace--revert-hook-function)
(thread-list--make-backtrace-frame)
(thread-list-backtrace--insert-header, thread-list--name): New
functions.

2 files changed, 114 insertions, 6 deletions

diff --git a/lisp/thread.el b/lisp/thread.el
index 4cd253e2cf5..c9f50ff5dba 100644
--- a/lisp/thread.el
+++ b/lisp/thread.el
@@ -26,6 +26,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'backtrace)
 (require 'pcase)
 (require 'subr-x)
 
@@ -55,11 +56,13 @@ An EVENT has the format
 (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)
@@ -68,7 +71,7 @@ An EVENT has the format
 (define-derived-mode thread-list-mode tabulated-list-mode "Thread-List"
   "Major mode for monitoring Lisp threads."
   (setq tabulated-list-format
-        [("Thread Name" 15 t)
+        [("Thread Name" 20 t)
          ("Status" 10 t)
          ("Blocked On" 30 t)])
   (setq tabulated-list-sort-key (cons (car (aref tabulated-list-format 0)) nil))
@@ -105,9 +108,7 @@ An EVENT has the format
   (let (entries)
     (dolist (thread (all-threads))
       (pcase-let ((`(,status ,blocker) (thread-list--get-status thread)))
-        (push `(,thread [,(or (thread-name thread)
-                              (and (eq thread main-thread) "Main")
-                              (prin1-to-string thread))
+        (push `(,thread [,(thread-list--name thread)
                          ,status ,blocker])
               entries)))
     entries))
@@ -137,12 +138,60 @@ other describing THREAD's blocker, if any."
   "Send the specified SIGNAL to the thread at point.
 Ask for user confirmation before signaling the thread."
   (let ((thread (tabulated-list-get-id)))
-    (if (and (threadp thread) (thread-alive-p thread))
+    (if (thread-alive-p thread)
         (when (y-or-n-p (format "Send %s signal to %s? " signal thread))
-          (if (and (threadp thread) (thread-alive-p thread))
+          (if (thread-alive-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-alive-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-alive-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-alive-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 1011fc888b5..60dd6f1e8d2 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);