* lisp/emacs-lisp/pcase.el (pcase--let*): New function.

(pcase-let*): Use it.  Use pcase--memoize to avoid repeated expansions.
(pcase--expand): Use macroexp-let².

1 files changed, 90 insertions, 72 deletions

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 3c9e82a823..61c3aef5b2 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -61,6 +61,8 @@
 ;; memoize previous macro expansions to try and avoid recomputing them
 ;; over and over again.
 (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
+;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
+;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
 
 (defconst pcase--dontcare-upats '(t _ dontcare))
 
@@ -107,31 +109,49 @@ like `(,a . ,(pred (< a))) or, with more checks:
     (if (and (equal exp (car data)) (equal cases (cadr data)))
         ;; We have the right expansion.
         (cddr data)
+      ;; (when (gethash (car cases) pcase--memoize-1)
+      ;;   (message "pcase-memoize failed because of weak key!!"))
+      ;; (when (gethash (car cases) pcase--memoize-2)
+      ;;   (message "pcase-memoize failed because of eq test on %S"
+      ;;            (car cases)))
       (when data
         (message "pcase-memoize: equal first branch, yet different"))
       (let ((expansion (pcase--expand exp cases)))
-        (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
+        (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
+        ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
+        ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
         expansion))))
 
+(defun pcase--let* (bindings body)
+  (cond
+   ((null bindings) (macroexp-progn body))
+   ((pcase--trivial-upat-p (caar bindings))
+    (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
+   (t
+    (let ((binding (pop bindings)))
+      (pcase--expand
+       (cadr binding)
+       `((,(car binding) ,(pcase--let* bindings body))
+         ;; We can either signal an error here, or just use `dontcare' which
+         ;; generates more efficient code.  In practice, if we use `dontcare'
+         ;; we will still often get an error and the few cases where we don't
+         ;; do not matter that much, so it's a better choice.
+         (dontcare nil)))))))
+
 ;;;###autoload
 (defmacro pcase-let* (bindings &rest body)
   "Like `let*' but where you can use `pcase' patterns for bindings.
 BODY should be an expression, and BINDINGS should be a list of bindings
 of the form (UPAT EXP)."
   (declare (indent 1)
-           (debug ((&rest &or (sexp &optional form) symbolp) body)))
-  (cond
-   ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
-   ((pcase--trivial-upat-p (caar bindings))
-    `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
-   (t
-    `(pcase ,(cadr (car bindings))
-       (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
-       ;; We can either signal an error here, or just use `dontcare' which
-       ;; generates more efficient code.  In practice, if we use `dontcare' we
-       ;; will still often get an error and the few cases where we don't do not
-       ;; matter that much, so it's a better choice.
-       (dontcare nil)))))
+           (debug ((&rest (sexp &optional form)) body)))
+  (let ((cached (gethash bindings pcase--memoize)))
+    ;; cached = (BODY . EXPANSION)
+    (if (equal (car cached) body)
+        (cdr cached)
+      (let ((expansion (pcase--let* bindings body)))
+        (puthash bindings (cons body expansion) pcase--memoize)
+        expansion))))
 
 ;;;###autoload
 (defmacro pcase-let (bindings &rest body)
@@ -169,64 +189,62 @@ of the form (UPAT EXP)."
 (defun pcase--expand (exp cases)
   ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
   ;;          (emacs-pid) exp (sxhash cases))
-  (let* ((defs (if (symbolp exp) '()
-                 (let ((sym (make-symbol "x")))
-                   (prog1 `((,sym ,exp)) (setq exp sym)))))
-         (seen '())
-         (codegen
-          (lambda (code vars)
-            (let ((prev (assq code seen)))
-              (if (not prev)
-                  (let ((res (pcase-codegen code vars)))
-                    (push (list code vars res) seen)
-                    res)
-                ;; Since we use a tree-based pattern matching
-                ;; technique, the leaves (the places that contain the
-                ;; code to run once a pattern is matched) can get
-                ;; copied a very large number of times, so to avoid
-                ;; code explosion, we need to keep track of how many
-                ;; times we've used each leaf and move it
-                ;; to a separate function if that number is too high.
-                ;;
-                ;; We've already used this branch.  So it is shared.
-                (let* ((code (car prev))         (cdrprev (cdr prev))
-                       (prevvars (car cdrprev))  (cddrprev (cdr cdrprev))
-                       (res (car cddrprev)))
-                  (unless (symbolp res)
-                    ;; This is the first repeat, so we have to move
-                    ;; the branch to a separate function.
-                    (let ((bsym
-                           (make-symbol (format "pcase-%d" (length defs)))))
-                      (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
-                      (setcar res 'funcall)
-                      (setcdr res (cons bsym (mapcar #'cdr prevvars)))
-                      (setcar (cddr prev) bsym)
-                      (setq res bsym)))
-                  (setq vars (copy-sequence vars))
-                  (let ((args (mapcar (lambda (pa)
-                                        (let ((v (assq (car pa) vars)))
-                                          (setq vars (delq v vars))
-                                          (cdr v)))
-                                      prevvars)))
-                    ;; If some of `vars' were not found in `prevvars', that's
-                    ;; OK it just means those vars aren't present in all
-                    ;; branches, so they can be used within the pattern
-                    ;; (e.g. by a `guard/let/pred') but not in the branch.
-                    ;; FIXME: But if some of `prevvars' are not in `vars' we
-                    ;; should remove them from `prevvars'!
-                    `(funcall ,res ,@args)))))))
-         (main
-          (pcase--u
-           (mapcar (lambda (case)
-                     `((match ,exp . ,(car case))
-                       ,(apply-partially
-                         (if (pcase--small-branch-p (cdr case))
-                             ;; Don't bother sharing multiple
-                             ;; occurrences of this leaf since it's small.
-                             #'pcase-codegen codegen)
-                         (cdr case))))
-                   cases))))
-    (if (null defs) main
+  (macroexp-let² macroexp-copyable-p val exp
+    (let* ((defs ())
+           (seen '())
+           (codegen
+            (lambda (code vars)
+              (let ((prev (assq code seen)))
+                (if (not prev)
+                    (let ((res (pcase-codegen code vars)))
+                      (push (list code vars res) seen)
+                      res)
+                  ;; Since we use a tree-based pattern matching
+                  ;; technique, the leaves (the places that contain the
+                  ;; code to run once a pattern is matched) can get
+                  ;; copied a very large number of times, so to avoid
+                  ;; code explosion, we need to keep track of how many
+                  ;; times we've used each leaf and move it
+                  ;; to a separate function if that number is too high.
+                  ;;
+                  ;; We've already used this branch.  So it is shared.
+                  (let* ((code (car prev))         (cdrprev (cdr prev))
+                         (prevvars (car cdrprev))  (cddrprev (cdr cdrprev))
+                         (res (car cddrprev)))
+                    (unless (symbolp res)
+                      ;; This is the first repeat, so we have to move
+                      ;; the branch to a separate function.
+                      (let ((bsym
+                             (make-symbol (format "pcase-%d" (length defs)))))
+                        (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
+                        (setcar res 'funcall)
+                        (setcdr res (cons bsym (mapcar #'cdr prevvars)))
+                        (setcar (cddr prev) bsym)
+                        (setq res bsym)))
+                    (setq vars (copy-sequence vars))
+                    (let ((args (mapcar (lambda (pa)
+                                          (let ((v (assq (car pa) vars)))
+                                            (setq vars (delq v vars))
+                                            (cdr v)))
+                                        prevvars)))
+                      ;; If some of `vars' were not found in `prevvars', that's
+                      ;; OK it just means those vars aren't present in all
+                      ;; branches, so they can be used within the pattern
+                      ;; (e.g. by a `guard/let/pred') but not in the branch.
+                      ;; FIXME: But if some of `prevvars' are not in `vars' we
+                      ;; should remove them from `prevvars'!
+                      `(funcall ,res ,@args)))))))
+           (main
+            (pcase--u
+             (mapcar (lambda (case)
+                       `((match ,val . ,(car case))
+                         ,(apply-partially
+                           (if (pcase--small-branch-p (cdr case))
+                               ;; Don't bother sharing multiple
+                               ;; occurrences of this leaf since it's small.
+                               #'pcase-codegen codegen)
+                           (cdr case))))
+                     cases))))
       (macroexp-let* defs main))))
 
 (defun pcase-codegen (code vars)