From 8e3a4317488940adfd58a43e2f66acafba2ea11f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sun, 26 May 2019 14:04:22 +0200
Subject: [PATCH 2/5] Share identical switch clause bodies

* lisp/emacs-lisp/bytecomp.el (byte-compile-cond-jump-table-info)
(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.
---
 lisp/emacs-lisp/byte-opt.el | 21 +++++++--------
 lisp/emacs-lisp/bytecomp.el | 51 ++++++++++++++++++++++---------------
 2 files changed, 42 insertions(+), 30 deletions(-)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 44cca6136c..b0aa407c8b 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1376,11 +1376,15 @@ byte-decompile-bytecode-1
                         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 @@ byte-optimize-lapcode
 		     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 8f089119de..5930386166 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4105,9 +4105,10 @@ byte-compile-cond-jump-table-info
 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)
@@ -4126,23 +4127,30 @@ byte-compile-cond-jump-table-info
                       (eq obj1 prev-var)
                       (or (not prev-test) (eq test prev-test)))
                  (setq prev-test test)
-                 ;; discard duplicate clauses
-                 (unless (assoc obj2 cases test)
-                   (push (list obj2 body) cases)))
+                 ;; 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)
-                 ;; Expand to individual equality tests.
-                 (dolist (elem obj2)
-                   (unless (assoc elem cases equality)
-                     (push (list elem (or body `(',(funcall test elem obj2))))
-                           cases))))
+                 (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
@@ -4158,18 +4166,20 @@ byte-compile-cond-jump-table
          (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
@@ -4206,10 +4216,11 @@ byte-compile-cond-jump-table
 
       (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))
-- 
2.20.1 (Apple Git-117)

