3 files changed, 166 insertions, 38 deletions

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 13f885448ae..9412ce3b26d 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -185,6 +185,7 @@
 (require 'bytecomp)
 (eval-when-compile (require 'cl-lib))
 (require 'macroexp)
+(require 'subr-x)
 
 (defun byte-compile-log-lap-1 (format &rest args)
   ;; Newer byte codes for stack-ref make the slot 0 non-nil again.
@@ -1728,7 +1729,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
               ;; unused-TAG: --> <deleted>
               ;;
               ((and (eq 'TAG (car lap0))
-                    (not (rassq lap0 lap)))
+                    (not (rassq lap0 lap))
+                    (= (length (cl-loop for table in byte-compile-jump-tables
+                                        when (member lap0 (hash-table-values table))
+                                        collect t))
+                       0))
                (and (memq byte-optimize-log '(t byte))
                     (byte-compile-log "  unused tag %d removed" (nth 1 lap0)))
                (setq lap (delq lap0 lap)
@@ -1736,9 +1741,12 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
               ;;
               ;; goto   ... --> goto   <delete until TAG or end>
               ;; return ... --> return <delete until TAG or end>
-              ;;
+              ;; (unless a jump-table is being used, where deleting may affect
+              ;; other valid case bodies)
+              ;;
               ((and (memq (car lap0) '(byte-goto byte-return))
-                    (not (memq (car lap1) '(TAG nil))))
+                    (not (memq (car lap1) '(TAG nil)))
+                    (not byte-compile-jump-tables))
                (setq tmp rest)
                (let ((i 0)
                      (opt-p (memq byte-optimize-log '(t lap)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 63be7e208b3..fe91fecd355 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -223,6 +223,11 @@ This includes variable references and calls to functions such as `car'."
   :group 'bytecomp
   :type 'boolean)
 
+(defcustom byte-compile-cond-use-jump-table t
+  "Compile `cond' clauses to a jump table implementation (using a hash-table)."
+  :group 'bytecomp
+  :type 'boolean)
+
 (defvar byte-compile-dynamic nil
   "If non-nil, compile function bodies so they load lazily.
 They are hidden in comments in the compiled file,
@@ -412,6 +417,8 @@ specify different fields to sort on."
                  (const calls+callers) (const nil)))
 
 (defvar byte-compile-debug nil)
+(defvar byte-compile-jump-tables nil
+  "List of all jump tables used during compilation of this form.")
 (defvar byte-compile-constants nil
   "List of all constants encountered during compilation of this form.")
 (defvar byte-compile-variables nil
@@ -747,6 +754,8 @@ otherwise pop it")
 ;; `byte-compile-lapcode').
 (defconst byte-discardN-preserve-tos byte-discardN)
 
+(byte-defop 183 -2 byte-switch)
+
 ;; unused: 182-191
 
 (byte-defop 192  1 byte-constant        "for reference to a constant")
@@ -823,7 +832,7 @@ CONST2 may be evaluated multiple times."
         op off                  ; Operation & offset
         opcode                  ; numeric value of OP
         (bytes '())             ; Put the output bytes here
-        (patchlist nil))        ; List of gotos to patch
+        (patchlist nil))        ; List of gotos to patch
     (dolist (lap-entry lap)
       (setq op (car lap-entry)
             off (cdr lap-entry))
@@ -905,6 +914,11 @@ CONST2 may be evaluated multiple times."
       ;; FIXME: Replace this by some workaround.
       (if (> (car bytes-tail) 255) (error "Bytecode overflow")))
 
+    (dolist (hash-table byte-compile-jump-tables)
+      (cl-loop for k being the hash-keys of hash-table do
+               (let ((tag (cdr (gethash k hash-table))))
+                 (setq pc (car tag))
+                 (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table))))
     (apply 'unibyte-string (nreverse bytes))))
 
 
@@ -1954,7 +1968,8 @@ With argument ARG, insert value in current buffer after the form."
 ;;      (edebug-all-defs nil)
 ;;      (edebug-all-forms nil)
         ;; Simulate entry to byte-compile-top-level
-        (byte-compile-constants nil)
+        (byte-compile-jump-tables nil)
+        (byte-compile-constants nil)
         (byte-compile-variables nil)
         (byte-compile-tag-number 0)
         (byte-compile-depth 0)
@@ -2250,7 +2265,8 @@ list that represents a doc string reference.
               byte-compile-variables nil
               byte-compile-depth 0
               byte-compile-maxdepth 0
-              byte-compile-output nil))))
+              byte-compile-output nil
+              byte-compile-jump-tables nil))))
 
 (defvar byte-compile-force-lexical-warnings nil)
 
@@ -2862,7 +2878,8 @@ for symbols generated by the byte compiler itself."
         (byte-compile-maxdepth 0)
         (byte-compile--lexical-environment lexenv)
         (byte-compile-reserved-constants (or reserved-csts 0))
-        (byte-compile-output nil))
+        (byte-compile-output nil)
+        (byte-compile-jump-tables nil))
     (if (memq byte-optimize '(t source))
         (setq form (byte-optimize-form form byte-compile--for-effect)))
     (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
@@ -3951,37 +3968,124 @@ that suppresses all warnings during execution of BODY."
         (byte-compile-out-tag donetag))))
   (setq byte-compile--for-effect nil))
 
+(defun byte-compile-cond-valid-obj2-p (obj)
+  (cond
+   ((symbolp obj) (keywordp obj))
+   ((consp obj) (eq (car obj) 'quote))
+   (t t)))
+
+(defun byte-compile-cond-vars (obj1 obj2)
+  (or
+   (and (symbolp obj1) (byte-compile-cond-valid-obj2-p obj2) (cons obj1 obj2))
+   (and (symbolp obj2) (byte-compile-cond-valid-obj2-p obj1) (cons obj2 obj1))))
+
+(defun byte-compile-cond-jump-table-info (clauses)
+  (let ((cases '())
+        (ok t)
+        prev-var prev-test)
+    (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))
+               (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))
+                   (push (list obj2 body) cases)
+                 (if (eq condition t)
+                     (progn (push (list 'default body) cases)
+                            (throw 'break t))
+                   (setq ok nil)
+                   (throw 'break nil))))))
+         (list (cons prev-test prev-var) (nreverse cases)))))
+
+(defun byte-compile-jump-table-add-tag (value tag jump-table)
+  (setcdr (cdr tag) byte-compile-depth)
+  (puthash value tag jump-table))
+
+(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-obj body tag donetag finaltag finalcase)
+    (when (and cases (not (= (length cases) 1)))
+      (setq jump-table (make-hash-table :test test :size (length cases))
+            donetag (byte-compile-make-tag))
+      (byte-compile-variable-ref var)
+      (byte-compile-push-constant jump-table)
+      (byte-compile-out 'byte-switch)
+
+      (when (assq 'default cases)
+        (setq finalcase (cadr (assq 'default cases))
+              finaltag (byte-compile-make-tag))
+        (setq cases (butlast cases 1))
+        (let ((byte-compile-depth byte-compile-depth))
+          (byte-compile-goto 'byte-goto finaltag)))
+
+      (dolist (case cases)
+        (setq tag (byte-compile-make-tag)
+              test-obj (nth 0 case)
+              body (nth 1 case))
+        (byte-compile-out-tag tag)
+        (byte-compile-jump-table-add-tag test-obj tag jump-table)
+
+        (let ((byte-compile-depth byte-compile-depth))
+          (byte-compile-maybe-guarded `(,test ,var ,test-obj)
+            (byte-compile-body body byte-compile--for-effect))
+          (byte-compile-goto 'byte-goto donetag))
+        (setcdr (cdr donetag) nil))
+
+      (if finalcase
+          (progn (byte-compile-out-tag finaltag)
+                 (byte-compile-body-do-effect finalcase))
+        (byte-compile-push-constant nil))
+      (byte-compile-out-tag donetag)
+      (push jump-table byte-compile-jump-tables))))
+
 (defun byte-compile-cond (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)))
+  (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))
+               ;; (message "out %s" donetag)
+               (if (null (cdr clause))
+                   ;; First clause is a singleton.
+                   (byte-compile-goto-if t byte-compile--for-effect donetag)
+                 ;; (message "inside %s" 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))))
 
 (defun byte-compile-and (form)
   (let ((failtag (byte-compile-make-tag))
@@ -4528,7 +4632,7 @@ binding slots have been popped."
         (and byte-compile-depth
              (not (= (cdr (cdr tag)) byte-compile-depth))
              (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
-        (setq byte-compile-depth (cdr (cdr tag))))
+         (setq byte-compile-depth (cdr (cdr tag))))
     (setcdr (cdr tag) byte-compile-depth)))
 
 (defun byte-compile-goto (opcode tag)
diff --git a/src/bytecode.c b/src/bytecode.c
index a64bc171d14..1695af9cb02 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -267,6 +267,8 @@ DEFINE (Bstack_set,  0262)						\
 DEFINE (Bstack_set2, 0263)                                              \
 DEFINE (BdiscardN,   0266)                                              \
                                                                         \
+DEFINE (Bswitch, 0267)                                                  \
+                                                                        \
 DEFINE (Bconstant, 0300)
 
 enum byte_code_op
@@ -1411,6 +1413,20 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
           DISCARD (op);
           NEXT;
 
+        CASE (Bswitch):
+          {
+            Lisp_Object jmp_table = POP;
+            Lisp_Object v1 = POP;
+            Lisp_Object dest = Fgethash(v1, jmp_table, Qnil);
+            if (!NILP(dest)) {
+              int car = XINT(XCAR(dest));
+              int cdr = XINT(XCDR(dest));
+              op = car + (cdr << 8); /* Simulate FETCH2 */
+              goto op_branch;
+            }
+          }
+          NEXT;
+
         CASE_DEFAULT
         CASE (Bconstant):
           if (BYTE_CODE_SAFE