Mercurial > hg > xemacs-beta
annotate lisp/diagnose.el @ 5158:9e0b43d3095c
more cleanups to object-memory-usage stuff
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-03-19 Ben Wing <ben@xemacs.org>
* diagnose.el (show-object-memory-usage-stats):
Rewrite to take into account non-lisp-storage statistics
returned by garbage-collect-1 and friends.
src/ChangeLog addition:
2010-03-19 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (struct):
* alloc.c (tick_lrecord_stats):
* alloc.c (gc_sweep_1):
* alloc.c (finish_object_memory_usage_stats):
* alloc.c (object_memory_usage_stats):
* alloc.c (compute_memusage_stats_length):
Call new memory-usage mechanism at sweep time to compute extra
memory utilization for all objects. Add up the values element-by-
element to get an aggregrate set of statistics, where each is the
sum of the values of a single statistic across different objects
of the same type. At end of sweep time, call
finish_object_memory_usage_stats() to add up all the aggreggrate
stats that are related to non-Lisp memory storage to compute
a single value, and add it to the list of values returned by
`garbage-collect' and `object-memory-usage-stats'.
* buffer.c (compute_buffer_text_usage):
Don't crash on buffers without text (killed buffers?) and don't
double-count indirect buffers.
* elhash.c:
* elhash.c (hash_table_objects_create):
* elhash.c (vars_of_elhash):
* symsinit.h:
Add memory-usage method to count the size of `hentries'.
* emacs.c (main_1):
Call new functions in elhash.c, frame.c at init.
* frame.c:
* frame.c (compute_frame_usage):
* frame.c (frame_memory_usage):
* frame.c (frame_objects_create):
* symsinit.h:
Add memory-usage method to count gutter display structures,
subwindow exposures.
* gc.c (gc_finish):
* lisp.h:
Declare finish_object_memory_usage_stats(), call it in gc_finish().
* lrecord.h (struct lrecord_implementation):
* lrecord.h (INIT_MEMORY_USAGE_STATS):
New value in implementation struct to track number of non-Lisp-memory
statistics. Computed in alloc.c.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 19 Mar 2010 14:47:44 -0500 |
| parents | 1fae11d56ad2 |
| children | ab9ee10a53e4 |
| rev | line source |
|---|---|
| 2618 | 1 ;;; diagnose.el --- routines for debugging problems in XEmacs |
| 787 | 2 |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
3 ;; Copyright (C) 2002, 2010 Ben Wing. |
| 787 | 4 |
| 5 ;; Maintainer: XEmacs Development Team | |
| 6 ;; Keywords: dumped | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;; This file is dumped with XEmacs. | |
| 30 | |
| 31 ;;; Code: | |
| 32 | |
| 33 | |
| 34 (defun show-memory-usage () | |
| 35 "Show statistics about memory usage of various sorts in XEmacs." | |
| 36 (interactive) | |
| 37 (garbage-collect) | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
38 (flet ((show-foo-stats (objtypename cleanfun objlist) |
| 787 | 39 (let* ((hash (make-hash-table)) |
| 40 (first t) | |
| 41 types fmt | |
| 42 (objnamelen 25) | |
| 43 (linelen objnamelen) | |
| 44 (totaltotal 0)) | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
45 (loop for obj in objlist do |
| 787 | 46 (let ((total 0) |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
47 (stats (object-memory-usage obj))) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
48 ;; Pop off the slice describing the object itself's |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
49 ;; memory |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
50 (while (and stats (not (eq t (pop stats))))) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
51 ;; Pop off the slice describing the associated |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
52 ;; non-Lisp-Object memory from the allocation |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
53 ;; perspective, so we can get to the slice describing |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
54 ;; the memory grouped by type |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
55 (while (and stats (pop stats))) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
56 |
| 787 | 57 (loop for (type . num) in stats while type do |
| 58 (puthash type (+ num (or (gethash type hash) 0)) hash) | |
| 59 (incf total num) | |
| 60 (if first (push type types))) | |
| 61 (incf totaltotal total) | |
| 62 (when first | |
| 63 (setq types (nreverse types)) | |
| 64 (setq fmt (concat | |
| 65 (format "%%-%ds" objnamelen) | |
| 66 (mapconcat | |
| 67 #'(lambda (type) | |
| 68 (let ((fieldlen | |
| 69 (max 8 (+ 2 (length | |
| 70 (symbol-name type)))))) | |
| 71 (incf linelen fieldlen) | |
| 72 (format "%%%ds" fieldlen))) | |
| 73 types "") | |
| 2618 | 74 (progn (incf linelen 9) "%9s\n"))) |
| 787 | 75 (princ "\n") |
| 76 (princ (apply 'format fmt objtypename | |
| 77 (append types (list 'total)))) | |
| 78 (princ (make-string linelen ?-)) | |
| 79 (princ "\n")) | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
80 (let ((objname (format "%s" (funcall cleanfun obj)))) |
| 787 | 81 (princ (apply 'format fmt (substring objname 0 |
| 82 (min (length objname) | |
| 83 (1- objnamelen))) | |
| 84 (nconc (mapcar #'(lambda (type) | |
| 85 (cdr (assq type stats))) | |
| 86 types) | |
| 87 (list total))))) | |
| 88 (setq first nil))) | |
| 89 (princ "\n") | |
| 90 (princ (apply 'format fmt "total" | |
| 91 (nconc (mapcar #'(lambda (type) | |
| 92 (gethash type hash)) | |
| 93 types) | |
| 94 (list totaltotal)))) | |
| 95 totaltotal))) | |
| 96 | |
| 2618 | 97 (let ((grandtotal 0) |
| 98 (buffer "*memory usage*") | |
| 99 begin) | |
| 100 (with-output-to-temp-buffer buffer | |
| 101 (save-excursion | |
| 102 (set-buffer buffer) | |
| 103 (when-fboundp 'charset-list | |
| 104 (setq begin (point)) | |
| 105 (incf grandtotal | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
106 (show-foo-stats 'charset 'charset-name |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
107 (mapcar 'get-charset (charset-list)))) |
| 3066 | 108 (when-fboundp 'sort-numeric-fields |
| 109 (sort-numeric-fields -1 | |
| 110 (save-excursion | |
| 111 (goto-char begin) | |
| 112 (forward-line 2) | |
| 113 (point)) | |
| 114 (save-excursion | |
| 115 (forward-line -2) | |
| 116 (point)))) | |
| 2618 | 117 (princ "\n")) |
| 118 (setq begin (point)) | |
| 119 (incf grandtotal | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
120 (show-foo-stats 'buffer 'buffer-name (buffer-list))) |
| 3066 | 121 (when-fboundp 'sort-numeric-fields |
| 122 (sort-numeric-fields -1 | |
| 123 (save-excursion | |
| 124 (goto-char begin) | |
| 125 (forward-line 3) | |
| 126 (point)) | |
| 127 (save-excursion | |
| 128 (forward-line -2) | |
| 129 (point)))) | |
| 2618 | 130 (princ "\n") |
| 131 (setq begin (point)) | |
| 787 | 132 (incf grandtotal |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
133 (show-foo-stats 'window #'(lambda (x) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
134 (buffer-name (window-buffer x))) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
135 (mapcan #'(lambda (fr) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
136 (window-list fr t)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5059
diff
changeset
|
137 (frame-list)))) |
| 4103 | 138 (when-fboundp #'sort-numeric-fields |
| 139 (sort-numeric-fields -1 | |
| 140 (save-excursion | |
| 141 (goto-char begin) | |
| 142 (forward-line 3) | |
| 143 (point)) | |
| 144 (save-excursion | |
| 145 (forward-line -2) | |
| 146 (point)))) | |
| 787 | 147 (princ "\n") |
| 2618 | 148 (let ((total 0) |
| 149 (fmt "%-30s%10s\n")) | |
| 150 (setq begin (point)) | |
| 151 (princ (format fmt "object" "storage")) | |
| 152 (princ (make-string 40 ?-)) | |
| 153 (princ "\n") | |
| 154 (map-plist #'(lambda (stat num) | |
| 2775 | 155 (when (string-match |
| 3278 | 156 "\\(.*\\)-storage$" |
| 2775 | 157 (symbol-name stat)) |
| 2618 | 158 (incf total num) |
| 159 (princ (format fmt | |
| 160 (match-string 1 (symbol-name stat)) | |
| 161 num))) | |
| 162 (when (eq stat 'long-strings-total-length) | |
| 163 (incf total num) | |
| 164 (princ (format fmt stat num)))) | |
| 165 (sixth (garbage-collect))) | |
| 166 (princ "\n") | |
| 167 (princ (format fmt "total" total)) | |
| 168 (incf grandtotal total)) | |
| 4103 | 169 (when-fboundp #'sort-numeric-fields |
| 170 (sort-numeric-fields -1 | |
| 171 (save-excursion | |
| 172 (goto-char begin) | |
| 173 (forward-line 2) | |
| 174 (point)) | |
| 175 (save-excursion | |
| 176 (forward-line -2) | |
| 177 (point)))) | |
| 787 | 178 |
| 2618 | 179 (princ (format "\n\ngrand total: %s\n" grandtotal))) |
| 787 | 180 grandtotal)))) |
| 2720 | 181 |
| 182 | |
| 3041 | 183 (defun show-object-memory-usage-stats () |
| 3888 | 184 "Show statistics about object memory usage in XEmacs." |
| 2775 | 185 (interactive) |
| 186 (garbage-collect) | |
| 3041 | 187 (let ((buffer "*object memory usage statistics*") |
| 188 (plist (object-memory-usage-stats)) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
189 (fmt "%-30s%10s%10s%18s\n") |
| 2775 | 190 (grandtotal 0) |
| 191 begin) | |
| 192 (flet ((show-stats (match-string) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
193 (princ (format fmt "object" "count" "storage" "non-Lisp storage")) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
194 (princ (make-string 68 ?-)) |
| 2775 | 195 (princ "\n") |
| 196 (let ((total-use 0) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
197 (total-non-lisp-use 0) |
| 2775 | 198 (total-use-overhead 0) |
| 199 (total-count 0)) | |
| 200 (map-plist | |
| 201 #'(lambda (stat num) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
202 (when (and (string-match match-string |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
203 (symbol-name stat)) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
204 (let ((match (match-string |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
205 1 (symbol-name stat)))) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
206 (or (< (length match) 9) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
207 (not (equal (substring match -9) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
208 "-non-lisp"))))) |
| 2775 | 209 (let ((storage-use num) |
| 210 (storage-use-overhead | |
| 211 (plist-get | |
| 212 plist | |
| 213 (intern (concat (match-string 1 (symbol-name stat)) | |
| 214 "-storage-including-overhead")))) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
215 (non-lisp-storage |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
216 (or (plist-get |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
217 plist |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
218 (intern (concat (match-string 1 |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
219 (symbol-name stat)) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
220 "-non-lisp-storage"))) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
221 0)) |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
222 |
| 2775 | 223 (storage-count |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
224 (or (loop for str in '("s-used" "es-used" "-used") |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
225 for val = (plist-get |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
226 plist |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
227 (intern |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
228 (concat (match-string |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
229 1 (symbol-name stat)) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
230 str))) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
231 if val |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
232 return val) |
| 2775 | 233 (plist-get |
| 234 plist | |
| 235 (intern | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
236 (concat (substring |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
237 (match-string 1 (symbol-name stat)) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
238 0 -1) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
239 "ies-used"))) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
240 ))) |
| 2775 | 241 (incf total-use storage-use) |
| 242 (incf total-use-overhead (if storage-use-overhead | |
| 243 storage-use-overhead | |
| 244 storage-use)) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
245 (incf total-non-lisp-use non-lisp-storage) |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
246 (incf total-count (or storage-count 0)) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
247 (and (> storage-use 0) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
248 (princ (format fmt |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
249 (match-string 1 (symbol-name stat)) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
250 (or storage-count "unknown") |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
251 storage-use |
|
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
252 non-lisp-storage)))))) |
| 2775 | 253 plist) |
| 254 (princ "\n") | |
| 255 (princ (format fmt "total" | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
256 total-count total-use-overhead total-non-lisp-use)) |
| 2775 | 257 (incf grandtotal total-use-overhead) |
| 4103 | 258 (when-fboundp #'sort-numeric-fields |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
259 (sort-numeric-fields -2 |
| 4103 | 260 (save-excursion |
| 261 (goto-char begin) | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
262 (forward-line 3) |
| 4103 | 263 (point)) |
| 264 (save-excursion | |
| 265 (forward-line -2) | |
| 266 (point))))))) | |
| 2775 | 267 (with-output-to-temp-buffer buffer |
| 268 (save-excursion | |
| 269 (set-buffer buffer) | |
| 270 (setq begin (point)) | |
|
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
271 (princ "Allocated with lisp allocator or related:\n") |
| 2775 | 272 (show-stats "\\(.*\\)-storage$") |
| 273 (princ (format "\n\ngrand total: %s\n" grandtotal))) | |
| 274 grandtotal)))) | |
| 275 | |
| 276 | |
| 2720 | 277 (defun show-mc-alloc-memory-usage () |
| 278 "Show statistics about memory usage of the new allocator." | |
| 279 (interactive) | |
| 280 (garbage-collect) | |
| 4103 | 281 (if-fboundp #'mc-alloc-memory-usage |
| 282 (let* ((stats (mc-alloc-memory-usage)) | |
| 283 (page-size (first stats)) | |
| 284 (heap-sects (second stats)) | |
| 285 (used-plhs (third stats)) | |
| 286 (free-plhs (fourth stats)) | |
| 287 (globals (fifth stats)) | |
| 288 (mc-malloced-bytes (sixth stats))) | |
| 289 (with-output-to-temp-buffer "*mc-alloc memory usage*" | |
| 290 (flet ((print-used-plhs (text plhs) | |
| 291 (let ((sum-n-pages 0) | |
| 292 (sum-used-n-cells 0) | |
| 293 (sum-used-space 0) | |
| 294 (sum-used-total 0) | |
| 295 (sum-total-n-cells 0) | |
| 296 (sum-total-space 0) | |
| 297 (sum-total-total 0) | |
| 298 (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) | |
| 299 (princ (format "%-14s|%-29s|%-29s|\n" | |
| 300 text | |
| 301 " currently in use" | |
| 302 " total available")) | |
| 303 (princ (format fmt "cell-sz" "#pages" | |
| 304 "#cells" "space" "total" "% " | |
| 305 "#cells" "space" "total" "% " "% ")) | |
| 306 (princ (make-string 79 ?-)) | |
| 307 (princ "\n") | |
| 308 (while plhs | |
| 309 (let* ((elem (car plhs)) | |
| 310 (cell-size (first elem)) | |
| 311 (n-pages (second elem)) | |
| 312 (used-n-cells (third elem)) | |
| 313 (used-space (fourth elem)) | |
| 314 (used-total (if (zerop cell-size) | |
| 315 (sixth elem) | |
| 316 (* cell-size used-n-cells))) | |
| 317 (used-eff (floor (if (not (zerop used-total)) | |
| 318 (* (/ (* used-space 1.0) | |
| 319 (* used-total 1.0)) | |
| 320 100.0) | |
| 321 0))) | |
| 322 (total-n-cells (fifth elem)) | |
| 323 (total-space (if (zerop cell-size) | |
| 324 used-space | |
| 325 (* cell-size total-n-cells))) | |
| 326 (total-total (sixth elem)) | |
| 327 (total-eff (floor (if (not (zerop total-total)) | |
| 328 (* (/ (* total-space 1.0) | |
| 329 (* total-total 1.0)) | |
| 330 100.0) | |
| 331 0))) | |
| 332 (eff (floor (if (not (zerop total-total)) | |
| 333 (* (/ (* used-space 1.0) | |
| 334 (* total-total 1.0)) | |
| 335 100.0) | |
| 336 0)))) | |
| 337 (princ (format fmt | |
| 338 cell-size n-pages used-n-cells used-space | |
| 339 used-total used-eff total-n-cells | |
| 340 total-space total-total total-eff eff)) | |
| 341 (incf sum-n-pages n-pages) | |
| 342 (incf sum-used-n-cells used-n-cells) | |
| 343 (incf sum-used-space used-space) | |
| 344 (incf sum-used-total used-total) | |
| 345 (incf sum-total-n-cells total-n-cells) | |
| 346 (incf sum-total-space total-space) | |
| 347 (incf sum-total-total total-total)) | |
| 348 (setq plhs (cdr plhs))) | |
| 349 (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) | |
| 350 (* (/ (* sum-used-space 1.0) | |
| 351 (* sum-used-total 1.0)) | |
| 352 100.0) | |
| 353 0))) | |
| 354 (avg-total-eff (floor (if (not (zerop sum-total-total)) | |
| 355 (* (/ (* sum-total-space 1.0) | |
| 356 (* sum-total-total 1.0)) | |
| 357 100.0) | |
| 358 0))) | |
| 359 (avg-eff (floor (if (not (zerop sum-total-total)) | |
| 360 (* (/ (* sum-used-space 1.0) | |
| 361 (* sum-total-total 1.0)) | |
| 362 100.0) | |
| 363 0)))) | |
| 364 (princ (format fmt "sum " sum-n-pages sum-used-n-cells | |
| 365 sum-used-space sum-used-total avg-used-eff | |
| 366 sum-total-n-cells sum-total-space | |
| 367 sum-total-total avg-total-eff avg-eff)) | |
| 368 (princ "\n")))) | |
| 2720 | 369 |
| 370 | |
| 4103 | 371 (print-free-plhs (text plhs) |
| 372 (let ((sum-n-pages 0) | |
| 373 (sum-n-sects 0) | |
| 374 (sum-space 0) | |
| 375 (sum-total 0) | |
| 376 (fmt "%6s%10s |%7s%10s\n")) | |
| 377 (princ (format "%s\n" text)) | |
| 378 (princ (format fmt "#pages" "space" "#sects" "total")) | |
| 379 (princ (make-string 35 ?-)) | |
| 380 (princ "\n") | |
| 381 (while plhs | |
| 382 (let* ((elem (car plhs)) | |
| 383 (n-pages (first elem)) | |
| 384 (n-sects (second elem)) | |
| 385 (space (* n-pages page-size)) | |
| 386 (total (* n-sects space))) | |
| 387 (princ (format fmt n-pages space n-sects total)) | |
| 388 (incf sum-n-pages n-pages) | |
| 389 (incf sum-n-sects n-sects) | |
| 390 (incf sum-space space) | |
| 391 (incf sum-total total)) | |
| 392 (setq plhs (cdr plhs))) | |
| 393 (princ (make-string 35 ?=)) | |
| 394 (princ "\n") | |
| 395 (princ (format fmt sum-n-pages sum-space | |
| 396 sum-n-sects sum-total)) | |
| 397 (princ "\n")))) | |
| 2720 | 398 |
| 4103 | 399 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size)) |
| 2720 | 400 |
| 4103 | 401 (print-used-plhs "USED HEAP" used-plhs) |
| 402 (princ "\n\n") | |
| 2720 | 403 |
| 4103 | 404 (print-free-plhs "FREE HEAP" free-plhs) |
| 405 (princ "\n\n") | |
| 2720 | 406 |
| 4103 | 407 (let ((fmt "%-30s%10s\n")) |
| 408 (princ (format fmt "heap sections" "")) | |
| 409 (princ (make-string 40 ?-)) | |
| 410 (princ "\n") | |
| 411 (princ (format fmt "number of heap sects" | |
| 412 (first heap-sects))) | |
| 413 (princ (format fmt "used size" (second heap-sects))) | |
| 414 (princ (make-string 40 ?-)) | |
| 415 (princ "\n") | |
| 416 (princ (format fmt "real size" (third heap-sects))) | |
| 417 (princ (format fmt "global allocator structs" globals)) | |
| 418 (princ (make-string 40 ?-)) | |
| 419 (princ "\n") | |
| 420 (princ (format fmt "real size + structs" | |
| 421 (+ (third heap-sects) globals))) | |
| 422 (princ "\n") | |
| 423 (princ (make-string 40 ?=)) | |
| 424 (princ "\n") | |
| 425 (princ (format fmt "grand total" mc-malloced-bytes))) | |
| 2720 | 426 |
| 4103 | 427 (+ mc-malloced-bytes)))) |
| 428 (message "mc-alloc not used in this XEmacs."))) | |
| 3092 | 429 |
| 430 | |
| 431 (defun show-gc-stats () | |
| 432 "Show statistics about garbage collection cycles." | |
| 433 (interactive) | |
| 4103 | 434 (if-fboundp #'gc-stats |
| 435 (let ((buffer "*garbage collection statistics*") | |
| 436 (plist (gc-stats)) | |
| 437 (fmt "%-9s %16s %12s %12s %12s %12s\n")) | |
| 438 (flet ((plist-get-stat (category field) | |
| 439 (let ((stat (plist-get plist | |
| 440 (intern (concat category field))))) | |
| 441 (if stat | |
| 442 (format "%.0f" stat) | |
| 443 "-"))) | |
| 444 (show-stats (category) | |
| 445 (princ (format fmt category | |
| 446 (plist-get-stat category "-total") | |
| 447 (plist-get-stat category "-in-last-gc") | |
| 448 (plist-get-stat category "-in-this-gc") | |
| 449 (plist-get-stat category "-in-last-cycle") | |
| 450 (plist-get-stat category "-in-this-cycle"))))) | |
| 451 (with-output-to-temp-buffer buffer | |
| 452 (save-excursion | |
| 453 (set-buffer buffer) | |
| 454 (princ (format "%s %g\n" "Current phase" | |
| 455 (plist-get plist 'phase))) | |
| 456 (princ (make-string 78 ?-)) | |
| 457 (princ "\n") | |
| 458 (princ (format fmt "stat" "total" "last-gc" "this-gc" | |
| 459 "last-cycle" "this-cylce")) | |
| 460 (princ (make-string 78 ?-)) | |
| 461 (princ "\n") | |
| 462 (show-stats "n-gc") | |
| 463 (show-stats "n-cycles") | |
| 464 (show-stats "enqueued") | |
| 465 (show-stats "dequeued") | |
| 466 (show-stats "repushed") | |
| 467 (show-stats "enqueued2") | |
| 468 (show-stats "dequeued2") | |
| 469 (show-stats "finalized") | |
| 470 (show-stats "freed") | |
| 471 (plist-get plist 'n-gc-total))))) | |
| 472 (error 'void-function "gc-stats not available."))) |