From: Stefan Monnier Date: Tue, 26 Dec 2023 02:41:08 +0000 (-0500) Subject: (backtrace-on-redisplay-error): Use `handler-bind` X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=391c208aecc44fd82c599696d47a18782f2f36da;p=emacs.git (backtrace-on-redisplay-error): Use `handler-bind` Reimplement `backtrace-on-redisplay-error` using `push_handler_bind`. This moves the code from `signal_or_quit` to `xdisp.c` and `debug-early.el`. * lisp/emacs-lisp/debug-early.el (debug-early-backtrace): Add `base` arg to strip "internal" frames. (debug--early): New function, extracted from `debug-early`. (debug-early, debug-early--handler): Use it. (debug-early--muted): New function, extracted (translated) from `signal_or_quit`; trim the buffer to a max of 10 backtraces. * src/xdisp.c (funcall_with_backtraces): New function. (dsafe_calln): Use it. (syms_of_xdisp): Defsym `Qdebug_early__muted`. * src/eval.c (redisplay_deep_handler): Delete var. (init_eval, internal_condition_case_n): Don't set it any more. (backtrace_yet): Delete var. (signal_or_quit): Remove special case for `backtrace_on_redisplay_error`. * src/keyboard.c (command_loop_1): Don't set `backtrace_yet` any more. * src/lisp.h (backtrace_yet): Don't declare. --- diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index 464c2e96927..8a0dddc2679 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -27,14 +27,17 @@ ;; This file dumps a backtrace on stderr when an error is thrown. It ;; has no dependencies on any Lisp libraries and is thus used for ;; generating backtraces for bugs in the early parts of bootstrapping. -;; It is also always used in batch model. It was introduced in Emacs +;; It is also always used in batch mode. It was introduced in Emacs ;; 29, before which there was no backtrace available during early ;; bootstrap. ;;; Code: +;; For bootstrap reasons, we cannot use any macros here since they're +;; not defined yet. + (defalias 'debug-early-backtrace - #'(lambda () + #'(lambda (&optional base) "Print a trace of Lisp function calls currently active. The output stream used is the value of `standard-output'. @@ -51,26 +54,39 @@ of the build process." (require 'cl-print) (error nil))) #'cl-prin1 - #'prin1))) + #'prin1)) + (first t)) (mapbacktrace #'(lambda (evald func args _flags) - (let ((args args)) - (if evald + (if first + ;; The first is the debug-early entry point itself. + (setq first nil) + (let ((args args)) + (if evald + (progn + (princ " ") + (funcall prin1 func) + (princ "(")) (progn - (princ " ") - (funcall prin1 func) - (princ "(")) - (progn - (princ " (") - (setq args (cons func args)))) - (if args - (while (progn - (funcall prin1 (car args)) - (setq args (cdr args))) - (princ " "))) - (princ ")\n"))))))) - -(defalias 'debug-early + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (funcall prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n")))) + base)))) + +(defalias 'debug--early + #'(lambda (error base) + (princ "\nError: ") + (prin1 (car error)) ; The error symbol. + (princ " ") + (prin1 (cdr error)) ; The error data. + (debug-early-backtrace base))) + +(defalias 'debug-early ;Called from C. #'(lambda (&rest args) "Print an error message with a backtrace of active Lisp function calls. The output stream used is the value of `standard-output'. @@ -88,14 +104,31 @@ support the latter, except in batch mode which always uses \(In versions of Emacs prior to Emacs 29, no backtrace was available before `debug' was usable.)" - (princ "\nError: ") - (prin1 (car (car (cdr args)))) ; The error symbol. - (princ " ") - (prin1 (cdr (car (cdr args)))) ; The error data. - (debug-early-backtrace))) + (debug--early (car (cdr args)) #'debug-early))) ; The error object. (defalias 'debug-early--handler ;Called from C. #'(lambda (err) - (if backtrace-on-error-noninteractive (debug-early 'error err)))) + (if backtrace-on-error-noninteractive + (debug--early err #'debug-early--handler)))) + +(defalias 'debug-early--muted ;Called from C. + #'(lambda (err) + (save-current-buffer + (set-buffer (get-buffer-create "*Redisplay-trace*")) + (goto-char (point-max)) + (if (bobp) nil + (let ((separator "\n\n\n\n")) + (save-excursion + ;; The C code tested `backtrace_yet', instead we + ;; keep a max of 10 backtraces. + (if (search-backward separator nil t 10) + (delete-region (point-min) (match-end 0)))) + (insert separator))) + (insert "-- Caught at " (current-time-string) "\n") + (let ((standard-output (current-buffer))) + (debug--early err #'debug-early--muted)) + (setq delayed-warnings-list + (cons '(error "Error in a redisplay Lisp hook. See buffer *Redisplay-trace*") + delayed-warnings-list))))) ;;; debug-early.el ends here. diff --git a/src/eval.c b/src/eval.c index 1dd797063eb..94f6d8e31f8 100644 --- a/src/eval.c +++ b/src/eval.c @@ -57,12 +57,6 @@ Lisp_Object Vrun_hooks; /* FIXME: We should probably get rid of this! */ Lisp_Object Vsignaling_function; -/* The handler structure which will catch errors in Lisp hooks called - from redisplay. We do not use it for this; we compare it with the - handler which is about to be used in signal_or_quit, and if it - matches, cause a backtrace to be generated. */ -static struct handler *redisplay_deep_handler; - /* These would ordinarily be static, but they need to be visible to GDB. */ bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE; Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE; @@ -244,7 +238,6 @@ init_eval (void) lisp_eval_depth = 0; /* This is less than the initial value of num_nonmacro_input_events. */ when_entered_debugger = -1; - redisplay_deep_handler = NULL; } static void @@ -1611,16 +1604,12 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), ptrdiff_t nargs, Lisp_Object *args)) { - struct handler *old_deep = redisplay_deep_handler; struct handler *c = push_handler (handlers, CONDITION_CASE); - if (redisplaying_p) - redisplay_deep_handler = c; if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; - redisplay_deep_handler = old_deep; return hfun (val, nargs, args); } else @@ -1628,7 +1617,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), Lisp_Object val = bfun (nargs, args); eassert (handlerlist == c); handlerlist = c->next; - redisplay_deep_handler = old_deep; return val; } } @@ -1766,11 +1754,6 @@ quit (void) return signal_or_quit (Qquit, Qnil, true); } -/* Has an error in redisplay giving rise to a backtrace occurred as - yet in the current command? This gets reset in the command - loop. */ -bool backtrace_yet = false; - /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal. If CONTINUABLE, the caller allows this function to return (presumably after calling the debugger); @@ -1897,51 +1880,13 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool continuable) return Qnil; } - /* If an error is signaled during a Lisp hook in redisplay, write a - backtrace into the buffer *Redisplay-trace*. */ - /* FIXME: Turn this into a `handler-bind` installed during redisplay? */ - if (!debugger_called && !oom - && backtrace_on_redisplay_error - && (NILP (clause) || h == redisplay_deep_handler) - && NILP (Vinhibit_debugger) - && !NILP (Ffboundp (Qdebug_early))) - { - specpdl_ref count = SPECPDL_INDEX (); - max_ensure_room (100); - AUTO_STRING (redisplay_trace, "*Redisplay-trace*"); - Lisp_Object redisplay_trace_buffer; - AUTO_STRING (gap, "\n\n\n\n"); /* Separates things in *Redisplay-trace* */ - Lisp_Object delayed_warning; - redisplay_trace_buffer = Fget_buffer_create (redisplay_trace, Qnil); - current_buffer = XBUFFER (redisplay_trace_buffer); - if (!backtrace_yet) /* Are we on the first backtrace of the command? */ - Ferase_buffer (); - else - Finsert (1, &gap); - backtrace_yet = true; - specbind (Qstandard_output, redisplay_trace_buffer); - specbind (Qdebugger, Qdebug_early); - call_debugger (list2 (Qerror, error)); - unbind_to (count, Qnil); - delayed_warning = make_string - ("Error in a redisplay Lisp hook. See buffer *Redisplay-trace*", 61); - - Vdelayed_warnings_list = Fcons (list2 (Qerror, delayed_warning), - Vdelayed_warnings_list); - } - if (!NILP (clause)) - { - unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, error); - } - else - { - if (handlerlist != handlerlist_sentinel) - /* FIXME: This will come right back here if there's no `top-level' - catcher. A better solution would be to abort here, and instead - add a catch-all condition handler so we never come here. */ - Fthrow (Qtop_level, Qt); - } + unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, error); + else if (handlerlist != handlerlist_sentinel) + /* FIXME: This will come right back here if there's no `top-level' + catcher. A better solution would be to abort here, and instead + add a catch-all condition handler so we never come here. */ + Fthrow (Qtop_level, Qt); string = Ferror_message_string (error); fatal ("%s", SDATA (string)); diff --git a/src/keyboard.c b/src/keyboard.c index aa7d732bcc3..e1d738dd6ef 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1167,9 +1167,10 @@ top_level_2 (void) encountering an error, to help with debugging. */ bool setup_handler = noninteractive; if (setup_handler) + /* FIXME: Should we (re)use `list_of_error` from `xdisp.c`? */ push_handler_bind (list1 (Qerror), Qdebug_early__handler, 0); - Lisp_Object res = Feval (Vtop_level, Qnil); + Lisp_Object res = Feval (Vtop_level, Qt); if (setup_handler) pop_handler (); @@ -1365,7 +1366,6 @@ command_loop_1 (void) display_malloc_warning (); Vdeactivate_mark = Qnil; - backtrace_yet = false; /* Don't ignore mouse movements for more than a single command loop. (This flag is set in xdisp.c whenever the tool bar is diff --git a/src/lisp.h b/src/lisp.h index 0e082d14a40..44f69892c6f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4529,7 +4529,6 @@ extern Lisp_Object Vrun_hooks; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; extern bool signal_quit_p (Lisp_Object); -extern bool backtrace_yet; /* To run a normal hook, use the appropriate function from the list below. The calling convention: diff --git a/src/xdisp.c b/src/xdisp.c index aeaf8b34652..f8670c6ecb5 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -3072,10 +3072,24 @@ dsafe__call (bool inhibit_quit, Lisp_Object (f) (ptrdiff_t, Lisp_Object *), return val; } +static Lisp_Object +funcall_with_backtraces (ptrdiff_t nargs, Lisp_Object *args) +{ + /* If an error is signaled during a Lisp hook in redisplay, write a + backtrace into the buffer *Redisplay-trace*. */ + push_handler_bind (list_of_error, Qdebug_early__muted, 0); + Lisp_Object res = Ffuncall (nargs, args); + pop_handler (); + return res; +} + #define SAFE_CALLMANY(inhibit_quit, f, array) \ dsafe__call ((inhibit_quit), f, ARRAYELTS (array), array) -#define dsafe_calln(inhibit_quit, ...) \ - SAFE_CALLMANY ((inhibit_quit), Ffuncall, ((Lisp_Object []) {__VA_ARGS__})) +#define dsafe_calln(inhibit_quit, ...) \ + SAFE_CALLMANY ((inhibit_quit), \ + backtrace_on_redisplay_error \ + ? funcall_with_backtraces : Ffuncall, \ + ((Lisp_Object []) {__VA_ARGS__})) static Lisp_Object dsafe_call1 (Lisp_Object f, Lisp_Object arg) @@ -37753,6 +37767,8 @@ cursor shapes. */); DEFSYM (Qthin_space, "thin-space"); DEFSYM (Qzero_width, "zero-width"); + DEFSYM (Qdebug_early__muted, "debug-early--muted"); + DEFVAR_LISP ("pre-redisplay-function", Vpre_redisplay_function, doc: /* Function run just before redisplay. It is called with one argument, which is the set of windows that are to