Add a new command `memory-report'

* doc/lispref/internals.texi (Garbage Collection): Document it.
* lisp/emacs-lisp/memory-report.el: New package.

diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index bb25983aa4b7b457d550cffc7dd35f1e3bf4621b..fb24544c91757a2f99d9c231a010e96e54682974 100644 (file)
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -615,6 +615,19 @@ during garbage collection so far in this Emacs session, as a
 floating-point number.
 @end defvar
 
+@defun memory-report
+It can sometimes be useful to see where Emacs is using memory (in
+various variables, buffers, and caches).  This command will open a new
+buffer (called @samp{"*Memory Report*"}) that will give an overview,
+in addition to listing the ``largest'' buffers and variables.
+
+All the data here is approximate, because there's really no consistent
+way to compute the size of a variable.  For instance, two variables
+may share parts of a data structure, and this will be counted twice,
+but this command may still give a useful high-level overview of which
+parts of Emacs is using memory.
+@end defun
+
 @node Stack-allocated Objects
 @section Stack-allocated Objects
 

diff --git a/etc/NEWS b/etc/NEWS
index 1640e2779874b0f7e116a567b47d8ac631d9c132..33cc2c30a0866994294ca8c2cb34b83c6ba2690e 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -275,6 +275,11 @@ preserving markers, properties and overlays.  The new variable
 number of seconds that 'revert-buffer-with-fine-grain' should spend
 trying to be non-destructive.
 
++++
+** New command 'memory-report'.
+This command opens a new buffer called "*Memory Report*" and gives a
+summary of where Emacs is using memory currently.
+
 ** Outline
 
 +++

diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el
new file mode 100644 (file)
index 0000000..58555fa
--- /dev/null
+++ b/lisp/emacs-lisp/memory-report.el
@@ -0,0 +1,299 @@
+;;; 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 (nreverse 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 "%5.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/test/lisp/emacs-lisp/memory-report-tests.el b/test/lisp/emacs-lisp/memory-report-tests.el
new file mode 100644 (file)
index 0000000..01bcf18
--- /dev/null
+++ b/test/lisp/emacs-lisp/memory-report-tests.el
@@ -0,0 +1,54 @@
+;;; memory-report-tests.el --- tests for memory-report.el              -*- lexical-binding: t -*-
+
+;; Copyright (C) 2016-2020 Free Software Foundation, Inc.
+
+;; 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/>.
+
+(require 'ert)
+(require 'memory-report)
+
+(defun setup-memory-report-tests ()
+  (memory-report--set-size
+   '((conses 16 499173 99889)
+     (symbols 48 22244 3)
+     (strings 32 92719 4559)
+     (string-bytes 1 40402011)
+     (vectors 16 31919)
+     (vector-slots 8 385148 149240)
+     (floats 8 434 4519)
+     (intervals 56 24499 997)
+     (buffers 984 33))))
+
+(ert-deftest memory-report-sizes ()
+  (setup-memory-report-tests)
+  (should (equal (memory-report-object-size (cons nil nil)) 16))
+  (should (equal (memory-report-object-size (cons 1 2)) 16))
+
+  (should (equal (memory-report-object-size (list 1 2)) 32))
+  (should (equal (memory-report-object-size (list 1)) 16))
+
+  (should (equal (memory-report-object-size (list 'foo)) 16))
+
+  (should (equal (memory-report-object-size (vector 1 2 3 4)) 80))
+
+  (should (equal (memory-report-object-size "") 32))
+  (should (equal (memory-report-object-size "a") 33))
+  (should (equal (memory-report-object-size (propertize "a" 'face 'foo))
+                 81)))
+
+(provide 'memory-report-tests)
+
+;;; memory-report-tests.el ends here