Mercurial > hg > xemacs-beta
comparison lisp/diagnose.el @ 5170:5ddbab03b0e6
various fixes to memory-usage stats
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-03-25 Ben Wing <ben@xemacs.org>
* diagnose.el (show-memory-usage):
* diagnose.el (show-object-memory-usage-stats):
Further changes to correspond with changes in the C code;
add an additional column in show-object-memory-usage-stats showing
the ancillary Lisp overhead used with each type; shrink columns for
windows in show-memory-usage to get it to fit in 79 chars.
src/ChangeLog addition:
2010-03-25 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (struct):
* alloc.c (finish_object_memory_usage_stats):
* alloc.c (object_memory_usage_stats):
* alloc.c (Fobject_memory_usage):
* alloc.c (lisp_object_memory_usage_full):
* alloc.c (compute_memusage_stats_length):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
Add fields to the `lrecord_implementation' structure to list an
offset into the array of extra statistics in a
`struct generic_usage_stats' and a length, listing the first slice
of ancillary Lisp-object memory. Compute automatically in
compute_memusage_stats_length(). Use to add an entry
`FOO-lisp-ancillary-storage' for object type FOO.
Don't crash when an int or char is given to object-memory-usage,
signal an error instead.
Add functions lisp_object_memory_usage_full() and
lisp_object_memory_usage() to compute the total memory usage of an
object (sum of object, non-Lisp attached, and Lisp ancillary
memory).
* array.c:
* array.c (gap_array_memory_usage):
* array.h:
Add function to return memory usage of a gap array.
* buffer.c (struct buffer_stats):
* buffer.c (compute_buffer_usage):
* buffer.c (vars_of_buffer):
* extents.c (compute_buffer_extent_usage):
* marker.c:
* marker.c (compute_buffer_marker_usage):
* extents.h:
* lisp.h:
Remove `struct usage_stats' arg from compute_buffer_marker_usage()
and compute_buffer_extent_usage() -- these are ancillary Lisp
objects and don't get accumulated into `struct usage_stats';
change the value of `memusage_stats_list' so that `markers' and
`extents' memory is in Lisp-ancillary, where it belongs.
In compute_buffer_marker_usage(), use lisp_object_memory_usage()
rather than lisp_object_storage_size().
* casetab.c:
* casetab.c (case_table_memory_usage):
* casetab.c (vars_of_casetab):
* emacs.c (main_1):
Add memory usage stats for case tables.
* lisp.h:
Add comment explaining the `struct generic_usage_stats' more,
as well as the new fields in lrecord_implementation.
* console-impl.h:
* console-impl.h (struct console_methods):
* scrollbar-gtk.c:
* scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage):
* scrollbar-msw.c:
* scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage):
* scrollbar-x.c:
* scrollbar-x.c (x_compute_scrollbar_instance_usage):
* scrollbar.c:
* scrollbar.c (struct scrollbar_instance_stats):
* scrollbar.c (compute_all_scrollbar_instance_usage):
* scrollbar.c (scrollbar_instance_memory_usage):
* scrollbar.c (scrollbar_objects_create):
* scrollbar.c (vars_of_scrollbar):
* scrollbar.h:
* symsinit.h:
* window.c:
* window.c (find_window_mirror_maybe):
* window.c (struct window_mirror_stats):
* window.c (compute_window_mirror_usage):
* window.c (window_mirror_memory_usage):
* window.c (compute_window_usage):
* window.c (window_objects_create):
* window.c (syms_of_window):
* window.c (vars_of_window):
Redo memory-usage associated with windows, window mirrors, and
scrollbar instances. Should fix crash in find_window_mirror,
among other things. Properly assign memo ry to object memory,
non-Lisp extra memory, and Lisp ancillary memory. For example,
redisplay structures are non-Lisp memory hanging off a window
mirror, not a window; make it an ancillary Lisp-object field.
Window mirrors and scrollbar instances have their own statistics,
among other things.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Thu, 25 Mar 2010 06:07:25 -0500 |
parents | ab9ee10a53e4 |
children | 4c56e7c6a704 |
comparison
equal
deleted
inserted
replaced
5169:6c6d78781d59 | 5170:5ddbab03b0e6 |
---|---|
33 | 33 |
34 (defun show-memory-usage () | 34 (defun show-memory-usage () |
35 "Show statistics about memory usage of various sorts in XEmacs." | 35 "Show statistics about memory usage of various sorts in XEmacs." |
36 (interactive) | 36 (interactive) |
37 (garbage-collect) | 37 (garbage-collect) |
38 (flet ((show-foo-stats (objtypename cleanfun objlist) | 38 (flet ((show-foo-stats (objtypename statname-plist cleanfun objlist |
39 &optional objnamelen) | |
39 (let* ((hash (make-hash-table)) | 40 (let* ((hash (make-hash-table)) |
40 (first t) | 41 (first t) |
41 types fmt | 42 types origtypes fmt |
42 (objnamelen 25) | 43 (objnamelen (or objnamelen 25)) |
43 (linelen objnamelen) | 44 (linelen objnamelen) |
44 (totaltotal 0)) | 45 (totaltotal 0)) |
45 (loop for obj in objlist do | 46 (loop for obj in objlist do |
46 (let ((total 0) | 47 (let ((total 0) |
47 (stats (object-memory-usage obj))) | 48 (stats (object-memory-usage obj))) |
52 ;; non-Lisp-Object memory from the allocation | 53 ;; non-Lisp-Object memory from the allocation |
53 ;; perspective, so we can get to the slice describing | 54 ;; perspective, so we can get to the slice describing |
54 ;; the memory grouped by type | 55 ;; the memory grouped by type |
55 (while (and stats (pop stats))) | 56 (while (and stats (pop stats))) |
56 | 57 |
57 (loop for (type . num) in stats while type do | 58 (loop for (type . num) in (remq t stats) while type do |
59 (if first (push type origtypes)) | |
60 (setq type (getf statname-plist type type)) | |
58 (puthash type (+ num (or (gethash type hash) 0)) hash) | 61 (puthash type (+ num (or (gethash type hash) 0)) hash) |
59 (incf total num) | 62 (incf total num) |
60 (if first (push type types))) | 63 (if first (push type types))) |
61 (incf totaltotal total) | 64 (incf totaltotal total) |
62 (when first | 65 (when first |
63 (setq types (nreverse types)) | 66 (setq types (nreverse types)) |
67 (setq origtypes (nreverse origtypes)) | |
64 (setq fmt (concat | 68 (setq fmt (concat |
65 (format "%%-%ds" objnamelen) | 69 (format "%%-%ds" objnamelen) |
66 (mapconcat | 70 (mapconcat |
67 #'(lambda (type) | 71 #'(lambda (type) |
68 (let ((fieldlen | 72 (let ((fieldlen |
69 (max 8 (+ 2 (length | 73 (max 7 (+ 2 (length |
70 (symbol-name type)))))) | 74 (symbol-name type)))))) |
71 (incf linelen fieldlen) | 75 (incf linelen fieldlen) |
72 (format "%%%ds" fieldlen))) | 76 (format "%%%ds" fieldlen))) |
73 types "") | 77 types "") |
74 (progn (incf linelen 9) "%9s\n"))) | 78 (progn (incf linelen 9) "%9s\n"))) |
81 (princ (apply 'format fmt (substring objname 0 | 85 (princ (apply 'format fmt (substring objname 0 |
82 (min (length objname) | 86 (min (length objname) |
83 (1- objnamelen))) | 87 (1- objnamelen))) |
84 (nconc (mapcar #'(lambda (type) | 88 (nconc (mapcar #'(lambda (type) |
85 (cdr (assq type stats))) | 89 (cdr (assq type stats))) |
86 types) | 90 origtypes) |
87 (list total))))) | 91 (list total))))) |
88 (setq first nil))) | 92 (setq first nil))) |
89 (princ "\n") | 93 (princ "\n") |
90 (princ (apply 'format fmt "total" | 94 (princ (apply 'format fmt "total" |
91 (nconc (mapcar #'(lambda (type) | 95 (nconc (mapcar #'(lambda (type) |
101 (save-excursion | 105 (save-excursion |
102 (set-buffer buffer) | 106 (set-buffer buffer) |
103 (when-fboundp 'charset-list | 107 (when-fboundp 'charset-list |
104 (setq begin (point)) | 108 (setq begin (point)) |
105 (incf grandtotal | 109 (incf grandtotal |
106 (show-foo-stats 'charset 'charset-name | 110 (show-foo-stats 'charset nil 'charset-name |
107 (mapcar 'get-charset (charset-list)))) | 111 (mapcar 'get-charset (charset-list)))) |
108 (when-fboundp 'sort-numeric-fields | 112 (when-fboundp 'sort-numeric-fields |
109 (sort-numeric-fields -1 | 113 (sort-numeric-fields -1 |
110 (save-excursion | 114 (save-excursion |
111 (goto-char begin) | 115 (goto-char begin) |
115 (forward-line -2) | 119 (forward-line -2) |
116 (point)))) | 120 (point)))) |
117 (princ "\n")) | 121 (princ "\n")) |
118 (setq begin (point)) | 122 (setq begin (point)) |
119 (incf grandtotal | 123 (incf grandtotal |
120 (show-foo-stats 'buffer 'buffer-name (buffer-list))) | 124 (show-foo-stats 'buffer nil 'buffer-name (buffer-list))) |
121 (when-fboundp 'sort-numeric-fields | 125 (when-fboundp 'sort-numeric-fields |
122 (sort-numeric-fields -1 | 126 (sort-numeric-fields -1 |
123 (save-excursion | 127 (save-excursion |
124 (goto-char begin) | 128 (goto-char begin) |
125 (forward-line 3) | 129 (forward-line 3) |
128 (forward-line -2) | 132 (forward-line -2) |
129 (point)))) | 133 (point)))) |
130 (princ "\n") | 134 (princ "\n") |
131 (setq begin (point)) | 135 (setq begin (point)) |
132 (incf grandtotal | 136 (incf grandtotal |
133 (show-foo-stats 'window #'(lambda (x) | 137 (show-foo-stats 'window |
134 (buffer-name (window-buffer x))) | 138 '(line-start-cache line-st. |
139 face-cache face | |
140 glyph-cache glyph | |
141 redisplay-structs redisplay | |
142 scrollbar-instances scrollbar | |
143 window-mirror mirror) | |
144 #'(lambda (x) | |
145 (buffer-name (window-buffer x))) | |
135 (mapcan #'(lambda (fr) | 146 (mapcan #'(lambda (fr) |
136 (window-list fr t)) | 147 (window-list fr t)) |
137 (frame-list)))) | 148 (frame-list)) |
149 16)) | |
138 (when-fboundp #'sort-numeric-fields | 150 (when-fboundp #'sort-numeric-fields |
139 (sort-numeric-fields -1 | 151 (sort-numeric-fields -1 |
140 (save-excursion | 152 (save-excursion |
141 (goto-char begin) | 153 (goto-char begin) |
142 (forward-line 3) | 154 (forward-line 3) |
150 (setq begin (point)) | 162 (setq begin (point)) |
151 (princ (format fmt "object" "storage")) | 163 (princ (format fmt "object" "storage")) |
152 (princ (make-string 40 ?-)) | 164 (princ (make-string 40 ?-)) |
153 (princ "\n") | 165 (princ "\n") |
154 (map-plist #'(lambda (stat num) | 166 (map-plist #'(lambda (stat num) |
155 (when (string-match | 167 (when (and |
156 "\\(.*\\)-storage$" | 168 (not |
157 (symbol-name stat)) | 169 (string-match |
170 "\\(.*\\)-ancillary-storage$" | |
171 (symbol-name stat))) | |
172 (string-match | |
173 "\\(.*\\)-storage$" | |
174 (symbol-name stat))) | |
158 (incf total num) | 175 (incf total num) |
159 (princ (format fmt | 176 (princ (format fmt |
160 (match-string 1 (symbol-name stat)) | 177 (match-string 1 (symbol-name stat)) |
161 num))) | 178 num))) |
162 ) | 179 ) |
182 "Show statistics about object memory usage in XEmacs." | 199 "Show statistics about object memory usage in XEmacs." |
183 (interactive) | 200 (interactive) |
184 (garbage-collect) | 201 (garbage-collect) |
185 (let ((buffer "*object memory usage statistics*") | 202 (let ((buffer "*object memory usage statistics*") |
186 (plist (object-memory-usage-stats)) | 203 (plist (object-memory-usage-stats)) |
187 (fmt "%-30s%10s%10s%10s%18s\n") | 204 (fmt "%-28s%10s%10s%10s%10s%10s\n") |
188 (grandtotal 0) | 205 (grandtotal 0) |
189 begin) | 206 begin) |
190 (flet ((show-stats (match-string) | 207 (flet ((show-stats (match-string) |
191 (princ (format fmt "object" "count" "storage" "overhead" | 208 (princ (format "%28s%10s%40s\n" "" "" |
192 "non-Lisp storage")) | 209 "--------------storage---------------")) |
210 (princ (format fmt "object" "count" "object" "overhead" | |
211 "non-Lisp" "ancillary")) | |
193 (princ (make-string 78 ?-)) | 212 (princ (make-string 78 ?-)) |
194 (princ "\n") | 213 (princ "\n") |
195 (let ((total-use 0) | 214 (let ((total-use 0) |
196 (total-non-lisp-use 0) | 215 (total-non-lisp-use 0) |
197 (total-use-overhead 0) | 216 (total-use-overhead 0) |
200 (map-plist | 219 (map-plist |
201 #'(lambda (stat num) | 220 #'(lambda (stat num) |
202 (let ((symmatch | 221 (let ((symmatch |
203 (and (string-match match-string (symbol-name stat)) | 222 (and (string-match match-string (symbol-name stat)) |
204 (match-string 1 (symbol-name stat))))) | 223 (match-string 1 (symbol-name stat))))) |
205 (when (and symmatch (or (< (length symmatch) 9) | 224 (when (and symmatch |
206 (not (equal (substring symmatch -9) | 225 (or (< (length symmatch) 9) |
207 "-non-lisp")))) | 226 (not (equal (substring symmatch -9) |
227 "-non-lisp"))) | |
228 (or (< (length symmatch) 15) | |
229 (not (equal (substring symmatch -15) | |
230 "-lisp-ancillary")))) | |
208 (let* ((storage-use num) | 231 (let* ((storage-use num) |
209 (storage-use-overhead | 232 (storage-use-overhead |
210 (or (plist-get | 233 (or (plist-get |
211 plist | 234 plist |
212 (intern (concat symmatch | 235 (intern (concat symmatch |
224 (non-lisp-storage | 247 (non-lisp-storage |
225 (or (plist-get | 248 (or (plist-get |
226 plist | 249 plist |
227 (intern (concat symmatch | 250 (intern (concat symmatch |
228 "-non-lisp-storage"))) | 251 "-non-lisp-storage"))) |
252 0)) | |
253 (lisp-ancillary-storage | |
254 (or (plist-get | |
255 plist | |
256 (intern (concat symmatch | |
257 "-lisp-ancillary-storage"))) | |
229 0)) | 258 0)) |
230 (storage-count | 259 (storage-count |
231 (or (loop for str in '("s-used" "es-used" "-used") | 260 (or (loop for str in '("s-used" "es-used" "-used") |
232 for val = (plist-get | 261 for val = (plist-get |
233 plist | 262 plist |
249 (and (> storage-use-with-overhead 0) | 278 (and (> storage-use-with-overhead 0) |
250 (princ (format fmt symmatch | 279 (princ (format fmt symmatch |
251 (or storage-count "unknown") | 280 (or storage-count "unknown") |
252 storage-use | 281 storage-use |
253 storage-use-overhead | 282 storage-use-overhead |
254 non-lisp-storage))))))) | 283 non-lisp-storage |
284 lisp-ancillary-storage))))))) | |
255 plist) | 285 plist) |
256 (princ "\n") | 286 (princ "\n") |
257 (princ (format fmt "total" | 287 (princ (format fmt "total" |
258 total-count total-use total-use-overhead | 288 total-count total-use total-use-overhead |
259 total-non-lisp-use)) | 289 total-non-lisp-use "")) |
260 (incf grandtotal total-use-with-overhead) | 290 (incf grandtotal total-use-with-overhead) |
261 (incf grandtotal total-non-lisp-use) | 291 (incf grandtotal total-non-lisp-use) |
262 (when-fboundp #'sort-numeric-fields | 292 (when-fboundp #'sort-numeric-fields |
263 (sort-numeric-fields -3 | 293 (sort-numeric-fields -4 |
264 (save-excursion | 294 (save-excursion |
265 (goto-char begin) | 295 (goto-char begin) |
266 (forward-line 3) | 296 (forward-line 4) |
267 (point)) | 297 (point)) |
268 (save-excursion | 298 (save-excursion |
269 (forward-line -2) | 299 (forward-line -2) |
270 (point))))))) | 300 (point))))))) |
271 (with-output-to-temp-buffer buffer | 301 (with-output-to-temp-buffer buffer |