procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Show backtraces of threads from thread list buffer

Browse source 
* 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.
This commit is contained in:
Gemini Lasswell 2018-08-09 14:21:57 -07:00
parent dc5c76c374
commit 3fb8f30647
2 changed files with 114 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
lisp/thread.el
View file

@ -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

59
src/eval.c
View file

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