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

[Lars Ingebrigtsen]

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