(pcase--app-subst-match): Try and fix performance regression (bug#71398)

* lisp/emacs-lisp/pcase.el (pcase--app-subst-match): Optimize matches
against (quote VAL).
* test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-quote-optimization):
Add new test case.

(cherry picked from commit e9a0256a556622474bcbb015f88d790666db2cc9)

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 69353daf7d09705d2a561d88de8199cb72d48396..5a7f3995311e37a28aa41e18c83dc4573cae85d8 100644 (file)
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -857,13 +857,36 @@ A and B can be one of:
   (or (keywordp upat) (integerp upat) (stringp upat)))
 
 (defun pcase--app-subst-match (match sym fun nsym)
+  "Refine MATCH knowing that NSYM = (funcall FUN SYM)."
   (cond
    ((eq (car-safe match) 'match)
-    (if (and (eq sym (cadr match))
-             (eq 'app (car-safe (cddr match)))
-             (equal fun (nth 1 (cddr match))))
-        (pcase--match nsym (nth 2 (cddr match)))
-      match))
+    (cond
+     ((not (eq sym (cadr match))) match)
+     ((and (eq 'app (car-safe (cddr match)))
+           (equal fun (nth 1 (cddr match))))
+      ;; MATCH is (match SYM app FUN UPAT), so we can refine it to refer to
+      ;; NSYM rather than re-compute (funcall FUN SYM).
+      (pcase--match nsym (nth 2 (cddr match))))
+     ((eq 'quote (car-safe (cddr match)))
+      ;; MATCH is (match SYM quote VAL), so we can decompose it into
+      ;; (match NSYM quote (funcall FUN VAL)) plus a check that
+      ;; the part of VAL not included in (funcall FUN VAL) still
+      ;; result is SYM matching (quote VAL).  (bug#71398)
+      (condition-case nil
+          `(and (match ,nsym . ',(funcall fun (nth 3 match)))
+                ;; FIXME: "the part of VAL not included in (funcall FUN VAL)"
+                ;; is hard to define for arbitrary FUN.  We do it only when
+                ;; FUN is `c[ad]r', and for the rest we just preserve
+                ;; the original `match' which is not optimal but safe.
+                ,(if (and (memq fun '(car cdr car-safe cdr-safe))
+                          (consp (nth 3 match)))
+                     (let ((otherfun (if (memq fun '(car car-safe))
+                                         #'cdr-safe #'car-safe)))
+                       `(match ,(cadr match) app ,otherfun
+                               ',(funcall otherfun (nth 3 match))))
+                   match))
+        (error match)))
+     (t match)))
    ((memq (car-safe match) '(or and))
     `(,(car match)
       ,@(mapcar (lambda (match)

diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index 35cf2f93cdc01ee09243df684014ea17f777da33..e777b71920c0d6f970ff149ebb34a4576ff783e6 100644 (file)
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -83,7 +83,14 @@
   (should-not (pcase-tests-grep
                'FOO (macroexpand '(pcase EXP
                                     (`(,_ . ,_) (BAR))
-                                    ('(a b) (FOO)))))))
+                                    ('(a b) (FOO))))))
+  (let ((exp1 (macroexpand '(pcase EXP
+                              (`(`(,(or 'a1 'b1)) (FOO1)))
+                              ('(c) (FOO2))
+                              ('(d) (FOO3))))))
+    (should (= 1 (with-temp-buffer (prin1 exp1 (current-buffer))
+                                   (goto-char (point-min))
+                                   (count-matches "(FOO3)"))))))
 
 (ert-deftest pcase-tests-bug14773 ()
   (let ((f (lambda (x)