From: Mattias Engdegård Date: Tue, 21 May 2019 09:56:14 +0000 (+0200) Subject: Compile list member functions in cond to switch (bug#36139) X-Git-Tag: emacs-27.0.90~2409 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=36ab408207d7adf94fd1396922e0df38d746a948;p=emacs.git 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. --- diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 44cca6136c0..b0aa407c8b4 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: --> ;; diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9e3e603c043..ab04c1bf439 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))