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.
;; 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'.
(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'.
\(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.
/* 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;
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
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
Lisp_Object val = bfun (nargs, args);
eassert (handlerlist == c);
handlerlist = c->next;
- redisplay_deep_handler = old_deep;
return val;
}
}
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);
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));
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 ();
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
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:
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)
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
projects / emacs.git / commitdiff