Fontification error backtrace [Was: Why is it so difficult to get a Lisp backtrace?]

[Alan Mackenzie]

Hello, Eli.

On Sun, Jun 26, 2022 at 08:20:47 +0300, Eli Zaretskii wrote:
> > Date: Sat, 25 Jun 2022 19:45:49 +0000
> > Cc: larsi@gnus.org, emacs-devel@gnu.org
> > From: Alan Mackenzie <acm@muc.de>

> > > The only two ways of having that, AFAIK, are:

> > >   . emit the backtrace int *Messages*
> > >   . add the backtrace to delayed-warnings-list

> > Why can't the backtrace be generated and stored, and only displayed at a
> > subsequent redisplay (probably the next one)?

> That's what the second alternative above already does.

OK, I've got some code.  :-)

What it does, on a fontification error during redisplay, is to write a
backtrace into the *Backtrace* buffer, attempts a pop-to-buffer (which
isn't working, not surprisingly), and aborts the redisplay.

The basic idea is to note the condition-case handler which is scheduled
to handle any fontification error.  In signal_or_quit, if that is the
handler which is about to handle an error, generate a backtrace instead.

To try it out, set the new variable backtrace-on-fontification-error to
non-nil, and tweak some code to generate an error during fontification.

As already noted, the *Backtrace* buffer doesn't appear on the screen,
yet.  Any hints on how to achieve this would be most welcome.  It seems I
could really do with after-redisplay-hook, in which I could call
pop-to-buffer, then cause redisplay to be restarted.

Maybe this code could go into Emacs 29, once it's working properly.



diff --git a/src/dispextern.h b/src/dispextern.h
index c7399ca299..4bf6fb843f 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -3406,6 +3406,7 @@ void move_it_in_display_line (struct it *it,
 int partial_line_height (struct it *it_origin);
 bool in_display_vector_p (struct it *);
 int frame_mode_line_height (struct frame *);
+extern struct handler *redisplay_deep_handler;
 extern bool redisplaying_p;
 extern bool help_echo_showing_p;
 extern Lisp_Object help_echo_string, help_echo_window;
diff --git a/src/eval.c b/src/eval.c
index 346dff8bdc..ad5eb9dc7e 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1550,9 +1550,12 @@ 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),
+                          struct handler **handler)
 {
   struct handler *c = push_handler (handlers, CONDITION_CASE);
+  if (handler)
+    *handler = c;
   if (sys_setjmp (c->jmp))
     {
       Lisp_Object val = handlerlist->val;
@@ -1812,6 +1815,32 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object 
data, bool keyboard_quit)
       unbind_to (count, Qnil);
     }
 
+  /* If an error is signalled during fontification in redisplay, print
+     a backtrace into the buffer *Backtrace*.  */
+  if (!debugger_called && !NILP (error_symbol)
+      && redisplay_fontifying
+      && backtrace_on_fontification_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);
+      Lisp_Object backtrace_buffer;
+      max_ensure_room (&max_specpdl_size, counti, 200);
+      backtrace_buffer = Fget_buffer_create (make_string ("*Backtrace*", 11),
+                                            Qnil);
+      current_buffer = XBUFFER (backtrace_buffer);
+      Ferase_buffer ();
+      specbind (Qstandard_output, backtrace_buffer);
+      specbind (Qdebugger, Qdebug_early);
+      call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
+      unbind_to (count, Qnil);
+      call1 (intern ("pop-to-buffer"), backtrace_buffer);
+      Fthrow (Qtop_level, Qt); /* This might not be needed. */
+    }
+
   if (!NILP (clause))
     {
       Lisp_Object unwind_data
@@ -4269,6 +4298,12 @@ 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-fontification-error", 
backtrace_on_fontification_error,
+              doc: /* Non-nil means show a backtrace if a fontification error 
occurs in redisplay.
+When this happens, it causes the current redisplay to be aborted and a new one
+including the *Backtrace* buffer to be performed.  */);
+  backtrace_on_fontification_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
diff --git a/src/keyboard.c b/src/keyboard.c
index e62b2e56d3..fdce343d6f 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1878,7 +1878,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, NULL);
   return Qnil;
 }
 
diff --git a/src/lisp.h b/src/lisp.h
index 05b0754ff6..16830c7d8e 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4558,7 +4558,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 *), 
struct handler **);
 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;
diff --git a/src/xdisp.c b/src/xdisp.c
index 90809ac3ab..6b2d09efb2 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -615,6 +615,9 @@ fill_column_indicator_column (struct it *it, int char_width)
 
 bool noninteractive_need_newline;
 
+/* The handler structure which will catch errors in fontification code.  */
+struct handler *redisplay_deep_handler;
+
 /* True means print newline to message log before next message.  */
 
 static bool message_log_need_newline;
@@ -3013,7 +3016,8 @@ 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,
+                                      &redisplay_deep_handler);
       val = SAFE_FREE_UNBIND_TO (count, val);
     }
 
@@ -4320,6 +4324,7 @@ handle_fontified_prop (struct it *it)
 
       val = Vfontification_functions;
       specbind (Qfontification_functions, Qnil);
+      specbind (Qredisplay_fontifying, Qt);
 
       eassert (it->end_charpos == ZV);
 
@@ -26431,7 +26436,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, NULL);
                    /* Add this item to mode_line_proptrans_alist.  */
                    mode_line_proptrans_alist
                      = Fcons (Fcons (elt, props),
@@ -35704,6 +35709,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_fontifying, "redisplay-fontifying");
 
   /* Name of the symbol which disables Lisp evaluation in 'display'
      properties.  This is used by enriched.el.  */
@@ -36221,6 +36227,10 @@ fontified regions the property `fontified'.  */);
   Vfontification_functions = Qnil;
   Fmake_variable_buffer_local (Qfontification_functions);
 
+  DEFVAR_BOOL ("redisplay-fontifying", redisplay_fontifying,
+    doc: /* Non-nil when fontification invoked from redisplay is in progress.  
*/);
+  redisplay_fontifying = 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 1372809da6..dc18cfb4ae 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, NULL);
   waiting_for_input = was_waiting_for_input_p;
 
   *length = coding.produced;


-- 
Alan Mackenzie (Nuremberg, Germany).