[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/list-threads 4516d71 6/9: Show backtraces of threa
From: |
Gemini Lasswell |
Subject: |
[Emacs-diffs] scratch/list-threads 4516d71 6/9: Show backtraces of threads from thread list buffer |
Date: |
Mon, 27 Aug 2018 11:53:10 -0400 (EDT) |
branch: scratch/list-threads
commit 4516d71351f62c65d4fa13f1bce4cc6c77e97964
Author: Gemini Lasswell <address@hidden>
Commit: Gemini Lasswell <address@hidden>
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.
---
lisp/thread.el | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++------
src/eval.c | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 114 insertions(+), 6 deletions(-)
diff --git a/lisp/thread.el b/lisp/thread.el
index c99fc59..7225ed4 100644
--- a/lisp/thread.el
+++ b/lisp/thread.el
@@ -26,6 +26,7 @@
;;; Code:
(require 'cl-lib)
+(require 'backtrace)
(require 'pcase)
(require 'subr-x)
@@ -38,11 +39,13 @@
(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)
@@ -51,7 +54,7 @@
(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))
@@ -88,9 +91,7 @@
(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))
@@ -120,12 +121,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 5964dd1..7a777c8 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)
{
@@ -3728,6 +3750,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
@@ -4203,6 +4261,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);
- [Emacs-diffs] branch scratch/list-threads created (now 49afbb9), Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 468a32c 8/9: Add check in list-threads for --without-threads configuration, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 4516d71 6/9: Show backtraces of threads from thread list buffer,
Gemini Lasswell <=
- [Emacs-diffs] scratch/list-threads fd3f62c 7/9: Document list-threads and its buffer, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 49afbb9 9/9: Add tests for list-threads and the *Threads* buffer, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 370b837 5/9: Make small fixes to Edebug and debugger documentation, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 0b7fb4c 4/9: Make list-threads refresh the *Threads* buffer if it already exists, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 833a2d4 2/9: Make lisp/thread.el the new home for thread-related Lisp functions, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 1c971c0 1/9: Add list-threads command and thread-list-mode, Gemini Lasswell, 2018/08/27
- [Emacs-diffs] scratch/list-threads 186ee8c 3/9: Improve docstrings of thread-list functions, Gemini Lasswell, 2018/08/27