From: Andrea Corallo <akrl@sdf.org>
Date: Wed, 29 Mar 2023 16:02:30 +0000 (+0200)
Subject: Comp fix calls to redefined primtives with op-bytecode (bug#61917)
X-Git-Tag: emacs-29.0.90~62
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ab4273056e0;p=emacs.git

Comp fix calls to redefined primtives with op-bytecode (bug#61917)

	* test/src/comp-tests.el (61917-1): New test.
	* src/comp.c (syms_of_comp): New variable.
	* lisp/loadup.el: Store primitive arities before dumping.
	* lisp/emacs-lisp/comp.el (comp--func-arity): New function.
	(comp-emit-set-call-subr): Make use of `comp--func-arity'.
---

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. ;;