From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Sat, 8 Jun 2024 21:34:30 +0000 (-0400)
Subject: (pcase--app-subst-match): Try and fix performance regression (bug#71398)
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9da4f4fe4d58fa44be680f37a2cf038d72c8329d;p=emacs.git

(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 69353daf7d0..5a7f3995311 100644
--- 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 35cf2f93cdc..e777b71920c 100644
--- 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)