From 58c8859a9d217dcb1e10ae65e03aaf736aa41224 Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Mon, 3 Jun 2024 13:26:10 -0400
Subject: [PATCH] pcase.el (\`): Try and handle large patterns better
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

Large backquote patterns tend to lead to very large and deeply
nested expansions, but they also tend to contain a lot of
"constant" subpatterns that can be compiled to quote patterns.
This patch does just that.  See discussion at
https://lists.gnu.org/archive/html/emacs-devel/2024-05/msg01140.html

* lisp/emacs-lisp/pcase.el (pcase--split-pred):
Improve the handling of pred-vs-quote so it also works with
quoted objects like cons cells, vectors, and strings.
Simplify the `pcase--mutually-exclusive-p` branch accordingly.
(pcase--expand-\`): New function, extracted from the \` pcase macro.
Make it recurse internally, and optimize backquote patterns to `quote`
patterns where possible.
(\`): Use it.

* test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-vectors): Add tests
that were broken by a more naïve version of the optimization.
(pcase-tests-quote-optimization): New test.

(cherry picked from commit 16fc5b6c0c72464a75d9a84b754375662b3acec6)
---
 lisp/emacs-lisp/pcase.el            | 52 +++++++++++++++++------------
 test/lisp/emacs-lisp/pcase-tests.el | 12 ++++++-
 2 files changed, 41 insertions(+), 23 deletions(-)

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 1a58c60734a..69353daf7d0 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -829,16 +829,8 @@ A and B can be one of:
       (let* ((test (cadr (cadr upat)))
              (res (pcase--split-pred vars `(pred ,test) pat)))
         (cons (cdr res) (car res))))
-     ((let ((otherpred
-             (cond ((eq 'pred (car-safe pat)) (cadr pat))
-                   ((not (eq 'quote (car-safe pat))) nil)
-                   ((consp (cadr pat)) #'consp)
-                   ((stringp (cadr pat)) #'stringp)
-                   ((vectorp (cadr pat)) #'vectorp)
-                   ((compiled-function-p (cadr pat))
-                    #'compiled-function-p))))
-        (and otherpred
-             (pcase--mutually-exclusive-p (cadr upat) otherpred)))
+     ((and (eq 'pred (car-safe pat))
+           (pcase--mutually-exclusive-p (cadr upat) (cadr pat)))
       '(:pcase--fail . nil))
      ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c)))
      ;; try and preserve the info we get from that memq test.
@@ -852,7 +844,8 @@ A and B can be one of:
           '(:pcase--fail . nil))))
      ((and (eq 'quote (car-safe pat))
            (symbolp (cadr upat))
-           (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
+           (or (get (cadr upat) 'pure)  ;FIXME: Drop this `or'?
+               (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
            (get (cadr upat) 'side-effect-free)
            (ignore-errors
              (setq test (list (funcall (cadr upat) (cadr pat))))))
@@ -1124,21 +1117,36 @@ The predicate is the logical-AND of:
  - True!  (The second element can be anything, and for the sake
    of the body forms, its value is bound to the symbol `forum'.)"
   (declare (debug (pcase-QPAT)))
+  (pcase--expand-\` qpat))
+
+(defun pcase--expand-\` (qpat)
   (cond
    ((eq (car-safe qpat) '\,) (cadr qpat))
-   ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat))
+   ((or (eq (car-safe qpat) '\,@) (eq qpat '...))
+    (error "Unsupported QPAT: %S" qpat))
    ((vectorp qpat)
-    `(and (pred vectorp)
-          (app length ,(length qpat))
-          ,@(let ((upats nil))
-              (dotimes (i (length qpat))
-                (push `(app (aref _ ,i) ,(list '\` (aref qpat i)))
-                      upats))
-              (nreverse upats))))
+    (let* ((trivial t)
+           (contents nil)
+           (upats nil))
+      (dotimes (i (length qpat))
+        (let* ((upat (pcase--expand-\` (aref qpat i))))
+          (if (eq (car-safe upat) 'quote)
+              (push (cadr upat) contents)
+            (setq trivial nil))
+          (push `(app (aref _ ,i) ,upat) upats)))
+      (if trivial
+          `',(apply #'vector (nreverse contents))
+        `(and (pred vectorp)
+              (app length ,(length qpat))
+              ,@(nreverse upats)))))
    ((consp qpat)
-    `(and (pred consp)
-          (app car-safe ,(list '\` (car qpat)))
-          (app cdr-safe ,(list '\` (cdr qpat)))))
+    (let ((upata (pcase--expand-\` (car qpat)))
+          (upatd (pcase--expand-\` (cdr qpat))))
+      (if (and (eq (car-safe upata) 'quote) (eq (car-safe upatd) 'quote))
+          `'(,(cadr upata) . ,(cadr upatd))
+        `(and (pred consp)
+              (app car-safe ,upata)
+              (app cdr-safe ,upatd)))))
    ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat)
    ;; In all other cases just raise an error so we can't break
    ;; backward compatibility when adding \` support for other
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index c79adcdfec5..35cf2f93cdc 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -73,7 +73,17 @@
     (should-not (pcase-tests-grep 'member exp))))
 
 (ert-deftest pcase-tests-vectors ()
-  (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3)))
+  (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))
+  (should (pcase [1 2] (`[1 ,'2] t)))
+  (should (pcase '(1 2) (`(1 ,'2) t))))
+
+(ert-deftest pcase-tests-quote-optimization ()
+  ;; FIXME: We could/should also test that we get a corresponding
+  ;; "shadowed branch" warning.
+  (should-not (pcase-tests-grep
+               'FOO (macroexpand '(pcase EXP
+                                    (`(,_ . ,_) (BAR))
+                                    ('(a b) (FOO)))))))
 
 (ert-deftest pcase-tests-bug14773 ()
   (let ((f (lambda (x)
-- 
2.39.2