[Emacs-diffs] master 68b374a: Correctly eliminate duplicate cases in switch compilation

[Mattias Engdegård]

branch: master
commit 68b374a62d8b7b98fd0b144ae83077d698e20bdb
Author: Mattias Engdegård <address@hidden>
Commit: Mattias Engdegård <address@hidden>

    Correctly eliminate duplicate cases in switch compilation
    
    Fix code mistakes that prevented the correct elimination of duplicated
    cases when compiling a `cond' form to a switch bytecode, as in
    
      (cond ((eq x 'a) 1)
            ((eq x 'b) 2)
            ((eq x 'a) 3)   ; should be elided
            ((eq x 'c) 4))
    
    Sometimes, this caused the bytecode to use the wrong branch (bug#35770).
    
    * lisp/emacs-lisp/bytecomp.el (byte-compile-cond-vars): Return obj2 eval'ed.
    (byte-compile-cond-jump-table-info):
    Discard redundant condition.  Use `obj2' as evaluated.
    Discard duplicated cases instead of failing the table generation.
    * test/lisp/emacs-lisp/bytecomp-tests.el (toplevel): Require subr-x.
    (byte-opt-testsuite-arith-data, bytecomp-test--switch-duplicates): Test.
---
 lisp/emacs-lisp/bytecomp.el            | 13 ++++----
 test/lisp/emacs-lisp/bytecomp-tests.el | 55 +++++++++++++++++++++++++++++++++-
 2 files changed, 60 insertions(+), 8 deletions(-)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index e76baf5..ce348ed 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4091,8 +4091,8 @@ that suppresses all warnings during execution of BODY."
   ;; and the other is a constant expression whose value can be
   ;; compared with `eq' (with `macroexp-const-p').
   (or
-   (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 obj2))
-   (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 obj1))))
+   (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2)))
+   (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 (eval obj1)))))
 
 (defconst byte-compile--default-val (cons nil nil) "A unique object.")
 
@@ -4121,12 +4121,11 @@ Return a list of the form ((TEST . VAR)  ((VALUE BODY) 
...))"
                (unless prev-test
                  (setq prev-test test))
                (if (and obj1 (memq test '(eq eql equal))
-                        (consp condition)
                         (eq test prev-test)
-                        (eq obj1 prev-var)
-                        ;; discard duplicate clauses
-                        (not (assq obj2 cases)))
-                   (push (list (if (consp obj2) (eval obj2) obj2) body) cases)
+                        (eq obj1 prev-var))
+                   ;; discard duplicate clauses
+                   (unless (assoc obj2 cases test)
+                     (push (list obj2 body) cases))
                  (if (and (macroexp-const-p condition) condition)
                     (progn (push (list byte-compile--default-val
                                        (or body `(,condition)))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el 
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 5fb64ff..ed10002 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -27,6 +27,7 @@
 
 (require 'ert)
 (require 'cl-lib)
+(require 'subr-x)
 (require 'bytecomp)
 
 ;;; Code:
@@ -296,7 +297,21 @@
        ((eq variable 'default)
        (message "equal"))
        (t
-       (message "not equal")))))
+       (message "not equal"))))
+    ;; Bug#35770
+    (let ((x 'a)) (cond ((eq x 'a) 'correct)
+                        ((eq x 'b) 'incorrect)
+                        ((eq x 'a) 'incorrect)
+                        ((eq x 'c) 'incorrect)))
+    (let ((x #x10000000000000000))
+      (cond ((eql x #x10000000000000000) 'correct)
+            ((eql x #x10000000000000001) 'incorrect)
+            ((eql x #x10000000000000000) 'incorrect)
+            ((eql x #x10000000000000002) 'incorrect)))
+    (let ((x "a")) (cond ((equal x "a") 'correct)
+                         ((equal x "b") 'incorrect)
+                         ((equal x "a") 'incorrect)
+                         ((equal x "c") 'incorrect))))
   "List of expression for test.
 Each element will be executed by interpreter and with
 bytecompiled code, and their results compared.")
@@ -613,6 +628,44 @@ literals (Bug#20852)."
       (if (buffer-live-p byte-compile-log-buffer)
           (kill-buffer byte-compile-log-buffer)))))
 
+(ert-deftest bytecomp-test--switch-duplicates ()
+  "Check that duplicates in switches are eliminated correctly (bug#35770)."
+  (dolist (params
+           '(((lambda (x)
+                (cond ((eq x 'a) 111)
+                      ((eq x 'b) 222)
+                      ((eq x 'a) 333)
+                      ((eq x 'c) 444)))
+              (a b c)
+              string<)
+             ((lambda (x)
+                (cond ((eql x #x10000000000000000) 111)
+                      ((eql x #x10000000000000001) 222)
+                      ((eql x #x10000000000000000) 333)
+                      ((eql x #x10000000000000002) 444)))
+              (#x10000000000000000 #x10000000000000001 #x10000000000000002)
+              <)
+             ((lambda (x)
+                (cond ((equal x "a") 111)
+                      ((equal x "b") 222)
+                      ((equal x "a") 333)
+                      ((equal x "c") 444)))
+              ("a" "b" "c")
+              string<)))
+    (let* ((lisp (nth 0 params))
+           (keys (nth 1 params))
+           (lessp (nth 2 params))
+           (bc (byte-compile lisp))
+           (lap (byte-decompile-bytecode (aref bc 1) (aref bc 2)))
+           ;; Assume the first constant is the switch table.
+           (table (cadr (assq 'byte-constant lap))))
+      (should (hash-table-p table))
+      (should (equal (sort (hash-table-keys table) lessp) keys))
+      (should (member '(byte-constant 111) lap))
+      (should (member '(byte-constant 222) lap))
+      (should-not (member '(byte-constant 333) lap))
+      (should (member '(byte-constant 444) lap)))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: