diff options
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 41 | ||||
| -rw-r--r-- | lisp/loadup.el | 6 | ||||
| -rw-r--r-- | src/comp.c | 8 | ||||
| -rw-r--r-- | test/src/comp-tests.el | 18 |
4 files changed, 54 insertions, 19 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 283c00103b5..e97832455b9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1763,27 +1763,32 @@ Return value is the fall-through block name." (_ (signal 'native-ice "missing previous setimm while creating a switch")))) +(defun comp--func-arity (subr-name) + "Like `func-arity' but invariant against primitive redefinitions. +SUBR-NAME is the name of function." + (or (gethash subr-name comp-subr-arities-h) + (func-arity subr-name))) + (defun comp-emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. SP-DELTA is the stack adjustment." - (let ((subr (symbol-function subr-name)) - (nargs (1+ (- sp-delta)))) - (let* ((arity (func-arity subr)) - (minarg (car arity)) - (maxarg (cdr arity))) - (when (eq maxarg 'unevalled) - (signal 'native-ice (list "subr contains unevalled args" subr-name))) - (if (eq maxarg 'many) - ;; callref case. - (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) - ;; Normal call. - (unless (and (>= maxarg nargs) (<= minarg nargs)) - (signal 'native-ice - (list "incoherent stack adjustment" nargs maxarg minarg))) - (let* ((subr-name subr-name) - (slots (cl-loop for i from 0 below maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) + (let* ((nargs (1+ (- sp-delta))) + (arity (comp--func-arity subr-name)) + (minarg (car arity)) + (maxarg (cdr arity))) + (when (eq maxarg 'unevalled) + (signal 'native-ice (list "subr contains unevalled args" subr-name))) + (if (eq maxarg 'many) + ;; callref case. + (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + ;; Normal call. + (unless (and (>= maxarg nargs) (<= minarg nargs)) + (signal 'native-ice + (list "incoherent stack adjustment" nargs maxarg minarg))) + (let* ((subr-name subr-name) + (slots (cl-loop for i from 0 below maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))) (eval-when-compile (defun comp-op-to-fun (x) diff --git a/lisp/loadup.el b/lisp/loadup.el index 46b26750cd5..1cc70348267 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -476,7 +476,13 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +(defvar comp-subr-arities-h) (when (featurep 'native-compile) + ;; Save the arity for all primitives so the compiler can always + ;; retrive it even in case of redefinition. + (mapatoms (lambda (f) + (when (subr-primitive-p (symbol-function f)) + (puthash f (func-arity f) comp-subr-arities-h)))) ;; Fix the compilation unit filename to have it working when ;; installed or if the source directory got moved. This is set to be ;; a pair in the form of: diff --git a/src/comp.c b/src/comp.c index 1fce108fea4..3f72d088a66 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5910,6 +5910,14 @@ For internal use. */); Vcomp_loaded_comp_units_h = CALLN (Fmake_hash_table, QCweakness, Qvalue, QCtest, Qequal); + DEFVAR_LISP ("comp-subr-arities-h", Vcomp_subr_arities_h, + doc: /* Hash table recording the arity of Lisp primitives. +This is in case they are redefined so the compiler still knows how to +compile calls to them. +subr-name -> arity +For internal use. */); + Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal); + Fprovide (intern_c_string ("native-compile"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 926ba27e563..c5e5b346adb 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -446,7 +446,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal comp-test-primitive-advice '(3 4)))) (advice-remove #'+ f)))) -(defvar comp-test-primitive-redefine-args) +(defvar comp-test-primitive-redefine-args nil) (comp-deftest primitive-redefine () "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) @@ -532,6 +532,22 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (subr-native-elisp-p (symbol-function 'comp-test-48029-nonascii-žžž-f)))) +(comp-deftest 61917-1 () + "Verify we can compile calls to redefined primitives with +dedicated byte-op code." + (let (x + (f (lambda (fn &rest args) + (setq comp-test-primitive-redefine-args args)))) + (advice-add #'delete-region :around f) + (unwind-protect + (setf x (native-compile + '(lambda () + (delete-region 1 2)))) + (should (subr-native-elisp-p x)) + (funcall x) + (advice-remove #'delete-region f) + (should (equal comp-test-primitive-redefine-args '(1 2)))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; |