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

7 files changed, 134 insertions, 75 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/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 b7ffd25d62c..55c7e67daa6 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2068,6 +2068,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 +2102,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 +2117,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 +2140,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 +2287,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/gv.el b/lisp/emacs-lisp/gv.el
index 3d8054950c1..ce48e578e0b 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -324,8 +324,7 @@ The return value is the last VAL in the list.
        (gv-letplace (getter setter) place
          (funcall do `(edebug-after ,before ,index ,getter)
                   (lambda (store)
-                    `(progn (edebug-after ,before ,index ,getter)
-                            ,(funcall setter store)))))))
+                    `(edebug-after ,before ,index ,(funcall setter store)))))))
 
 ;;; The common generalized variables.
 
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 059eda602c3..f1022f08f1b 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2223,10 +2223,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).
@@ -2237,10 +2240,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'"