diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 14 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eldoc.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/elint.el | 10 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 8 | ||||
| -rw-r--r-- | lisp/emacs-lisp/memory-report.el | 301 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/thunk.el | 2 |
8 files changed, 331 insertions, 10 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 02da07daaf4..b37b05b9a3a 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -410,8 +410,18 @@ the specializer used will be the one returned by BODY." ;;;###autoload (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. -I.e. it defines the implementation of NAME to use for invocations where the -values of the dispatch arguments match the specified TYPEs. +This it defines an implementation of NAME to use for invocations +of specific types of arguments. + +ARGS is a list of dispatch arguments (see `cl-defun'), but where +each variable element is either just a single variable name VAR, +or a list on the form (VAR TYPE). + +For instance: + + (cl-defmethod foo (bar (format-string string) &optional zot) + (format format-string bar)) + The dispatch arguments have to be among the mandatory arguments, and all methods of NAME have to use the same set of arguments for dispatch. Each dispatch argument and TYPE are specified in ARGS where the corresponding diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index d81060ef165..6a976841038 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -467,7 +467,6 @@ This holds the results of the last documentation request." (defun eldoc--format-doc-buffer (docs) "Ensure DOCS are displayed in an *eldoc* buffer." - (interactive (list t)) (with-current-buffer (if (buffer-live-p eldoc--doc-buffer) eldoc--doc-buffer (setq eldoc--doc-buffer diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index ef97c8279d7..79b72ff969f 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -558,7 +558,8 @@ Return nil if there are no more forms, t otherwise." (when . elint-check-conditional-form) (unless . elint-check-conditional-form) (and . elint-check-conditional-form) - (or . elint-check-conditional-form)) + (or . elint-check-conditional-form) + (require . elint-require-form)) "Functions to call when some special form should be linted.") (defun elint-form (form env &optional nohandler) @@ -953,6 +954,13 @@ Does basic handling of `featurep' tests." (elint-form form env t)))) env) +(defun elint-require-form (form _env) + "Load `require'd files." + (pcase form + (`(require ',x) + (require x))) + nil) + ;;; ;;; Message functions ;;; diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 5f29c2665a3..25237feae2a 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -274,7 +274,7 @@ DATA is displayed to the user and should state the reason for skipping." It should only be stopped when ran from inside ert--run-test-internal." (when (and (not (symbolp debugger)) ; only run on anonymous debugger (memq error-symbol '(ert-test-failed ert-test-skipped))) - (funcall debugger 'error data))) + (funcall debugger 'error (list error-symbol data)))) (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 081ef8d441a..e477ef17000 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -38,7 +38,7 @@ (define-abbrev-table 'lisp-mode-abbrev-table () "Abbrev table for Lisp mode.") -(defvar lisp--mode-syntax-table +(defvar lisp-data-mode-syntax-table (let ((table (make-syntax-table)) (i 0)) (while (< i ?0) @@ -77,11 +77,13 @@ (modify-syntax-entry ?\\ "\\ " table) (modify-syntax-entry ?\( "() " table) (modify-syntax-entry ?\) ")( " table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) table) "Parent syntax table used in Lisp modes.") (defvar lisp-mode-syntax-table - (let ((table (make-syntax-table lisp--mode-syntax-table))) + (let ((table (make-syntax-table lisp-data-mode-syntax-table))) (modify-syntax-entry ?\[ "_ " table) (modify-syntax-entry ?\] "_ " table) (modify-syntax-entry ?# "' 14" table) @@ -669,7 +671,7 @@ font-lock keywords will not be case sensitive." (define-derived-mode lisp-data-mode prog-mode "Lisp-Data" "Major mode for buffers holding data written in Lisp syntax." :group 'lisp - (lisp-mode-variables t t nil) + (lisp-mode-variables nil t nil) (setq-local electric-quote-string t) (setq imenu-case-fold-search nil)) diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el new file mode 100644 index 00000000000..c88d9f2768a --- /dev/null +++ b/lisp/emacs-lisp/memory-report.el @@ -0,0 +1,301 @@ +;;; memory-report.el --- Short function summaries -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Keywords: lisp, help + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Todo (possibly): Font cache, regexp cache, bidi cache, various +;; buffer caches (newline cache, free_region_cache, etc), composition +;; cache, face cache. + +;;; Code: + +(require 'seq) +(require 'subr-x) +(eval-when-compile (require 'cl-lib)) + +(defvar memory-report--type-size (make-hash-table)) + +;;;###autoload +(defun memory-report () + "Generate a report of how Emacs is using memory. + +This report is approximate, and will commonly over-count memory +usage by variables, because shared data structures will usually +by counted more than once." + (interactive) + (pop-to-buffer "*Memory Report*") + (special-mode) + (button-mode 1) + (setq truncate-lines t) + (message "Gathering data...") + (let ((reports (append (memory-report--garbage-collect) + (memory-report--image-cache) + (memory-report--buffers) + (memory-report--largest-variables))) + (inhibit-read-only t) + summaries details) + (message "Gathering data...done") + (erase-buffer) + (insert (propertize "Estimated Emacs Memory Usage\n\n" 'face 'bold)) + (dolist (report reports) + (if (listp report) + (push report summaries) + (push report details))) + (dolist (summary (seq-sort (lambda (e1 e2) + (> (cdr e1) (cdr e2))) + summaries)) + (insert (format "%s %s\n" + (memory-report--format (cdr summary)) + (car summary)))) + (insert "\n") + (dolist (detail (nreverse details)) + (insert detail "\n"))) + (goto-char (point-min))) + +(defun memory-report-object-size (object) + "Return the size of OBJECT in bytes." + (unless memory-report--type-size + (memory-report--garbage-collect)) + (memory-report--object-size (make-hash-table :test #'eq) object)) + +(defun memory-report--size (type) + (or (gethash type memory-report--type-size) + (gethash 'object memory-report--type-size))) + +(defun memory-report--set-size (elems) + (setf (gethash 'string memory-report--type-size) + (cadr (assq 'strings elems))) + (setf (gethash 'cons memory-report--type-size) + (cadr (assq 'conses elems))) + (setf (gethash 'symbol memory-report--type-size) + (cadr (assq 'symbols elems))) + (setf (gethash 'object memory-report--type-size) + (cadr (assq 'vectors elems))) + (setf (gethash 'float memory-report--type-size) + (cadr (assq 'floats elems))) + (setf (gethash 'buffer memory-report--type-size) + (cadr (assq 'buffers elems)))) + +(defun memory-report--garbage-collect () + (let ((elems (garbage-collect))) + (memory-report--set-size elems) + (let ((data (list + (list 'strings + (+ (memory-report--gc-elem elems 'strings) + (memory-report--gc-elem elems 'string-bytes))) + (list 'vectors + (+ (memory-report--gc-elem elems 'vectors) + (memory-report--gc-elem elems 'vector-slots))) + (list 'floats (memory-report--gc-elem elems 'floats)) + (list 'conses (memory-report--gc-elem elems 'conses)) + (list 'symbols (memory-report--gc-elem elems 'symbols)) + (list 'intervals (memory-report--gc-elem elems 'intervals)) + (list 'buffer-objects + (memory-report--gc-elem elems 'buffers))))) + (list (cons "Overall Object Memory Usage" + (seq-reduce #'+ (mapcar (lambda (elem) + (* (nth 1 elem) (nth 2 elem))) + elems) + 0)) + (cons "Reserved (But Unused) Object Memory" + (seq-reduce #'+ (mapcar (lambda (elem) + (if (nth 3 elem) + (* (nth 1 elem) (nth 3 elem)) + 0)) + elems) + 0)) + (with-temp-buffer + (insert (propertize "Object Storage\n\n" 'face 'bold)) + (dolist (object (seq-sort (lambda (e1 e2) + (> (cadr e1) (cadr e2))) + data)) + (insert (format "%s %s\n" + (memory-report--format (cadr object)) + (capitalize (symbol-name (car object)))))) + (buffer-string)))))) + +(defun memory-report--largest-variables () + (let ((variables nil)) + (mapatoms + (lambda (symbol) + (when (boundp symbol) + (let ((size (memory-report--object-size + (make-hash-table :test #'eq) + (symbol-value symbol)))) + (when (> size 1000) + (push (cons symbol size) variables))))) + obarray) + (list + (cons (propertize "Memory Used By Global Variables" + 'help-echo "Upper bound; mutually overlapping data from different variables are counted several times") + (seq-reduce #'+ (mapcar #'cdr variables) 0)) + (with-temp-buffer + (insert (propertize "Largest Variables\n\n" 'face 'bold)) + (cl-loop for i from 1 upto 20 + for (symbol . size) in (seq-sort (lambda (e1 e2) + (> (cdr e1) (cdr e2))) + variables) + do (insert (memory-report--format size) + " " + (symbol-name symbol) + "\n")) + (buffer-string))))) + +(defun memory-report--object-size (counted value) + (if (gethash value counted) + 0 + (setf (gethash value counted) t) + (memory-report--object-size-1 counted value))) + +(cl-defgeneric memory-report--object-size-1 (_counted _value) + 0) + +(cl-defmethod memory-report--object-size-1 (_ (value symbol)) + ;; Don't count global symbols -- makes sizes of lists of symbols too + ;; heavey. + (if (intern-soft value obarray) + 0 + (memory-report--size 'symbol))) + +(cl-defmethod memory-report--object-size-1 (_ (_value buffer)) + (memory-report--size 'buffer)) + +(cl-defmethod memory-report--object-size-1 (counted (value string)) + (+ (memory-report--size 'string) + (string-bytes value) + (memory-report--interval-size counted (object-intervals value)))) + +(defun memory-report--interval-size (counted intervals) + ;; We get a list back of intervals, but only count the "inner list" + ;; (i.e., the actual text properties), and add the size of the + ;; intervals themselves. + (+ (* (memory-report--size 'interval) (length intervals)) + (seq-reduce #'+ (mapcar + (lambda (interval) + (memory-report--object-size counted (nth 2 interval))) + intervals) + 0))) + +(cl-defmethod memory-report--object-size-1 (counted (value list)) + (let ((total 0) + (size (memory-report--size 'cons))) + (while value + (cl-incf total size) + (setf (gethash value counted) t) + (when (car value) + (cl-incf total (memory-report--object-size counted (car value)))) + (if (cdr value) + (if (consp (cdr value)) + (setq value (cdr value)) + (cl-incf total (memory-report--object-size counted (cdr value))) + (setq value nil)) + (setq value nil))) + total)) + +(cl-defmethod memory-report--object-size-1 (counted (value vector)) + (let ((total (+ (memory-report--size 'vector) + (* (memory-report--size 'object) (length value))))) + (cl-loop for elem across value + do (setf (gethash elem counted) t) + (cl-incf total (memory-report--object-size counted elem))) + total)) + +(cl-defmethod memory-report--object-size-1 (counted (value hash-table)) + (let ((total (+ (memory-report--size 'vector) + (* (memory-report--size 'object) (hash-table-size value))))) + (maphash + (lambda (key elem) + (setf (gethash key counted) t) + (setf (gethash elem counted) t) + (cl-incf total (memory-report--object-size counted key)) + (cl-incf total (memory-report--object-size counted elem))) + value) + total)) + +(defun memory-report--format (bytes) + (setq bytes (/ bytes 1024.0)) + (let ((units '("kB" "MB" "GB" "TB"))) + (while (>= bytes 1024) + (setq bytes (/ bytes 1024.0)) + (setq units (cdr units))) + (format "%6.1f%s" bytes (car units)))) + +(defun memory-report--gc-elem (elems type) + (* (nth 1 (assq type elems)) + (nth 2 (assq type elems)))) + +(defun memory-report--buffers () + (let ((buffers (mapcar (lambda (buffer) + (cons buffer (memory-report--buffer buffer))) + (buffer-list)))) + (list (cons "Total Buffer Memory Usage" + (seq-reduce #'+ (mapcar #'cdr buffers) 0)) + (with-temp-buffer + (insert (propertize "Largest Buffers\n\n" 'face 'bold)) + (cl-loop for i from 1 upto 20 + for (buffer . size) in (seq-sort (lambda (e1 e2) + (> (cdr e1) (cdr e2))) + buffers) + do (insert (memory-report--format size) + " " + (button-buttonize + (buffer-name buffer) + #'memory-report--buffer-details buffer) + "\n")) + (buffer-string))))) + +(defun memory-report--buffer-details (buffer) + (with-current-buffer buffer + (apply + #'message + "Buffer text: %s; variables: %s; text properties: %s; overlays: %s" + (mapcar #'string-trim (mapcar #'memory-report--format + (memory-report--buffer-data buffer)))))) + +(defun memory-report--buffer (buffer) + (seq-reduce #'+ (memory-report--buffer-data buffer) 0)) + +(defun memory-report--buffer-data (buffer) + (with-current-buffer buffer + (list (save-restriction + (widen) + (+ (position-bytes (point-max)) + (- (position-bytes (point-min))) + (gap-size))) + (seq-reduce #'+ (mapcar (lambda (elem) + (if (cdr elem) + (memory-report--object-size + (make-hash-table :test #'eq) + (cdr elem)) + 0)) + (buffer-local-variables buffer)) + 0) + (memory-report--object-size (make-hash-table :test #'eq) + (object-intervals buffer)) + (memory-report--object-size (make-hash-table :test #'eq) + (overlay-lists))))) + +(defun memory-report--image-cache () + (list (cons "Total Image Cache Size" (image-cache-size)))) + +(provide 'memory-report) + +;;; memory-report.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index e603900b095..206f0dd1a9d 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -409,7 +409,8 @@ of the elements of LIST is performed as if by `pcase-let'. (dolist (case cases) (unless (or (memq case used-cases) (memq (car case) pcase--dontwarn-upats)) - (message "Redundant pcase pattern: %S" (car case)))) + (message "pcase pattern %S shadowed by previous pcase pattern" + (car case)))) (macroexp-let* defs main)))) (defun pcase--macroexpand (pat) diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el index c8e483e9a4a..cd42152527e 100644 --- a/lisp/emacs-lisp/thunk.el +++ b/lisp/emacs-lisp/thunk.el @@ -122,7 +122,7 @@ Using `thunk-let' and `thunk-let*' requires `lexical-binding'." (declare (indent 1) (debug let)) (cl-reduce (lambda (expr binding) `(thunk-let (,binding) ,expr)) - (nreverse bindings) + (reverse bindings) :initial-value (macroexp-progn body))) ;; (defalias 'lazy-let #'thunk-let) |