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.

1 files changed, 59 insertions, 0 deletions

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