[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/correct-warning-pos ff9af1f1f6: Miscellaneous enhancements to sc
From: |
Alan Mackenzie |
Subject: |
scratch/correct-warning-pos ff9af1f1f6: Miscellaneous enhancements to scratch/correct-warning-pos. |
Date: |
Fri, 31 Dec 2021 16:23:51 -0500 (EST) |
branch: scratch/correct-warning-pos
commit ff9af1f1f69264bcbb7b926363293e55a6b3f330
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
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 8581fe8066..1912d0d003 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 dafd549763..11204f7f7f 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 ac38c2131f..834656897e 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 1f2af6f474..6d9c0aef93 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 94ad060773..5cb673ab22 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 1cc5acc6d3..835228439f 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))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/correct-warning-pos ff9af1f1f6: Miscellaneous enhancements to scratch/correct-warning-pos.,
Alan Mackenzie <=