From: Mattias Engdegård <mattiase@acm.org>
Date: Fri, 4 Aug 2023 09:08:57 +0000 (+0200)
Subject: Don't allow the `eq` and `unbind` byte-ops to commute (bug#65017)
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=44d7fd3805f5b1e0b571ece007abc466e1b39ba5;p=emacs.git

Don't allow the `eq` and `unbind` byte-ops to commute (bug#65017)

* lisp/emacs-lisp/byte-opt.el (byte-after-unwind-ops):
Cease sinking `eq` past `unwind`, because that optimised away the
let-binding in

  (let ((symbols-with-pos-enabled nil))
    (eq x y))

and `eq` is currently sensitive to `symbols-with-pos-enabled`.
* test/lisp/emacs-lisp/bytecomp-tests.el
(bytecomp--eq-symbols-with-pos-enabled): New test.
---

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index c7d8531a870..12c2bc51b92 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -2141,7 +2141,7 @@ See Info node `(elisp) Integer Basics'."
    '(byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard
      byte-discardN byte-discardN-preserve-tos
      byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
-     byte-eq byte-not
+     byte-not
      byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN
      byte-interactive-p)
    ;; How about other side-effect-free-ops?  Is it safe to move an
@@ -2149,6 +2149,11 @@ See Info node `(elisp) Integer Basics'."
    ;; No, it is not, because the unwind-protect forms can alter
    ;; the inside of the object to which nth would apply.
    ;; For the same reason, byte-equal was deleted from this list.
+   ;;
+   ;; In particular, `byte-eq' isn't here despite `eq' being nominally
+   ;; pure because it is currently affected by `symbols-with-pos-enabled'
+   ;; and so cannot be sunk past an unwind op that might end a binding of
+   ;; that variable.  Yes, this is unsatisfactory.
    "Byte-codes that can be moved past an unbind.")
 
 (defconst byte-compile-side-effect-and-error-free-ops
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 593fd117685..246ffff532f 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -2001,6 +2001,40 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
                                      (backtrace-frame-args frame))
                                call))))))))))
 
+(ert-deftest bytecomp--eq-symbols-with-pos-enabled ()
+  ;; Verify that we don't optimise away a binding of
+  ;; `symbols-with-pos-enabled' around an application of `eq' (bug#65017).
+  (let* ((sym-with-pos1 (read-positioning-symbols "sym"))
+         (sym-with-pos2 (read-positioning-symbols " sym"))  ; <- space!
+         (without-pos-eq (lambda (a b)
+                           (let ((symbols-with-pos-enabled nil))
+                             (eq a b))))
+         (without-pos-eq-compiled (byte-compile without-pos-eq))
+         (with-pos-eq (lambda (a b)
+                        (let ((symbols-with-pos-enabled t))
+                          (eq a b))))
+         (with-pos-eq-compiled (byte-compile with-pos-eq)))
+    (dolist (mode '(interpreted compiled))
+      (ert-info ((symbol-name mode) :prefix "mode: ")
+        (ert-info ("disabled" :prefix "symbol-pos: ")
+          (let ((eq-fn (pcase-exhaustive mode
+                         ('interpreted without-pos-eq)
+                         ('compiled    without-pos-eq-compiled))))
+            (should (equal (funcall eq-fn 'sym 'sym) t))
+            (should (equal (funcall eq-fn sym-with-pos1 'sym) nil))
+            (should (equal (funcall eq-fn 'sym sym-with-pos1) nil))
+            (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t))
+            (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) nil))))
+        (ert-info ("enabled" :prefix "symbol-pos: ")
+          (let ((eq-fn (pcase-exhaustive mode
+                         ('interpreted with-pos-eq)
+                         ('compiled    with-pos-eq-compiled))))
+            (should (equal (funcall eq-fn 'sym 'sym) t))
+            (should (equal (funcall eq-fn sym-with-pos1 'sym) t))
+            (should (equal (funcall eq-fn 'sym sym-with-pos1) t))
+            (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t))
+            (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) t))))))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: