Package: emacs;
Reported by: Pip Cet <pipcet <at> gmail.com>
Date: Sun, 7 Mar 2021 13:48:01 UTC
Severity: wishlist
Tags: patch
Found in version 28.0.50
Message #31 received at 46988 <at> debbugs.gnu.org (full text, mbox):
From: Lars Ingebrigtsen <larsi <at> gnus.org> To: Pip Cet <pipcet <at> gmail.com> Cc: 46988 <at> debbugs.gnu.org, Mattias Engdegård <mattiase <at> acm.org>, Stefan Monnier <monnier <at> iro.umontreal.ca> Subject: Re: bug#46988: 28.0.50; Documenting and verifying assumptions about C code not calling quit or GCing Date: Mon, 20 Jun 2022 03:41:42 +0200
Pip Cet <pipcet <at> 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.