Subject: bug#46988: 28.0.50; Documenting and verifying assumptions about C code not calling quit or GCing

From: Pip Cet <[email-masked]>
Date: Sun, 7 Mar 2021 14:06:01 +0000

On Sun, Mar 7, 2021 at 1:48 PM Pip Cet <[email-masked]> wrote:
> Proof-of-concept patch for a runtime check will be attached once this
> has a bug number.

Patch attached. It assumes the standard stack growth direction, and
that __builtin_frame_address (0) is available and works. Uses GCC's
__attribute__ ((cleanup (...))).

My point here is that the technical implementation isn't the problem,
the question is whether we're disciplined enough to run with checking
enabled and react to bug reports about the fatal error being thrown.

Pip
From f5ad576ee0aa6c2b3975b0ca131aea4444c7e336 Mon Sep 17 00:00:00 2001
From: Pip Cet <[email-masked]>
Date: Sun, 7 Mar 2021 13:59:32 +0000
Subject: [PATCH] Runtime check that some functions don't GC (bug#46988)

* src/alloc.c (mark_object): Mark as DONT_ALLOW_GC ().
(global_dont_allow_gc): New variable.
* src/eval.c (push_handler): Require an sp argument. All callers
changed.
(push_handler_nosignal): Require an sp argument. All callers changed.
Save sp argument in handler structure.
(unwind_to_catch): Handle dont_allow_gc stack.
(Fthrow): Mark as DONT_ALLOW_GC ().
* src/lisp.h (struct handler): Add sp field, for custom stack
unwinding.
(struct dont_allow_gc): New struct.
(dont_allow_gc_init): New function.
(dont_allow_gc_destroy): New function.
(DONT_ALLOW_GC): New macro.
(maybe_gc): Check whether GC is allowed, throw a fatal error if not.
---
 src/alloc.c        |  3 +++
 src/bytecode.c     |  3 ++-
 src/emacs-module.c |  2 +-
 src/eval.c         | 35 ++++++++++++++++++++++++-----------
 src/lisp.h         | 33 +++++++++++++++++++++++++++++++--
 src/thread.c       |  2 +-
 6 files changed, 62 insertions(+), 16 deletions(-)

diff --git a/src/alloc.c b/src/alloc.c
index e72fc4c4332de..5fe62ef953117 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -6565,6 +6565,7 @@ mark_objects (Lisp_Object *obj, ptrdiff_t n)
 void
 mark_object (Lisp_Object arg)
 {
+  DONT_ALLOW_GC ();
   register Lisp_Object obj;
   void *po;
 #if GC_CHECK_MARKED_OBJECTS
@@ -7668,3 +7669,5 @@ syms_of_alloc (void)
   enum defined_HAVE_X_WINDOWS defined_HAVE_X_WINDOWS;
 } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
 #endif	/* __GNUC__ */
+
+struct dont_allow_gc *global_dont_allow_gc;
diff --git a/src/bytecode.c b/src/bytecode.c
index 4fd41acab856a..5a85fe81ae6da 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -776,7 +776,8 @@ #define DEFINE(name, value) LABEL (name) ,
 	  type = CONDITION_CASE;
 	pushhandler:
 	  {
-	    struct handler *c = push_handler (POP, type);
+	    struct handler *c = push_handler (POP, type,
+					      __builtin_frame_address (0));
 	    c->bytecode_dest = FETCH2;
 	    c->bytecode_top = top;
 
diff --git a/src/emacs-module.c b/src/emacs-module.c
index f8fb54c072823..63fe495b91a17 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -272,7 +272,7 @@ #define MODULE_HANDLE_NONLOCAL_EXIT(retval)                             \
   if (module_non_local_exit_check (env) != emacs_funcall_exit_return)	\
     return retval;							\
   struct handler *internal_handler =                                    \
-    push_handler_nosignal (Qt, CATCHER_ALL);                            \
+    push_handler_nosignal (Qt, CATCHER_ALL, __builtin_frame_address (0)); \
   if (!internal_handler)                                                \
     {									\
       module_out_of_memory (env);					\
diff --git a/src/eval.c b/src/eval.c
index ddaa8edd81706..b3964b51a1ed1 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -243,7 +243,7 @@ init_eval (void)
        which would otherwise leak every time we unwind back to top-level.   */
     handlerlist_sentinel = xzalloc (sizeof (struct handler));
     handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
-    struct handler *c = push_handler (Qunbound, CATCHER);
+    struct handler *c = push_handler (Qunbound, CATCHER, __builtin_frame_address (0));
     eassert (c == handlerlist_sentinel);
     handlerlist_sentinel->nextfree = NULL;
     handlerlist_sentinel->next = NULL;
@@ -1178,7 +1178,7 @@ internal_catch (Lisp_Object tag,
 		Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
 {
   /* This structure is made part of the chain `catchlist'.  */
-  struct handler *c = push_handler (tag, CATCHER);
+  struct handler *c = push_handler (tag, CATCHER, __builtin_frame_address (0));
 
   if (EQ (tag, Qexit))
     minibuffer_quit_level = 0;
@@ -1258,6 +1258,9 @@ unwind_to_catch (struct handler *catch, enum nonlocal_exit type,
 
   lisp_eval_depth = catch->f_lisp_eval_depth;
 
+  void *sp = catch->sp;
+  while (global_dont_allow_gc && (void *)global_dont_allow_gc < sp)
+    global_dont_allow_gc = global_dont_allow_gc->prev;
   sys_longjmp (catch->jmp, 1);
 }
 
@@ -1267,6 +1270,7 @@ DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
        attributes: noreturn)
   (register Lisp_Object tag, Lisp_Object value)
 {
+  DONT_ALLOW_GC ();
   struct handler *c;
 
   if (!NILP (tag))
@@ -1376,7 +1380,8 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
       Lisp_Object condition = CONSP (clause) ? XCAR (clause) : Qnil;
       if (!CONSP (condition))
 	condition = list1 (condition);
-      struct handler *c = push_handler (condition, CONDITION_CASE);
+      struct handler *c = push_handler (condition, CONDITION_CASE,
+					__builtin_frame_address (0));
       if (sys_setjmp (c->jmp))
 	{
 	  Lisp_Object val = handlerlist->val;
@@ -1426,7 +1431,8 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
 internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
 			 Lisp_Object (*hfun) (Lisp_Object))
 {
-  struct handler *c = push_handler (handlers, CONDITION_CASE);
+  struct handler *c = push_handler (handlers, CONDITION_CASE,
+				    __builtin_frame_address (0));
   if (sys_setjmp (c->jmp))
     {
       Lisp_Object val = handlerlist->val;
@@ -1450,7 +1456,8 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
 			   Lisp_Object handlers,
 			   Lisp_Object (*hfun) (Lisp_Object))
 {
-  struct handler *c = push_handler (handlers, CONDITION_CASE);
+  struct handler *c = push_handler (handlers, CONDITION_CASE,
+				    __builtin_frame_address (0));
   if (sys_setjmp (c->jmp))
     {
       Lisp_Object val = handlerlist->val;
@@ -1477,7 +1484,8 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
 			   Lisp_Object handlers,
 			   Lisp_Object (*hfun) (Lisp_Object))
 {
-  struct handler *c = push_handler (handlers, CONDITION_CASE);
+  struct handler *c = push_handler (handlers, CONDITION_CASE,
+				    __builtin_frame_address (0));
   if (sys_setjmp (c->jmp))
     {
       Lisp_Object val = handlerlist->val;
@@ -1506,7 +1514,8 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
 						ptrdiff_t nargs,
 						Lisp_Object *args))
 {
-  struct handler *c = push_handler (handlers, CONDITION_CASE);
+  struct handler *c = push_handler (handlers, CONDITION_CASE,
+				    __builtin_frame_address (0));
   if (sys_setjmp (c->jmp))
     {
       Lisp_Object val = handlerlist->val;
@@ -1533,7 +1542,8 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
 internal_catch_all (Lisp_Object (*function) (void *), void *argument,
                     Lisp_Object (*handler) (enum nonlocal_exit, Lisp_Object))
 {
-  struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
+  struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL,
+					     __builtin_frame_address (0));
   if (c == NULL)
     return Qcatch_all_memory_full;
 
@@ -1555,16 +1565,18 @@ internal_catch_all (Lisp_Object (*function) (void *), void *argument,
 }
 
 struct handler *
-push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
+push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype,
+	      void *sp)
 {
-  struct handler *c = push_handler_nosignal (tag_ch_val, handlertype);
+  struct handler *c = push_handler_nosignal (tag_ch_val, handlertype, sp);
   if (!c)
     memory_full (sizeof *c);
   return c;
 }
 
 struct handler *
-push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
+push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype,
+		       void *sp)
 {
   struct handler *CACHEABLE c = handlerlist->nextfree;
   if (!c)
@@ -1585,6 +1597,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
   c->pdlcount = SPECPDL_INDEX ();
   c->poll_suppress_count = poll_suppress_count;
   c->interrupt_input_blocked = interrupt_input_blocked;
+  c->sp = sp;
   handlerlist = c;
   return c;
 }
diff --git a/src/lisp.h b/src/lisp.h
index b95f389b89024..9d94376b5b897 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3259,6 +3259,7 @@ SPECPDL_INDEX (void)
   ptrdiff_t pdlcount;
   int poll_suppress_count;
   int interrupt_input_blocked;
+  void *sp;
 };
 
 extern Lisp_Object memory_signal_data;
@@ -4143,8 +4144,9 @@ xsignal (Lisp_Object error_symbol, Lisp_Object data)
     (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
      Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
 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);
-extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
+extern struct handler *push_handler (Lisp_Object, enum handlertype, void *);
+extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype,
+					      void *);
 extern void specbind (Lisp_Object, Lisp_Object);
 extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);
 extern void record_unwind_protect_array (Lisp_Object *, ptrdiff_t);
@@ -5050,9 +5052,36 @@ #define FOR_EACH_ALIST_VALUE(head_var, list_var, value_var)		\
 
 /* Check whether it's time for GC, and run it if so.  */
 
+/* Do not wrap into do { } while (0). */
+
+struct dont_allow_gc;
+struct dont_allow_gc
+{
+  struct dont_allow_gc *prev;
+};
+
+extern struct dont_allow_gc *global_dont_allow_gc;
+
+INLINE void
+dont_allow_gc_init (struct dont_allow_gc *dag)
+{
+  dag->prev = global_dont_allow_gc;
+  global_dont_allow_gc = dag;
+}
+
+INLINE void
+dont_allow_gc_destroy (struct dont_allow_gc *dag)
+{
+  global_dont_allow_gc = dag->prev;
+}
+
+#define DONT_ALLOW_GC() struct dont_allow_gc __attribute__ ((cleanup (dont_allow_gc_destroy))) dont_allow_gc; dont_allow_gc_init (&dont_allow_gc)
+
 INLINE void
 maybe_gc (void)
 {
+  if (global_dont_allow_gc)
+    fatal ("GC disallowed");
   if (consing_until_gc < 0)
     maybe_garbage_collect ();
 }
diff --git a/src/thread.c b/src/thread.c
index f74f611148647..6f5deb4101032 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -748,7 +748,7 @@ run_thread (void *state)
      which would otherwise leak every time we unwind back to top-level.   */
   handlerlist_sentinel = xzalloc (sizeof (struct handler));
   handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
-  struct handler *c = push_handler (Qunbound, CATCHER);
+  struct handler *c = push_handler (Qunbound, CATCHER, __builtin_frame_address (0));
   eassert (c == handlerlist_sentinel);
   handlerlist_sentinel->nextfree = NULL;
   handlerlist_sentinel->next = NULL;
-- 
2.30.1