From c58ea90dfa61b99e1851311031528442fed96d22 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 9 Jul 2025 15:53:52 +0200 Subject: [PATCH] Nativecomp don't materialize non-materializable objects (bug#78606) The native compiler should not try to generate in rendered code immediate floats produced by the constrain on the '=' operator. * test/src/comp-tests.el (comp-test-78606-1): Add test. * test/src/comp-resources/comp-test-funcs.el (comp-test-78606-1-f): New function. * src/comp.c (emit_mvar_rval): Check if an immediate is materializable. * lisp/emacs-lisp/comp.el (comp-ctxt): Add 'non-materializable-objs-h' slot. (comp--fwprop-insn): Update call. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): Add parameter. (cherry picked from commit 48a5917681dd53b8b75764f4e1455a6c24f95498) --- lisp/emacs-lisp/comp-cstr.el | 13 +++++-- lisp/emacs-lisp/comp.el | 6 ++- src/comp.c | 43 ++++++++++++---------- test/src/comp-resources/comp-test-funcs.el | 6 +++ test/src/comp-tests.el | 5 +++ 5 files changed, 49 insertions(+), 24 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index fad54d4cd46..ac9e8eb2ace 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -985,8 +985,10 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (and (comp-cstr-cl-tag-p cstr) (intern (match-string 1 (symbol-name (car (valset cstr)))))))) -(defun comp-cstr-= (dst op1 op2) - "Constraint OP1 being = OP2 setting the result into DST." +(defun comp-cstr-= (dst op1 op2 nm-objs-h) + "Constraint OP1 being = OP2 setting the result into DST. +NM-OBJS-H is an hash with all the immediates generated at compile time +which should not be rendered into compiled code." (with-comp-cstr-accessors (cl-flet ((relax-cstr (cstr) (setf cstr (copy-sequence cstr)) @@ -1014,8 +1016,11 @@ Non memoized version of `comp-cstr-intersection-no-mem'." else do (cl-pushnew 'float (typeset cstr)) (cl-return cstr) - finally (setf (valset cstr) - (append vals-to-add (valset cstr)))) + finally + (mapc (lambda (x) (puthash x t nm-objs-h)) + vals-to-add) + (setf (valset cstr) + (append vals-to-add (valset cstr)))) (when (memql 0.0 (valset cstr)) (cl-pushnew -0.0 (valset cstr))) (when (memql -0.0 (valset cstr)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9e3962ecd9d..aa6bfbf0e6a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -398,6 +398,9 @@ Needed to replace immediate byte-compiled lambdas with the compiled reference.") :documentation "Standard data relocated in use by functions.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") + (non-materializable-objs-h (make-hash-table :test #'equal) :type hash-table + :documentation "Objects produced by the propagation engine which can't be materialized. +Typically floating points (which are not cons-hashed).") (with-late-load nil :type boolean :documentation "When non-nil support late load.")) @@ -2730,7 +2733,8 @@ Fold the call in case." (<= (comp-cstr-<= lval (car operands) (cadr operands))) (= - (comp-cstr-= lval (car operands) (cadr operands))))) + (comp-cstr-= lval (car operands) (cadr operands) + (comp-ctxt-non-materializable-objs-h comp-ctxt))))) (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)) (`(phi ,lval . ,rest) diff --git a/src/comp.c b/src/comp.c index a2b6a959c2a..bd5e637afe3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1972,27 +1972,32 @@ emit_mvar_rval (Lisp_Object mvar) if (!NILP (const_vld)) { Lisp_Object value = CALLNI (comp-cstr-imm, mvar); - if (comp.debug > 1) + if (NILP (Fgethash (value, + CALLNI (comp-ctxt-non-materializable-objs-h, Vcomp_ctxt), + Qnil))) { - Lisp_Object func = - Fgethash (value, - CALLNI (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), - Qnil); - - emit_comment ( - SSDATA ( - Fprin1_to_string ( - NILP (func) ? value : CALLNI (comp-func-c-name, func), - Qnil, Qnil))); - } - if (FIXNUMP (value)) - { - /* We can still emit directly objects that are self-contained in a - word (read fixnums). */ - return emit_rvalue_from_lisp_obj (value); + if (comp.debug > 1) + { + Lisp_Object func = + Fgethash (value, + CALLNI (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), + Qnil); + + emit_comment ( + SSDATA ( + Fprin1_to_string ( + NILP (func) ? value : CALLNI (comp-func-c-name, func), + Qnil, Qnil))); + } + if (FIXNUMP (value)) + { + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ + return emit_rvalue_from_lisp_obj (value); + } + /* Other const objects are fetched from the reloc array. */ + return emit_lisp_obj_rval (value); } - /* Other const objects are fetched from the reloc array. */ - return emit_lisp_obj_rval (value); } return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el index 837ef018efb..5154b875499 100644 --- a/test/src/comp-resources/comp-test-funcs.el +++ b/test/src/comp-resources/comp-test-funcs.el @@ -582,6 +582,12 @@ (defun comp-test-76573-1-f () (record 'undeclared-type)) +(defun comp-test-78606-1-f (x) + (and (= x 1) + (if (eql x 1) + 1 + x))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6b608d73540..879fda6f9c1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -596,6 +596,11 @@ dedicated byte-op code." "" (should (eq (comp-test-73270-1-f (make-comp-test-73270-child4)) 'child4))) +(comp-deftest comp-test-78606-1 () + "" + (should (let ((x 1.0)) + (eq (comp-test-78606-1-f x) x)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; -- 2.39.5