* 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'.
(_ (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)
;; 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:
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 */
(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)
(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))))))
+
\f
;;;;;;;;;;;;;;;;;;;;;
;; Tromey's tests. ;;