From ff9af1f1f69264bcbb7b926363293e55a6b3f330 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 31 Dec 2021 21:21:46 +0000 Subject: [PATCH] Miscellaneous enhancements to scratch/correct-warning-pos. 1. Check the type (symbol with position) of the argument given to the native compiled version of SYMBOL_WITH_POS_SYM. 2. Handle infinite recursion caused by circular lists, etc., in macroexp-strip-symbol-positions by using hash tables. 3. Read byte compiled functions without giving symbols positions. * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Add symbol-with-pos-p into the list of relocated symbols. * lisp/emacs-lisp/macroexp.el (macroexp--ssp-conses-seen) (macroexp--ssp-vectors-seen, macroexp--ssp-records-seen): Renamed, and animated as hash tables. (macroexp--strip-s-p-2): Optionally tests for the presence of an argument in one of the above hash tables, so as to handle otherwise infinite recursion. (byte-compile-strip-s-p-1): Add a condition-case to handle infinite recursion caused by circular lists etc., using the above hash tables as required. * src/comp.c (comp_t): New element symbol_with_pos_sym. (emit_SYMBOL_WITH_POS_SYM): Amend just to call the new SYMBOL_WITH_POS_SYM. (emit_CHECK_SYMBOL_WITH_POS, define_SYMBOL_WITH_POS_SYM): New functions. (Fcomp__init_ctxt): Register an emitter for Qsymbol_with_pos_p. (Fcomp__compile_ctxt_to_file): Call define_SYMBOL_WITH_POS_SYM. (syms_of_comp): Define Qsymbol_with_pos_p. * src/data.c (syms_of_data): Define a new error symbol Qrecursion_error, an error category for the new error symbols Qexcessive_variable_binding and Qexcessive_lisp_nesting. * src/eval.c (grow_specpdl): Change the signal_error call to an xsignal0 call using the new error symbol Qexcessive_variable_binding. (eval_sub, Ffuncall): Change the `error' calls to xsignal using the new error symbol Qexcessive_lisp_nesting. * src/lread.c (read1): When reading a compiled function, read the components of the vector without giving its symbols a position. --- lisp/emacs-lisp/comp.el | 2 +- lisp/emacs-lisp/macroexp.el | 40 +++++++++++------ src/comp.c | 90 ++++++++++++++++++++++++++++++------- src/data.c | 16 ++++++- src/eval.c | 7 ++- src/lread.c | 2 +- 6 files changed, 122 insertions(+), 35 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8581fe80662..1912d0d0037 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3576,7 +3576,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index dafd5497639..11204f7f7fb 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -32,11 +32,11 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defvar byte-compile--ssp-conses-seen nil +(defvar macroexp--ssp-conses-seen nil "Which conses have been processed in a strip-symbol-positions operation?") -(defvar byte-compile--ssp-vectors-seen nil +(defvar macroexp--ssp-vectors-seen nil "Which vectors have been processed in a strip-symbol-positions operation?") -(defvar byte-compile--ssp-records-seen nil +(defvar macroexp--ssp-records-seen nil "Which records have been processed in a strip-symbol-positions operation?") (defun macroexp--strip-s-p-2 (arg) @@ -46,8 +46,10 @@ Return the modified ARG." ((symbolp arg) (bare-symbol arg)) ((consp arg) - (unless (memq arg byte-compile--ssp-conses-seen) - ;; (push arg byte-compile--ssp-conses-seen) + (unless (and macroexp--ssp-conses-seen + (gethash arg macroexp--ssp-conses-seen)) + (if macroexp--ssp-conses-seen + (puthash arg t macroexp--ssp-conses-seen)) (let ((a arg)) (while (consp (cdr a)) (setcar a (macroexp--strip-s-p-2 (car a))) @@ -58,8 +60,10 @@ Return the modified ARG." (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) arg) ((vectorp arg) - (unless (memq arg byte-compile--ssp-vectors-seen) - (push arg byte-compile--ssp-vectors-seen) + (unless (and macroexp--ssp-vectors-seen + (gethash arg macroexp--ssp-vectors-seen)) + (if macroexp--ssp-vectors-seen + (puthash arg t macroexp--ssp-vectors-seen)) (let ((i 0) (len (length arg))) (while (< i len) @@ -67,8 +71,10 @@ Return the modified ARG." (setq i (1+ i))))) arg) ((recordp arg) - (unless (memq arg byte-compile--ssp-records-seen) - (push arg byte-compile--ssp-records-seen) + (unless (and macroexp--ssp-records-seen + (gethash arg macroexp--ssp-records-seen)) + (if macroexp--ssp-records-seen + (puthash arg t macroexp--ssp-records-seen)) (let ((i 0) (len (length arg))) (while (< i len) @@ -80,10 +86,18 @@ Return the modified ARG." (defun byte-compile-strip-s-p-1 (arg) "Strip all positions from symbols in ARG, destructively modifying ARG. Return the modified ARG." - (setq byte-compile--ssp-conses-seen nil) - (setq byte-compile--ssp-vectors-seen nil) - (setq byte-compile--ssp-records-seen nil) - (macroexp--strip-s-p-2 arg)) + (condition-case err + (progn + (setq macroexp--ssp-conses-seen nil) + (setq macroexp--ssp-vectors-seen nil) + (setq macroexp--ssp-records-seen nil) + (macroexp--strip-s-p-2 arg)) + (recursion-error + (dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen + macroexp--ssp-records-seen)) + (set tab (make-hash-table :test 'eq))) + (macroexp--strip-s-p-2 arg)) + (error (signal (car err) (cdr err))))) (defun macroexp-strip-symbol-positions (arg) "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." diff --git a/src/comp.c b/src/comp.c index ac38c2131f9..834656897e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -574,6 +574,7 @@ typedef struct { gcc_jit_type *lisp_symbol_with_position_type; gcc_jit_type *lisp_symbol_with_position_ptr_type; gcc_jit_function *get_symbol_with_position; + gcc_jit_function *symbol_with_pos_sym; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -1475,21 +1476,12 @@ emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) { emit_comment ("SYMBOL_WITH_POS_SYM"); - gcc_jit_rvalue *tmp2, *swp; - gcc_jit_lvalue *tmpl; - - gcc_jit_rvalue *args[] = { obj }; - swp = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.get_symbol_with_position, - 1, - args); - tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0)); - tmp2 = gcc_jit_lvalue_as_rvalue (tmpl); - return - gcc_jit_rvalue_access_field (tmp2, - NULL, - comp.lisp_symbol_with_position_sym); + gcc_jit_rvalue *arg [] = { obj }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.symbol_with_pos_sym, + 1, + arg); } static gcc_jit_rvalue * @@ -1858,6 +1850,29 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) args)); } +static void +emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x) +{ + emit_comment ("CHECK_SYMBOL_WITH_POS"); + + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_SYMBOL_WITH_POS_P (x), + comp.int_type), + emit_lisp_obj_rval (Qsymbol_with_pos_p), + x }; + + gcc_jit_block_add_eval ( + comp.block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); +} + static gcc_jit_rvalue * emit_car_addr (gcc_jit_rvalue *c) { @@ -3886,6 +3901,48 @@ define_GET_SYMBOL_WITH_POSITION (void) 1, args, false)); } +static void define_SYMBOL_WITH_POS_SYM (void) +{ + gcc_jit_rvalue *tmpr, *swp; + gcc_jit_lvalue *tmpl; + + gcc_jit_param *param [] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + comp.symbol_with_pos_sym = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "SYMBOL_WITH_POS_SYM", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.symbol_with_pos_sym); + comp.func = comp.symbol_with_pos_sym; + comp.block = entry_block; + + emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0])); + + gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) }; + + swp = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.get_symbol_with_position, + 1, + args); + tmpl = gcc_jit_rvalue_dereference (swp, NULL); + tmpr = gcc_jit_lvalue_as_rvalue (tmpl); + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + tmpr, + NULL, + comp.lisp_symbol_with_position_sym)); +} + static void define_CHECK_IMPURE (void) { @@ -4504,6 +4561,7 @@ Return t on success. */) register_emitter (Qnumberp, emit_numperp); register_emitter (Qintegerp, emit_integerp); register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); + register_emitter (Qsymbol_with_pos_p, emit_SYMBOL_WITH_POS_P); } comp.ctxt = gcc_jit_context_acquire (); @@ -4820,6 +4878,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_PSEUDOVECTORP (); define_GET_SYMBOL_WITH_POSITION (); define_CHECK_TYPE (); + define_SYMBOL_WITH_POS_SYM (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr (); @@ -5618,6 +5677,7 @@ compiled one. */); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); /* Allocation classes. */ DEFSYM (Qd_default, "d-default"); diff --git a/src/data.c b/src/data.c index 1f2af6f4743..6d9c0aef933 100644 --- a/src/data.c +++ b/src/data.c @@ -3969,7 +3969,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */) void syms_of_data (void) { - Lisp_Object error_tail, arith_tail; + Lisp_Object error_tail, arith_tail, recursion_tail; DEFSYM (Qquote, "quote"); DEFSYM (Qlambda, "lambda"); @@ -4004,6 +4004,10 @@ syms_of_data (void) DEFSYM (Qmark_inactive, "mark-inactive"); DEFSYM (Qinhibited_interaction, "inhibited-interaction"); + DEFSYM (Qrecursion_error, "recursion-error"); + DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding"); + DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting"); + DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); DEFSYM (Qbare_symbol_p, "bare-symbol-p"); @@ -4112,6 +4116,16 @@ syms_of_data (void) PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail), "Arithmetic underflow error"); + recursion_tail = pure_cons (Qrecursion_error, error_tail); + Fput (Qrecursion_error, Qerror_conditions, recursion_tail); + Fput (Qrecursion_error, Qerror_message, build_pure_c_string + ("Excessive recursive calling error")); + + PUT_ERROR (Qexcessive_variable_binding, recursion_tail, + "Variable binding depth exceeds max-specpdl-size"); + PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail, + "Lisp nesting exceeds `max-lisp-eval-depth'"); + /* Types that type-of returns. */ DEFSYM (Qinteger, "integer"); DEFSYM (Qsymbol, "symbol"); diff --git a/src/eval.c b/src/eval.c index 94ad0607732..5cb673ab223 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2398,8 +2398,7 @@ grow_specpdl (void) if (max_specpdl_size < 400) max_size = max_specpdl_size = 400; if (max_size <= specpdl_size) - signal_error ("Variable binding depth exceeds max-specpdl-size", - Qnil); + xsignal0 (Qexcessive_variable_binding); } pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl); specpdl = pdlvec + 1; @@ -2453,7 +2452,7 @@ eval_sub (Lisp_Object form) if (max_lisp_eval_depth < 100) max_lisp_eval_depth = 100; if (lisp_eval_depth > max_lisp_eval_depth) - error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + xsignal0 (Qexcessive_lisp_nesting); } Lisp_Object original_fun = XCAR (form); @@ -3044,7 +3043,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) if (max_lisp_eval_depth < 100) max_lisp_eval_depth = 100; if (lisp_eval_depth > max_lisp_eval_depth) - error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + xsignal0 (Qexcessive_lisp_nesting); } count = record_in_backtrace (args[0], &args[1], nargs - 1); diff --git a/src/lread.c b/src/lread.c index 1cc5acc6d3a..835228439f1 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3225,7 +3225,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp = read_vector (readcharfun, 1, locate_syms); + tmp = read_vector (readcharfun, 1, false); vec = XVECTOR (tmp); if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) -- 2.39.5