* bug#36139: [PATCH] Make better use of the switch op in cond forms
@ 2019-06-08 14:40 Mattias Engdegård
2019-06-08 15:38 ` Drew Adams
` (5 more replies)
0 siblings, 6 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-08 14:40 UTC (permalink / raw)
To: 36139; +Cc: Stefan Monnier
[-- Attachment #1: Type: text/plain, Size: 2920 bytes --]
Currently, `cond' forms will only use a switch op under very specific circumstances, which limits their potential utility: every condition must be a scalar comparison (eq, eql or equal) between a variable and a constant; the same variable and the same test function must be used everywhere. These restrictions also limit the generation of switch ops from `pcase' and `cl-case' constructs.
In actual `cond' forms, scalar comparisons are mixed with multi-value ones (memq, memql, member); different comparisons are mixed, since the type of values can vary at runtime. There are also non-switch comparisons thrown into the same `cond' for convenience, typically at the beginning or end. Occasionally, there are even multiple switch-like sequences against different variables in the same cond.
Attached is a set of patches which gradually eliminate many of these restrictions. Each patch makes a fixed and hopefully easily-reviewed improvement. Short overview:
* 0001-Compile-list-member-functions-in-cond-to-switch.patch
Allow memq, memql and member to be used in switch generation, since these are idiomatically used for multiple values with the same body. They are also used by `pcase' and `cl-case'. For example,
(cond ((eq x 'a) 11)
((memq x '(b c d)) 22))
will generate a single switch as if the code had been
(cond ((eq x 'a) 11)
((eq x 'b) 22)
((eq x 'c) 22)
((eq x 'd) 22))
- that is, the byte code for the body (22) will be generated thrice.
* 0002-Share-identical-switch-clause-bodies.patch
An improvement of the above to share the body byte code between all values of the same `cond' clause. This means that the switch jump table is no longer an injective mapping.
* 0003-Tighter-pcase-or-pattern-member-function-selection.patch
Make `pcase' use the most specific comparison function (memq instead of memql, etc) in each case, depending on the values.
This patch is technically independent of the other ones, but improves code generation for `pcase'.
* 0004-Compile-cond-with-heterogeneous-tests-into-switch.patch
Allow switch generation with a mixture of eq, eql, equal, memq, memql and member.
* 0005-Compile-any-subsequence-of-cond-clauses-to-switch.patch
Generalise the code to produce switch ops for any switch-like part of a `cond' form. These switches can use different variables, and there can be any number of non-switch clauses before, after and between the switch clauses.
Performance: The patch set is loosely monotonous with the assumptions already present, in the sense that if the current code generator does not produce slower code in any case, nor is it expected to do so after the patches have been applied. In practice, micro-benchmarks naturally show the expected gains, but I haven't found much real-world code that is easy enough to benchmark. Some unpublished tree-traversal code improved about 7 %.
[-- Attachment #2: 0001-Compile-list-member-functions-in-cond-to-switch.patch --]
[-- Type: application/octet-stream, Size: 3322 bytes --]
From 7ddfbaf4e50f96d0feb05983c4f1d144af774052 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Tue, 21 May 2019 11:56:14 +0200
Subject: [PATCH 1/5] Compile list member functions in cond to switch
* lisp/emacs-lisp/bytecomp.el (byte-compile-cond-jump-table-info):
Expand `memq', `memql' and `member' to their corresponding
equality tests.
---
lisp/emacs-lisp/bytecomp.el | 46 +++++++++++++++++++++++++------------
1 file changed, 31 insertions(+), 15 deletions(-)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 38cce14fd6..8f089119de 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4117,23 +4117,39 @@ byte-compile-cond-jump-table-info
(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 duplicate clauses
+ (unless (assoc obj2 cases test)
+ (push (list obj2 body) cases)))
+
+ ((and obj1 (memq test '(memq memql member))
+ (eq obj1 prev-var)
+ (listp obj2)
+ (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))))
+
+ ((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)))))
--
2.20.1 (Apple Git-117)
[-- Attachment #3: 0002-Share-identical-switch-clause-bodies.patch --]
[-- Type: application/octet-stream, Size: 7260 bytes --]
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)
[-- Attachment #4: 0003-Tighter-pcase-or-pattern-member-function-selection.patch --]
[-- Type: application/octet-stream, Size: 3390 bytes --]
From 16e72d20f6a13ff626721ae55b66e1c3848a5813 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Tue, 21 May 2019 12:19:38 +0200
Subject: [PATCH 3/5] Tighter pcase or-pattern member function selection
* lisp/emacs-lisp/pcase.el (pcase--u1):
Use the most specific of `memq', `memql' and `member' in or-patterns
with constant cases. This improves performance and may help the byte-code
compiler generate a switch.
* test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-member):
Add mixed-type or-pattern test cases.
---
lisp/emacs-lisp/pcase.el | 15 ++++++++-------
test/lisp/emacs-lisp/pcase-tests.el | 6 ++++--
2 files changed, 12 insertions(+), 9 deletions(-)
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index a644453a94..ae2cf8eb02 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -785,25 +785,26 @@ pcase--u1
((eq 'or (caar matches))
(let* ((alts (cdar matches))
(var (if (eq (caar alts) 'match) (cadr (car alts))))
- (simples '()) (others '()) (memql-ok t))
+ (simples '()) (others '()) (mem-fun 'memq))
(when var
(dolist (alt alts)
(if (and (eq (car alt) 'match) (eq var (cadr alt))
(let ((upat (cddr alt)))
(eq (car-safe upat) 'quote)))
(let ((val (cadr (cddr alt))))
- (unless (or (integerp val) (symbolp val))
- (setq memql-ok nil))
- (push (cadr (cddr alt)) simples))
+ (cond ((integerp val)
+ (when (eq mem-fun 'memq)
+ (setq mem-fun 'memql)))
+ ((not (symbolp val))
+ (setq mem-fun 'member)))
+ (push val simples))
(push alt others))))
(cond
((null alts) (error "Please avoid it") (pcase--u rest))
;; Yes, we can use `memql' (or `member')!
((> (length simples) 1)
(pcase--u1 (cons `(match ,var
- . (pred (pcase--flip
- ,(if memql-ok #'memql #'member)
- ',simples)))
+ . (pred (pcase--flip ,mem-fun ',simples)))
(cdr matches))
code vars
(if (null others) rest
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index af8c9a3f3c..e8c0b8219c 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -51,9 +51,11 @@ pcase-tests-grep
(ert-deftest pcase-tests-member ()
(should (pcase-tests-grep
- 'memql (macroexpand-all '(pcase x ((or 1 2 3) body)))))
+ 'memq (macroexpand-all '(pcase x ((or 'a 'b 'c) body)))))
(should (pcase-tests-grep
- 'member (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
+ 'memql (macroexpand-all '(pcase x ((or 1 2 3 'a) body)))))
+ (should (pcase-tests-grep
+ 'member (macroexpand-all '(pcase x ((or "a" 2 3 'a) body)))))
(should-not (pcase-tests-grep
'memq (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
(should-not (pcase-tests-grep
--
2.20.1 (Apple Git-117)
[-- Attachment #5: 0004-Compile-cond-with-heterogeneous-tests-into-switch.patch --]
[-- Type: application/octet-stream, Size: 5806 bytes --]
From 876f73720ef3274352cf707dbeb1cbb02817cd03 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Wed, 22 May 2019 12:36:03 +0200
Subject: [PATCH 4/5] Compile cond with heterogeneous tests into switch
Allow any mixture of `eq', `eql' and `equal', `memq', `memql' and
`member' in a switch-like `cond' to be compiled into a single switch.
* lisp/emacs-lisp/bytecomp.el (byte-compile--common-test): New.
(byte-compile-cond-jump-table-info): Use most specific common test.
* test/lisp/emacs-lisp/bytecomp-tests.el (byte-opt-testsuite-arith-data):
Add test cases for multi-value clause cond forms.
---
lisp/emacs-lisp/bytecomp.el | 29 +++++++++++++++-----------
test/lisp/emacs-lisp/bytecomp-tests.el | 25 +++++++++++++++++++++-
2 files changed, 41 insertions(+), 13 deletions(-)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 5930386166..5ee5ceac18 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4098,6 +4098,12 @@ byte-compile-cond-vars
(defconst byte-compile--default-val (cons nil nil) "A unique object.")
+(defun byte-compile--common-test (test-1 test-2)
+ "Most specific common test of `eq', `eql' and `equal'"
+ (cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal)
+ ((or (eq test-1 'eql) (eq test-2 'eql)) 'eql)
+ (t 'eq)))
+
(defun byte-compile-cond-jump-table-info (clauses)
"If CLAUSES is a `cond' form where:
The condition for each clause is of the form (TEST VAR VALUE).
@@ -4109,7 +4115,8 @@ byte-compile-cond-jump-table-info
(let ((cases '())
(ok t)
(all-keys nil)
- prev-var prev-test)
+ (prev-test 'eq)
+ prev-var)
(and (catch 'break
(dolist (clause (cdr clauses) ok)
(let* ((condition (car clause))
@@ -4118,15 +4125,13 @@ byte-compile-cond-jump-table-info
(byte-compile-cond-vars (cadr condition) (cl-caddr condition))))
(obj1 (car-safe vars))
(obj2 (cdr-safe vars))
- (body (cdr-safe clause))
- equality)
+ (body (cdr-safe clause)))
(unless prev-var
(setq prev-var obj1))
(cond
((and obj1 (memq test '(eq eql equal))
- (eq obj1 prev-var)
- (or (not prev-test) (eq test prev-test)))
- (setq prev-test test)
+ (eq obj1 prev-var))
+ (setq prev-test (byte-compile--common-test prev-test test))
;; Discard values already tested for.
(unless (member obj2 all-keys)
(push obj2 all-keys)
@@ -4137,12 +4142,12 @@ byte-compile-cond-jump-table-info
(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)
+ 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)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index f45c9209c1..87f2c13bf7 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -311,7 +311,30 @@ byte-opt-testsuite-arith-data
(let ((x "a")) (cond ((equal x "a") 'correct)
((equal x "b") 'incorrect)
((equal x "a") 'incorrect)
- ((equal x "c") 'incorrect))))
+ ((equal x "c") 'incorrect)))
+ ;; Multi-value clauses
+ (mapcar (lambda (x) (cond ((eq x 'a) 11)
+ ((memq x '(b a c d)) 22)
+ ((eq x 'c) 33)
+ ((eq x 'e) 44)
+ ((memq x '(d f g)) 55)
+ (t 99)))
+ '(a b c d e f g h))
+ (mapcar (lambda (x) (cond ((eql x 1) 11)
+ ((memq x '(a b c)) 22)
+ ((memql x '(2 1 4 1e-3)) 33)
+ ((eq x 'd) 44)
+ ((eql x #x10000000000000000))))
+ '(1 2 4 1e-3 a b c d 1.0 #x10000000000000000))
+ (mapcar (lambda (x) (cond ((eq x 'a) 11)
+ ((memq x '(b d)) 22)
+ ((equal x '(a . b)) 33)
+ ((member x '(b c 1.5 2.5 "X" (d))) 44)
+ ((eql x 3.14) 55)
+ ((memql x '(9 0.5 1.5 q)) 66)
+ (t 99)))
+ '(a b c d (d) (a . b) "X" 0.5 1.5 3.14 9 9.0))
+ )
"List of expression for test.
Each element will be executed by interpreter and with
bytecompiled code, and their results compared.")
--
2.20.1 (Apple Git-117)
[-- Attachment #6: 0005-Compile-any-subsequence-of-cond-clauses-to-switch.patch --]
[-- Type: application/octet-stream, Size: 19223 bytes --]
From 9822f95ca1c3c92b2097c01b3f209d0155284be2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Fri, 7 Jun 2019 17:04:10 +0200
Subject: [PATCH 5/5] Compile any subsequence of `cond' clauses to switch
A single `cond' form can how be compiled to any number of switch ops,
interspersed with non-switch conditions in arbitrary ways. 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.
---
lisp/emacs-lisp/bytecomp.el | 339 ++++++++++++-------------
test/lisp/emacs-lisp/bytecomp-tests.el | 15 +-
2 files changed, 173 insertions(+), 181 deletions(-)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 5ee5ceac18..82e47794e3 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4088,7 +4088,7 @@ byte-compile-if
(byte-compile-out-tag donetag))))
(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,
;; and the other is a constant expression whose value can be
;; compared with `eq' (with `macroexp-const-p').
@@ -4096,193 +4096,172 @@ byte-compile-cond-vars
(and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2)))
(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)
"Most specific common test of `eq', `eql' and `equal'"
(cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal)
((or (eq test-1 'eql) (eq test-2 'eql)) 'eql)
(t 'eq)))
-(defun byte-compile-cond-jump-table-info (clauses)
- "If CLAUSES is a `cond' form where:
-The condition for each clause is of the form (TEST VAR VALUE).
-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) ((VALUES BODY) ...))"
- (let ((cases '())
- (ok t)
- (all-keys nil)
- (prev-test 'eq)
- prev-var)
- (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))
- (cond
- ((and obj1 (memq test '(eq eql equal))
- (eq obj1 prev-var))
- (setq prev-test (byte-compile--common-test 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 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)
- (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)))))
-
-(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-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.
- (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)
- (byte-compile-push-constant jump-table)
- (byte-compile-out 'byte-switch)
-
- ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
- ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
- ;; 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-switch-prefix (clauses)
+ "Find a switch corresponding to a prefix of CLAUSES, or nil if none.
+Return (TAIL VAR TEST CASES), where:
+ TAIL is the remaining part of CLAUSES after the switch, including
+ any default clause,
+ 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)))
+ (and (> (length cases) 1)
+ (list clauses switch-var switch-test (nreverse cases)))))
+
+(defun byte-compile-cond-jump-table (switch donetag)
+ "Generate code for SWITCH, ending at DONETAG."
+ (let* ((var (car switch))
+ (test (nth 1 switch))
+ (cases (nth 2 switch))
+ jump-table test-objects body tag default-tag)
+ ;; 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 nvalues)))
+ (setq default-tag (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 remaining (non-switch) clauses>
+ ;; DONETAG
+
+ (byte-compile-variable-ref var)
+ (byte-compile-push-constant jump-table)
+ (byte-compile-out 'byte-switch)
+
+ ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
+ ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
+ ;; 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))
+
+ (dolist (case cases)
+ (setq tag (byte-compile-make-tag)
+ test-objects (car case)
+ body (cdr 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'.
+ (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)
+ (push jump-table byte-compile-jump-tables)))
(defun byte-compile-cond (clauses)
- (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))
- (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))))
+ (let ((donetag (byte-compile-make-tag))
+ nexttag clause)
+ (setq clauses (cdr clauses))
+ (while clauses
+ (let ((switch-prefix (and byte-compile-cond-use-jump-table
+ (byte-compile--cond-switch-prefix clauses))))
+ (if switch-prefix
+ (progn
+ (byte-compile-cond-jump-table (cdr switch-prefix) donetag)
+ (setq clauses (car switch-prefix)))
+ (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))))
+ (setq clauses (cdr clauses)))))
+ ;; 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))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 87f2c13bf7..b2a47af63b 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -334,7 +334,20 @@ byte-opt-testsuite-arith-data
((memql x '(9 0.5 1.5 q)) 66)
(t 99)))
'(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.
Each element will be executed by interpreter and with
bytecompiled code, and their results compared.")
--
2.20.1 (Apple Git-117)
^ permalink raw reply related [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
@ 2019-06-08 15:38 ` Drew Adams
2019-06-09 8:38 ` Mattias Engdegård
2019-06-10 15:38 ` npostavs
2019-06-18 18:48 ` Stefan Monnier
` (4 subsequent siblings)
5 siblings, 2 replies; 18+ messages in thread
From: Drew Adams @ 2019-06-08 15:38 UTC (permalink / raw)
To: Mattias Engdegård, 36139; +Cc: Stefan Monnier
How does this kind of thing work with an enclosing `cl-flet' or similar that redefines `memq' or whatever? Or in a file that redefines `memq' or whatever using `defun' or similar?
(But I guess the same problem exists in the current code, wrt `eq' etc.?)
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 15:38 ` Drew Adams
@ 2019-06-09 8:38 ` Mattias Engdegård
2019-06-10 15:38 ` npostavs
1 sibling, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-09 8:38 UTC (permalink / raw)
To: Drew Adams; +Cc: 36139, Stefan Monnier
8 juni 2019 kl. 17.38 skrev Drew Adams <drew.adams@oracle.com>:
>
> How does this kind of thing work with an enclosing `cl-flet' or similar that redefines `memq' or whatever? Or in a file that redefines `memq' or whatever using `defun' or similar?
`cl-flet' works by macro-expansion, not by lexical rebinding of the function value, so it should be reasonably safe.
monotonic
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 15:38 ` Drew Adams
2019-06-09 8:38 ` Mattias Engdegård
@ 2019-06-10 15:38 ` npostavs
2019-06-11 11:12 ` Mattias Engdegård
1 sibling, 1 reply; 18+ messages in thread
From: npostavs @ 2019-06-10 15:38 UTC (permalink / raw)
To: Drew Adams; +Cc: Mattias Engdegård, 36139, Stefan Monnier
Drew Adams <drew.adams@oracle.com> writes:
> Or in a file that redefines `memq' or whatever using `defun' or similar?
>
> (But I guess the same problem exists in the current code, wrt `eq' etc.?)
Redefining eq, equal, memq, or member with defun or advice is already
unreliable because they are translated to byte codes. eql and memql are
not, so this patchset (specifically, the last 2 patches, I think) would
make the situation a bit worse for those functions, in that it would
prevent defun/advice override for eql and memql from applying in cond
forms.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-10 15:38 ` npostavs
@ 2019-06-11 11:12 ` Mattias Engdegård
2019-06-11 11:25 ` Noam Postavsky
0 siblings, 1 reply; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-11 11:12 UTC (permalink / raw)
To: Noam Postavsky; +Cc: 36139, Stefan Monnier
10 juni 2019 kl. 17.38 skrev npostavs@gmail.com:
>
> Redefining eq, equal, memq, or member with defun or advice is already
> unreliable because they are translated to byte codes. eql and memql are
> not, so this patchset (specifically, the last 2 patches, I think) would
> make the situation a bit worse for those functions, in that it would
> prevent defun/advice override for eql and memql from applying in cond
> forms.
`eql' is already recognised for switch generation in cond forms today. More generally, is redefinition of such fundamental built-ins really a serious concern? The compiler assumes standard semantics for plenty of functions, byte-codes or not. This is also mentioned in the manual.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-11 11:12 ` Mattias Engdegård
@ 2019-06-11 11:25 ` Noam Postavsky
2019-06-18 12:46 ` Mattias Engdegård
0 siblings, 1 reply; 18+ messages in thread
From: Noam Postavsky @ 2019-06-11 11:25 UTC (permalink / raw)
To: Mattias Engdegård; +Cc: 36139, Stefan Monnier
Mattias Engdegård <mattiase@acm.org> writes:
> 10 juni 2019 kl. 17.38 skrev npostavs@gmail.com:
>>
>> Redefining eq, equal, memq, or member with defun or advice is already
>> unreliable because they are translated to byte codes. eql and memql are
>> not, so this patchset (specifically, the last 2 patches, I think) would
>> make the situation a bit worse for those functions, in that it would
>> prevent defun/advice override for eql and memql from applying in cond
>> forms.
>
> `eql' is already recognised for switch generation in cond forms
> today.
Oh, I wasn't aware of that. Somehow I had the impression it was only
for `eq'.
> More generally, is redefinition of such fundamental built-ins
> really a serious concern?
Not in my opinion, I just wanted to mention it for completeness.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-11 11:25 ` Noam Postavsky
@ 2019-06-18 12:46 ` Mattias Engdegård
0 siblings, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-18 12:46 UTC (permalink / raw)
To: 36139, Stefan Monnier, Noam Postavsky, Drew Adams
Anything I can do to make the changes easier to review? All tests pass, bootstrap works, and so on; I'm using them daily.
The patches could be reviewed and committed piecemeal. Patch 3 (pcase) may be a good start since it's a small independent improvement.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
2019-06-08 15:38 ` Drew Adams
@ 2019-06-18 18:48 ` Stefan Monnier
2019-06-19 9:25 ` Mattias Engdegård
2019-06-18 18:56 ` Stefan Monnier
` (3 subsequent siblings)
5 siblings, 1 reply; 18+ messages in thread
From: Stefan Monnier @ 2019-06-18 18:48 UTC (permalink / raw)
To: Mattias Engdegård; +Cc: 36139
> * lisp/emacs-lisp/bytecomp.el (byte-compile-cond-jump-table-info):
> Expand `memq', `memql' and `member' to their corresponding
> equality tests.
> ---
> lisp/emacs-lisp/bytecomp.el | 46 +++++++++++++++++++++++++------------
> 1 file changed, 31 insertions(+), 15 deletions(-)
>
> diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
> index 38cce14fd6..8f089119de 100644
> --- a/lisp/emacs-lisp/bytecomp.el
> +++ b/lisp/emacs-lisp/bytecomp.el
> @@ -4117,23 +4117,39 @@ byte-compile-cond-jump-table-info
> (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 duplicate clauses
> + (unless (assoc obj2 cases test)
> + (push (list obj2 body) cases)))
> +
> + ((and obj1 (memq test '(memq memql member))
> + (eq obj1 prev-var)
> + (listp obj2)
> + (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))))
> +
> + ((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)))))
This patch on its own is problematic because of the code-increase it
can introduce. So I'd suggest merging it with the other one.
Stefan
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
2019-06-08 15:38 ` Drew Adams
2019-06-18 18:48 ` Stefan Monnier
@ 2019-06-18 18:56 ` Stefan Monnier
2019-06-18 19:03 ` Stefan Monnier
` (2 subsequent siblings)
5 siblings, 0 replies; 18+ messages in thread
From: Stefan Monnier @ 2019-06-18 18:56 UTC (permalink / raw)
To: Mattias Engdegård; +Cc: 36139
> Allow switch generation with a mixture of eq, eql, equal, memq, memql and member.
AFAIK all of those give the same result (in practice) as using
equal/member: I'm having a hard time imagining an eq/eql/memq/memql test
against a constant which behaves differently from equal/member except
for those that can simply always return nil (e.g. (eq x "toto") can
always return nil since there's no way the caller of this code can make
sure x is really the same string object as the "toto" generated by the
compiler).
So I think we should "standardize" on equal/member and mostly disregard
the eq/eql/equal difference (except maybe for emitting a warning when
comparing against something where `equal` doesn't give the same result).
Stefan
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
` (2 preceding siblings ...)
2019-06-18 18:56 ` Stefan Monnier
@ 2019-06-18 19:03 ` Stefan Monnier
2019-06-19 9:30 ` Mattias Engdegård
2019-06-19 14:03 ` Mattias Engdegård
2019-06-18 19:06 ` Stefan Monnier
2019-06-18 19:19 ` Stefan Monnier
5 siblings, 2 replies; 18+ messages in thread
From: Stefan Monnier @ 2019-06-18 19:03 UTC (permalink / raw)
To: Mattias Engdegård; +Cc: 36139
> * lisp/emacs-lisp/pcase.el (pcase--u1):
> Use the most specific of `memq', `memql' and `member' in or-patterns
> with constant cases. This improves performance and may help the byte-code
> compiler generate a switch.
> * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-member):
> Add mixed-type or-pattern test cases.
> ---
> lisp/emacs-lisp/pcase.el | 15 ++++++++-------
> test/lisp/emacs-lisp/pcase-tests.el | 6 ++++--
> 2 files changed, 12 insertions(+), 9 deletions(-)
>
> diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
> index a644453a94..ae2cf8eb02 100644
> --- a/lisp/emacs-lisp/pcase.el
> +++ b/lisp/emacs-lisp/pcase.el
> @@ -785,25 +785,26 @@ pcase--u1
> ((eq 'or (caar matches))
> (let* ((alts (cdar matches))
> (var (if (eq (caar alts) 'match) (cadr (car alts))))
> - (simples '()) (others '()) (memql-ok t))
> + (simples '()) (others '()) (mem-fun 'memq))
> (when var
> (dolist (alt alts)
> (if (and (eq (car alt) 'match) (eq var (cadr alt))
> (let ((upat (cddr alt)))
> (eq (car-safe upat) 'quote)))
> (let ((val (cadr (cddr alt))))
> - (unless (or (integerp val) (symbolp val))
> - (setq memql-ok nil))
> - (push (cadr (cddr alt)) simples))
> + (cond ((integerp val)
> + (when (eq mem-fun 'memq)
> + (setq mem-fun 'memql)))
> + ((not (symbolp val))
> + (setq mem-fun 'member)))
> + (push val simples))
> (push alt others))))
> (cond
> ((null alts) (error "Please avoid it") (pcase--u rest))
> ;; Yes, we can use `memql' (or `member')!
> ((> (length simples) 1)
> (pcase--u1 (cons `(match ,var
> - . (pred (pcase--flip
> - ,(if memql-ok #'memql #'member)
> - ',simples)))
> + . (pred (pcase--flip ,mem-fun ',simples)))
> (cdr matches))
> code vars
> (if (null others) rest
LGTM. The other direction is to just always use `member`
and speed up the implementation of `member` by testing the type of
the first arg and dispatch to memq/memql when possible.
Stefan
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
` (3 preceding siblings ...)
2019-06-18 19:03 ` Stefan Monnier
@ 2019-06-18 19:06 ` Stefan Monnier
2019-06-19 9:30 ` Mattias Engdegård
2019-06-18 19:19 ` Stefan Monnier
5 siblings, 1 reply; 18+ messages in thread
From: Stefan Monnier @ 2019-06-18 19:06 UTC (permalink / raw)
To: Mattias Engdegård; +Cc: 36139
> Allow any mixture of `eq', `eql' and `equal', `memq', `memql' and
> `member' in a switch-like `cond' to be compiled into a single switch.
LGTM,
Stefan
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
` (4 preceding siblings ...)
2019-06-18 19:06 ` Stefan Monnier
@ 2019-06-18 19:19 ` Stefan Monnier
2019-06-19 10:14 ` Mattias Engdegård
5 siblings, 1 reply; 18+ messages in thread
From: Stefan Monnier @ 2019-06-18 19:19 UTC (permalink / raw)
To: Mattias Engdegård; +Cc: 36139
> A single `cond' form can how be compiled to any number of switch ops,
> interspersed with non-switch conditions in arbitrary ways.
It can also be compiled to a bunch of switch ops only, right?
(e.g. if it starts with a switch on `x` and then is followed by
a switch on `y`)
> + (and (> (length cases) 1)
I think this `1` deserves a comment (IIRC it's the number of cases
above which using a switch is expected to be faster than a sequence of
tests).
> + ;; 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))))
IIRC the depth is altered depending on byte-compile--for-effect (if
byte-compile--for-effect is non-nil when entering the function but nil
afterwards, depth should be identical, and it should be increased by
1 otherwise), so we should be able to tighten this assertion to replace
the `or` with an `if`.
Other than that, the patch looks fine to me.
Stefan
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-18 18:48 ` Stefan Monnier
@ 2019-06-19 9:25 ` Mattias Engdegård
0 siblings, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-19 9:25 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 36139
18 juni 2019 kl. 20.48 skrev Stefan Monnier <monnier@iro.umontreal.ca>:
>
> This patch on its own is problematic because of the code-increase it
> can introduce. So I'd suggest merging it with the other one.
Thanks, I merged and pushed those two patches as one.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-18 19:03 ` Stefan Monnier
@ 2019-06-19 9:30 ` Mattias Engdegård
2019-06-19 14:03 ` Mattias Engdegård
1 sibling, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-19 9:30 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 36139
18 juni 2019 kl. 21.03 skrev Stefan Monnier <monnier@iro.umontreal.ca>:
>
> LGTM. The other direction is to just always use `member`
> and speed up the implementation of `member` by testing the type of
> the first arg and dispatch to memq/memql when possible.
Thank you. I ended up pushing this patch on the grounds that it took care of unfinished business in pcase (it did try to select which function to use, just didn't go all the way). Speeding up `member' is, of course, useful on its own.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-18 19:06 ` Stefan Monnier
@ 2019-06-19 9:30 ` Mattias Engdegård
0 siblings, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-19 9:30 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 36139
18 juni 2019 kl. 21.06 skrev Stefan Monnier <monnier@iro.umontreal.ca>:
>
>> Allow any mixture of `eq', `eql' and `equal', `memq', `memql' and
>> `member' in a switch-like `cond' to be compiled into a single switch.
>
> LGTM,
Thank you, pushed.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-18 19:19 ` Stefan Monnier
@ 2019-06-19 10:14 ` Mattias Engdegård
0 siblings, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-19 10:14 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 36139
18 juni 2019 kl. 21.19 skrev Stefan Monnier <monnier@iro.umontreal.ca>:
>
>> A single `cond' form can how be compiled to any number of switch ops,
>> interspersed with non-switch conditions in arbitrary ways.
>
> It can also be compiled to a bunch of switch ops only, right?
> (e.g. if it starts with a switch on `x` and then is followed by
> a switch on `y`)
Correct, and good catch. I rephrased the commit message.
>> + (and (> (length cases) 1)
>
> I think this `1` deserves a comment (IIRC it's the number of cases
> above which using a switch is expected to be faster than a sequence of
> tests).
Agreed, but the condition comes from the existing code (bytecomp.el:4180) where the number isn't motivated further either. I just assumed it was chosen with at least some care.
The ability to include multi-value cases in the switch makes the condition a conservative choice: if it is a good decision for single-value cases, it is definitely valid for multiple values per case.
I added a comment stating the intent, but it's not a lot more than restating the Lisp in English.
>> + ;; 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))))
>
> IIRC the depth is altered depending on byte-compile--for-effect (if
> byte-compile--for-effect is non-nil when entering the function but nil
> afterwards, depth should be identical, and it should be increased by
> 1 otherwise), so we should be able to tighten this assertion to replace
> the `or` with an `if`.
I'll do that in a separate change then, because it seems to be orthogonal to my changes.
Brief experiments seem to indicate that the
(byte-compile-body body byte-compile--for-effect)
call does not seem to alter byte-compile--for-effect, but it does increase depth by 1 iff byte-compile--for-effect is non-nil.
> Other than that, the patch looks fine to me.
Thanks for the review! Pushed to master.
^ permalink raw reply [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-18 19:03 ` Stefan Monnier
2019-06-19 9:30 ` Mattias Engdegård
@ 2019-06-19 14:03 ` Mattias Engdegård
2019-06-28 20:51 ` Mattias Engdegård
1 sibling, 1 reply; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-19 14:03 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 36139
[-- Attachment #1: Type: text/plain, Size: 847 bytes --]
18 juni 2019 kl. 21.03 skrev Stefan Monnier <monnier@iro.umontreal.ca>:
>
> LGTM. The other direction is to just always use `member`
> and speed up the implementation of `member` by testing the type of
> the first arg and dispatch to memq/memql when possible.
Here is a patch that does some cheap static optimisations: equal/eql and member/memql become eq and memq if constant symbols are involved. (Works for me, bootstraps fine, etc.)
I considered doing the same for equal->eql and member->memql. It turns out that equal is faster than eql for numbers, since eql doesn't have its own byte op. For the same reason, member is faster than memql for lists of up to 5 elements (on this machine). While we could reduce equal to eql for constant lists > 5 elements of only symbols and numbers, it's perhaps more trouble than it's worth.
[-- Attachment #2: 0001-Strength-reduce-equal-eql-member-and-memql.patch --]
[-- Type: application/octet-stream, Size: 3179 bytes --]
From e5f3da7af6cc209d4b29378d41427937d8a32435 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Wed, 19 Jun 2019 13:26:58 +0200
Subject: [PATCH] Strength-reduce `equal', `eql', `member' and `memql'
When comparing against symbols, turn `equal' and `eql' into `eq',
and `member' and `memql' into `memq'.
* lisp/emacs-lisp/byte-opt.el (byte-optimizer--constant-symbol-p)
(byte-optimize-equal, byte-optimize-member): New.
(member, memql, equal, eql): Use new byte-optimizers.
---
lisp/emacs-lisp/byte-opt.el | 35 ++++++++++++++++++++++++++++++++++-
1 file changed, 34 insertions(+), 1 deletion(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index b0aa407c8b..ca08b2ce50 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -834,6 +834,36 @@ byte-optimize-identity
(if (= 1 (length (cdr form))) "" "s"))
form))
+(defun byte-optimizer--constant-symbol-p (expr)
+ "Whether EXPR is a constant symbol."
+ (and (macroexp-const-p expr) (symbolp (eval expr))))
+
+(defun byte-optimize-equal (form)
+ ;; Replace `equal' or `eql' with `eq' if at least one arg is a symbol.
+ (if (= (length (cdr form)) 2)
+ (let ((form (byte-optimize-binary-predicate form)))
+ (if (or (byte-optimizer--constant-symbol-p (nth 1 form))
+ (byte-optimizer--constant-symbol-p (nth 2 form)))
+ (cons 'eq (cdr form))
+ form))
+ ;; Arity errors reported elsewhere.
+ form))
+
+(defun byte-optimize-member (form)
+ ;; Replace `member' or `memql' with `memq' if the first arg is a symbol,
+ ;; or the second arg is a list of symbols.
+ (if (= (length (cdr form)) 2)
+ (if (or (byte-optimizer--constant-symbol-p (nth 1 form))
+ (let ((arg2 (nth 2 form)))
+ (and (macroexp-const-p arg2)
+ (let ((listval (eval arg2)))
+ (and (listp listval)
+ (not (memq nil (mapcar #'symbolp listval))))))))
+ (cons 'memq (cdr form))
+ form)
+ ;; Arity errors reported elsewhere.
+ form))
+
(defun byte-optimize-memq (form)
;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar))
(if (/= (length (cdr form)) 2)
@@ -852,6 +882,8 @@ byte-optimize-memq
(put 'identity 'byte-optimizer 'byte-optimize-identity)
(put 'memq 'byte-optimizer 'byte-optimize-memq)
+(put 'memql 'byte-optimizer 'byte-optimize-member)
+(put 'member 'byte-optimizer 'byte-optimize-member)
(put '+ 'byte-optimizer 'byte-optimize-plus)
(put '* 'byte-optimizer 'byte-optimize-multiply)
@@ -862,7 +894,8 @@ byte-optimize-memq
(put '= 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate)
-(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate)
+(put 'eql 'byte-optimizer 'byte-optimize-equal)
+(put 'equal 'byte-optimizer 'byte-optimize-equal)
(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
--
2.20.1 (Apple Git-117)
^ permalink raw reply related [flat|nested] 18+ messages in thread
* bug#36139: [PATCH] Make better use of the switch op in cond forms
2019-06-19 14:03 ` Mattias Engdegård
@ 2019-06-28 20:51 ` Mattias Engdegård
0 siblings, 0 replies; 18+ messages in thread
From: Mattias Engdegård @ 2019-06-28 20:51 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 36139-done
19 juni 2019 kl. 16.03 skrev Mattias Engdegård <mattiase@acm.org>:
>
> Here is a patch that does some cheap static optimisations: equal/eql and member/memql become eq and memq if constant symbols are involved. (Works for me, bootstraps fine, etc.)
After dithering a bit and testing alternatives, I pushed a tweaked version of that patch; there seemed to be little reason not to.
^ permalink raw reply [flat|nested] 18+ messages in thread
end of thread, other threads:[~2019-06-28 20:51 UTC | newest]
Thread overview: 18+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-06-08 14:40 bug#36139: [PATCH] Make better use of the switch op in cond forms Mattias Engdegård
2019-06-08 15:38 ` Drew Adams
2019-06-09 8:38 ` Mattias Engdegård
2019-06-10 15:38 ` npostavs
2019-06-11 11:12 ` Mattias Engdegård
2019-06-11 11:25 ` Noam Postavsky
2019-06-18 12:46 ` Mattias Engdegård
2019-06-18 18:48 ` Stefan Monnier
2019-06-19 9:25 ` Mattias Engdegård
2019-06-18 18:56 ` Stefan Monnier
2019-06-18 19:03 ` Stefan Monnier
2019-06-19 9:30 ` Mattias Engdegård
2019-06-19 14:03 ` Mattias Engdegård
2019-06-28 20:51 ` Mattias Engdegård
2019-06-18 19:06 ` Stefan Monnier
2019-06-19 9:30 ` Mattias Engdegård
2019-06-18 19:19 ` Stefan Monnier
2019-06-19 10:14 ` Mattias Engdegård
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).