scratch/handler-bind 26b7078705a 10/10: (backtrace-on-redisplay-error): Use `handler-bind`

[Stefan Monnier]

branch: scratch/handler-bind
commit 26b7078705ae5b9226c99e370740ab9a4063f20f
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (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.
---
 lisp/emacs-lisp/debug-early.el | 83 +++++++++++++++++++++++++++++-------------
 src/eval.c                     | 67 +++-------------------------------
 src/keyboard.c                 |  4 +-
 src/lisp.h                     |  1 -
 src/xdisp.c                    | 20 +++++++++-
 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