[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 36ab408 1/4: Compile list member functions in cond
|
From: |
Mattias Engdegård |
|
Subject: |
[Emacs-diffs] master 36ab408 1/4: Compile list member functions in cond to switch (bug#36139) |
|
Date: |
Wed, 19 Jun 2019 05:24:50 -0400 (EDT) |
branch: master
commit 36ab408207d7adf94fd1396922e0df38d746a948
Author: Mattias Engdegård <address@hidden>
Commit: Mattias Engdegård <address@hidden>
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.
---
lisp/emacs-lisp/byte-opt.el | 21 ++++++------
lisp/emacs-lisp/bytecomp.el | 81 ++++++++++++++++++++++++++++++---------------
2 files changed, 65 insertions(+), 37 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 44cca61..b0aa407 100644
--- 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 9e3e603..ab04c1b 100644
--- 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))