Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk

8 files changed, 248 insertions, 179 deletions

diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 2a3efbe5a1b..439d3bd363e 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -31,6 +31,8 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'subr-x))   ;For `named-let'.
+
 (defmacro benchmark-elapse (&rest forms)
   "Return the time in seconds elapsed for execution of FORMS."
   (declare (indent 0) (debug t))
@@ -41,6 +43,61 @@
        (float-time (time-since ,t1)))))
 
 ;;;###autoload
+(defun benchmark-call (func &optional repetitions)
+  "Measure the run time of calling FUNC a number REPETITIONS of times.
+The result is a list (TIME GC GCTIME)
+where TIME is the total time it took, in seconds.
+GCTIME is the amount of time that was spent in the GC
+and GC is the number of times the GC was called.
+
+REPETITIONS can also be a floating point number, in which case it
+specifies a minimum number of seconds that the benchmark execution
+should take.  In that case the return value is prepended with the
+number of repetitions actually used."
+  (if (floatp repetitions)
+      (benchmark--adaptive func repetitions)
+    (unless repetitions (setq repetitions 1))
+    (let ((gc gc-elapsed)
+	  (gcs gcs-done)
+	  (empty-func (lambda () 'empty-func)))
+      (list
+       (if (> repetitions 1)
+	   (- (benchmark-elapse (dotimes (_ repetitions) (funcall func)))
+	      (benchmark-elapse (dotimes (_ repetitions) (funcall empty-func))))
+	 (- (benchmark-elapse (funcall func))
+            (benchmark-elapse (funcall empty-func))))
+       (- gcs-done gcs)
+       (- gc-elapsed gc)))))
+
+(defun benchmark--adaptive (func time)
+  "Measure the run time of FUNC, calling it enough times to last TIME seconds.
+Result is (REPETITIONS . DATA) where DATA is as returned by `branchmark-call'."
+  (named-let loop ((repetitions 1)
+                   (data (let ((x (list 0))) (setcdr x x) x)))
+    ;; (message "Running %d iteration" repetitions)
+    (let ((newdata (benchmark-call func repetitions)))
+      (if (<= (car newdata) 0)
+          ;; This can happen if we're unlucky, e.g. the process got preempted
+          ;; (or the GC ran) just during the empty-func loop.
+          ;; Just try again, hopefully this won't repeat itself.
+          (progn
+            ;; (message "Ignoring the %d iterations" repetitions)
+            (loop (* 2 repetitions) data))
+        (let* ((sum (cl-mapcar #'+ data (cons repetitions newdata)))
+               (totaltime (nth 1 sum)))
+          (if (>= totaltime time)
+              sum
+            (let* ((iter-time (/ totaltime (car sum)))
+                   (missing-time (- time totaltime))
+                   (missing-iter (/ missing-time iter-time)))
+              ;; `iter-time' is approximate because of effects like the GC,
+              ;; so multiply at most by 10, in case we are wildly off the mark.
+              (loop (max repetitions
+                         (min (ceiling missing-iter)
+                              (* 10 repetitions)))
+                    sum))))))))
+
+;;;###autoload
 (defmacro benchmark-run (&optional repetitions &rest forms)
   "Time execution of FORMS.
 If REPETITIONS is supplied as a number, run FORMS that many times,
@@ -53,20 +110,7 @@ See also `benchmark-run-compiled'."
   (unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
     (setq forms (cons repetitions forms)
 	  repetitions 1))
-  (let ((i (make-symbol "i"))
-	(gcs (make-symbol "gcs"))
-	(gc (make-symbol "gc")))
-    `(let ((,gc gc-elapsed)
-	   (,gcs gcs-done))
-       (list ,(if (or (symbolp repetitions) (> repetitions 1))
-		  ;; Take account of the loop overhead.
-		  `(- (benchmark-elapse (dotimes (,i ,repetitions)
-					  ,@forms))
-		      (benchmark-elapse (dotimes (,i ,repetitions)
-                                          nil)))
-		`(benchmark-elapse ,@forms))
-	     (- gcs-done ,gcs)
-	     (- gc-elapsed ,gc)))))
+  `(benchmark-call (lambda () ,@forms) ,repetitions))
 
 ;;;###autoload
 (defmacro benchmark-run-compiled (&optional repetitions &rest forms)
@@ -78,21 +122,7 @@ result.  The overhead of the `lambda's is accounted for."
   (unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
     (setq forms (cons repetitions forms)
 	  repetitions 1))
-  (let ((i (make-symbol "i"))
-	(gcs (make-symbol "gcs"))
-	(gc (make-symbol "gc"))
-	(code (byte-compile `(lambda () ,@forms)))
-        (lambda-code (byte-compile '(lambda ()))))
-    `(let ((,gc gc-elapsed)
-	   (,gcs gcs-done))
-       (list ,(if (or (symbolp repetitions) (> repetitions 1))
-		  ;; Take account of the loop overhead.
-		  `(- (benchmark-elapse (dotimes (,i ,repetitions)
-					  (funcall ,code)))
-		      (benchmark-elapse (dotimes (,i ,repetitions)
-					  (funcall ,lambda-code))))
-		`(benchmark-elapse (funcall ,code)))
-	     (- gcs-done ,gcs) (- gc-elapsed ,gc)))))
+  `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions))
 
 ;;;###autoload
 (defun benchmark (repetitions form)
@@ -100,9 +130,15 @@ result.  The overhead of the `lambda's is accounted for."
 Interactively, REPETITIONS is taken from the prefix arg, and
 the command prompts for the form to benchmark.
 For non-interactive use see also `benchmark-run' and
-`benchmark-run-compiled'."
+`benchmark-run-compiled'.
+FORM can also be a function in which case we measure the time it takes
+to call it without any argument."
   (interactive "p\nxForm: ")
-  (let ((result (eval `(benchmark-run ,repetitions ,form) t)))
+  (let ((result (benchmark-call (eval (pcase form
+                                        ((or `#',_ `(lambda . ,_)) form)
+                                        (_ `(lambda () ,form)))
+                                      t)
+                                repetitions)))
     (if (zerop (nth 1 result))
 	(message "Elapsed time: %fs" (car result))
       (message "Elapsed time: %fs (%fs in %d GCs)" (car result)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 74eb5b0377f..0babbbb978d 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -548,6 +548,10 @@ has the form (autoload . FILENAME).")
 
 (defvar byte-compile-unresolved-functions nil
   "Alist of undefined functions to which calls have been compiled.
+Each element in the list has the form (FUNCTION POSITION . CALLS)
+where CALLS is a list whose elements are integers (indicating the
+number of arguments passed in the function call) or the constant `t'
+if the function is called indirectly.
 This variable is only significant whilst compiling an entire buffer.
 Used for warnings when a function is not known to be defined or is later
 defined with incorrect args.")
@@ -1423,9 +1427,9 @@ when printing the error message."
       ;; Remember number of args in call.
       (let ((cons (assq f byte-compile-unresolved-functions)))
         (if cons
-            (or (memq nargs (cdr cons))
-                (push nargs (cdr cons)))
-          (push (list f nargs)
+            (or (memq nargs (cddr cons))
+                (push nargs (cddr cons)))
+          (push (list f byte-compile-last-position nargs)
                 byte-compile-unresolved-functions)))))
 
 ;; Warn if the form is calling a function with the wrong number of arguments.
@@ -1525,14 +1529,14 @@ extra args."
     (setq byte-compile-unresolved-functions
           (delq calls byte-compile-unresolved-functions))
     (setq calls (delq t calls))      ;Ignore higher-order uses of the function.
-    (when (cdr calls)
+    (when (cddr calls)
       (when (and (symbolp name)
                  (eq (function-get name 'byte-optimizer)
                      'byte-compile-inline-expand))
         (byte-compile-warn "defsubst `%s' was used before it was defined"
                            name))
       (setq sig (byte-compile-arglist-signature arglist)
-            nums (sort (copy-sequence (cdr calls)) (function <))
+            nums (sort (copy-sequence (cddr calls)) (function <))
             min (car nums)
             max (car (nreverse nums)))
       (when (or (< min (car sig))
@@ -1640,56 +1644,21 @@ It is too wide if it has any lines longer than the largest of
                            kind name col))))
   form)
 
-(defun byte-compile-print-syms (str1 strn syms)
-  (when syms
-    (byte-compile-set-symbol-position (car syms) t))
-  (cond ((and (cdr syms) (not noninteractive))
-	 (let* ((str strn)
-		(L (length str))
-		s)
-	   (while syms
-	     (setq s (symbol-name (pop syms))
-		   L (+ L (length s) 2))
-	     (if (< L (1- (buffer-local-value 'fill-column
-                                              (or (get-buffer
-                                                   byte-compile-log-buffer)
-                                                  (current-buffer)))))
-		 (setq str (concat str " " s (and syms ",")))
-	       (setq str (concat str "\n    " s (and syms ","))
-		     L (+ (length s) 4))))
-	   (byte-compile-warn "%s" str)))
-	((cdr syms)
-	 (byte-compile-warn "%s %s"
-			    strn
-			    (mapconcat #'symbol-name syms ", ")))
-
-	(syms
-	 (byte-compile-warn str1 (car syms)))))
-
 ;; If we have compiled any calls to functions which are not known to be
 ;; defined, issue a warning enumerating them.
 ;; `unresolved' in the list `byte-compile-warnings' disables this.
 (defun byte-compile-warn-about-unresolved-functions ()
   (when (byte-compile-warning-enabled-p 'unresolved)
-    (let ((byte-compile-current-form :end)
-	  (noruntime nil)
-	  (unresolved nil))
+    (let ((byte-compile-current-form :end))
       ;; Separate the functions that will not be available at runtime
       ;; from the truly unresolved ones.
-      (dolist (f byte-compile-unresolved-functions)
-        (setq f (car f))
-        (when (not (memq f byte-compile-new-defuns))
-          (if (fboundp f) (push f noruntime) (push f unresolved))))
-      ;; Complain about the no-run-time functions
-      (byte-compile-print-syms
-       "the function `%s' might not be defined at runtime."
-       "the following functions might not be defined at runtime:"
-       noruntime)
-      ;; Complain about the unresolved functions
-      (byte-compile-print-syms
-       "the function `%s' is not known to be defined."
-       "the following functions are not known to be defined:"
-       unresolved)))
+      (dolist (urf byte-compile-unresolved-functions)
+        (let ((f (car urf)))
+          (when (not (memq f byte-compile-new-defuns))
+            (let ((byte-compile-last-position (cadr urf)))
+              (byte-compile-warn
+               (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.")
+               (car urf))))))))
   nil)
 
 
@@ -4912,10 +4881,10 @@ binding slots have been popped."
      (byte-compile-push-constant op)
      (byte-compile-form fun)
      (byte-compile-form prop)
-     (let* ((fun (eval fun))
-            (prop (eval prop))
+     (let* ((fun (eval fun t))
+            (prop (eval prop t))
             (val (if (macroexp-const-p val)
-                     (eval val)
+                     (eval val t)
                    (byte-compile-lambda (cadr val)))))
        (push `(,fun
                . (,prop ,val ,@(alist-get fun overriding-plist-environment)))
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 40c17b916f9..5afc6d3bde3 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -89,33 +89,39 @@ Useful if new Emacs is used on B&W display.")
 
 (declare-function x-display-color-cells "xfns.c" (&optional terminal))
 
-(defvar chart-face-list
-  (if (display-color-p)
-      (let ((cl chart-face-color-list)
-            (pl chart-face-pixmap-list)
-            (faces ())
-            nf)
-        (while cl
-          (setq nf (make-face
-                    (intern (concat "chart-" (car cl) "-" (car pl)))))
-          (set-face-background nf (if (condition-case nil
-                                          (> (x-display-color-cells) 4)
-                                        (error t))
-                                      (car cl)
-                                    "white"))
-          (set-face-foreground nf "black")
-          (if (and chart-face-use-pixmaps pl)
-              (condition-case nil
-                  (set-face-background-pixmap nf (car pl))
-                (error (message "Cannot set background pixmap %s" (car pl)))))
-          (push nf faces)
-          (setq cl (cdr cl)
-                pl (cdr pl)))
-        faces))
+(defvar chart-face-list #'chart--face-list
   "Faces used to colorize charts.
+This should either be a list of faces, or a function that returns
+a list of faces.
+
 List is limited currently, which is ok since you really can't display
 too much in text characters anyways.")
 
+(defun chart--face-list ()
+  (and
+   (display-color-p)
+   (let ((cl chart-face-color-list)
+         (pl chart-face-pixmap-list)
+         (faces ())
+         nf)
+     (while cl
+       (setq nf (make-face
+                 (intern (concat "chart-" (car cl) "-" (car pl)))))
+       (set-face-background nf (if (condition-case nil
+                                       (> (x-display-color-cells) 4)
+                                     (error t))
+                                   (car cl)
+                                 "white"))
+       (set-face-foreground nf "black")
+       (if (and chart-face-use-pixmaps pl)
+           (condition-case nil
+               (set-face-background-pixmap nf (car pl))
+             (error (message "Cannot set background pixmap %s" (car pl)))))
+       (push nf faces)
+       (setq cl (cdr cl)
+             pl (cdr pl)))
+     faces)))
+
 (define-derived-mode chart-mode special-mode "Chart"
   "Define a mode in Emacs for displaying a chart."
   (buffer-disable-undo)
@@ -374,7 +380,10 @@ of the drawing."
   (let* ((data (oref c sequences))
 	 (dir (oref c direction))
 	 (odir (if (eq dir 'vertical) 'horizontal 'vertical))
-	)
+         (faces
+          (if (functionp chart-face-list)
+              (funcall chart-face-list)
+            chart-face-list)))
     (while data
       (if (stringp (car (oref (car data) data)))
 	  ;; skip string lists...
@@ -390,10 +399,9 @@ of the drawing."
 		  (zp (if (eq dir 'vertical)
 			  (chart-translate-ypos c 0)
 			(chart-translate-xpos c 0)))
-		  (fc (if chart-face-list
-			  (nth (% i (length chart-face-list)) chart-face-list)
-			'default))
-		  )
+		  (fc (if faces
+			  (nth (% i (length faces)) faces)
+			'default)))
 	      (if (< dp zp)
 		  (progn
 		    (chart-draw-line dir (car rng) dp zp)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c38dc44ff60..27ed07b6673 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1976,7 +1976,8 @@ a `let' form, except that the list of symbols can be computed at run-time."
               (,binds ()))
          (while ,syms
            (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
-         (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
+         (eval (list 'let (nreverse ,binds)
+                     (list 'funcall (list 'quote ,bodyfun))))))))
 
 (defconst cl--labels-magic (make-symbol "cl--labels-magic"))
 
@@ -2068,6 +2069,8 @@ Like `cl-flet' but the definitions can refer to previous ones.
   ;; even handle mutually recursive functions.
   (letrec
       ((done nil) ;; Non-nil if some TCO happened.
+       ;; This var always holds the value `nil' until (just before) we
+       ;; exit the loop.
        (retvar (make-symbol "retval"))
        (ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s
                                 (make-symbol (symbol-name s))))
@@ -2100,6 +2103,12 @@ Like `cl-flet' but the definitions can refer to previous ones.
             (`(progn . ,exps) `(progn . ,(funcall opt-exps exps)))
             (`(if ,cond ,then . ,else)
              `(if ,cond ,(funcall opt then) . ,(funcall opt-exps else)))
+            (`(and  . ,exps) `(and . ,(funcall opt-exps exps)))
+            (`(or ,arg) (funcall opt arg))
+            (`(or ,arg . ,args)
+             (let ((val (make-symbol "val")))
+               `(let ((,val ,arg))
+                  (if ,val ,(funcall opt val) ,(funcall opt `(or . ,args))))))
             (`(cond . ,conds)
              (let ((cs '()))
                (while conds
@@ -2109,14 +2118,18 @@ Like `cl-flet' but the definitions can refer to previous ones.
                               ;; This returns the value of `exp' but it's
                               ;; only in tail position if it's the
                               ;; last condition.
+                              ;; Note: This may set the var before we
+                              ;; actually exit the loop, but luckily it's
+                              ;; only the case if we set the var to nil,
+                              ;; so it does preserve the invariant that
+                              ;; the var is nil until we exit the loop.
                               `((setq ,retvar ,exp) nil)
                             `(,(funcall opt exp)))
                           cs))
                    (exps
                     (push (funcall opt-exps exps) cs))))
-               (if (eq t (caar cs))
-                   `(cond . ,(nreverse cs))
-                 `(cond ,@(nreverse cs) (t (setq ,retvar nil))))))
+               ;; No need to set `retvar' to return nil.
+               `(cond . ,(nreverse cs))))
             ((and `(,(or 'let 'let*) ,bindings . ,exps)
                   (guard
                    ;; Note: it's OK for this `let' to shadow any
@@ -2128,8 +2141,8 @@ Like `cl-flet' but the definitions can refer to previous ones.
                      ;; tail-called any more.
                      (not (memq var shadowings)))))
              `(,(car exp) ,bindings . ,(funcall opt-exps exps)))
-            (_
-             `(progn (setq ,retvar ,exp) nil))))))
+            ('nil nil)  ;No need to set `retvar' to return nil.
+            (_ `(progn (setq ,retvar ,exp) nil))))))
 
     (let ((optimized-body (funcall opt-exps body)))
       (if (not done)
@@ -2275,7 +2288,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros."
             ;; on this behavior (haven't found any yet).
             ;; Such code should explicitly use `cl-letf' instead, I think.
             ;;
-            ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+            ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare))
             ;;  (let ((letf nil) (found nil) (nbs ()))
             ;;    (dolist (binding bindings)
             ;;      (let* ((var (if (symbolp binding) binding (car binding)))
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index e45260c32ac..4ae20ba4205 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -1,6 +1,6 @@
 ;;; generator.el --- generators  -*- lexical-binding: t -*-
 
-;;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2021  Free Software Foundation, Inc.
 
 ;; Author: Daniel Colascione <dancol@dancol.org>
 ;; Keywords: extensions, elisp
diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el
index 3d6ca957e63..ecbca280e59 100644
--- a/lisp/emacs-lisp/memory-report.el
+++ b/lisp/emacs-lisp/memory-report.el
@@ -295,7 +295,7 @@ by counted more than once."
 	       (- (position-bytes (point-min)))
 	       (gap-size)))
           (seq-reduce #'+ (mapcar (lambda (elem)
-                                    (if (cdr elem)
+                                    (if (and (consp elem) (cdr elem))
                                         (memory-report--object-size
                                          (make-hash-table :test #'eq)
                                          (cdr elem))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 0973963af22..2ecd92cee9d 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2206,10 +2206,13 @@ directory."
     (package-install-from-buffer)))
 
 ;;;###autoload
-(defun package-install-selected-packages ()
+(defun package-install-selected-packages (&optional noconfirm)
   "Ensure packages in `package-selected-packages' are installed.
-If some packages are not installed propose to install them."
+If some packages are not installed, propose to install them.
+If optional argument NOCONFIRM is non-nil, don't ask for
+confirmation to install packages."
   (interactive)
+  (package--archives-initialize)
   ;; We don't need to populate `package-selected-packages' before
   ;; using here, because the outcome is the same either way (nothing
   ;; gets installed).
@@ -2220,10 +2223,11 @@ If some packages are not installed propose to install them."
            (difference (- (length not-installed) (length available))))
       (cond
        (available
-        (when (y-or-n-p
-               (format "Packages to install: %d (%s), proceed? "
-                       (length available)
-                       (mapconcat #'symbol-name available " ")))
+        (when (or noconfirm
+                  (y-or-n-p
+                   (format "Packages to install: %d (%s), proceed? "
+                           (length available)
+                           (mapconcat #'symbol-name available " "))))
           (mapc (lambda (p) (package-install p 'dont-select)) available)))
        ((> difference 0)
         (message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'"
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 5342a0179d9..006517db759 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -207,6 +207,7 @@ If EXP fails to match any of the patterns in CASES, an error is signaled."
          (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
     (pcase--expand
      ;; FIXME: Could we add the FILE:LINE data in the error message?
+     ;; FILE is available from `macroexp-file-name'.
      exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
 
 ;;;###autoload
@@ -320,34 +321,46 @@ of the elements of LIST is performed as if by `pcase-let'.
 (defun pcase--trivial-upat-p (upat)
   (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
 
-(defun pcase--expand (exp cases)
-  ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
-  ;;          (emacs-pid) exp (sxhash cases))
+(defun pcase-compile-patterns (exp cases)
+  "Compile the set of patterns in CASES.
+EXP is the expression that will be matched against the patterns.
+CASES is a list of elements (PAT . CODEGEN)
+where CODEGEN is a function that returns the code to use when
+PAT matches.  That code has to be in the form of a cons cell.
+
+CODEGEN will be called with at least 2 arguments, VARVALS and COUNT.
+VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR
+is a variable bound by the pattern and VAL is a duplicable expression
+that returns the value this variable should be bound to.
+If the pattern PAT uses `or', CODEGEN may be called multiple times,
+in which case it may want to generate the code differently to avoid
+a potential code explosion.  For this reason the COUNT argument indicates
+how many time this CODEGEN is called."
   (macroexp-let2 macroexp-copyable-p val exp
-    (let* ((defs ())
-           (seen '())
+    (let* ((seen '())
+           (phcounter 0)
            (main
             (pcase--u
              (mapcar
               (lambda (case)
                 `(,(pcase--match val (pcase--macroexpand (car case)))
                   ,(lambda (vars)
-                     (let ((prev (assq case seen))
-                           (code (cdr case)))
+                     (let ((prev (assq case seen)))
                        (unless prev
                          ;; Keep track of the cases that are used.
                          (push (setq prev (list case)) seen))
-                       (if (member code '(nil (nil))) nil
-                         ;; Put `code' in the cdr just so that not all
-                         ;; branches look identical (to avoid things like
-                         ;; `macroexp--if' optimizing them too optimistically).
-                         (let ((ph (list 'pcase--placeholder code)))
-                           (setcdr prev (cons (cons vars ph) (cdr prev)))
-                           ph))))))
+                       ;; Put a counter in the cdr just so that not
+                       ;; all branches look identical (to avoid things
+                       ;; like `macroexp--if' optimizing them too
+                       ;; optimistically).
+                       (let ((ph (cons 'pcase--placeholder
+                                       (setq phcounter (1+ phcounter)))))
+                         (setcdr prev (cons (cons vars ph) (cdr prev)))
+                         ph)))))
               cases))))
       ;; Take care of the place holders now.
       (dolist (branch seen)
-        (let ((code (cdar branch))
+        (let ((codegen (cdar branch))
               (uses (cdr branch)))
           ;; Find all the vars that are in scope (the union of the
           ;; vars provided in each use case).
@@ -358,48 +371,74 @@ of the elements of LIST is performed as if by `pcase-let'.
                           (if vi
                               (if (cddr v) (setcdr vi 'used))
                             (push (cons (car v) (cddr v)) allvarinfo))))))
-                 (allvars (mapcar #'car allvarinfo))
-                 (ignores (mapcar (lambda (vi) (when (cdr vi) `(ignore ,(car vi))))
-                                  allvarinfo)))
-            ;; 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.
-            (if (or (null (cdr uses)) (pcase--small-branch-p code))
-                (dolist (use uses)
-                  (let ((vars (car use))
-                        (placeholder (cdr use)))
-                    ;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
-                    (setcar placeholder 'let)
-                    (setcdr placeholder
-                            `(,(mapcar (lambda (v) (list v (cadr (assq v vars))))
-                                       allvars)
-                              ;; Try and silence some of the most common
-                              ;; spurious "unused var" warnings.
-                              ,@ignores
-                              ,@code))))
-              ;; Several occurrence of this non-small branch in the output.
-              (let ((bsym
-                     (make-symbol (format "pcase-%d" (length defs)))))
-                (push `(,bsym (lambda ,allvars ,@ignores ,@code)) defs)
-                (dolist (use uses)
-                  (let ((vars (car use))
-                        (placeholder (cdr use)))
-                    ;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
-                    (setcar placeholder 'funcall)
-                    (setcdr placeholder
-                            `(,bsym
-                              ,@(mapcar (lambda (v) (cadr (assq v vars)))
-                                        allvars))))))))))
+                 (allvars (mapcar #'car allvarinfo)))
+            (dolist (use uses)
+              (let* ((vars (car use))
+                     (varvals
+                      (mapcar (lambda (v)
+                                `(,v ,(cadr (assq v vars))
+                                     ,(cdr (assq v allvarinfo))))
+                              allvars))
+                     (placeholder (cdr use))
+                     (code (funcall codegen varvals (length uses))))
+                ;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
+                (setcar placeholder (car code))
+                (setcdr placeholder (cdr code)))))))
       (dolist (case cases)
         (unless (or (assq case seen)
                     (memq (car case) pcase--dontwarn-upats))
-          (message "pcase pattern %S shadowed by previous pcase pattern"
-                   (car case))))
-      (macroexp-let* defs main))))
+          (setq main
+                (macroexp-warn-and-return
+                 (format "pcase pattern %S shadowed by previous pcase pattern"
+                         (car case))
+                 main))))
+      main)))
+
+(defun pcase--expand (exp cases)
+  ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
+  ;;          (emacs-pid) exp (sxhash cases))
+  (let* ((defs ())
+         (codegen
+          (lambda (code)
+            (if (member code '(nil (nil) ('nil)))
+                (lambda (&rest _) ''nil)
+              (let ((bsym ()))
+                (lambda (varvals count &rest _)
+                  (let* ((ignored-vars
+                          (delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv)))
+                                            varvals)))
+                         (ignores (if ignored-vars
+                                      `((ignore . ,ignored-vars)))))
+                    ;; 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.
+                    (if (or (< count 2) (pcase--small-branch-p code))
+                        `(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv)))
+                                       varvals)
+                           ;; Try and silence some of the most common
+                           ;; spurious "unused var" warnings.
+                           ,@ignores
+                           ,@code)
+                    ;; Several occurrence of this non-small branch in
+                    ;; the output.
+                    (unless bsym
+                      (setq bsym (make-symbol
+                                  (format "pcase-%d" (length defs))))
+                      (push `(,bsym (lambda ,(mapcar #'car varvals)
+                                      ,@ignores ,@code))
+                            defs))
+                    `(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
+         (main
+          (pcase-compile-patterns
+           exp
+           (mapcar (lambda (case)
+                     (cons (car case) (funcall codegen (cdr case))))
+                   cases))))
+    (macroexp-let* defs main)))
 
 (defun pcase--macroexpand (pat)
   "Expands all macro-patterns in PAT."