Redisplay hook error bactraces [Was: Fontification error backtrace]

[Alan Mackenzie <acm@muc.de>]

Hello, Eli.

I've amended the patch I previously submitted considerably.  In
particular, it will generate a backtrace for a Lisp error in (almost) any
hook called from redisplay.  The exception is
redisplay-end-trigger-functions, which is obsolete, being used
(hopefully) only by the obsolete lazy-lock.

To use it, set the variable backtrace-on-redisplay-error to t.
Optionally, configure redisplay-last-error, which determines which
backtrace(s) to keep, should a command cause more than one.

In detail....

On Wed, Jun 29, 2022 at 22:00:54 +0300, Eli Zaretskii wrote:
> > Date: Tue, 28 Jun 2022 19:31:59 +0000
> > Cc: larsi@gnus.org, emacs-devel@gnu.org
> > From: Alan Mackenzie <acm@muc.de>

[ .... ]

> > I'm currently using the buffer *Backtrace*.  Is there anything wrong
> > with that?

> Not that I see, no.

OK, *Backtrace* it is.

> > > The buffer with warnings pops up very soon after redisplay, which is
> > > more-or-less exactly what you wanted?

> > OK, I've never used it.  On reading the documentation, I expected it to
> > wait until after the next command.

> That's because the ELisp reference manual describes it from the POV of
> setting up the warning as part of some command.  And even then, it
> says:

>      The value of this variable is a list of warnings to be displayed
>      after the current command has finished.

> "Current command", not "next command".

> If you add a warning to the list inside redisplay, it will pop up
> after redisplay returns.

I've tried to use it, but the list of warnings does indeed wait until
after the next command before being displayed.  I think the command loop
calls the functions for it between post-command-hook and redisplay.
Maybe the command loop could call it after redisplay as well.

> > Now I remember why I created the backtrace in signal_or_quit - it needs
> > to be done before the stack gets unwound, which happens later in
> > signal_or_quit.  On return to save_eval_handler is just too late for
> > this.

> That's orthogonal, I think?  You can collect the data inside
> signal_or_quit, and the signal handler then only needs to handle the
> error gracefully after it adds the warning.

The "handling" of the error is to allow the redisplay to continue, just
as though no backtrace were generated.  Since there's no possibility of
user interaction or a recursive redisplay, that should be OK.

> > > It will, because any Lisp we call goes though safe_eval.  The only
> > > reason why your original proposal didn't was because it bound the
> > > variable which enables this only in handle_fontified_prop.  But we
> > > don't need this flag if the logic to decide what to do with the error
> > > will be in save_eval_handler.

> > Then the mechanism I've implemented, namely to set redisplay_deep_handler
> > to the handler which would handle an error, could be made to serve for
> > other sorts of Lisp code.

> It could, but I see no reason for having a new handler.

Sorry, I didn't express that well.  That variable redisplay_deep_handler
merely records the handler that a condition-case might use.  In
signal_or_quit, if the handler about to be used matches
redisplay_deep_handler, then a backtrace gets generated.

> > > And you need to consider one more factor: code from display engine,
> > > including fontification via handle_fontified_prop, is called also from
> > > user commands, not via redisplay_internal.  For example, commands like
> > > C-n and C-v invoke display code.  Errors signaled there _can_ be left
> > > to go to top-level and probably could call the debugger.  To test
> > > whether any given code was called from redisplay_internal, test the
> > > value of the variable redisplaying_p.

> > OK, this is a further complication.  But it would be good to get to the
> > debugger if possible, rather than just having a "historical" backtrace.

> If the display code is called from "normal" commands, you can.

I haven't attended to this possibility, yet, but I don't foresee it as
being particularly difficult or time-consuming.

I also still need to write documentation for the new code.

Anyhow, here's the current state of the patch, which still clearly isn't
finished:



diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index df919fd715..f5f52a2076 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -265,6 +265,10 @@ minibuffer-prompt-properties--setter
 	     (debug-ignored-errors debug (repeat (choice symbol regexp)))
 	     (debug-on-quit debug boolean)
 	     (debug-on-signal debug boolean)
+             (redisplay-last-error debug
+                                   (choice (const :tag "First backtrace only" nil)
+                                           (const :tag "Last backtrace only" t)
+                                           (const :tag "All backtraces" 'many)))
              (debugger-stack-frame-as-list debugger boolean "26.1")
 	     ;; fileio.c
 	     (delete-by-moving-to-trash auto-save boolean "23.1")
diff --git a/src/eval.c b/src/eval.c
index 141d2546f0..50982980cb 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -57,6 +57,12 @@ 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;
@@ -333,7 +339,8 @@ call_debugger (Lisp_Object arg)
   /* Interrupting redisplay and resuming it later is not safe under
      all circumstances.  So, when the debugger returns, abort the
      interrupted redisplay by going back to the top-level.  */
-  if (debug_while_redisplaying)
+  if (debug_while_redisplaying
+      && !EQ (Vdebugger, Qdebug_early))
     Ftop_level ();
 
   return unbind_to (count, val);
@@ -1550,14 +1557,18 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
 			   Lisp_Object handlers,
 			   Lisp_Object (*hfun) (Lisp_Object err,
 						ptrdiff_t nargs,
-						Lisp_Object *args))
+						Lisp_Object *args),
+			   bool note_handler)
 {
   struct handler *c = push_handler (handlers, CONDITION_CASE);
+  if (note_handler)
+    redisplay_deep_handler = c;
   if (sys_setjmp (c->jmp))
     {
       Lisp_Object val = handlerlist->val;
       clobbered_eassert (handlerlist == c);
       handlerlist = handlerlist->next;
+      redisplay_deep_handler = NULL;
       return hfun (val, nargs, args);
     }
   else
@@ -1565,6 +1576,7 @@ 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 = NULL;
       return val;
     }
 }
@@ -1697,6 +1709,11 @@ 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 KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
    Qquit and DATA should be Qnil, and this function may return.
@@ -1812,6 +1829,42 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
       unbind_to (count, Qnil);
     }
 
+  /* If an error is signalled during a Lisp hook in redisplay, write a
+     backtrace into the buffer *Backtrace*.  */
+  if (!debugger_called && !NILP (error_symbol)
+      && redisplay_lisping
+      && backtrace_on_redisplay_lisp_error
+      && (!backtrace_yet || !NILP (Vredisplay_last_error))
+      && (NILP (clause) || h == redisplay_deep_handler)
+      && NILP (Vinhibit_debugger)
+      && !NILP (Ffboundp (Qdebug_early)))
+    {
+      max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
+      specpdl_ref count = SPECPDL_INDEX ();
+      ptrdiff_t counti = specpdl_ref_to_count (count);
+      AUTO_STRING (backtrace, "*Backtrace*");
+      Lisp_Object backtrace_buffer;
+      AUTO_STRING (gap, "\n\n\n\n"); /* Separates backtraces in *Backtrace* */
+      Lisp_Object delayed_warning;
+      max_ensure_room (&max_specpdl_size, counti, 200);
+      backtrace_buffer = Fget_buffer_create (backtrace, Qnil);
+      current_buffer = XBUFFER (backtrace_buffer);
+      if (!backtrace_yet
+	  || EQ (Vredisplay_last_error, Qt))
+	Ferase_buffer ();
+      else if (!EQ (Vredisplay_last_error, Qt))
+	Finsert (1, &gap);
+      backtrace_yet = true;
+      specbind (Qstandard_output, backtrace_buffer);
+      specbind (Qdebugger, Qdebug_early);
+      call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
+      unbind_to (count, Qnil);
+      delayed_warning = make_string ("Error in a redisplay Lisp hook.  See buffer *Backtrace*", 55);
+
+      Vdelayed_warnings_list = Fcons (list2 (Qerror, delayed_warning),
+				      Vdelayed_warnings_list);
+    }
+
   if (!NILP (clause))
     {
       Lisp_Object unwind_data
@@ -4274,6 +4327,11 @@ Does not apply if quit is handled by a `condition-case'.  */);
   DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call,
 	       doc: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'.  */);
 
+  DEFVAR_BOOL ("backtrace-on-redisplay-lisp-error", backtrace_on_redisplay_lisp_error,
+	       doc: /* Non-nil means create a backtrace if a lisp error occurs in a redisplay hook.
+The backtrace is written to buffer *Backtrace*.  */);
+  backtrace_on_redisplay_lisp_error = false;
+
   DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue,
 	       doc: /* Non-nil means debugger may continue execution.
 This is nil when the debugger is called under circumstances where it
@@ -4314,6 +4372,13 @@ message upon encountering an unhandled error, without showing
 the Lisp backtrace.  */);
   backtrace_on_error_noninteractive = true;
 
+  DEFVAR_LISP ("redisplay-last-error", Vredisplay_last_error,
+	       doc: /* Handling of *Backtrace* when several redisplay errors occur in one command.
+If nil (default), we write only the backtrace from the command's first error.
+If t, we save only the backtrace from the last error in the command.
+If any other value, we write backtraces for all errors in the command.  */);
+  Vredisplay_last_error = Qnil;
+
   /* The value of num_nonmacro_input_events as of the last time we
    started to enter the debugger.  If we decide to enter the debugger
    again when this is still equal to num_nonmacro_input_events, then we
diff --git a/src/keyboard.c b/src/keyboard.c
index c729d5dfb3..d95dc404c8 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1330,6 +1330,7 @@ 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
@@ -1823,12 +1824,18 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
 }
 
 /* Subroutine for safe_run_hooks: run the hook, which is ARGS[1].  */
-
 static Lisp_Object
 safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args)
 {
-  eassert (nargs == 2);
-  return call0 (args[1]);
+  eassert (nargs >= 2 && nargs <= 4);
+  switch (nargs) {
+  case 2:
+    return call0 (args[1]);
+  case 3:
+    return call1 (args[1], args[2]);
+  default:
+    return call2 (args[1], args[2], args[3]);
+  }
 }
 
 /* Subroutine for safe_run_hooks: handle an error by clearing out the function
@@ -1837,7 +1844,7 @@ safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args)
 static Lisp_Object
 safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args)
 {
-  eassert (nargs == 2);
+  eassert (nargs >= 2 && nargs <= 4);
   AUTO_STRING (format, "Error in %s (%S): %S");
   Lisp_Object hook = args[0];
   Lisp_Object fun = args[1];
@@ -1877,7 +1884,7 @@ safe_run_hook_funcall (ptrdiff_t nargs, Lisp_Object *args)
   /* Yes, run_hook_with_args works with args in the other order.  */
   internal_condition_case_n (safe_run_hooks_1,
 			     2, ((Lisp_Object []) {args[1], args[0]}),
-			     Qt, safe_run_hooks_error);
+			     Qt, safe_run_hooks_error, false);
   return Qnil;
 }
 
@@ -1895,6 +1902,49 @@ safe_run_hooks (Lisp_Object hook)
   unbind_to (count, Qnil);
 }
 
+static Lisp_Object
+safe_run_hook_with_backtrace_funcall (ptrdiff_t nargs, Lisp_Object *args)
+{
+  Lisp_Object args_out [4];
+
+  eassert (nargs >= 2 && nargs <= 4);
+  args_out [0] = args[1];
+  args_out [1] = args[0];
+  if (nargs >= 3) args_out [2] = args [2];
+  if (nargs == 4) args_out [3] = args [3];
+  /* Yes, run_hook_with_args works with args in the other order.  */
+  internal_condition_case_n (safe_run_hooks_1,
+			     nargs, args_out,
+			     Qt, safe_run_hooks_error, true);
+  return Qnil;
+}
+
+/* Like safe_run_hooks, but in the event of a lisp error in a hook,
+   output a backtrace, should Emacs currently be configured for
+   this (backtrace-on-redisplay-lisp-error is non-nil).  */
+void
+safe_run_hooks_with_backtrace (Lisp_Object hook)
+{
+  specpdl_ref count = SPECPDL_INDEX ();
+
+  specbind (Qinhibit_quit, Qt);
+  run_hook_with_args (2, ((Lisp_Object []) {hook, hook}),
+		      safe_run_hook_with_backtrace_funcall);
+  unbind_to (count, Qnil);
+}
+
+void
+safe_run_hooks_2_with_backtrace (Lisp_Object hook, Lisp_Object arg1,
+				 Lisp_Object arg2)
+{
+  specpdl_ref count = SPECPDL_INDEX ();
+
+  specbind (Qinhibit_quit, Qt);
+  run_hook_with_args (4, ((Lisp_Object []) {hook, hook, arg1, arg2}),
+		      safe_run_hook_with_backtrace_funcall);
+  unbind_to (count, Qnil);
+}
+
 \f
 /* Nonzero means polling for input is temporarily suppressed.  */
 
diff --git a/src/lisp.h b/src/lisp.h
index dc496cc165..2227349d04 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4526,6 +4526,7 @@ 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:
@@ -4562,7 +4563,7 @@ extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lis
 extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
 extern Lisp_Object internal_condition_case_n
     (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
-     Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
+     Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *), bool);
 extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (enum nonlocal_exit, Lisp_Object));
 extern struct handler *push_handler (Lisp_Object, enum handlertype)
   ATTRIBUTE_RETURNS_NONNULL;
@@ -4823,6 +4824,9 @@ extern bool detect_input_pending (void);
 extern bool detect_input_pending_ignore_squeezables (void);
 extern bool detect_input_pending_run_timers (bool);
 extern void safe_run_hooks (Lisp_Object);
+extern void safe_run_hooks_with_backtrace (Lisp_Object);
+extern void safe_run_hooks_2_with_backtrace (Lisp_Object, Lisp_Object,
+					     Lisp_Object);
 extern void cmd_error_internal (Lisp_Object, const char *);
 extern Lisp_Object command_loop_2 (Lisp_Object);
 extern Lisp_Object read_menu_command (void);
diff --git a/src/xdisp.c b/src/xdisp.c
index f205327cc3..5c4afa4a8d 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -3022,7 +3022,7 @@ safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap)
       /* Use Qt to ensure debugger does not run,
 	 so there is no possibility of wanting to redisplay.  */
       val = internal_condition_case_n (Ffuncall, nargs, args, Qt,
-				       safe_eval_handler);
+				       safe_eval_handler, true);
       val = SAFE_FREE_UNBIND_TO (count, val);
     }
 
@@ -4332,6 +4332,7 @@ handle_fontified_prop (struct it *it)
 
       val = Vfontification_functions;
       specbind (Qfontification_functions, Qnil);
+      specbind (Qredisplay_lisping, Qt);
 
       eassert (it->end_charpos == ZV);
 
@@ -12628,6 +12629,7 @@ set_message (Lisp_Object string)
     {
       specpdl_ref count = SPECPDL_INDEX ();
       specbind (Qinhibit_quit, Qt);
+      specbind (Qredisplay_lisping, Qt);
       message = safe_call1 (Vset_message_function, string);
       unbind_to (count, Qnil);
 
@@ -12705,7 +12707,8 @@ clear_message (bool current_p, bool last_displayed_p)
         {
           specpdl_ref count = SPECPDL_INDEX ();
           specbind (Qinhibit_quit, Qt);
-          preserve = safe_call (1, Vclear_message_function);
+	  specbind (Qredisplay_lisping, Qt);
+	  preserve = safe_call (1, Vclear_message_function);
           unbind_to (count, Qnil);
         }
 
@@ -13289,6 +13292,7 @@ prepare_menu_bars (void)
 {
   bool all_windows = windows_or_buffers_changed || update_mode_lines;
   bool some_windows = REDISPLAY_SOME_P ();
+  specpdl_ref count = SPECPDL_INDEX ();
 
   if (FUNCTIONP (Vpre_redisplay_function))
     {
@@ -13306,7 +13310,9 @@ prepare_menu_bars (void)
 		windows = Fcons (this, windows);
 	    }
 	}
+      specbind (Qredisplay_lisping, Qt);
       safe__call1 (true, Vpre_redisplay_function, windows);
+      unbind_to (count, Qnil);
     }
 
   /* Update all frame titles based on their buffer names, etc.  We do
@@ -13463,12 +13469,11 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run)
 
 	  if (!hooks_run)
 	    {
-	      /* Run the Lucid hook.  */
-	      safe_run_hooks (Qactivate_menubar_hook);
+	      specbind (Qredisplay_lisping, Qt);
 
 	      /* If it has changed current-menubar from previous value,
 		 really recompute the menu-bar from the value.  */
-	      safe_run_hooks (Qmenu_bar_update_hook);
+	      safe_run_hooks_with_backtrace (Qmenu_bar_update_hook);
 
 	      hooks_run = true;
 	    }
@@ -17915,8 +17920,9 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp)
     {
       specpdl_ref count = SPECPDL_INDEX ();
       specbind (Qinhibit_quit, Qt);
-      run_hook_with_args_2 (Qwindow_scroll_functions, window,
-			    make_fixnum (CHARPOS (startp)));
+      specbind (Qredisplay_lisping, Qt);
+      safe_run_hooks_2_with_backtrace
+	(Qwindow_scroll_functions, window, make_fixnum (CHARPOS (startp)));
       unbind_to (count, Qnil);
       SET_TEXT_POS_FROM_MARKER (startp, w->start);
       /* In case the hook functions switch buffers.  */
@@ -19419,6 +19425,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
 	 now actually do it.  */
       if (new_vpos >= 0)
 	{
+	  specpdl_ref count = SPECPDL_INDEX ();
 	  struct glyph_row *row;
 
 	  row = MATRIX_FIRST_TEXT_ROW (w->desired_matrix);
@@ -19444,7 +19451,9 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
 	     propagated its info to `w' anyway.  */
 	  w->redisplay = false;
 	  XBUFFER (w->contents)->text->redisplay = false;
+	  specbind (Qredisplay_lisping, Qt);
 	  safe__call1 (true, Vpre_redisplay_function, Fcons (window, Qnil));
+	  unbind_to (count, Qnil);
 
 	  if (w->redisplay || XBUFFER (w->contents)->text->redisplay
 	      || ((EQ (Vdisplay_line_numbers, Qrelative)
@@ -26544,7 +26553,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
 						   Flength (elt),
 						   props,
 						   elt}),
-					       Qt, safe_eval_handler);
+					       Qt, safe_eval_handler, false);
 		    /* Add this item to mode_line_proptrans_alist.  */
 		    mode_line_proptrans_alist
 		      = Fcons (Fcons (elt, props),
@@ -35848,6 +35857,7 @@ be let-bound around code that needs to disable messages temporarily. */);
   DEFSYM (QCfile, ":file");
   DEFSYM (Qfontified, "fontified");
   DEFSYM (Qfontification_functions, "fontification-functions");
+  DEFSYM (Qredisplay_lisping, "redisplay-lisping");
 
   /* Name of the symbol which disables Lisp evaluation in 'display'
      properties.  This is used by enriched.el.  */
@@ -36365,6 +36375,10 @@ fontified regions the property `fontified'.  */);
   Vfontification_functions = Qnil;
   Fmake_variable_buffer_local (Qfontification_functions);
 
+  DEFVAR_BOOL ("redisplay-lisping", redisplay_lisping,
+    doc: /* Non-nil when a Lisp hook call from redisplay is in progress.  */);
+  redisplay_lisping = false;
+
   DEFVAR_BOOL ("unibyte-display-via-language-environment",
                unibyte_display_via_language_environment,
     doc: /* Non-nil means display unibyte text according to language environment.
diff --git a/src/xfns.c b/src/xfns.c
index 331f22763e..b026605053 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -3405,7 +3405,7 @@ x_xim_text_to_utf8_unix (XIMText *text, ptrdiff_t *length)
   waiting_for_input = false;
   arg = make_mint_ptr (&data);
   internal_condition_case_n (x_xim_text_to_utf8_unix_1, 1, &arg,
-			     Qt, x_xim_text_to_utf8_unix_2);
+			     Qt, x_xim_text_to_utf8_unix_2, false);
   waiting_for_input = was_waiting_for_input_p;
 
   *length = coding.produced;


-- 
Alan Mackenzie (Nuremberg, Germany).