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