New debugging facility: backtraces from errors in Lisp called from redisplay

Setting backtrace-on-redisplay-error to non-nil enables the generation of a
Lisp backtrace in buffer *Redisplay-trace* following an error in Lisp called
from redisplay.

* doc/lispref/debugging.texi (Debugging Redisplay): New subsection.
(Error Debugging): Reference to the new subsection.

* etc/NEWS: New entry for the new facility.

* src/eval.c (redisplay_deep_handler): New variable.
(init_eval): Initialize redisplay_deep_handler.
(call_debugger): Don't throw to top-level after calling debug-early
(internal_condition_case_n): "Bind" redisplay_deep_handler to the current
handler.
(backtrace_yet): New boolean variable.
(signal_or_quit): New code section to handle Lisp errors occurring in
redisplay.
(syms_of_eval): New DEFVAR_BOOL backtrace-on-redisplay-error.

* src/keyboard.c (command_loop_1): Set backtrace_yet to false each time around
the loop.
(safe_run_hooks_error): Allow args to be up to four Lisp_Objects long.
(safe_run_hooks_2): New function.

* src/lisp.h (top level): declare as externs backtrace_yet and
safe_run_hooks_2.

* src/xdisp.c (run_window_scroll_functions): Replace a call to
run_hook_with_args_2 with one to safe_run_hooks_2.

6 files changed, 126 insertions, 4 deletions

diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index 058c9319544..9ae40949d1e 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -77,6 +77,7 @@ debugger recursively.  @xref{Recursive Editing}.
 
 @menu
 * Error Debugging::       Entering the debugger when an error happens.
+* Debugging Redisplay::   Getting backtraces from redisplay errors.
 * Infinite Loops::        Stopping and debugging a program that doesn't exit.
 * Function Debugging::    Entering it when a certain function is called.
 * Variable Debugging::    Entering it when a variable is modified.
@@ -105,6 +106,10 @@ debugger, set the variable @code{debug-on-error} to non-@code{nil}.
 (The command @code{toggle-debug-on-error} provides an easy way to do
 this.)
 
+Note that, for technical reasons, you cannot use the facilities
+defined in this subsection to debug errors in Lisp that the redisplay
+code has invoked.  @xref{Debugging Redisplay}, for help with these.
+
 @defopt debug-on-error
 This variable determines whether the debugger is called when an error
 is signaled and not handled.  If @code{debug-on-error} is @code{t},
@@ -213,6 +218,45 @@ file, use the option @samp{--debug-init}.  This binds
 bypasses the @code{condition-case} which normally catches errors in the
 init file.
 
+@node Debugging Redisplay
+@subsection Debugging Redisplay Errors
+@cindex redisplay errors
+@cindex debugging redisplay errors
+
+When an error occurs in Lisp code which redisplay has invoked, Emacs's
+usual debugging mechanisms are unusable, for technical reasons.  This
+subsection describes how to get a backtrace from such an error, which
+should be helpful in debugging it.
+
+These directions apply to Lisp forms used, for example, in
+@code{:eval} mode line constructs (@pxref{Mode Line Data}), and in all
+hooks invoked from redisplay, such as:
+
+@itemize
+@item
+@code{fontification-functions} (@pxref{Auto Faces}).
+@item
+@code{window-scroll-functions} (@pxref{Window Hooks}).
+@end itemize
+
+Note that if you have had an error in a hook function called from
+redisplay, the error handling might have removed this function from
+the hook.  You will thus need to reinitialize that hook somehow,
+perhaps with @code{add-hook}, to be able to replay the bug.
+
+To generate a backtrace in these circumstances, set the variable
+@code{backtrace-on-redisplay-error} to non-@code{nil}.  When the error
+occurs, Emacs will dump the backtrace to the buffer
+@file{*Redisplay-trace*}, but won't automatically display it in a
+window.  This is to avoid needlessly corrupting the redisplay you are
+debugging.  You will thus need to display the buffer yourself, with a
+command such as @code{switch-to-buffer-other-frame} @key{C-x 5 b}.
+
+@defvar backtrace-on-redisplay-error
+Set this variable to non-@code{nil} to enable the generation of a
+backtrace when an error occurs in any Lisp called from redisplay.
+@end defvar
+
 @node Infinite Loops
 @subsection Debugging Infinite Loops
 @cindex infinite loops
diff --git a/etc/NEWS b/etc/NEWS
index 8d54ccc0dc8..2747cec18c5 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1339,6 +1339,13 @@ When invoked with a non-zero prefix argument, as in 'C-u C-x C-e',
 this command will pop up a new buffer and show the full pretty-printed
 value there.
 
++++
+*** You can now generate a backtrace from Lisp errors in redisplay.
+To do this, set the new variable 'backtrace-on-redisplay-error' to a
+non-nil value.  The backtrace will be written to buffer
+*Redisplay-trace*.  This buffer will not be automatically displayed in
+a window.
+
 ** Compile
 
 +++
diff --git a/src/eval.c b/src/eval.c
index d82d05797b2..56b42966623 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;
@@ -246,6 +252,7 @@ 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;
 }
 
 /* Ensure that *M is at least A + B if possible, or is its maximum
@@ -333,7 +340,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);
@@ -1556,12 +1564,16 @@ 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
@@ -1569,6 +1581,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 = old_deep;
       return val;
     }
 }
@@ -1701,6 +1714,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.
@@ -1816,6 +1834,40 @@ 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 *Redisplay-trace*.  */
+  if (!debugger_called && !NILP (error_symbol)
+      && backtrace_on_redisplay_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 (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;
+      max_ensure_room (&max_specpdl_size, counti, 200);
+      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, Fcons (error_symbol, data)));
+      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))
     {
       Lisp_Object unwind_data
@@ -4278,6 +4330,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-error", backtrace_on_redisplay_error,
+               doc: /* Non-nil means create a backtrace if a lisp error occurs in redisplay.
+The backtrace is written to buffer *Redisplay-trace*.  */);
+  backtrace_on_redisplay_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 4ad6e4e6bd1..719226caedc 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1331,6 +1331,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
@@ -1841,7 +1842,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];
@@ -1915,6 +1916,17 @@ safe_run_hooks_maybe_narrowed (Lisp_Object hook, struct window *w)
   unbind_to (count, Qnil);
 }
 
+void
+safe_run_hooks_2 (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_funcall);
+  unbind_to (count, Qnil);
+}
+
 
 /* Nonzero means polling for input is temporarily suppressed.  */
 
diff --git a/src/lisp.h b/src/lisp.h
index fe6e98843d1..2f73ba4c617 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4530,6 +4530,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:
@@ -4831,6 +4832,7 @@ 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_maybe_narrowed (Lisp_Object, struct window *);
+extern void safe_run_hooks_2 (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 855f48f2bde..5268c359ecd 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -18133,8 +18133,8 @@ 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)));
+      safe_run_hooks_2
+        (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.  */