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

[Lars Ingebrigtsen <larsi@gnus.org>]

Pip Cet <pipcet@gmail.com> writes:

> 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.

I've respun the patch for the current trunk, and I wonder whether
anybody has any comments here (so I've added Stefan and Mattias to the
CCs).

I think if we add this, it should be enabled only if the build is
configured with --enable-checking.

diff --git a/src/alloc.c b/src/alloc.c
index 55e18ecd77..276267ef10 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -7019,6 +7019,7 @@ #define CHECK_ALLOCATED_AND_LIVE_SYMBOL()		((void) 0)
 void
 mark_object (Lisp_Object obj)
 {
+  DONT_ALLOW_GC ();
   ptrdiff_t sp = mark_stk.sp;
   mark_stack_push_value (obj);
   process_mark_stack (sp);
@@ -7921,3 +7922,5 @@ syms_of_alloc (void)
   enum defined_HAVE_PGTK defined_HAVE_PGTK;
 } 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 fa068e1ec6..6d3b3fdb98 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -958,7 +958,8 @@ #define DEFINE(name, value) [name] = &&insn_ ## 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 1c392d65df..87d9fe070a 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 346dff8bdc..f04b814c0e 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -236,7 +236,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;
@@ -1200,7 +1200,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));
 
   /* Call FUNC.  */
   if (! sys_setjmp (c->jmp))
@@ -1274,6 +1274,9 @@ unwind_to_catch (struct handler *catch, enum nonlocal_exit type,
   lisp_eval_depth = catch->f_lisp_eval_depth;
   set_act_rec (current_thread, catch->act_rec);
 
+  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);
 }
 
@@ -1283,6 +1286,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))
@@ -1405,7 +1409,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;
@@ -1472,7 +1477,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;
@@ -1496,7 +1502,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;
@@ -1523,7 +1530,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;
@@ -1552,7 +1560,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;
@@ -1579,7 +1588,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;
 
@@ -1601,16 +1611,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)
@@ -1635,6 +1647,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
 #ifdef HAVE_X_WINDOWS
   c->x_error_handler_depth = x_error_message_count;
 #endif
+  c->sp = sp;
   handlerlist = c;
   return c;
 }
diff --git a/src/lisp.h b/src/lisp.h
index 05b0754ff6..f15abb4519 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3649,6 +3649,7 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
 #ifdef HAVE_X_WINDOWS
   int x_error_handler_depth;
 #endif
+  void *sp;
 };
 
 extern Lisp_Object memory_signal_data;
@@ -4560,9 +4561,10 @@ 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 (Lisp_Object, enum handlertype, void *)
   ATTRIBUTE_RETURNS_NONNULL;
-extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
+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);
@@ -5541,9 +5543,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 626d14aad0..e172785a64 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -779,7 +779,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;


-- 
(domestic pets only, the antidote for overdose, milk.)
   bloggy blog: http://lars.ingebrigtsen.no