From d3a7f3e6cd0124e62ed2b5ffc87eee57fee39a9a Mon Sep 17 00:00:00 2001
From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Fri, 7 Jun 2019 17:04:10 +0200
Subject: [PATCH] Compile any subsequence of `cond' clauses to switch
 (bug#36139)

A single `cond' form can how be compiled to any number of switch ops,
optionally interspersed with non-switch conditions.
Previously, switch ops would only be used for whole `cond' forms
containing no other tests.

* lisp/emacs-lisp/bytecomp.el (byte-compile--cond-vars):
Rename from `byte-compile-cond-vars'.
(byte-compile--default-val): Remove.
(byte-compile--cond-switch-prefix):
Replace `byte-compile-cond-jump-table-info'; now also returns
trailing non-switch clauses.
(byte-compile-cond-jump-table): New arguments; no longer compiles
the default case.
(byte-compile-cond): Look for and compile switches at any place in the
list of clauses.
* test/lisp/emacs-lisp/bytecomp-tests.el (byte-opt-testsuite-arith-data):
Add test expression.
---
 lisp/emacs-lisp/bytecomp.el            | 342 ++++++++++++-------------
 test/lisp/emacs-lisp/bytecomp-tests.el |  15 +-
 2 files changed, 176 insertions(+), 181 deletions(-)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 3a23543f6a7..c01c74a4569 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4122,7 +4122,7 @@ that suppresses all warnings during execution of BODY."
 	(byte-compile-out-tag donetag))))
   (setq byte-compile--for-effect nil))
 
-(defun byte-compile-cond-vars (obj1 obj2)
+(defun byte-compile--cond-vars (obj1 obj2)
   ;; We make sure that of OBJ1 and OBJ2, one of them is a symbol,
   ;; and the other is a constant expression whose value can be
   ;; compared with `eq' (with `macroexp-const-p').
@@ -4130,193 +4130,175 @@ that suppresses all warnings during execution of BODY."
    (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.")
-
 (defun byte-compile--common-test (test-1 test-2)
   "Most specific common test of `eq', `eql' and `equal'"
   (cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal)
         ((or (eq test-1 'eql)   (eq test-2 'eql))   'eql)
         (t                                          'eq)))
 
-(defun byte-compile-cond-jump-table-info (clauses)
-  "If CLAUSES is a `cond' form where:
-The condition for each clause is of the form (TEST VAR VALUE).
-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)  ((VALUES BODY) ...))"
-  (let ((cases '())
-        (ok t)
-        (all-keys nil)
-        (prev-test 'eq)
-        prev-var)
-    (and (catch 'break
-           (dolist (clause (cdr clauses) ok)
-             (let* ((condition (car clause))
-                    (test (car-safe condition))
-                    (vars (when (consp condition)
-                            (byte-compile-cond-vars (cadr condition) (cl-caddr condition))))
-                    (obj1 (car-safe vars))
-                    (obj2 (cdr-safe vars))
-                    (body (cdr-safe clause)))
-               (unless prev-var
-                 (setq prev-var obj1))
-               (cond
-                ((and obj1 (memq test '(eq eql equal))
-                      (eq obj1 prev-var))
-                 (setq prev-test (byte-compile--common-test 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 prev-test
-                       (byte-compile--common-test
-                        prev-test (cdr (assq test '((memq   . eq)
-                                                    (memql  . eql)
-                                                    (member . equal))))))
-                 (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)))))
-
-(defun byte-compile-cond-jump-table (clauses)
-  (let* ((table-info (byte-compile-cond-jump-table-info clauses))
-         (test (caar table-info))
-         (var (cdar table-info))
-         (cases (cadr table-info))
-         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.
-      (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
-      ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2)))
-      ;; switch
-      ;; goto DEFAULT-TAG
-      ;; TAG1
-      ;; <clause body>
-      ;; goto DONETAG
-      ;; TAG2
-      ;; <clause body>
-      ;; goto DONETAG
-      ;; DEFAULT-TAG
-      ;; <body for `t' clause, if any (else `constant nil')>
-      ;; DONETAG
-
-      (byte-compile-variable-ref var)
-      (byte-compile-push-constant jump-table)
-      (byte-compile-out 'byte-switch)
-
-      ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
-      ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
-      ;; to be non-nil for generating tags for all cases. Since
-      ;; `byte-compile-depth' will increase by at most 1 after compiling
-      ;; all of the clause (which is further enforced by cl-assert below)
-      ;; it should be safe to preserve its value.
-      (let ((byte-compile-depth byte-compile-depth))
-        (byte-compile-goto 'byte-goto default-tag))
-
-      (let ((default-match (assq byte-compile--default-val cases)))
-        (when default-match
-	  (setq default-case (cadr default-match)
-                cases (butlast cases))))
-
-      (dolist (case cases)
-        (setq tag (byte-compile-make-tag)
-              test-objects (nth 0 case)
-              body (nth 1 case))
-        (byte-compile-out-tag tag)
-        (dolist (value test-objects)
-          (puthash value tag jump-table))
-
-        (let ((byte-compile-depth byte-compile-depth)
-              (init-depth byte-compile-depth))
-          ;; Since `byte-compile-body' might increase `byte-compile-depth'
-          ;; by 1, not preserving its value will cause it to potentially
-          ;; increase by one for every clause body compiled, causing
-          ;; depth/tag conflicts or violating asserts down the road.
-          ;; To make sure `byte-compile-body' itself doesn't violate this,
-          ;; we use `cl-assert'.
-          (if (null body)
-              (byte-compile-form t byte-compile--for-effect)
-            (byte-compile-body body byte-compile--for-effect))
-          (cl-assert (or (= byte-compile-depth init-depth)
-                         (= byte-compile-depth (1+ init-depth))))
-          (byte-compile-goto 'byte-goto donetag)
-          (setcdr (cdr donetag) nil)))
-
-      (byte-compile-out-tag default-tag)
-      (if default-case
-          (byte-compile-body-do-effect default-case)
-        (byte-compile-constant nil))
-      (byte-compile-out-tag donetag)
-      (push jump-table byte-compile-jump-tables))))
+(defun byte-compile--cond-switch-prefix (clauses)
+  "Find a switch corresponding to a prefix of CLAUSES, or nil if none.
+Return (TAIL VAR TEST CASES), where:
+  TAIL is the remaining part of CLAUSES after the switch, including
+  any default clause,
+  VAR is the variable being switched on,
+  TEST is the equality test (`eq', `eql' or `equal'),
+  CASES is a list of (VALUES . BODY) where VALUES is a list of values
+    corresponding to BODY (always non-empty)."
+  (let ((cases nil)                 ; Reversed list of (VALUES BODY).
+        (keys nil)                  ; Switch keys seen so far.
+        (switch-var nil)
+        (switch-test 'eq))
+    (while (pcase (car clauses)
+             (`((,fn ,expr1 ,expr2) . ,body)
+              (let* ((vars (byte-compile--cond-vars expr1 expr2))
+                     (var (car vars))
+                     (value (cdr vars)))
+                (and var (or (eq var switch-var) (not switch-var))
+                     (cond
+                      ((memq fn '(eq eql equal))
+                       (setq switch-var var)
+                       (setq switch-test
+                             (byte-compile--common-test switch-test fn))
+                       (unless (member value keys)
+                         (push value keys)
+                         (push (cons (list value) (or body '(t))) cases))
+                       t)
+                      ((and (memq fn '(memq memql member))
+                            (listp value)
+                            ;; Require a non-empty body, since the member
+                            ;; function value depends on the switch
+                            ;; argument.
+                            body)
+                       (setq switch-var var)
+                       (setq switch-test
+                             (byte-compile--common-test
+                              switch-test (cdr (assq fn '((memq   . eq)
+                                                          (memql  . eql)
+                                                          (member . equal))))))
+                       (let ((vals nil))
+                         (dolist (elem value)
+                           (unless (funcall fn elem keys)
+                             (push elem vals)))
+                         (when vals
+                           (setq keys (append vals keys))
+                           (push (cons (nreverse vals) body) cases)))
+                       t))))))
+      (setq clauses (cdr clauses)))
+    ;; Assume that a single switch is cheaper than two or more discrete
+    ;; compare clauses.  This could be tuned, possibly taking into
+    ;; account the total number of values involved.
+    (and (> (length cases) 1)
+         (list clauses switch-var switch-test (nreverse cases)))))
+
+(defun byte-compile-cond-jump-table (switch donetag)
+  "Generate code for SWITCH, ending at DONETAG."
+  (let* ((var (car switch))
+         (test (nth 1 switch))
+         (cases (nth 2 switch))
+         jump-table test-objects body tag default-tag)
+    ;; TODO: Once :linear-search is implemented for `make-hash-table'
+    ;; set it to `t' for cond forms with a small number of cases.
+    (let ((nvalues (apply #'+ (mapcar (lambda (case) (length (car case)))
+                                      cases))))
+      (setq jump-table (make-hash-table
+			:test test
+			:purecopy t
+			:size nvalues)))
+    (setq default-tag (byte-compile-make-tag))
+    ;; The structure of byte-switch code:
+    ;;
+    ;; varref var
+    ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2)))
+    ;; switch
+    ;; goto DEFAULT-TAG
+    ;; TAG1
+    ;; <clause body>
+    ;; goto DONETAG
+    ;; TAG2
+    ;; <clause body>
+    ;; goto DONETAG
+    ;; DEFAULT-TAG
+    ;; <body for remaining (non-switch) clauses>
+    ;; DONETAG
+
+    (byte-compile-variable-ref var)
+    (byte-compile-push-constant jump-table)
+    (byte-compile-out 'byte-switch)
+
+    ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
+    ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
+    ;; to be non-nil for generating tags for all cases. Since
+    ;; `byte-compile-depth' will increase by at most 1 after compiling
+    ;; all of the clause (which is further enforced by cl-assert below)
+    ;; it should be safe to preserve its value.
+    (let ((byte-compile-depth byte-compile-depth))
+      (byte-compile-goto 'byte-goto default-tag))
+
+    (dolist (case cases)
+      (setq tag (byte-compile-make-tag)
+            test-objects (car case)
+            body (cdr case))
+      (byte-compile-out-tag tag)
+      (dolist (value test-objects)
+        (puthash value tag jump-table))
+
+      (let ((byte-compile-depth byte-compile-depth)
+            (init-depth byte-compile-depth))
+        ;; Since `byte-compile-body' might increase `byte-compile-depth'
+        ;; by 1, not preserving its value will cause it to potentially
+        ;; increase by one for every clause body compiled, causing
+        ;; depth/tag conflicts or violating asserts down the road.
+        ;; To make sure `byte-compile-body' itself doesn't violate this,
+        ;; we use `cl-assert'.
+        (byte-compile-body body byte-compile--for-effect)
+        (cl-assert (or (= byte-compile-depth init-depth)
+                       (= byte-compile-depth (1+ init-depth))))
+        (byte-compile-goto 'byte-goto donetag)
+        (setcdr (cdr donetag) nil)))
+
+    (byte-compile-out-tag default-tag)
+    (push jump-table byte-compile-jump-tables)))
 
 (defun byte-compile-cond (clauses)
-  (or (and byte-compile-cond-use-jump-table
-           (byte-compile-cond-jump-table clauses))
-    (let ((donetag (byte-compile-make-tag))
-          nexttag clause)
-      (while (setq clauses (cdr clauses))
-        (setq clause (car clauses))
-        (cond ((or (eq (car clause) t)
-                   (and (eq (car-safe (car clause)) 'quote)
-                        (car-safe (cdr-safe (car clause)))))
-               ;; Unconditional clause
-               (setq clause (cons t clause)
-                     clauses nil))
-              ((cdr clauses)
-               (byte-compile-form (car clause))
-               (if (null (cdr clause))
-                   ;; First clause is a singleton.
-                   (byte-compile-goto-if t byte-compile--for-effect donetag)
-                 (setq nexttag (byte-compile-make-tag))
-                 (byte-compile-goto 'byte-goto-if-nil nexttag)
-                 (byte-compile-maybe-guarded (car clause)
-                   (byte-compile-body (cdr clause) byte-compile--for-effect))
-                 (byte-compile-goto 'byte-goto donetag)
-                 (byte-compile-out-tag nexttag)))))
-      ;; Last clause
-      (let ((guard (car clause)))
-        (and (cdr clause) (not (eq guard t))
-             (progn (byte-compile-form guard)
-                    (byte-compile-goto-if nil byte-compile--for-effect donetag)
-                    (setq clause (cdr clause))))
-        (byte-compile-maybe-guarded guard
-          (byte-compile-body-do-effect clause)))
-      (byte-compile-out-tag donetag))))
+  (let ((donetag (byte-compile-make-tag))
+        nexttag clause)
+    (setq clauses (cdr clauses))
+    (while clauses
+      (let ((switch-prefix (and byte-compile-cond-use-jump-table
+                                (byte-compile--cond-switch-prefix clauses))))
+        (if switch-prefix
+            (progn
+              (byte-compile-cond-jump-table (cdr switch-prefix) donetag)
+              (setq clauses (car switch-prefix)))
+          (setq clause (car clauses))
+          (cond ((or (eq (car clause) t)
+                     (and (eq (car-safe (car clause)) 'quote)
+                          (car-safe (cdr-safe (car clause)))))
+                 ;; Unconditional clause
+                 (setq clause (cons t clause)
+                       clauses nil))
+                ((cdr clauses)
+                 (byte-compile-form (car clause))
+                 (if (null (cdr clause))
+                     ;; First clause is a singleton.
+                     (byte-compile-goto-if t byte-compile--for-effect donetag)
+                   (setq nexttag (byte-compile-make-tag))
+                   (byte-compile-goto 'byte-goto-if-nil nexttag)
+                   (byte-compile-maybe-guarded (car clause)
+                     (byte-compile-body (cdr clause) byte-compile--for-effect))
+                   (byte-compile-goto 'byte-goto donetag)
+                   (byte-compile-out-tag nexttag))))
+          (setq clauses (cdr clauses)))))
+    ;; Last clause
+    (let ((guard (car clause)))
+      (and (cdr clause) (not (eq guard t))
+           (progn (byte-compile-form guard)
+                  (byte-compile-goto-if nil byte-compile--for-effect donetag)
+                  (setq clause (cdr clause))))
+      (byte-compile-maybe-guarded guard
+        (byte-compile-body-do-effect clause)))
+    (byte-compile-out-tag donetag)))
 
 (defun byte-compile-and (form)
   (let ((failtag (byte-compile-make-tag))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 0f18a34578d..5bd36898702 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -334,7 +334,20 @@
                               ((memql x '(9 0.5 1.5 q)) 66)
                               (t 99)))
             '(a b c d (d) (a . b) "X" 0.5 1.5 3.14 9 9.0))
-    )
+    ;; Multi-switch cond form
+    (mapcar (lambda (p) (let ((x (car p)) (y (cadr p)))
+                          (cond ((consp x) 11)
+                                ((eq x 'a) 22)
+                                ((memql x '(b 7 a -3)) 33)
+                                ((equal y "a") 44)
+                                ((memq y '(c d e)) 55)
+                                ((booleanp x) 66)
+                                ((eq x 'q) 77)
+                                ((memq x '(r s)) 88)
+                                ((eq x 't) 99)
+                                (t 999))))
+            '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c)
+              (t c) (x "a") (x "c") (x c) (x d) (x e))))
   "List of expression for test.
 Each element will be executed by interpreter and with
 bytecompiled code, and their results compared.")
-- 
2.39.2