procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Andrea Corallo 2021-03-19 15:28:00 +01:00
commit 6ca6c71cd0
251 changed files with 3552 additions and 2998 deletions
Download patch file Download diff file Expand all files Collapse all files

98
lisp/emacs-lisp/benchmark.el
View file

@ -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))
@ -40,6 +42,61 @@
,@forms
(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.
@ -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)

64
lisp/emacs-lisp/chart.el
View file

@ -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)

24
lisp/emacs-lisp/cl-macs.el
View file

@ -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)))

2
lisp/emacs-lisp/generator.el
View file

@ -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

3
lisp/emacs-lisp/gv.el
View file

@ -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.

2
lisp/emacs-lisp/memory-report.el
View file

@ -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))

16
lisp/emacs-lisp/package.el
View file

@ -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'"