Commit 68b374a6 authored by Mattias Engdegård's avatar Mattias Engdegård

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.
parent 457b0244
Pipeline #1813 failed with stage
in 51 minutes and 36 seconds
......@@ -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)))
......
......@@ -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:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment