[Emacs-diffs] feature/byte-switch 88549ec: Add new 'switch' byte-code.

[Vibhav Pant]

branch: feature/byte-switch
commit 88549ec38e9bb30e338a9985d0de4e6263b40fb7
Author: Vibhav Pant <address@hidden>
Commit: Vibhav Pant <address@hidden>

    Add new 'switch' byte-code.
    
    'switch' takes two arguments from the stack: the variable to test, and
    a jump table (implemented as a hash-table with the appropriate :test
    function). By looking up the value of the variable in the hash table,
    the interpreter can jump to the label pointed to by the value, if any.
    This implementation can only be used for `cond' forms of the type
    `(cond ((test x 'foo) 'bar) ...)`, such that the function `test` and
    variable `x` is same for all clauses.
    
    * lisp/emacs-lisp/bytecomp.el:
    
      * Add (byte-compile-cond-valid-obj2-p), (byte-compile-cond-vars),
        (byte-compile-cond-jump-table-info), (byte-compile-jump-table-add-tag),
        (byte-compile-cond-jump-table), byte-compile-jump-tables.
    
      * Add defcustom `byte-compile-cond-use-jump-table'.
    
      * (byte-compile-cond): Use them.
    
      * (byte-compile-lapcode): Patch tags present in jump tables, if any.
    
    * lisp/emacs-lisp//byte-opt.el: (byte-optimize-lapcode): Add checks to
      some peephole optimizations to prevent them from messing up any code
      involving `byte-switch`.
    
    * src/bytecode.c: (exec_byte_code): Add bytecode Bswitch.
---
 lisp/emacs-lisp/byte-opt.el |   14 +++-
 lisp/emacs-lisp/bytecomp.el |  174 ++++++++++++++++++++++++++++++++++---------
 src/bytecode.c              |   16 ++++
 3 files changed, 166 insertions(+), 38 deletions(-)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 13f8854..9412ce3 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 63be7e2..fe91fec 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 a64bc17..1695af9 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