aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMattias EngdegÄrd2019-05-21 12:19:38 +0200
committerMattias EngdegÄrd2019-06-19 11:20:58 +0200
commitb8c74742c0238fe15b1cdc9a7f6ee021d038368f (patch)
treed2d51fb226584f28017cb04ef8c3d173e83f1e87
parent36ab408207d7adf94fd1396922e0df38d746a948 (diff)
downloademacs-b8c74742c0238fe15b1cdc9a7f6ee021d038368f.tar.gz
emacs-b8c74742c0238fe15b1cdc9a7f6ee021d038368f.zip
Tighter pcase or-pattern member function selection (bug#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.
-rw-r--r--lisp/emacs-lisp/pcase.el15
-rw-r--r--test/lisp/emacs-lisp/pcase-tests.el6
2 files changed, 12 insertions, 9 deletions
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index a644453a948..ae2cf8eb02f 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -785,25 +785,26 @@ Otherwise, it defers to REST which is a list of branches of the form
785 ((eq 'or (caar matches)) 785 ((eq 'or (caar matches))
786 (let* ((alts (cdar matches)) 786 (let* ((alts (cdar matches))
787 (var (if (eq (caar alts) 'match) (cadr (car alts)))) 787 (var (if (eq (caar alts) 'match) (cadr (car alts))))
788 (simples '()) (others '()) (memql-ok t)) 788 (simples '()) (others '()) (mem-fun 'memq))
789 (when var 789 (when var
790 (dolist (alt alts) 790 (dolist (alt alts)
791 (if (and (eq (car alt) 'match) (eq var (cadr alt)) 791 (if (and (eq (car alt) 'match) (eq var (cadr alt))
792 (let ((upat (cddr alt))) 792 (let ((upat (cddr alt)))
793 (eq (car-safe upat) 'quote))) 793 (eq (car-safe upat) 'quote)))
794 (let ((val (cadr (cddr alt)))) 794 (let ((val (cadr (cddr alt))))
795 (unless (or (integerp val) (symbolp val)) 795 (cond ((integerp val)
796 (setq memql-ok nil)) 796 (when (eq mem-fun 'memq)
797 (push (cadr (cddr alt)) simples)) 797 (setq mem-fun 'memql)))
798 ((not (symbolp val))
799 (setq mem-fun 'member)))
800 (push val simples))
798 (push alt others)))) 801 (push alt others))))
799 (cond 802 (cond
800 ((null alts) (error "Please avoid it") (pcase--u rest)) 803 ((null alts) (error "Please avoid it") (pcase--u rest))
801 ;; Yes, we can use `memql' (or `member')! 804 ;; Yes, we can use `memql' (or `member')!
802 ((> (length simples) 1) 805 ((> (length simples) 1)
803 (pcase--u1 (cons `(match ,var 806 (pcase--u1 (cons `(match ,var
804 . (pred (pcase--flip 807 . (pred (pcase--flip ,mem-fun ',simples)))
805 ,(if memql-ok #'memql #'member)
806 ',simples)))
807 (cdr matches)) 808 (cdr matches))
808 code vars 809 code vars
809 (if (null others) rest 810 (if (null others) rest
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index af8c9a3f3c3..e8c0b8219c5 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -51,9 +51,11 @@
51 51
52(ert-deftest pcase-tests-member () 52(ert-deftest pcase-tests-member ()
53 (should (pcase-tests-grep 53 (should (pcase-tests-grep
54 'memql (macroexpand-all '(pcase x ((or 1 2 3) body))))) 54 'memq (macroexpand-all '(pcase x ((or 'a 'b 'c) body)))))
55 (should (pcase-tests-grep 55 (should (pcase-tests-grep
56 'member (macroexpand-all '(pcase x ((or "a" 2 3) body))))) 56 'memql (macroexpand-all '(pcase x ((or 1 2 3 'a) body)))))
57 (should (pcase-tests-grep
58 'member (macroexpand-all '(pcase x ((or "a" 2 3 'a) body)))))
57 (should-not (pcase-tests-grep 59 (should-not (pcase-tests-grep
58 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) 60 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
59 (should-not (pcase-tests-grep 61 (should-not (pcase-tests-grep