From: Gemini Lasswell Date: Thu, 9 Aug 2018 21:21:57 +0000 (-0700) Subject: Show backtraces of threads from thread list buffer X-Git-Tag: emacs-27.0.90~4449^2~5 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3fb8f306475a87a30a7dd68387d8da859cffc90a;p=emacs.git 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. --- 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);