Merge remote-tracking branch 'savannah/master' into native-comp

10 files changed, 810 insertions, 712 deletions

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index cf89456541e..66a117fccc8 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -284,8 +284,10 @@
                           ;; If `fn' is from the same file, it has already
                           ;; been preprocessed!
                           `(function ,fn)
-                        (byte-compile-preprocess
-                         (byte-compile--reify-function fn)))))
+                        ;; Try and process it "in its original environment".
+                        (let ((byte-compile-bound-variables nil))
+                          (byte-compile-preprocess
+                           (byte-compile--reify-function fn))))))
            (if (eq (car-safe newfn) 'function)
                (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
              ;; This can happen because of macroexp-warn-and-return &co.
@@ -374,185 +376,184 @@
   ;; the important aspect is that they are subrs that don't evaluate all of
   ;; their args.)
   ;;
-  (let ((fn (car-safe form))
-	tmp)
-    (cond ((not (consp form))
-	   (if (not (and for-effect
-			 (or byte-compile-delete-errors
-			     (not (symbolp form))
-			     (eq form t))))
-	     form))
-	  ((eq fn 'quote)
-	   (if (cdr (cdr form))
-	       (byte-compile-warn "malformed quote form: `%s'"
-				  (prin1-to-string form)))
-	   ;; map (quote nil) to nil to simplify optimizer logic.
-	   ;; map quoted constants to nil if for-effect (just because).
-	   (and (nth 1 form)
-		(not for-effect)
-		form))
-	  ((memq fn '(let let*))
-	   ;; recursively enter the optimizer for the bindings and body
-	   ;; of a let or let*.  This for depth-firstness: forms that
-	   ;; are more deeply nested are optimized first.
-	   (cons fn
+  ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably
+  ;; have no place in an optimizer: the corresponding tests should be
+  ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'.
+  (let ((fn (car-safe form)))
+    (pcase form
+      ((pred (not consp))
+       (if (not (and for-effect
+		     (or byte-compile-delete-errors
+			 (not (symbolp form))
+			 (eq form t))))
+	   form))
+      (`(quote . ,v)
+       (if (cdr v)
+	   (byte-compile-warn "malformed quote form: `%s'"
+			      (prin1-to-string form)))
+       ;; Map (quote nil) to nil to simplify optimizer logic.
+       ;; Map quoted constants to nil if for-effect (just because).
+       (and (car v)
+	    (not for-effect)
+	    form))
+      (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare))
+       ;; Recursively enter the optimizer for the bindings and body
+       ;; of a let or let*.  This for depth-firstness: forms that
+       ;; are more deeply nested are optimized first.
+       (cons fn
 	     (cons
 	      (mapcar (lambda (binding)
-			 (if (symbolp binding)
-			     binding
-			   (if (cdr (cdr binding))
-			       (byte-compile-warn "malformed let binding: `%s'"
-						  (prin1-to-string binding)))
-			   (list (car binding)
-				 (byte-optimize-form (nth 1 binding) nil))))
-		      (nth 1 form))
-	      (byte-optimize-body (cdr (cdr form)) for-effect))))
-	  ((eq fn 'cond)
-	   (cons fn
-		 (mapcar (lambda (clause)
-			    (if (consp clause)
-				(cons
-				 (byte-optimize-form (car clause) nil)
-				 (byte-optimize-body (cdr clause) for-effect))
-			      (byte-compile-warn "malformed cond form: `%s'"
-						 (prin1-to-string clause))
-			      clause))
-			 (cdr form))))
-	  ((eq fn 'progn)
-	   ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
-	   (if (cdr (cdr form))
-               (macroexp-progn (byte-optimize-body (cdr form) for-effect))
-	     (byte-optimize-form (nth 1 form) for-effect)))
-	  ((eq fn 'prog1)
-	   (if (cdr (cdr form))
-	       (cons 'prog1
-		     (cons (byte-optimize-form (nth 1 form) for-effect)
-			   (byte-optimize-body (cdr (cdr form)) t)))
-	     (byte-optimize-form (nth 1 form) for-effect)))
-
-	  ((memq fn '(save-excursion save-restriction save-current-buffer))
-	   ;; those subrs which have an implicit progn; it's not quite good
-	   ;; enough to treat these like normal function calls.
-	   ;; This can turn (save-excursion ...) into (save-excursion) which
-	   ;; will be optimized away in the lap-optimize pass.
-	   (cons fn (byte-optimize-body (cdr form) for-effect)))
-
-	  ((eq fn 'if)
-	   (when (< (length form) 3)
-	     (byte-compile-warn "too few arguments for `if'"))
-	   (cons fn
-	     (cons (byte-optimize-form (nth 1 form) nil)
-	       (cons
-		(byte-optimize-form (nth 2 form) for-effect)
-		(byte-optimize-body (nthcdr 3 form) for-effect)))))
-
-	  ((memq fn '(and or))  ; Remember, and/or are control structures.
-	   ;; Take forms off the back until we can't any more.
-	   ;; In the future it could conceivably be a problem that the
-	   ;; subexpressions of these forms are optimized in the reverse
-	   ;; order, but it's ok for now.
-	   (if for-effect
-	       (let ((backwards (reverse (cdr form))))
-		 (while (and backwards
-			     (null (setcar backwards
-					   (byte-optimize-form (car backwards)
-							       for-effect))))
-		   (setq backwards (cdr backwards)))
-		 (if (and (cdr form) (null backwards))
-		     (byte-compile-log
-		      "  all subforms of %s called for effect; deleted" form))
-		 (and backwards
-		      (cons fn (nreverse (mapcar 'byte-optimize-form
-                                                 backwards)))))
-	     (cons fn (mapcar 'byte-optimize-form (cdr form)))))
-
-	  ((eq fn 'while)
-           (unless (consp (cdr form))
-	     (byte-compile-warn "too few arguments for `while'"))
-           (cons fn
-                 (cons (byte-optimize-form (cadr form) nil)
-                       (byte-optimize-body (cddr form) t))))
-
-	  ((eq fn 'interactive)
-	   (byte-compile-warn "misplaced interactive spec: `%s'"
-			      (prin1-to-string form))
-	   nil)
-
-	  ((eq fn 'function)
-	   ;; This forms is compiled as constant or by breaking out
-	   ;; all the subexpressions and compiling them separately.
-	   form)
-
-	  ((eq fn 'condition-case)
-           `(condition-case ,(nth 1 form) ;Not evaluated.
-                ,(byte-optimize-form (nth 2 form) for-effect)
-              ,@(mapcar (lambda (clause)
-                          `(,(car clause)
-                            ,@(byte-optimize-body (cdr clause) for-effect)))
-                        (nthcdr 3 form))))
-
-	  ((eq fn 'unwind-protect)
-	   ;; the "protected" part of an unwind-protect is compiled (and thus
-	   ;; optimized) as a top-level form, so don't do it here.  But the
-	   ;; non-protected part has the same for-effect status as the
-	   ;; unwind-protect itself.  (The protected part is always for effect,
-	   ;; but that isn't handled properly yet.)
-	   (cons fn
-		 (cons (byte-optimize-form (nth 1 form) for-effect)
-		       (cdr (cdr form)))))
-
-	  ((eq fn 'catch)
-	   (cons fn
-		 (cons (byte-optimize-form (nth 1 form) nil)
-                       (byte-optimize-body (cdr form) for-effect))))
-
-	  ((eq fn 'ignore)
-	   ;; Don't treat the args to `ignore' as being
-	   ;; computed for effect.  We want to avoid the warnings
-	   ;; that might occur if they were treated that way.
-	   ;; However, don't actually bother calling `ignore'.
-	   `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
-
-          ;; Needed as long as we run byte-optimize-form after cconv.
-          ((eq fn 'internal-make-closure) form)
-
-	  ((eq (car-safe fn) 'lambda)
-	   (let ((newform (byte-compile-unfold-lambda form)))
-	     (if (eq newform form)
-		 ;; Some error occurred, avoid infinite recursion
-		 form
-	       (byte-optimize-form newform for-effect))))
-
-	  ((eq (car-safe fn) 'closure) form)
-
-          ((byte-code-function-p fn)
-           (cons fn (mapcar #'byte-optimize-form (cdr form))))
-
-	  ((not (symbolp fn))
-	   (byte-compile-warn "`%s' is a malformed function"
-			      (prin1-to-string fn))
-	   form)
-
-	  ((and for-effect (setq tmp (get fn 'side-effect-free))
-		(or byte-compile-delete-errors
-		    (eq tmp 'error-free)
-		    (progn
-		      (byte-compile-warn "value returned from %s is unused"
-					 (prin1-to-string form))
-		      nil)))
-	   (byte-compile-log "  %s called for effect; deleted" fn)
-	   ;; appending a nil here might not be necessary, but it can't hurt.
-	   (byte-optimize-form
-	    (cons 'progn (append (cdr form) '(nil))) t))
+			(if (symbolp binding)
+			    binding
+			  (if (cdr (cdr binding))
+			      (byte-compile-warn "malformed let binding: `%s'"
+						 (prin1-to-string binding)))
+			  (list (car binding)
+				(byte-optimize-form (nth 1 binding) nil))))
+		      bindings)
+	      (byte-optimize-body exps for-effect))))
+      (`(cond . ,clauses)
+       (cons fn
+	     (mapcar (lambda (clause)
+		       (if (consp clause)
+			   (cons
+			    (byte-optimize-form (car clause) nil)
+			    (byte-optimize-body (cdr clause) for-effect))
+			 (byte-compile-warn "malformed cond form: `%s'"
+					    (prin1-to-string clause))
+			 clause))
+		     clauses)))
+      (`(progn . ,exps)
+       ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
+       (if (cdr exps)
+           (macroexp-progn (byte-optimize-body exps for-effect))
+	 (byte-optimize-form (car exps) for-effect)))
+      (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare))
+       (if exps
+	   `(prog1 ,(byte-optimize-form exp for-effect)
+	      . ,(byte-optimize-body exps t))
+	 (byte-optimize-form exp for-effect)))
+
+      (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps)
+       ;; Those subrs which have an implicit progn; it's not quite good
+       ;; enough to treat these like normal function calls.
+       ;; This can turn (save-excursion ...) into (save-excursion) which
+       ;; will be optimized away in the lap-optimize pass.
+       (cons fn (byte-optimize-body exps for-effect)))
+
+      (`(if ,test ,then . ,else)
+       `(if ,(byte-optimize-form test nil)
+	    ,(byte-optimize-form then for-effect)
+	  . ,(byte-optimize-body else for-effect)))
+      (`(if . ,_)
+       (byte-compile-warn "too few arguments for `if'"))
+
+      (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures.
+       ;; Take forms off the back until we can't any more.
+       ;; In the future it could conceivably be a problem that the
+       ;; subexpressions of these forms are optimized in the reverse
+       ;; order, but it's ok for now.
+       (if for-effect
+	   (let ((backwards (reverse exps)))
+	     (while (and backwards
+			 (null (setcar backwards
+				       (byte-optimize-form (car backwards)
+							   for-effect))))
+	       (setq backwards (cdr backwards)))
+	     (if (and exps (null backwards))
+		 (byte-compile-log
+		  "  all subforms of %s called for effect; deleted" form))
+	     (and backwards
+		  (cons fn (nreverse (mapcar #'byte-optimize-form
+                                             backwards)))))
+	 (cons fn (mapcar #'byte-optimize-form exps))))
+
+      (`(while ,exp . ,exps)
+       `(while ,(byte-optimize-form exp nil)
+          . ,(byte-optimize-body exps t)))
+      (`(while . ,_)
+       (byte-compile-warn "too few arguments for `while'"))
+
+      (`(interactive . ,_)
+       (byte-compile-warn "misplaced interactive spec: `%s'"
+			  (prin1-to-string form))
+       nil)
+
+      (`(function . ,_)
+       ;; This forms is compiled as constant or by breaking out
+       ;; all the subexpressions and compiling them separately.
+       form)
 
-	  (t
-	   ;; Otherwise, no args can be considered to be for-effect,
-	   ;; even if the called function is for-effect, because we
-	   ;; don't know anything about that function.
-	   (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form)))))
-	     (if (get fn 'pure)
-		 (byte-optimize-constant-args form)
-	       form))))))
+      (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare))
+       `(condition-case ,var            ;Not evaluated.
+            ,(byte-optimize-form exp for-effect)
+          ,@(mapcar (lambda (clause)
+                      `(,(car clause)
+                        ,@(byte-optimize-body (cdr clause) for-effect)))
+                    clauses)))
+
+      (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare))
+       ;; The "protected" part of an unwind-protect is compiled (and thus
+       ;; optimized) as a top-level form, so don't do it here.  But the
+       ;; non-protected part has the same for-effect status as the
+       ;; unwind-protect itself.  (The protected part is always for effect,
+       ;; but that isn't handled properly yet.)
+       `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps))
+
+      (`(catch . ,(or `(,tag . ,exps) pcase--dontcare))
+       `(catch ,(byte-optimize-form tag nil)
+          . ,(byte-optimize-body exps for-effect)))
+
+      (`(ignore . ,exps)
+       ;; Don't treat the args to `ignore' as being
+       ;; computed for effect.  We want to avoid the warnings
+       ;; that might occur if they were treated that way.
+       ;; However, don't actually bother calling `ignore'.
+       `(prog1 nil . ,(mapcar #'byte-optimize-form exps)))
+
+      ;; Needed as long as we run byte-optimize-form after cconv.
+      (`(internal-make-closure . ,_) form)
+
+      (`((lambda . ,_) . ,_)
+       (let ((newform (byte-compile-unfold-lambda form)))
+	 (if (eq newform form)
+	     ;; Some error occurred, avoid infinite recursion.
+	     form
+	   (byte-optimize-form newform for-effect))))
+
+      ;; FIXME: Strictly speaking, I think this is a bug: (closure...)
+      ;; is a *value* and shouldn't appear in the car.
+      (`((closure . ,_) . ,_) form)
+
+      (`(,(pred byte-code-function-p) . ,exps)
+       (cons fn (mapcar #'byte-optimize-form exps)))
+
+      (`(,(pred (not symbolp)) . ,_)
+       (byte-compile-warn "`%s' is a malformed function"
+			  (prin1-to-string fn))
+       form)
+
+      ((guard (when for-effect
+		(if-let ((tmp (get fn 'side-effect-free)))
+		    (or byte-compile-delete-errors
+		        (eq tmp 'error-free)
+		        (progn
+			  (byte-compile-warn "value returned from %s is unused"
+					     (prin1-to-string form))
+			  nil)))))
+       (byte-compile-log "  %s called for effect; deleted" fn)
+       ;; appending a nil here might not be necessary, but it can't hurt.
+       (byte-optimize-form
+	(cons 'progn (append (cdr form) '(nil))) t))
+
+      (_
+       ;; Otherwise, no args can be considered to be for-effect,
+       ;; even if the called function is for-effect, because we
+       ;; don't know anything about that function.
+       (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form)))))
+	 (if (get fn 'pure)
+	     (byte-optimize-constant-args form)
+	   form))))))
 
 (defun byte-optimize-form (form &optional for-effect)
   "The source-level pass of the optimizer."
@@ -1562,467 +1563,548 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
 	;; You may notice that sequences like "dup varset discard" are
 	;; optimized but sequences like "dup varset TAG1: discard" are not.
 	;; You may be tempted to change this; resist that temptation.
-	(cond ;;
-	      ;; <side-effect-free> pop -->  <deleted>
-	      ;;  ...including:
-	      ;; const-X pop   -->  <deleted>
-	      ;; varref-X pop  -->  <deleted>
-	      ;; dup pop       -->  <deleted>
-	      ;;
-	      ((and (eq 'byte-discard (car lap1))
-		    (memq (car lap0) side-effect-free))
-	       (setq keep-going t)
-	       (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
-	       (setq rest (cdr rest))
-	       (cond ((= tmp 1)
-		      (byte-compile-log-lap
- 		       "  %s discard\t-->\t<deleted>" lap0)
-		      (setq lap (delq lap0 (delq lap1 lap))))
-		     ((= tmp 0)
-		      (byte-compile-log-lap
-		       "  %s discard\t-->\t<deleted> discard" lap0)
-		      (setq lap (delq lap0 lap)))
-		     ((= tmp -1)
-		      (byte-compile-log-lap
-		       "  %s discard\t-->\tdiscard discard" lap0)
-		      (setcar lap0 'byte-discard)
-		      (setcdr lap0 0))
-		     ((error "Optimizer error: too much on the stack"))))
-	      ;;
-	      ;; goto*-X X:  -->  X:
-	      ;;
-	      ((and (memq (car lap0) byte-goto-ops)
-		    (eq (cdr lap0) lap1))
-	       (cond ((eq (car lap0) 'byte-goto)
-		      (setq lap (delq lap0 lap))
-		      (setq tmp "<deleted>"))
-		     ((memq (car lap0) byte-goto-always-pop-ops)
-		      (setcar lap0 (setq tmp 'byte-discard))
-		      (setcdr lap0 0))
-		     ((error "Depth conflict at tag %d" (nth 2 lap0))))
-	       (and (memq byte-optimize-log '(t byte))
-		    (byte-compile-log "  (goto %s) %s:\t-->\t%s %s:"
-				      (nth 1 lap1) (nth 1 lap1)
-				      tmp (nth 1 lap1)))
-	       (setq keep-going t))
-	      ;;
-	      ;; varset-X varref-X  -->  dup varset-X
-	      ;; varbind-X varref-X  -->  dup varbind-X
-	      ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
-	      ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
-	      ;; The latter two can enable other optimizations.
-	      ;;
-              ;; For lexical variables, we could do the same
-              ;;   stack-set-X+1 stack-ref-X  -->  dup stack-set-X+2
-              ;; but this is a very minor gain, since dup is stack-ref-0,
-              ;; i.e. it's only better if X>5, and even then it comes
-              ;; at the cost of an extra stack slot.  Let's not bother.
-	      ((and (eq 'byte-varref (car lap2))
-                    (eq (cdr lap1) (cdr lap2))
-                    (memq (car lap1) '(byte-varset byte-varbind)))
-	       (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
-			(not (eq (car lap0) 'byte-constant)))
-		   nil
-		 (setq keep-going t)
-                 (if (memq (car lap0) '(byte-constant byte-dup))
-                     (progn
-                       (setq tmp (if (or (not tmp)
-                                         (macroexp--const-symbol-p
-                                          (car (cdr lap0))))
-                                     (cdr lap0)
-                                   (byte-compile-get-constant t)))
-		       (byte-compile-log-lap "  %s %s %s\t-->\t%s %s %s"
-					     lap0 lap1 lap2 lap0 lap1
-					     (cons (car lap0) tmp))
-		       (setcar lap2 (car lap0))
-		       (setcdr lap2 tmp))
-		   (byte-compile-log-lap "  %s %s\t-->\tdup %s" lap1 lap2 lap1)
-		   (setcar lap2 (car lap1))
-		   (setcar lap1 'byte-dup)
-		   (setcdr lap1 0)
-		   ;; The stack depth gets locally increased, so we will
-		   ;; increase maxdepth in case depth = maxdepth here.
-		   ;; This can cause the third argument to byte-code to
-		   ;; be larger than necessary.
-		   (setq add-depth 1))))
-	      ;;
-	      ;; dup varset-X discard  -->  varset-X
-	      ;; dup varbind-X discard  -->  varbind-X
-              ;; dup stack-set-X discard  -->  stack-set-X-1
-	      ;; (the varbind variant can emerge from other optimizations)
-	      ;;
-	      ((and (eq 'byte-dup (car lap0))
-		    (eq 'byte-discard (car lap2))
-		    (memq (car lap1) '(byte-varset byte-varbind
-                                       byte-stack-set)))
-	       (byte-compile-log-lap "  dup %s discard\t-->\t%s" lap1 lap1)
-	       (setq keep-going t
-		     rest (cdr rest))
-               (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
-	       (setq lap (delq lap0 (delq lap2 lap))))
-	      ;;
-	      ;; not goto-X-if-nil              -->  goto-X-if-non-nil
-	      ;; not goto-X-if-non-nil          -->  goto-X-if-nil
-	      ;;
-	      ;; it is wrong to do the same thing for the -else-pop variants.
-	      ;;
-	      ((and (eq 'byte-not (car lap0))
-		    (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
-	       (byte-compile-log-lap "  not %s\t-->\t%s"
-				     lap1
-				     (cons
-				      (if (eq (car lap1) 'byte-goto-if-nil)
-					  'byte-goto-if-not-nil
-					'byte-goto-if-nil)
-				      (cdr lap1)))
-	       (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
-				'byte-goto-if-not-nil
-				'byte-goto-if-nil))
-	       (setq lap (delq lap0 lap))
-	       (setq keep-going t))
-	      ;;
-	      ;; goto-X-if-nil     goto-Y X:  -->  goto-Y-if-non-nil X:
-	      ;; goto-X-if-non-nil goto-Y X:  -->  goto-Y-if-nil     X:
-	      ;;
-	      ;; it is wrong to do the same thing for the -else-pop variants.
-	      ;;
-	      ((and (memq (car lap0)
-                          '(byte-goto-if-nil byte-goto-if-not-nil))	; gotoX
-		    (eq 'byte-goto (car lap1))			; gotoY
-		    (eq (cdr lap0) lap2))			; TAG X
-	       (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
-				  'byte-goto-if-not-nil 'byte-goto-if-nil)))
-		 (byte-compile-log-lap "  %s %s %s:\t-->\t%s %s:"
-				       lap0 lap1 lap2
-				       (cons inverse (cdr lap1)) lap2)
-		 (setq lap (delq lap0 lap))
-		 (setcar lap1 inverse)
-		 (setq keep-going t)))
-	      ;;
-	      ;; const goto-if-* --> whatever
-	      ;;
-	      ((and (eq 'byte-constant (car lap0))
-		    (memq (car lap1) byte-conditional-ops)
-                    ;; If the `byte-constant's cdr is not a cons cell, it has
-                    ;; to be an index into the constant pool); even though
-                    ;; it'll be a constant, that constant is not known yet
-                    ;; (it's typically a free variable of a closure, so will
-                    ;; only be known when the closure will be built at
-                    ;; run-time).
-                    (consp (cdr lap0)))
-	       (cond ((if (memq (car lap1) '(byte-goto-if-nil
-                                             byte-goto-if-nil-else-pop))
-                          (car (cdr lap0))
-                        (not (car (cdr lap0))))
-		      (byte-compile-log-lap "  %s %s\t-->\t<deleted>"
-					    lap0 lap1)
-		      (setq rest (cdr rest)
-			    lap (delq lap0 (delq lap1 lap))))
-		     (t
-		      (byte-compile-log-lap "  %s %s\t-->\t%s"
-					    lap0 lap1
-					    (cons 'byte-goto (cdr lap1)))
-		      (when (memq (car lap1) byte-goto-always-pop-ops)
-			(setq lap (delq lap0 lap)))
-		      (setcar lap1 'byte-goto)))
-               (setq keep-going t))
-	      ;;
-	      ;; varref-X varref-X  -->  varref-X dup
-	      ;; varref-X [dup ...] varref-X  -->  varref-X [dup ...] dup
-	      ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
-	      ;; We don't optimize the const-X variations on this here,
-	      ;; because that would inhibit some goto optimizations; we
-	      ;; optimize the const-X case after all other optimizations.
-	      ;;
-	      ((and (memq (car lap0) '(byte-varref byte-stack-ref))
-		    (progn
-		      (setq tmp (cdr rest))
-                      (setq tmp2 0)
-		      (while (eq (car (car tmp)) 'byte-dup)
-			(setq tmp2 (1+ tmp2))
-                        (setq tmp (cdr tmp)))
-		      t)
-		    (eq (if (eq 'byte-stack-ref (car lap0))
-                            (+ tmp2 1 (cdr lap0))
-                          (cdr lap0))
-                        (cdr (car tmp)))
-		    (eq (car lap0) (car (car tmp))))
-	       (if (memq byte-optimize-log '(t byte))
-		   (let ((str ""))
-		     (setq tmp2 (cdr rest))
-		     (while (not (eq tmp tmp2))
-		       (setq tmp2 (cdr tmp2)
-			     str (concat str " dup")))
-		     (byte-compile-log-lap "  %s%s %s\t-->\t%s%s dup"
-					   lap0 str lap0 lap0 str)))
-	       (setq keep-going t)
-	       (setcar (car tmp) 'byte-dup)
-	       (setcdr (car tmp) 0)
-	       (setq rest tmp))
-	      ;;
-	      ;; TAG1: TAG2: --> TAG1: <deleted>
-	      ;; (and other references to TAG2 are replaced with TAG1)
-	      ;;
-	      ((and (eq (car lap0) 'TAG)
-		    (eq (car lap1) 'TAG))
-	       (and (memq byte-optimize-log '(t byte))
-		    (byte-compile-log "  adjacent tags %d and %d merged"
-				      (nth 1 lap1) (nth 1 lap0)))
-	       (setq tmp3 lap)
-	       (while (setq tmp2 (rassq lap0 tmp3))
-		 (setcdr tmp2 lap1)
-		 (setq tmp3 (cdr (memq tmp2 tmp3))))
-	       (setq lap (delq lap0 lap)
-		     keep-going t)
-               ;; replace references to tag in jump tables, if any
-               (dolist (table byte-compile-jump-tables)
-                   (maphash #'(lambda (value tag)
-                                (when (equal tag lap0)
-                                  (puthash value lap1 table)))
-                            table)))
-	      ;;
-	      ;; unused-TAG: --> <deleted>
-	      ;;
-	      ((and (eq 'TAG (car lap0))
-		    (not (rassq lap0 lap))
-                    ;; make sure this tag isn't used in a jump-table
-                    (cl-loop for table in byte-compile-jump-tables
-                             when (member lap0 (hash-table-values table))
-                             return nil finally return t))
-	       (and (memq byte-optimize-log '(t byte))
-		    (byte-compile-log "  unused tag %d removed" (nth 1 lap0)))
-	       (setq lap (delq lap0 lap)
-		     keep-going t))
-	      ;;
-	      ;; goto   ... --> goto   <delete until TAG or end>
-	      ;; return ... --> return <delete until TAG or end>
-	      ;; (unless a jump-table is being used, where deleting may affect
-              ;; other valid case bodies)
-              ;;
-	      ((and (memq (car lap0) '(byte-goto byte-return))
-		    (not (memq (car lap1) '(TAG nil)))
-                    ;; FIXME: Instead of deferring simply when jump-tables are
-                    ;; being used, keep a list of tags used for switch tags and
-                    ;; use them instead (see `byte-compile-inline-lapcode').
-                    (not byte-compile-jump-tables))
-	       (setq tmp rest)
-	       (let ((i 0)
-		     (opt-p (memq byte-optimize-log '(t lap)))
-		     str deleted)
-		 (while (and (setq tmp (cdr tmp))
-			     (not (eq 'TAG (car (car tmp)))))
-		   (if opt-p (setq deleted (cons (car tmp) deleted)
-				   str (concat str " %s")
-				   i (1+ i))))
-		 (if opt-p
-		     (let ((tagstr
-			    (if (eq 'TAG (car (car tmp)))
-				(format "%d:" (car (cdr (car tmp))))
-			      (or (car tmp) ""))))
-		       (if (< i 6)
-			   (apply 'byte-compile-log-lap-1
-				  (concat "  %s" str
-					  " %s\t-->\t%s <deleted> %s")
-				  lap0
-				  (nconc (nreverse deleted)
-					 (list tagstr lap0 tagstr)))
-			 (byte-compile-log-lap
-			  "  %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
-			  lap0 i (if (= i 1) "" "s")
-			  tagstr lap0 tagstr))))
-		 (rplacd rest tmp))
-	       (setq keep-going t))
-	      ;;
-	      ;; <safe-op> unbind --> unbind <safe-op>
-	      ;; (this may enable other optimizations.)
-	      ;;
-	      ((and (eq 'byte-unbind (car lap1))
-		    (memq (car lap0) byte-after-unbind-ops))
-	       (byte-compile-log-lap "  %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
-	       (setcar rest lap1)
-	       (setcar (cdr rest) lap0)
-	       (setq keep-going t))
-	      ;;
-	      ;; varbind-X unbind-N         -->  discard unbind-(N-1)
-	      ;; save-excursion unbind-N    -->  unbind-(N-1)
-	      ;; save-restriction unbind-N  -->  unbind-(N-1)
-	      ;;
-	      ((and (eq 'byte-unbind (car lap1))
-		    (memq (car lap0) '(byte-varbind byte-save-excursion
-				       byte-save-restriction))
-		    (< 0 (cdr lap1)))
-	       (if (zerop (setcdr lap1 (1- (cdr lap1))))
-		   (delq lap1 rest))
-	       (if (eq (car lap0) 'byte-varbind)
-		   (setcar rest (cons 'byte-discard 0))
+	(cond
+	 ;; <side-effect-free> pop -->  <deleted>
+	 ;;  ...including:
+	 ;; const-X pop   -->  <deleted>
+	 ;; varref-X pop  -->  <deleted>
+	 ;; dup pop       -->  <deleted>
+	 ;;
+	 ((and (eq 'byte-discard (car lap1))
+	       (memq (car lap0) side-effect-free))
+	  (setq keep-going t)
+	  (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
+	  (setq rest (cdr rest))
+	  (cond ((= tmp 1)
+		 (byte-compile-log-lap
+		  "  %s discard\t-->\t<deleted>" lap0)
+		 (setq lap (delq lap0 (delq lap1 lap))))
+		((= tmp 0)
+		 (byte-compile-log-lap
+		  "  %s discard\t-->\t<deleted> discard" lap0)
 		 (setq lap (delq lap0 lap)))
-	       (byte-compile-log-lap "  %s %s\t-->\t%s %s"
-		 lap0 (cons (car lap1) (1+ (cdr lap1)))
-		 (if (eq (car lap0) 'byte-varbind)
-		     (car rest)
-		   (car (cdr rest)))
-		 (if (and (/= 0 (cdr lap1))
-			  (eq (car lap0) 'byte-varbind))
-		     (car (cdr rest))
-		   ""))
-	       (setq keep-going t))
-	      ;;
-	      ;; goto*-X ... X: goto-Y  --> goto*-Y
-	      ;; goto-X ...  X: return  --> return
-	      ;;
-	      ((and (memq (car lap0) byte-goto-ops)
-		    (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
-			  '(byte-goto byte-return)))
-	       (cond ((and (not (eq tmp lap0))
-			   (or (eq (car lap0) 'byte-goto)
-			       (eq (car tmp) 'byte-goto)))
-		      (byte-compile-log-lap "  %s [%s]\t-->\t%s"
-					    (car lap0) tmp tmp)
-		      (if (eq (car tmp) 'byte-return)
-			  (setcar lap0 'byte-return))
-		      (setcdr lap0 (cdr tmp))
-		      (setq keep-going t))))
-	      ;;
-	      ;; goto-*-else-pop X ... X: goto-if-* --> whatever
-	      ;; goto-*-else-pop X ... X: discard --> whatever
-	      ;;
-	      ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
-				       byte-goto-if-not-nil-else-pop))
-		    (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
-			  (eval-when-compile
-			   (cons 'byte-discard byte-conditional-ops)))
-		    (not (eq lap0 (car tmp))))
-	       (setq tmp2 (car tmp))
-	       (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
-					      byte-goto-if-nil)
-					     (byte-goto-if-not-nil-else-pop
-					      byte-goto-if-not-nil))))
-	       (if (memq (car tmp2) tmp3)
-		   (progn (setcar lap0 (car tmp2))
-			  (setcdr lap0 (cdr tmp2))
-			  (byte-compile-log-lap "  %s-else-pop [%s]\t-->\t%s"
-						(car lap0) tmp2 lap0))
-		 ;; Get rid of the -else-pop's and jump one step further.
+		((= tmp -1)
+		 (byte-compile-log-lap
+		  "  %s discard\t-->\tdiscard discard" lap0)
+		 (setcar lap0 'byte-discard)
+		 (setcdr lap0 0))
+		((error "Optimizer error: too much on the stack"))))
+	 ;;
+	 ;; goto*-X X:  -->  X:
+	 ;;
+	 ((and (memq (car lap0) byte-goto-ops)
+	       (eq (cdr lap0) lap1))
+	  (cond ((eq (car lap0) 'byte-goto)
+		 (setq lap (delq lap0 lap))
+		 (setq tmp "<deleted>"))
+		((memq (car lap0) byte-goto-always-pop-ops)
+		 (setcar lap0 (setq tmp 'byte-discard))
+		 (setcdr lap0 0))
+		((error "Depth conflict at tag %d" (nth 2 lap0))))
+	  (and (memq byte-optimize-log '(t byte))
+	       (byte-compile-log "  (goto %s) %s:\t-->\t%s %s:"
+				 (nth 1 lap1) (nth 1 lap1)
+				 tmp (nth 1 lap1)))
+	  (setq keep-going t))
+	 ;;
+	 ;; varset-X varref-X  -->  dup varset-X
+	 ;; varbind-X varref-X  -->  dup varbind-X
+	 ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+	 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
+	 ;; The latter two can enable other optimizations.
+	 ;;
+         ;; For lexical variables, we could do the same
+         ;;   stack-set-X+1 stack-ref-X  -->  dup stack-set-X+2
+         ;; but this is a very minor gain, since dup is stack-ref-0,
+         ;; i.e. it's only better if X>5, and even then it comes
+         ;; at the cost of an extra stack slot.  Let's not bother.
+	 ((and (eq 'byte-varref (car lap2))
+               (eq (cdr lap1) (cdr lap2))
+               (memq (car lap1) '(byte-varset byte-varbind)))
+	  (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
+		   (not (eq (car lap0) 'byte-constant)))
+	      nil
+	    (setq keep-going t)
+            (if (memq (car lap0) '(byte-constant byte-dup))
+                (progn
+                  (setq tmp (if (or (not tmp)
+                                    (macroexp--const-symbol-p
+                                     (car (cdr lap0))))
+                                (cdr lap0)
+                              (byte-compile-get-constant t)))
+		  (byte-compile-log-lap "  %s %s %s\t-->\t%s %s %s"
+					lap0 lap1 lap2 lap0 lap1
+					(cons (car lap0) tmp))
+		  (setcar lap2 (car lap0))
+		  (setcdr lap2 tmp))
+	      (byte-compile-log-lap "  %s %s\t-->\tdup %s" lap1 lap2 lap1)
+	      (setcar lap2 (car lap1))
+	      (setcar lap1 'byte-dup)
+	      (setcdr lap1 0)
+	      ;; The stack depth gets locally increased, so we will
+	      ;; increase maxdepth in case depth = maxdepth here.
+	      ;; This can cause the third argument to byte-code to
+	      ;; be larger than necessary.
+	      (setq add-depth 1))))
+	 ;;
+	 ;; dup varset-X discard  -->  varset-X
+	 ;; dup varbind-X discard  -->  varbind-X
+         ;; dup stack-set-X discard  -->  stack-set-X-1
+	 ;; (the varbind variant can emerge from other optimizations)
+	 ;;
+	 ((and (eq 'byte-dup (car lap0))
+	       (eq 'byte-discard (car lap2))
+	       (memq (car lap1) '(byte-varset byte-varbind
+                                  byte-stack-set)))
+	  (byte-compile-log-lap "  dup %s discard\t-->\t%s" lap1 lap1)
+	  (setq keep-going t
+		rest (cdr rest))
+          (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
+	  (setq lap (delq lap0 (delq lap2 lap))))
+	 ;;
+	 ;; not goto-X-if-nil              -->  goto-X-if-non-nil
+	 ;; not goto-X-if-non-nil          -->  goto-X-if-nil
+	 ;;
+	 ;; it is wrong to do the same thing for the -else-pop variants.
+	 ;;
+	 ((and (eq 'byte-not (car lap0))
+	       (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
+	  (byte-compile-log-lap "  not %s\t-->\t%s"
+				lap1
+				(cons
+				 (if (eq (car lap1) 'byte-goto-if-nil)
+				     'byte-goto-if-not-nil
+				   'byte-goto-if-nil)
+				 (cdr lap1)))
+	  (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
+			   'byte-goto-if-not-nil
+			 'byte-goto-if-nil))
+	  (setq lap (delq lap0 lap))
+	  (setq keep-going t))
+	 ;;
+	 ;; goto-X-if-nil     goto-Y X:  -->  goto-Y-if-non-nil X:
+	 ;; goto-X-if-non-nil goto-Y X:  -->  goto-Y-if-nil     X:
+	 ;;
+	 ;; it is wrong to do the same thing for the -else-pop variants.
+	 ;;
+	 ((and (memq (car lap0)
+                     '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
+	       (eq 'byte-goto (car lap1))                      ; gotoY
+	       (eq (cdr lap0) lap2))                           ; TAG X
+	  (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
+			     'byte-goto-if-not-nil 'byte-goto-if-nil)))
+	    (byte-compile-log-lap "  %s %s %s:\t-->\t%s %s:"
+				  lap0 lap1 lap2
+				  (cons inverse (cdr lap1)) lap2)
+	    (setq lap (delq lap0 lap))
+	    (setcar lap1 inverse)
+	    (setq keep-going t)))
+	 ;;
+	 ;; const goto-if-* --> whatever
+	 ;;
+	 ((and (eq 'byte-constant (car lap0))
+	       (memq (car lap1) byte-conditional-ops)
+               ;; If the `byte-constant's cdr is not a cons cell, it has
+               ;; to be an index into the constant pool); even though
+               ;; it'll be a constant, that constant is not known yet
+               ;; (it's typically a free variable of a closure, so will
+               ;; only be known when the closure will be built at
+               ;; run-time).
+               (consp (cdr lap0)))
+	  (cond ((if (memq (car lap1) '(byte-goto-if-nil
+                                        byte-goto-if-nil-else-pop))
+                     (car (cdr lap0))
+                   (not (car (cdr lap0))))
+		 (byte-compile-log-lap "  %s %s\t-->\t<deleted>"
+				       lap0 lap1)
+		 (setq rest (cdr rest)
+		       lap (delq lap0 (delq lap1 lap))))
+		(t
+		 (byte-compile-log-lap "  %s %s\t-->\t%s"
+				       lap0 lap1
+				       (cons 'byte-goto (cdr lap1)))
+		 (when (memq (car lap1) byte-goto-always-pop-ops)
+		   (setq lap (delq lap0 lap)))
+		 (setcar lap1 'byte-goto)))
+          (setq keep-going t))
+	 ;;
+	 ;; varref-X varref-X  -->  varref-X dup
+	 ;; varref-X [dup ...] varref-X  -->  varref-X [dup ...] dup
+	 ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
+	 ;; We don't optimize the const-X variations on this here,
+	 ;; because that would inhibit some goto optimizations; we
+	 ;; optimize the const-X case after all other optimizations.
+	 ;;
+	 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
+	       (progn
+		 (setq tmp (cdr rest))
+                 (setq tmp2 0)
+		 (while (eq (car (car tmp)) 'byte-dup)
+		   (setq tmp2 (1+ tmp2))
+                   (setq tmp (cdr tmp)))
+		 t)
+	       (eq (if (eq 'byte-stack-ref (car lap0))
+                       (+ tmp2 1 (cdr lap0))
+                     (cdr lap0))
+                   (cdr (car tmp)))
+	       (eq (car lap0) (car (car tmp))))
+	  (if (memq byte-optimize-log '(t byte))
+	      (let ((str ""))
+		(setq tmp2 (cdr rest))
+		(while (not (eq tmp tmp2))
+		  (setq tmp2 (cdr tmp2)
+			str (concat str " dup")))
+		(byte-compile-log-lap "  %s%s %s\t-->\t%s%s dup"
+				      lap0 str lap0 lap0 str)))
+	  (setq keep-going t)
+	  (setcar (car tmp) 'byte-dup)
+	  (setcdr (car tmp) 0)
+	  (setq rest tmp))
+	 ;;
+	 ;; TAG1: TAG2: --> TAG1: <deleted>
+	 ;; (and other references to TAG2 are replaced with TAG1)
+	 ;;
+	 ((and (eq (car lap0) 'TAG)
+	       (eq (car lap1) 'TAG))
+	  (and (memq byte-optimize-log '(t byte))
+	       (byte-compile-log "  adjacent tags %d and %d merged"
+				 (nth 1 lap1) (nth 1 lap0)))
+	  (setq tmp3 lap)
+	  (while (setq tmp2 (rassq lap0 tmp3))
+	    (setcdr tmp2 lap1)
+	    (setq tmp3 (cdr (memq tmp2 tmp3))))
+	  (setq lap (delq lap0 lap)
+		keep-going t)
+          ;; replace references to tag in jump tables, if any
+          (dolist (table byte-compile-jump-tables)
+            (maphash #'(lambda (value tag)
+                         (when (equal tag lap0)
+                           (puthash value lap1 table)))
+                     table)))
+	 ;;
+	 ;; unused-TAG: --> <deleted>
+	 ;;
+	 ((and (eq 'TAG (car lap0))
+	       (not (rassq lap0 lap))
+               ;; make sure this tag isn't used in a jump-table
+               (cl-loop for table in byte-compile-jump-tables
+                        when (member lap0 (hash-table-values table))
+                        return nil finally return t))
+	  (and (memq byte-optimize-log '(t byte))
+	       (byte-compile-log "  unused tag %d removed" (nth 1 lap0)))
+	  (setq lap (delq lap0 lap)
+		keep-going t))
+	 ;;
+	 ;; goto   ... --> goto   <delete until TAG or end>
+	 ;; return ... --> return <delete until TAG or end>
+	 ;; (unless a jump-table is being used, where deleting may affect
+         ;; other valid case bodies)
+         ;;
+	 ((and (memq (car lap0) '(byte-goto byte-return))
+	       (not (memq (car lap1) '(TAG nil)))
+               ;; FIXME: Instead of deferring simply when jump-tables are
+               ;; being used, keep a list of tags used for switch tags and
+               ;; use them instead (see `byte-compile-inline-lapcode').
+               (not byte-compile-jump-tables))
+	  (setq tmp rest)
+	  (let ((i 0)
+		(opt-p (memq byte-optimize-log '(t lap)))
+		str deleted)
+	    (while (and (setq tmp (cdr tmp))
+			(not (eq 'TAG (car (car tmp)))))
+	      (if opt-p (setq deleted (cons (car tmp) deleted)
+			      str (concat str " %s")
+			      i (1+ i))))
+	    (if opt-p
+		(let ((tagstr
+		       (if (eq 'TAG (car (car tmp)))
+			   (format "%d:" (car (cdr (car tmp))))
+			 (or (car tmp) ""))))
+		  (if (< i 6)
+		      (apply 'byte-compile-log-lap-1
+			     (concat "  %s" str
+				     " %s\t-->\t%s <deleted> %s")
+			     lap0
+			     (nconc (nreverse deleted)
+				    (list tagstr lap0 tagstr)))
+		    (byte-compile-log-lap
+		     "  %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
+		     lap0 i (if (= i 1) "" "s")
+		     tagstr lap0 tagstr))))
+	    (rplacd rest tmp))
+	  (setq keep-going t))
+	 ;;
+	 ;; <safe-op> unbind --> unbind <safe-op>
+	 ;; (this may enable other optimizations.)
+	 ;;
+	 ((and (eq 'byte-unbind (car lap1))
+	       (memq (car lap0) byte-after-unbind-ops))
+	  (byte-compile-log-lap "  %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+	  (setcar rest lap1)
+	  (setcar (cdr rest) lap0)
+	  (setq keep-going t))
+	 ;;
+	 ;; varbind-X unbind-N         -->  discard unbind-(N-1)
+	 ;; save-excursion unbind-N    -->  unbind-(N-1)
+	 ;; save-restriction unbind-N  -->  unbind-(N-1)
+	 ;;
+	 ((and (eq 'byte-unbind (car lap1))
+	       (memq (car lap0) '(byte-varbind byte-save-excursion
+				  byte-save-restriction))
+	       (< 0 (cdr lap1)))
+	  (if (zerop (setcdr lap1 (1- (cdr lap1))))
+	      (delq lap1 rest))
+	  (if (eq (car lap0) 'byte-varbind)
+	      (setcar rest (cons 'byte-discard 0))
+	    (setq lap (delq lap0 lap)))
+	  (byte-compile-log-lap "  %s %s\t-->\t%s %s"
+		                lap0 (cons (car lap1) (1+ (cdr lap1)))
+		                (if (eq (car lap0) 'byte-varbind)
+		                    (car rest)
+		                  (car (cdr rest)))
+		                (if (and (/= 0 (cdr lap1))
+			                 (eq (car lap0) 'byte-varbind))
+			            (car (cdr rest))
+			          ""))
+	  (setq keep-going t))
+	 ;;
+	 ;; goto*-X ... X: goto-Y  --> goto*-Y
+	 ;; goto-X ...  X: return  --> return
+	 ;;
+	 ((and (memq (car lap0) byte-goto-ops)
+	       (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
+		     '(byte-goto byte-return)))
+	  (cond ((and (not (eq tmp lap0))
+		      (or (eq (car lap0) 'byte-goto)
+			  (eq (car tmp) 'byte-goto)))
+		 (byte-compile-log-lap "  %s [%s]\t-->\t%s"
+				       (car lap0) tmp tmp)
+		 (if (eq (car tmp) 'byte-return)
+		     (setcar lap0 'byte-return))
+		 (setcdr lap0 (cdr tmp))
+		 (setq keep-going t))))
+	 ;;
+	 ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+	 ;; goto-*-else-pop X ... X: discard --> whatever
+	 ;;
+	 ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
+				  byte-goto-if-not-nil-else-pop))
+	       (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
+		     (eval-when-compile
+		       (cons 'byte-discard byte-conditional-ops)))
+	       (not (eq lap0 (car tmp))))
+	  (setq tmp2 (car tmp))
+	  (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
+					 byte-goto-if-nil)
+					(byte-goto-if-not-nil-else-pop
+					 byte-goto-if-not-nil))))
+	  (if (memq (car tmp2) tmp3)
+	      (progn (setcar lap0 (car tmp2))
+		     (setcdr lap0 (cdr tmp2))
+		     (byte-compile-log-lap "  %s-else-pop [%s]\t-->\t%s"
+					   (car lap0) tmp2 lap0))
+	    ;; Get rid of the -else-pop's and jump one step further.
+	    (or (eq 'TAG (car (nth 1 tmp)))
+		(setcdr tmp (cons (byte-compile-make-tag)
+				  (cdr tmp))))
+	    (byte-compile-log-lap "  %s [%s]\t-->\t%s <skip>"
+				  (car lap0) tmp2 (nth 1 tmp3))
+	    (setcar lap0 (nth 1 tmp3))
+	    (setcdr lap0 (nth 1 tmp)))
+	  (setq keep-going t))
+	 ;;
+	 ;; const goto-X ... X: goto-if-* --> whatever
+	 ;; const goto-X ... X: discard   --> whatever
+	 ;;
+	 ((and (eq (car lap0) 'byte-constant)
+	       (eq (car lap1) 'byte-goto)
+	       (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
+		     (eval-when-compile
+		       (cons 'byte-discard byte-conditional-ops)))
+	       (not (eq lap1 (car tmp))))
+	  (setq tmp2 (car tmp))
+	  (cond ((when (consp (cdr lap0))
+		   (memq (car tmp2)
+			 (if (null (car (cdr lap0)))
+			     '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+			   '(byte-goto-if-not-nil
+			     byte-goto-if-not-nil-else-pop))))
+		 (byte-compile-log-lap "  %s goto [%s]\t-->\t%s %s"
+				       lap0 tmp2 lap0 tmp2)
+		 (setcar lap1 (car tmp2))
+		 (setcdr lap1 (cdr tmp2))
+		 ;; Let next step fix the (const,goto-if*) sequence.
+		 (setq rest (cons nil rest))
+		 (setq keep-going t))
+		((or (consp (cdr lap0))
+		     (eq (car tmp2) 'byte-discard))
+		 ;; Jump one step further
+		 (byte-compile-log-lap
+		  "  %s goto [%s]\t-->\t<deleted> goto <skip>"
+		  lap0 tmp2)
 		 (or (eq 'TAG (car (nth 1 tmp)))
 		     (setcdr tmp (cons (byte-compile-make-tag)
 				       (cdr tmp))))
-		 (byte-compile-log-lap "  %s [%s]\t-->\t%s <skip>"
-				       (car lap0) tmp2 (nth 1 tmp3))
-		 (setcar lap0 (nth 1 tmp3))
-		 (setcdr lap0 (nth 1 tmp)))
-	       (setq keep-going t))
-	      ;;
-	      ;; const goto-X ... X: goto-if-* --> whatever
-	      ;; const goto-X ... X: discard   --> whatever
-	      ;;
-	      ((and (eq (car lap0) 'byte-constant)
-		    (eq (car lap1) 'byte-goto)
-		    (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
-			  (eval-when-compile
-			    (cons 'byte-discard byte-conditional-ops)))
-		    (not (eq lap1 (car tmp))))
-	       (setq tmp2 (car tmp))
-	       (cond ((when (consp (cdr lap0))
-		        (memq (car tmp2)
-			      (if (null (car (cdr lap0)))
-				  '(byte-goto-if-nil byte-goto-if-nil-else-pop)
-				'(byte-goto-if-not-nil
-				  byte-goto-if-not-nil-else-pop))))
-		      (byte-compile-log-lap "  %s goto [%s]\t-->\t%s %s"
-					    lap0 tmp2 lap0 tmp2)
-		      (setcar lap1 (car tmp2))
-		      (setcdr lap1 (cdr tmp2))
-		      ;; Let next step fix the (const,goto-if*) sequence.
-		      (setq rest (cons nil rest))
-		      (setq keep-going t))
-		     ((or (consp (cdr lap0))
-			  (eq (car tmp2) 'byte-discard))
-		      ;; Jump one step further
-		      (byte-compile-log-lap
-		       "  %s goto [%s]\t-->\t<deleted> goto <skip>"
-		       lap0 tmp2)
-		      (or (eq 'TAG (car (nth 1 tmp)))
-			  (setcdr tmp (cons (byte-compile-make-tag)
-					    (cdr tmp))))
-		      (setcdr lap1 (car (cdr tmp)))
-		      (setq lap (delq lap0 lap))
-		      (setq keep-going t))))
-	      ;;
-	      ;; X: varref-Y    ...     varset-Y goto-X  -->
-	      ;; X: varref-Y Z: ... dup varset-Y goto-Z
-	      ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
-	      ;; (This is so usual for while loops that it is worth handling).
-              ;;
-              ;; Here again, we could do it for stack-ref/stack-set, but
-	      ;; that's replacing a stack-ref-Y with a stack-ref-0, which
-              ;; is a very minor improvement (if any), at the cost of
-	      ;; more stack use and more byte-code.  Let's not do it.
-	      ;;
-	      ((and (eq (car lap1) 'byte-varset)
-		    (eq (car lap2) 'byte-goto)
-		    (not (memq (cdr lap2) rest)) ;Backwards jump
-		    (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
-			'byte-varref)
-		    (eq (cdr (car tmp)) (cdr lap1))
-		    (not (memq (car (cdr lap1)) byte-boolean-vars)))
-	       ;;(byte-compile-log-lap "  Pulled %s to end of loop" (car tmp))
-	       (let ((newtag (byte-compile-make-tag)))
-		 (byte-compile-log-lap
-		  "  %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
-		  (nth 1 (cdr lap2)) (car tmp)
-                  lap1 lap2
-		  (nth 1 (cdr lap2)) (car tmp)
-		  (nth 1 newtag) 'byte-dup lap1
-		  (cons 'byte-goto newtag)
-		  )
-		 (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
-		 (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
-	       (setq add-depth 1)
-	       (setq keep-going t))
-	      ;;
-	      ;; goto-X Y: ... X: goto-if*-Y  -->  goto-if-not-*-X+1 Y:
-	      ;; (This can pull the loop test to the end of the loop)
-	      ;;
-	      ((and (eq (car lap0) 'byte-goto)
-		    (eq (car lap1) 'TAG)
-		    (eq lap1
-			(cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
-		    (memq (car (car tmp))
-			  '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
-				      byte-goto-if-nil-else-pop)))
-;;	       (byte-compile-log-lap "  %s %s, %s %s  --> moved conditional"
-;;				     lap0 lap1 (cdr lap0) (car tmp))
-	       (let ((newtag (byte-compile-make-tag)))
-		 (byte-compile-log-lap
-		  "%s %s: ... %s: %s\t-->\t%s ... %s:"
-		  lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
-		  (cons (cdr (assq (car (car tmp))
-				   '((byte-goto-if-nil . byte-goto-if-not-nil)
-				     (byte-goto-if-not-nil . byte-goto-if-nil)
-				     (byte-goto-if-nil-else-pop .
-				      byte-goto-if-not-nil-else-pop)
-				     (byte-goto-if-not-nil-else-pop .
-				      byte-goto-if-nil-else-pop))))
-			newtag)
-
-		  (nth 1 newtag)
-		  )
-		 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
-		 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
-		     ;; We can handle this case but not the -if-not-nil case,
-		     ;; because we won't know which non-nil constant to push.
-		   (setcdr rest (cons (cons 'byte-constant
-					    (byte-compile-get-constant nil))
-				      (cdr rest))))
-	       (setcar lap0 (nth 1 (memq (car (car tmp))
-					 '(byte-goto-if-nil-else-pop
-					   byte-goto-if-not-nil
-					   byte-goto-if-nil
-					   byte-goto-if-not-nil
-					   byte-goto byte-goto))))
-	       )
-	       (setq keep-going t))
-	      )
+		 (setcdr lap1 (car (cdr tmp)))
+		 (setq lap (delq lap0 lap))
+		 (setq keep-going t))))
+	 ;;
+	 ;; X: varref-Y    ...     varset-Y goto-X  -->
+	 ;; X: varref-Y Z: ... dup varset-Y goto-Z
+	 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
+	 ;; (This is so usual for while loops that it is worth handling).
+         ;;
+         ;; Here again, we could do it for stack-ref/stack-set, but
+	 ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+         ;; is a very minor improvement (if any), at the cost of
+	 ;; more stack use and more byte-code.  Let's not do it.
+	 ;;
+	 ((and (eq (car lap1) 'byte-varset)
+	       (eq (car lap2) 'byte-goto)
+	       (not (memq (cdr lap2) rest)) ;Backwards jump
+	       (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
+		   'byte-varref)
+	       (eq (cdr (car tmp)) (cdr lap1))
+	       (not (memq (car (cdr lap1)) byte-boolean-vars)))
+	  ;;(byte-compile-log-lap "  Pulled %s to end of loop" (car tmp))
+	  (let ((newtag (byte-compile-make-tag)))
+	    (byte-compile-log-lap
+	     "  %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
+	     (nth 1 (cdr lap2)) (car tmp)
+             lap1 lap2
+	     (nth 1 (cdr lap2)) (car tmp)
+	     (nth 1 newtag) 'byte-dup lap1
+	     (cons 'byte-goto newtag)
+	     )
+	    (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
+	    (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
+	  (setq add-depth 1)
+	  (setq keep-going t))
+	 ;;
+	 ;; goto-X Y: ... X: goto-if*-Y  -->  goto-if-not-*-X+1 Y:
+	 ;; (This can pull the loop test to the end of the loop)
+	 ;;
+	 ((and (eq (car lap0) 'byte-goto)
+	       (eq (car lap1) 'TAG)
+	       (eq lap1
+		   (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
+	       (memq (car (car tmp))
+		     '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
+		       byte-goto-if-nil-else-pop)))
+	  ;;	       (byte-compile-log-lap "  %s %s, %s %s  --> moved conditional"
+	  ;;				     lap0 lap1 (cdr lap0) (car tmp))
+	  (let ((newtag (byte-compile-make-tag)))
+	    (byte-compile-log-lap
+	     "%s %s: ... %s: %s\t-->\t%s ... %s:"
+	     lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
+	     (cons (cdr (assq (car (car tmp))
+			      '((byte-goto-if-nil . byte-goto-if-not-nil)
+				(byte-goto-if-not-nil . byte-goto-if-nil)
+				(byte-goto-if-nil-else-pop .
+				                           byte-goto-if-not-nil-else-pop)
+				(byte-goto-if-not-nil-else-pop .
+				                               byte-goto-if-nil-else-pop))))
+		   newtag)
+
+	     (nth 1 newtag)
+	     )
+	    (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
+	    (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
+		;; We can handle this case but not the -if-not-nil case,
+		;; because we won't know which non-nil constant to push.
+		(setcdr rest (cons (cons 'byte-constant
+					 (byte-compile-get-constant nil))
+				   (cdr rest))))
+	    (setcar lap0 (nth 1 (memq (car (car tmp))
+				      '(byte-goto-if-nil-else-pop
+					byte-goto-if-not-nil
+					byte-goto-if-nil
+					byte-goto-if-not-nil
+					byte-goto byte-goto))))
+	    )
+	  (setq keep-going t))
+
+	 ;;
+	 ;; stack-set-M [discard/discardN ...]  -->  discardN-preserve-tos
+	 ;; stack-set-M [discard/discardN ...]  -->  discardN
+	 ;;
+	 ((and (eq (car lap0) 'byte-stack-set)
+	       (memq (car lap1) '(byte-discard byte-discardN))
+	       (progn
+	         ;; See if enough discard operations follow to expose or
+	         ;; destroy the value stored by the stack-set.
+	         (setq tmp (cdr rest))
+	         (setq tmp2 (1- (cdr lap0)))
+	         (setq tmp3 0)
+	         (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+	           (setq tmp3
+                         (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+                                     1
+                                   (cdr (car tmp)))))
+	           (setq tmp (cdr tmp)))
+	         (>= tmp3 tmp2)))
+	  ;; Do the optimization.
+	  (setq lap (delq lap0 lap))
+          (setcar lap1
+                  (if (= tmp2 tmp3)
+                      ;; The value stored is the new TOS, so pop one more
+                      ;; value (to get rid of the old value) using the
+                      ;; TOS-preserving discard operator.
+                      'byte-discardN-preserve-tos
+                    ;; Otherwise, the value stored is lost, so just use a
+                    ;; normal discard.
+                    'byte-discardN))
+          (setcdr lap1 (1+ tmp3))
+	  (setcdr (cdr rest) tmp)
+	  (byte-compile-log-lap "  %s [discard/discardN]...\t-->\t%s"
+	                        lap0 lap1))
+
+	 ;;
+	 ;; discardN-preserve-tos return  -->  return
+	 ;; dup return  -->  return
+	 ;; stack-set-N return  -->  return     ; where N is TOS-1
+	 ;;
+	 ((and (eq (car lap1) 'byte-return)
+	       (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+	           (and (eq (car lap0) 'byte-stack-set)
+	                (= (cdr lap0) 1))))
+	  (setq keep-going t)
+	  ;; The byte-code interpreter will pop the stack for us, so
+	  ;; we can just leave stuff on it.
+	  (setq lap (delq lap0 lap))
+	  (byte-compile-log-lap "  %s %s\t-->\t%s" lap0 lap1 lap1))
+
+	 ;;
+	 ;; goto-X ... X: discard  ==>  discard goto-Y ... X: discard Y:
+	 ;;
+	 ((and (eq (car lap0) 'byte-goto)
+	       (setq tmp (cdr (memq (cdr lap0) lap)))
+	       (memq (caar tmp) '(byte-discard byte-discardN
+	                          byte-discardN-preserve-tos)))
+	  (byte-compile-log-lap
+	   "  goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
+	   (car tmp) (car tmp))
+	  (setq keep-going t)
+	  (let* ((newtag (byte-compile-make-tag))
+	         ;; Make a copy, since we sometimes modify insts in-place!
+	         (newdiscard (cons (caar tmp) (cdar tmp)))
+	         (newjmp (cons (car lap0) newtag)))
+	    (push newtag (cdr tmp))     ;Push new tag after the discard.
+	    (setcar rest newdiscard)
+	    (push newjmp (cdr rest))))
+
+	 ;;
+	 ;; const discardN-preserve-tos ==> discardN const
+	 ;;
+	 ((and (eq (car lap0) 'byte-constant)
+	       (eq (car lap1) 'byte-discardN-preserve-tos))
+	  (setq keep-going t)
+	  (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
+	    (byte-compile-log-lap
+	     "  %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
+	    (setf (car rest) newdiscard)
+	    (setf (cadr rest) lap0)))
+	 )
 	(setq rest (cdr rest)))
       )
     ;; Cleanup stage:
@@ -2086,41 +2168,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
 	     (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
 
 	    ;;
-	    ;; stack-set-M [discard/discardN ...]  -->  discardN-preserve-tos
-	    ;; stack-set-M [discard/discardN ...]  -->  discardN
-	    ;;
-	    ((and (eq (car lap0) 'byte-stack-set)
-	          (memq (car lap1) '(byte-discard byte-discardN))
-	          (progn
-	            ;; See if enough discard operations follow to expose or
-	            ;; destroy the value stored by the stack-set.
-	            (setq tmp (cdr rest))
-	            (setq tmp2 (1- (cdr lap0)))
-	            (setq tmp3 0)
-	            (while (memq (car (car tmp)) '(byte-discard byte-discardN))
-	              (setq tmp3
-                            (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
-                                        1
-                                      (cdr (car tmp)))))
-	              (setq tmp (cdr tmp)))
-	            (>= tmp3 tmp2)))
-	     ;; Do the optimization.
-	     (setq lap (delq lap0 lap))
-             (setcar lap1
-                     (if (= tmp2 tmp3)
-                         ;; The value stored is the new TOS, so pop one more
-                         ;; value (to get rid of the old value) using the
-                         ;; TOS-preserving discard operator.
-                         'byte-discardN-preserve-tos
-                       ;; Otherwise, the value stored is lost, so just use a
-                       ;; normal discard.
-                       'byte-discardN))
-             (setcdr lap1 (1+ tmp3))
-	     (setcdr (cdr rest) tmp)
-	     (byte-compile-log-lap "  %s [discard/discardN]...\t-->\t%s"
-	        		   lap0 lap1))
-
-	    ;;
 	    ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y  -->
 	    ;; discardN-(X+Y)
 	    ;;
@@ -2147,20 +2194,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
 	     (setq lap (delq lap0 lap))
 	     (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
 	     (byte-compile-log-lap "  %s %s\t-->\t%s" lap0 lap1 (car rest)))
-
-	    ;;
-	    ;; discardN-preserve-tos return  -->  return
-	    ;; dup return  -->  return
-	    ;; stack-set-N return  -->  return     ; where N is TOS-1
-	    ;;
-	    ((and (eq (car lap1) 'byte-return)
-	          (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
-	              (and (eq (car lap0) 'byte-stack-set)
-	        	   (= (cdr lap0) 1))))
-	     ;; The byte-code interpreter will pop the stack for us, so
-	     ;; we can just leave stuff on it.
-	     (setq lap (delq lap0 lap))
-	     (byte-compile-log-lap "  %s %s\t-->\t%s" lap0 lap1 lap1))
             )
       (setq rest (cdr rest)))
     (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 3ed299864b7..a3ad43038e7 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -238,8 +238,11 @@ The return value is undefined.
 		  #'(lambda (x)
 		      (let ((f (cdr (assq (car x) macro-declarations-alist))))
 			(if f (apply (car f) name arglist (cdr x))
-			  (message "Warning: Unknown macro property %S in %S"
-				   (car x) name))))
+			  (macroexp--warn-and-return
+			   (format-message
+			    "Unknown macro property %S in %S"
+			    (car x) name)
+			   nil))))
 		  decls)))
 	   ;; Refresh font-lock if this is a new macro, or it is an
 	   ;; existing macro whose 'no-font-lock-keyword declaration
@@ -307,9 +310,12 @@ The return value is undefined.
                                 (cdr body)
                               body)))
                     nil)
-                   (t (message "Warning: Unknown defun property `%S' in %S"
-                               (car x) name)))))
-                   decls))
+                   (t
+                    (macroexp--warn-and-return
+                     (format-message "Unknown defun property `%S' in %S"
+                                     (car x) name)
+                     nil)))))
+            decls))
           (def (list 'defalias
                      (list 'quote name)
                      (list 'function
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 54f8301b085..c0f8db69e51 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2577,7 +2577,8 @@ list that represents a doc string reference.
   (when (memq sym byte-compile-lexical-variables)
     (setq byte-compile-lexical-variables
           (delq sym byte-compile-lexical-variables))
-    (byte-compile-warn "Variable `%S' declared after its first use" sym))
+    (when (byte-compile-warning-enabled-p 'lexical sym)
+      (byte-compile-warn "Variable `%S' declared after its first use" sym)))
   (push sym byte-compile-bound-variables)
   (push sym byte-compile--seen-defvars))
 
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 2e204ff7aea..76638ec13b1 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -241,7 +241,12 @@ system.  Possible values are:
   defun       - Spell-check when style checking a single defun.
   buffer      - Spell-check when style checking the whole buffer.
   interactive - Spell-check during any interactive check.
-  t           - Always spell-check."
+  t           - Always spell-check.
+
+There is a list of Lisp-specific words which checkdoc will
+install into Ispell on the fly, but only if Ispell is not already
+running.  Use `ispell-kill-ispell' to make checkdoc restart it
+with these words enabled."
   :type '(choice (const nil)
           (const defun)
           (const buffer)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 58517549454..fdbf95319ff 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil."
 Returns nil if they are."
   (if (not (eq (type-of a) (type-of b)))
       `(different-types ,a ,b)
-    (pcase-exhaustive a
+    (pcase a
       ((pred consp)
        (let ((a-length (proper-list-p a))
              (b-length (proper-list-p b)))
@@ -538,7 +538,7 @@ Returns nil if they are."
                   for xi = (ert--explain-equal-rec ai bi)
                   do (when xi (cl-return `(array-elt ,i ,xi)))
                   finally (cl-assert (equal a b) t))))
-      ((pred atom)
+      (_
        (if (not (equal a b))
            (if (and (symbolp a) (symbolp b) (string= a b))
                `(different-symbols-with-the-same-name ,a ,b)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 37844977f8f..aa49bccc8d0 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution."
     (cond
      ((null msg) form)
      ((macroexp--compiling-p)
-      (if (gethash form macroexp--warned)
+      (if (and (consp form) (gethash form macroexp--warned))
           ;; Already wrapped this exp with a warning: avoid inf-looping
           ;; where we keep adding the same warning onto `form' because
           ;; macroexpand-all gets right back to macroexpanding `form'.
@@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution."
            ,form)))
      (t
       (unless compile-only
-        (message "%s%s" (if (stringp load-file-name)
-                            (concat (file-relative-name load-file-name) ": ")
-                          "")
+        (message "%sWarning: %s"
+                 (if (stringp load-file-name)
+                     (concat (file-relative-name load-file-name) ": ")
+                   "")
                  msg))
       form))))
 
@@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution."
 
 (defun macroexp-macroexpand (form env)
   "Like `macroexpand' but checking obsolescence."
-  (let ((new-form
-         (macroexpand form env)))
+  (let* ((macroexpand-all-environment env)
+         (new-form
+          (macroexpand form env)))
     (if (and (not (eq form new-form))   ;It was a macro call.
              (car-safe form)
              (symbolp (car form))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 125fbe09961..9f155bad394 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -3288,9 +3288,9 @@ To unhide a package, type
 `\\[customize-variable] RET package-hidden-regexps'.
 
 Type \\[package-menu-toggle-hiding] to toggle package hiding."
+  (declare (interactive-only "change `package-hidden-regexps' instead."))
   (interactive)
   (package--ensure-package-menu-mode)
-  (declare (interactive-only "change `package-hidden-regexps' instead."))
   (let* ((name (when (derived-mode-p 'package-menu-mode)
                  (concat "\\`" (regexp-quote (symbol-name (package-desc-name
                                                            (tabulated-list-get-id))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 72ea1ba0188..bfd577c5d14 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -39,10 +39,10 @@
 ;; - along these lines, provide patterns to match CL structs.
 ;; - provide something like (setq VAR) so a var can be set rather than
 ;;   let-bound.
-;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
-;;   this :-()
+;; - provide a way to fallthrough to subsequent cases
+;;   (e.g. Like Racket's (=> ID).
 ;; - try and be more clever to reduce the size of the decision tree, and
-;;   to reduce the number of leaves that need to be turned into function:
+;;   to reduce the number of leaves that need to be turned into functions:
 ;;   - first, do the tests shared by all remaining branches (it will have
 ;;     to be performed anyway, so better do it first so it's shared).
 ;;   - then choose the test that discriminates more (?).
@@ -97,11 +97,15 @@
 (declare-function get-edebug-spec "edebug" (symbol))
 (declare-function edebug-match "edebug" (cursor specs))
 
+(defun pcase--get-macroexpander (s)
+  "Return the macroexpander for pcase pattern head S, or nil"
+  (get s 'pcase-macroexpander))
+
 (defun pcase--edebug-match-macro (cursor)
   (let (specs)
     (mapatoms
      (lambda (s)
-       (let ((m (get s 'pcase-macroexpander)))
+       (let ((m (pcase--get-macroexpander s)))
 	 (when (and m (get-edebug-spec m))
 	   (push (cons (symbol-name s) (get-edebug-spec m))
 		 specs)))))
@@ -128,6 +132,7 @@ PATTERN matches.  PATTERN can take one of the forms:
                    If a SYMBOL is used twice in the same pattern
                    the second occurrence becomes an `eq'uality test.
   (pred FUN)       matches if FUN called on EXPVAL returns non-nil.
+  (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
   (app FUN PAT)    matches if FUN called on EXPVAL matches PAT.
   (guard BOOLEXP)  matches if BOOLEXP evaluates to non-nil.
   (let PAT EXPR)   matches if EXPR matches PAT.
@@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples."
       (let (more)
         ;; Collect all the extensions.
         (mapatoms (lambda (symbol)
-                    (let ((me (get symbol 'pcase-macroexpander)))
+                    (let ((me (pcase--get-macroexpander symbol)))
                       (when me
                         (push (cons symbol me)
                               more)))))
@@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'.
      ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
      ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
      (t
-      (let* ((expander (get head 'pcase-macroexpander))
+      (let* ((expander (pcase--get-macroexpander head))
              (npat (if expander (apply expander (cdr pat)))))
         (if (null npat)
             (error (if expander
@@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form:
     '(:pcase--succeed . nil))))
 
 (defun pcase--split-pred (vars upat pat)
+  "Indicate the overlap or mutual-exclusion between UPAT and PAT.
+More specifically retuns a pair (A . B) where A indicates whether PAT
+can match when UPAT has matched, and B does the same for the case
+where UPAT failed to match.
+A and B can be one of:
+- nil if we don't know
+- `:pcase--fail' if UPAT match's result implies that PAT can't match
+- `:pcase--succeed' if UPAT match's result implies that PAT matches"
   (let (test)
     (cond
      ((and (equal upat pat)
@@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form:
                ;; and catch at least the easy cases such as (bug#14773).
                (not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
       '(:pcase--succeed . :pcase--fail))
+     ;; In case UPAT is of the form (pred (not PRED))
+     ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
+      (let* ((test (cadr (cadr upat)))
+             (res (pcase--split-pred vars `(pred ,test) pat)))
+        (cons (cdr res) (car res))))
+     ;; In case PAT is of the form (pred (not PRED))
+     ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
+      (let* ((test (cadr (cadr pat)))
+             (res (pcase--split-pred vars upat `(pred ,test)))
+             (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
+                                   ((eq x :pcase--fail) :pcase--succeed)))))
+        (cons (funcall reverse (car res))
+              (funcall reverse (cdr res)))))
      ((and (eq 'pred (car upat))
            (let ((otherpred
                   (cond ((eq 'pred (car-safe pat)) (cadr pat))
@@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form:
 
 (defun pcase--funcall (fun arg vars)
   "Build a function call to FUN with arg ARG."
-  (if (symbolp fun)
-      `(,fun ,arg)
+  (cond
+   ((symbolp fun) `(,fun ,arg))
+   ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
+   (t
     (let* (;; `env' is an upper bound on the bindings we need.
            (env (mapcar (lambda (x) (list (car x) (cdr x)))
                         (macroexp--fgrep vars fun)))
@@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form:
         ;; Let's not replace `vars' in `fun' since it's
         ;; too difficult to do it right, instead just
         ;; let-bind `vars' around `fun'.
-        `(let* ,env ,call)))))
+        `(let* ,env ,call))))))
 
 (defun pcase--eval (exp vars)
   "Build an expression that will evaluate EXP."
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el
index 6a483a6d498..0905ac608bb 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -198,9 +198,10 @@ If not found, return nil."
   (pcase-defmacro radix-tree-leaf (vpat)
     "Pattern which matches a radix-tree leaf.
 The pattern VPAT is matched against the leaf's carried value."
-    ;; FIXME: We'd like to use a negative pattern (not consp), but pcase
-    ;; doesn't support it.  Using `atom' works but generates sub-optimal code.
-    `(or `(t . ,,vpat) (and (pred atom) ,vpat))))
+    ;; We used to use `(pred atom)', but `pcase' doesn't understand that
+    ;; `atom' is equivalent to the negation of `consp' and hence generates
+    ;; suboptimal code.
+    `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat))))
 
 (defun radix-tree-iter-subtrees (tree fun)
   "Apply FUN to every immediate subtree of radix TREE.
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index b90227da42f..a4514454c0b 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -389,6 +389,28 @@ it makes no sense to convert it to a string using
 		(set-buffer source-buffer)
 		(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
 
+(defmacro named-let (name bindings &rest body)
+  "Looping construct taken from Scheme.
+Like `let', bind variables in BINDINGS and then evaluate BODY,
+but with the twist that BODY can evaluate itself recursively by
+calling NAME, where the arguments passed to NAME are used
+as the new values of the bound variables in the recursive invocation."
+  (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
+  (require 'cl-lib)
+  (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
+        (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
+    ;; According to the Scheme semantics of named let, `name' is not in scope
+    ;; while evaluating the expressions in `bindings', and for this reason, the
+    ;; "initial" function call below needs to be outside of the `cl-labels'.
+    ;; When the "self-tco" eliminates all recursive calls, the `cl-labels'
+    ;; expands to a lambda which the byte-compiler then combines with the
+    ;; funcall to make a `let' so we end up with a plain `while' loop and no
+    ;; remaining `lambda' at all.
+    `(funcall
+      (cl-labels ((,name ,fargs . ,body)) #',name)
+      . ,aargs)))
+
+
 (provide 'subr-x)
 
 ;;; subr-x.el ends here