5 files changed, 84 insertions, 91 deletions

diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el
index 2e56d5ab321..bb41d55f02d 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 0cff38ce7a8..3e352911479 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 f10e9fd79b7..447f8d5d4ff 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 db6c3e32be7..c051c35e169 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 2a979c5cb9e..aa1d4433914 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)
@@ -37748,6 +37762,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