mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-04 11:00:45 -08:00
Code Issues Projects Releases Wiki Activity

Compile any subsequence of `cond' clauses to switch (bug#36139)

Browse source 
A single `cond' form can how be compiled to any number of switch ops,
optionally interspersed with non-switch conditions.
Previously, switch ops would only be used for whole `cond' forms
containing no other tests.

* lisp/emacs-lisp/bytecomp.el (byte-compile--cond-vars):
Rename from `byte-compile-cond-vars'.
(byte-compile--default-val): Remove.
(byte-compile--cond-switch-prefix):
Replace `byte-compile-cond-jump-table-info'; now also returns
trailing non-switch clauses.
(byte-compile-cond-jump-table): New arguments; no longer compiles
the default case.
(byte-compile-cond): Look for and compile switches at any place in the
list of clauses.
* test/lisp/emacs-lisp/bytecomp-tests.el (byte-opt-testsuite-arith-data):
Add test expression.
This commit is contained in:
Mattias Engdegård 2019-06-07 17:04:10 +02:00
parent 14a81524c2
commit d3a7f3e6cd
2 changed files with 170 additions and 175 deletions
Download patch file Download diff file Expand all files Collapse all files

330
lisp/emacs-lisp/bytecomp.el
View file

@ -4122,7 +4122,7 @@ that suppresses all warnings during execution of BODY."
(byte-compile-out-tag donetag)))) (byte-compile-out-tag donetag))))
(setq byte-compile--for-effect nil)) (setq byte-compile--for-effect nil))
(defun byte-compile-cond-vars (obj1 obj2) (defun byte-compile--cond-vars (obj1 obj2)
;; We make sure that of OBJ1 and OBJ2, one of them is a symbol, ;; We make sure that of OBJ1 and OBJ2, one of them is a symbol,
;; and the other is a constant expression whose value can be ;; and the other is a constant expression whose value can be
;; compared with `eq' (with `macroexp-const-p'). ;; compared with `eq' (with `macroexp-const-p').
@ -4130,193 +4130,175 @@ that suppresses all warnings during execution of BODY."
(and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2))) (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2)))
(and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 (eval obj1))))) (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 (eval obj1)))))
(defconst byte-compile--default-val (cons nil nil) "A unique object.")
(defun byte-compile--common-test (test-1 test-2) (defun byte-compile--common-test (test-1 test-2)
"Most specific common test of `eq', `eql' and `equal'" "Most specific common test of `eq', `eql' and `equal'"
(cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal) (cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal)
((or (eq test-1 'eql) (eq test-2 'eql)) 'eql) ((or (eq test-1 'eql) (eq test-2 'eql)) 'eql)
(t 'eq))) (t 'eq)))
(defun byte-compile-cond-jump-table-info (clauses) (defun byte-compile--cond-switch-prefix (clauses)
"If CLAUSES is a `cond' form where: "Find a switch corresponding to a prefix of CLAUSES, or nil if none.
The condition for each clause is of the form (TEST VAR VALUE). Return (TAIL VAR TEST CASES), where:
VAR is a variable. TAIL is the remaining part of CLAUSES after the switch, including
TEST and VAR are the same throughout all conditions. any default clause,
VALUE satisfies `macroexp-const-p'. VAR is the variable being switched on,
TEST is the equality test (`eq', `eql' or `equal'),
CASES is a list of (VALUES . BODY) where VALUES is a list of values
corresponding to BODY (always non-empty)."
(let ((cases nil) ; Reversed list of (VALUES BODY).
(keys nil) ; Switch keys seen so far.
(switch-var nil)
(switch-test 'eq))
(while (pcase (car clauses)
(`((,fn ,expr1 ,expr2) . ,body)
(let* ((vars (byte-compile--cond-vars expr1 expr2))
(var (car vars))
(value (cdr vars)))
(and var (or (eq var switch-var) (not switch-var))
(cond
((memq fn '(eq eql equal))
(setq switch-var var)
(setq switch-test
(byte-compile--common-test switch-test fn))
(unless (member value keys)
(push value keys)
(push (cons (list value) (or body '(t))) cases))
t)
((and (memq fn '(memq memql member))
(listp value)
;; Require a non-empty body, since the member
;; function value depends on the switch
;; argument.
body)
(setq switch-var var)
(setq switch-test
(byte-compile--common-test
switch-test (cdr (assq fn '((memq . eq)
(memql . eql)
(member . equal))))))
(let ((vals nil))
(dolist (elem value)
(unless (funcall fn elem keys)
(push elem vals)))
(when vals
(setq keys (append vals keys))
(push (cons (nreverse vals) body) cases)))
t))))))
(setq clauses (cdr clauses)))
;; Assume that a single switch is cheaper than two or more discrete
;; compare clauses. This could be tuned, possibly taking into
;; account the total number of values involved.
(and (> (length cases) 1)
(list clauses switch-var switch-test (nreverse cases)))))
Return a list of the form ((TEST . VAR) ((VALUES BODY) ...))" (defun byte-compile-cond-jump-table (switch donetag)
(let ((cases '()) "Generate code for SWITCH, ending at DONETAG."
(ok t) (let* ((var (car switch))
(all-keys nil) (test (nth 1 switch))
(prev-test 'eq) (cases (nth 2 switch))
prev-var) jump-table test-objects body tag default-tag)
(and (catch 'break ;; TODO: Once :linear-search is implemented for `make-hash-table'
(dolist (clause (cdr clauses) ok) ;; set it to `t' for cond forms with a small number of cases.
(let* ((condition (car clause)) (let ((nvalues (apply #'+ (mapcar (lambda (case) (length (car case)))
(test (car-safe condition)) cases))))
(vars (when (consp condition) (setq jump-table (make-hash-table
(byte-compile-cond-vars (cadr condition) (cl-caddr condition)))) :test test
(obj1 (car-safe vars)) :purecopy t
(obj2 (cdr-safe vars)) :size nvalues)))
(body (cdr-safe clause))) (setq default-tag (byte-compile-make-tag))
(unless prev-var ;; The structure of byte-switch code:
(setq prev-var obj1)) ;;
(cond ;; varref var
((and obj1 (memq test '(eq eql equal)) ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2)))
(eq obj1 prev-var)) ;; switch
(setq prev-test (byte-compile--common-test prev-test test)) ;; goto DEFAULT-TAG
;; Discard values already tested for. ;; TAG1
(unless (member obj2 all-keys) ;; <clause body>
(push obj2 all-keys) ;; goto DONETAG
(push (list (list obj2) body) cases))) ;; TAG2
;; <clause body>
;; goto DONETAG
;; DEFAULT-TAG
;; <body for remaining (non-switch) clauses>
;; DONETAG
((and obj1 (memq test '(memq memql member)) (byte-compile-variable-ref var)
(eq obj1 prev-var) (byte-compile-push-constant jump-table)
(listp obj2) (byte-compile-out 'byte-switch)
;; Require a non-empty body, since the member function
;; value depends on the switch argument.
body)
(setq prev-test
(byte-compile--common-test
prev-test (cdr (assq test '((memq . eq)
(memql . eql)
(member . equal))))))
(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) ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
(push (list byte-compile--default-val ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
(or body `(,condition))) ;; to be non-nil for generating tags for all cases. Since
cases) ;; `byte-compile-depth' will increase by at most 1 after compiling
(throw 'break t)) ;; all of the clause (which is further enforced by cl-assert below)
(t (setq ok nil) ;; it should be safe to preserve its value.
(throw 'break nil)))))) (let ((byte-compile-depth byte-compile-depth))
(list (cons prev-test prev-var) (nreverse cases))))) (byte-compile-goto 'byte-goto default-tag))
(defun byte-compile-cond-jump-table (clauses) (dolist (case cases)
(let* ((table-info (byte-compile-cond-jump-table-info clauses)) (setq tag (byte-compile-make-tag)
(test (caar table-info)) test-objects (car case)
(var (cdar table-info)) body (cdr case))
(cases (cadr table-info)) (byte-compile-out-tag tag)
jump-table test-objects body tag donetag default-tag default-case) (dolist (value test-objects)
(when (and cases (not (= (length cases) 1))) (puthash value tag jump-table))
;; TODO: Once :linear-search is implemented for `make-hash-table'
;; set it to `t' for cond forms with a small number of cases.
(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
;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2)))
;; switch
;; goto DEFAULT-TAG
;; TAG1
;; <clause body>
;; goto DONETAG
;; TAG2
;; <clause body>
;; goto DONETAG
;; DEFAULT-TAG
;; <body for `t' clause, if any (else `constant nil')>
;; DONETAG
(byte-compile-variable-ref var) (let ((byte-compile-depth byte-compile-depth)
(byte-compile-push-constant jump-table) (init-depth byte-compile-depth))
(byte-compile-out 'byte-switch) ;; Since `byte-compile-body' might increase `byte-compile-depth'
;; by 1, not preserving its value will cause it to potentially
;; increase by one for every clause body compiled, causing
;; depth/tag conflicts or violating asserts down the road.
;; To make sure `byte-compile-body' itself doesn't violate this,
;; we use `cl-assert'.
(byte-compile-body body byte-compile--for-effect)
(cl-assert (or (= byte-compile-depth init-depth)
(= byte-compile-depth (1+ init-depth))))
(byte-compile-goto 'byte-goto donetag)
(setcdr (cdr donetag) nil)))
;; When the opcode argument is `byte-goto', `byte-compile-goto' sets (byte-compile-out-tag default-tag)
;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' (push jump-table byte-compile-jump-tables)))
;; to be non-nil for generating tags for all cases. Since
;; `byte-compile-depth' will increase by at most 1 after compiling
;; all of the clause (which is further enforced by cl-assert below)
;; it should be safe to preserve its value.
(let ((byte-compile-depth byte-compile-depth))
(byte-compile-goto 'byte-goto default-tag))
(let ((default-match (assq byte-compile--default-val cases)))
(when default-match
(setq default-case (cadr default-match)
cases (butlast cases))))
(dolist (case cases)
(setq tag (byte-compile-make-tag)
test-objects (nth 0 case)
body (nth 1 case))
(byte-compile-out-tag tag)
(dolist (value test-objects)
(puthash value tag jump-table))
(let ((byte-compile-depth byte-compile-depth)
(init-depth byte-compile-depth))
;; Since `byte-compile-body' might increase `byte-compile-depth'
;; by 1, not preserving its value will cause it to potentially
;; increase by one for every clause body compiled, causing
;; depth/tag conflicts or violating asserts down the road.
;; To make sure `byte-compile-body' itself doesn't violate this,
;; we use `cl-assert'.
(if (null body)
(byte-compile-form t byte-compile--for-effect)
(byte-compile-body body byte-compile--for-effect))
(cl-assert (or (= byte-compile-depth init-depth)
(= byte-compile-depth (1+ init-depth))))
(byte-compile-goto 'byte-goto donetag)
(setcdr (cdr donetag) nil)))
(byte-compile-out-tag default-tag)
(if default-case
(byte-compile-body-do-effect default-case)
(byte-compile-constant nil))
(byte-compile-out-tag donetag)
(push jump-table byte-compile-jump-tables))))
(defun byte-compile-cond (clauses) (defun byte-compile-cond (clauses)
(or (and byte-compile-cond-use-jump-table (let ((donetag (byte-compile-make-tag))
(byte-compile-cond-jump-table clauses)) nexttag clause)
(let ((donetag (byte-compile-make-tag)) (setq clauses (cdr clauses))
nexttag clause) (while clauses
(while (setq clauses (cdr clauses)) (let ((switch-prefix (and byte-compile-cond-use-jump-table
(setq clause (car clauses)) (byte-compile--cond-switch-prefix clauses))))
(cond ((or (eq (car clause) t) (if switch-prefix
(and (eq (car-safe (car clause)) 'quote) (progn
(car-safe (cdr-safe (car clause))))) (byte-compile-cond-jump-table (cdr switch-prefix) donetag)
;; Unconditional clause (setq clauses (car switch-prefix)))
(setq clause (cons t clause) (setq clause (car clauses))
clauses nil)) (cond ((or (eq (car clause) t)
((cdr clauses) (and (eq (car-safe (car clause)) 'quote)
(byte-compile-form (car clause)) (car-safe (cdr-safe (car clause)))))
(if (null (cdr clause)) ;; Unconditional clause
;; First clause is a singleton. (setq clause (cons t clause)
(byte-compile-goto-if t byte-compile--for-effect donetag) clauses nil))
(setq nexttag (byte-compile-make-tag)) ((cdr clauses)
(byte-compile-goto 'byte-goto-if-nil nexttag) (byte-compile-form (car clause))
(byte-compile-maybe-guarded (car clause) (if (null (cdr clause))
(byte-compile-body (cdr clause) byte-compile--for-effect)) ;; First clause is a singleton.
(byte-compile-goto 'byte-goto donetag) (byte-compile-goto-if t byte-compile--for-effect donetag)
(byte-compile-out-tag nexttag))))) (setq nexttag (byte-compile-make-tag))
;; Last clause (byte-compile-goto 'byte-goto-if-nil nexttag)
(let ((guard (car clause))) (byte-compile-maybe-guarded (car clause)
(and (cdr clause) (not (eq guard t)) (byte-compile-body (cdr clause) byte-compile--for-effect))
(progn (byte-compile-form guard) (byte-compile-goto 'byte-goto donetag)
(byte-compile-goto-if nil byte-compile--for-effect donetag) (byte-compile-out-tag nexttag))))
(setq clause (cdr clause)))) (setq clauses (cdr clauses)))))
(byte-compile-maybe-guarded guard ;; Last clause
(byte-compile-body-do-effect clause))) (let ((guard (car clause)))
(byte-compile-out-tag donetag)))) (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) (defun byte-compile-and (form)
(let ((failtag (byte-compile-make-tag)) (let ((failtag (byte-compile-make-tag))

15
test/lisp/emacs-lisp/bytecomp-tests.el
View file

@ -334,7 +334,20 @@
((memql x '(9 0.5 1.5 q)) 66) ((memql x '(9 0.5 1.5 q)) 66)
(t 99))) (t 99)))
'(a b c d (d) (a . b) "X" 0.5 1.5 3.14 9 9.0)) '(a b c d (d) (a . b) "X" 0.5 1.5 3.14 9 9.0))
) ;; Multi-switch cond form
(mapcar (lambda (p) (let ((x (car p)) (y (cadr p)))
(cond ((consp x) 11)
((eq x 'a) 22)
((memql x '(b 7 a -3)) 33)
((equal y "a") 44)
((memq y '(c d e)) 55)
((booleanp x) 66)
((eq x 'q) 77)
((memq x '(r s)) 88)
((eq x 't) 99)
(t 999))))
'((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c)
(t c) (x "a") (x "c") (x c) (x d) (x e))))
"List of expression for test. "List of expression for test.
Each element will be executed by interpreter and with Each element will be executed by interpreter and with
bytecompiled code, and their results compared.") bytecompiled code, and their results compared.")