Compile list member functions in cond to switch (bug#36139)

* lisp/emacs-lisp/bytecomp.el (byte-compile-cond-jump-table-info):
Expand `memq', `memql' and `member' to their corresponding
equality tests.
(byte-compile-cond-jump-table): Cases now have multiple values.
* lisp/emacs-lisp/byte-opt.el (byte-decompile-bytecode-1)
(byte-optimize-lapcode): Don't assume switch hash tables to be injective.

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 44cca6136c0f32c503b18b914615d63494c0d6b1..b0aa407c8b4983882fbf042a899cd48d4f935e1d 100644 (file)
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1376,11 +1376,15 @@
                         do (setq last-constant (copy-hash-table e))
                         and return nil)
                ;; Replace all addresses with TAGs.
-               (maphash #'(lambda (value tag)
-                            (let (newtag)
-                              (setq newtag (byte-compile-make-tag))
-                              (push (cons tag newtag) tags)
-                              (puthash value newtag last-constant)))
+               (maphash #'(lambda (value offset)
+                            (let ((match (assq offset tags)))
+                              (puthash value
+                                       (if match
+                                           (cdr match)
+                                         (let ((tag (byte-compile-make-tag)))
+                                           (push (cons offset tag) tags)
+                                           tag))
+                                       last-constant)))
                         last-constant)
                ;; Replace the hash table referenced in the lapcode with our
                ;; modified one.
@@ -1722,13 +1726,10 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
                     keep-going t)
                ;; replace references to tag in jump tables, if any
                (dolist (table byte-compile-jump-tables)
-                 (catch 'break
                    (maphash #'(lambda (value tag)
                                 (when (equal tag lap0)
-                                  ;; each tag occurs only once in the jump table
-                                  (puthash value lap1 table)
-                                  (throw 'break nil)))
-                            table))))
+                                  (puthash value lap1 table)))
+                            table)))
              ;;
              ;; unused-TAG: --> <deleted>
              ;;

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 9e3e603c043b32c02bba6d8f05ae7e945972c991..ab04c1bf4399b13bf66eb9c6913f745b73734cde 100644 (file)
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4139,9 +4139,10 @@ VAR is a variable.
 TEST and VAR are the same throughout all conditions.
 VALUE satisfies `macroexp-const-p'.
 
-Return a list of the form ((TEST . VAR)  ((VALUE BODY) ...))"
+Return a list of the form ((TEST . VAR)  ((VALUES BODY) ...))"
   (let ((cases '())
         (ok t)
+        (all-keys nil)
         prev-var prev-test)
     (and (catch 'break
            (dolist (clause (cdr clauses) ok)
@@ -4151,23 +4152,46 @@ Return a list of the form ((TEST . VAR)  ((VALUE BODY) ...))"
                             (byte-compile-cond-vars (cadr condition) (cl-caddr condition))))
                     (obj1 (car-safe vars))
                     (obj2 (cdr-safe vars))
-                    (body (cdr-safe clause)))
+                    (body (cdr-safe clause))
+                    equality)
                (unless prev-var
                  (setq prev-var obj1))
-               (unless prev-test
-                 (setq prev-test test))
-               (if (and obj1 (memq test '(eq eql equal))
-                        (eq test prev-test)
-                        (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)))
-                                 cases)
-                            (throw 'break t))
-                   (setq ok nil)
+               (cond
+                ((and obj1 (memq test '(eq eql equal))
+                      (eq obj1 prev-var)
+                      (or (not prev-test) (eq test prev-test)))
+                 (setq prev-test test)
+                 ;; Discard values already tested for.
+                 (unless (member obj2 all-keys)
+                   (push obj2 all-keys)
+                   (push (list (list obj2) body) cases)))
+
+                ((and obj1 (memq test '(memq memql member))
+                      (eq obj1 prev-var)
+                      (listp obj2)
+                      ;; Require a non-empty body, since the member function
+                      ;; value depends on the switch argument.
+                      body
+                      (setq equality (cdr (assq test '((memq   . eq)
+                                                       (memql  . eql)
+                                                       (member . equal)))))
+                      (or (not prev-test) (eq equality prev-test)))
+                 (setq prev-test equality)
+                 (let ((vals nil))
+                   ;; Discard values already tested for.
+                   (dolist (elem obj2)
+                     (unless (funcall test elem all-keys)
+                       (push elem vals)))
+                   (when vals
+                     (setq all-keys (append vals all-keys))
+                     (push (list vals body) cases))))
+
+                ((and (macroexp-const-p condition) condition)
+                (push (list byte-compile--default-val
+                             (or body `(,condition)))
+                      cases)
+                 (throw 'break t))
+                (t (setq ok nil)
                    (throw 'break nil))))))
          (list (cons prev-test prev-var) (nreverse cases)))))
 
@@ -4176,18 +4200,20 @@ Return a list of the form ((TEST . VAR)  ((VALUE BODY) ...))"
          (test (caar table-info))
          (var (cdar table-info))
          (cases (cadr table-info))
-         jump-table test-obj body tag donetag default-tag default-case)
+         jump-table test-objects body tag donetag default-tag default-case)
     (when (and cases (not (= (length cases) 1)))
       ;; TODO: Once :linear-search is implemented for `make-hash-table'
       ;; set it to `t' for cond forms with a small number of cases.
-      (setq jump-table (make-hash-table
-                       :test test
-                       :purecopy t
-                       :size (if (assq byte-compile--default-val cases)
-                                 (1- (length cases))
-                               (length cases)))
-            default-tag (byte-compile-make-tag)
-            donetag (byte-compile-make-tag))
+      (let ((nvalues (apply #'+ (mapcar (lambda (case) (length (car case)))
+                                        cases))))
+        (setq jump-table (make-hash-table
+                         :test test
+                         :purecopy t
+                         :size (if (assq byte-compile--default-val cases)
+                                   (1- nvalues)
+                                 nvalues))))
+      (setq default-tag (byte-compile-make-tag))
+      (setq donetag (byte-compile-make-tag))
       ;; The structure of byte-switch code:
       ;;
       ;; varref var
@@ -4224,10 +4250,11 @@ Return a list of the form ((TEST . VAR)  ((VALUE BODY) ...))"
 
       (dolist (case cases)
         (setq tag (byte-compile-make-tag)
-              test-obj (nth 0 case)
+              test-objects (nth 0 case)
               body (nth 1 case))
         (byte-compile-out-tag tag)
-        (puthash test-obj tag jump-table)
+        (dolist (value test-objects)
+          (puthash value tag jump-table))
 
         (let ((byte-compile-depth byte-compile-depth)
               (init-depth byte-compile-depth))