Mercurial > hg > xemacs-beta
annotate lisp/diagnose.el @ 5067:7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-02-22 Ben Wing <ben@xemacs.org>
* cl-seq.el:
* cl-seq.el (stable-union): New.
* cl-seq.el (stable-intersection): New.
New functions to do stable set operations, i.e. preserve the order
of the elements in the argument lists, and prefer LIST1 over LIST2
when ordering the combined result. The result looks as much like
LIST1 as possible, followed (in the case of `stable-union') by
any necessary elements from LIST2, in order. This is contrary to
`union' and `intersection', which are not required to be order-
preserving and are not -- they prefer LIST2 and output results in
backwards order.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Mon, 22 Feb 2010 21:23:02 -0600 |
parents | c8f90d61dcf3 |
children | 1fae11d56ad2 |
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) | |
38 (flet ((show-foo-stats (objtypename objlist memfun) | |
39 (let* ((hash (make-hash-table)) | |
40 (first t) | |
41 types fmt | |
42 (objnamelen 25) | |
43 (linelen objnamelen) | |
44 (totaltotal 0)) | |
45 (dolist (obj objlist) | |
46 (let ((total 0) | |
47 (stats (funcall memfun obj))) | |
48 (loop for (type . num) in stats while type do | |
49 (puthash type (+ num (or (gethash type hash) 0)) hash) | |
50 (incf total num) | |
51 (if first (push type types))) | |
52 (incf totaltotal total) | |
53 (when first | |
54 (setq types (nreverse types)) | |
55 (setq fmt (concat | |
56 (format "%%-%ds" objnamelen) | |
57 (mapconcat | |
58 #'(lambda (type) | |
59 (let ((fieldlen | |
60 (max 8 (+ 2 (length | |
61 (symbol-name type)))))) | |
62 (incf linelen fieldlen) | |
63 (format "%%%ds" fieldlen))) | |
64 types "") | |
2618 | 65 (progn (incf linelen 9) "%9s\n"))) |
787 | 66 (princ "\n") |
67 (princ (apply 'format fmt objtypename | |
68 (append types (list 'total)))) | |
69 (princ (make-string linelen ?-)) | |
70 (princ "\n")) | |
71 (let ((objname (format "%s" obj))) | |
72 (princ (apply 'format fmt (substring objname 0 | |
73 (min (length objname) | |
74 (1- objnamelen))) | |
75 (nconc (mapcar #'(lambda (type) | |
76 (cdr (assq type stats))) | |
77 types) | |
78 (list total))))) | |
79 (setq first nil))) | |
80 (princ "\n") | |
81 (princ (apply 'format fmt "total" | |
82 (nconc (mapcar #'(lambda (type) | |
83 (gethash type hash)) | |
84 types) | |
85 (list totaltotal)))) | |
86 totaltotal))) | |
87 | |
2618 | 88 (let ((grandtotal 0) |
89 (buffer "*memory usage*") | |
90 begin) | |
91 (with-output-to-temp-buffer buffer | |
92 (save-excursion | |
93 (set-buffer buffer) | |
94 (when-fboundp 'charset-list | |
95 (setq begin (point)) | |
96 (incf grandtotal | |
97 (show-foo-stats 'charset (charset-list) | |
98 #'charset-memory-usage)) | |
3066 | 99 (when-fboundp 'sort-numeric-fields |
100 (sort-numeric-fields -1 | |
101 (save-excursion | |
102 (goto-char begin) | |
103 (forward-line 2) | |
104 (point)) | |
105 (save-excursion | |
106 (forward-line -2) | |
107 (point)))) | |
2618 | 108 (princ "\n")) |
109 (setq begin (point)) | |
110 (incf grandtotal | |
111 (show-foo-stats 'buffer (buffer-list) #'buffer-memory-usage)) | |
3066 | 112 (when-fboundp 'sort-numeric-fields |
113 (sort-numeric-fields -1 | |
114 (save-excursion | |
115 (goto-char begin) | |
116 (forward-line 3) | |
117 (point)) | |
118 (save-excursion | |
119 (forward-line -2) | |
120 (point)))) | |
2618 | 121 (princ "\n") |
122 (setq begin (point)) | |
787 | 123 (incf grandtotal |
2618 | 124 (show-foo-stats 'window (mapcan #'(lambda (fr) |
125 (window-list fr t)) | |
126 (frame-list)) | |
127 #'window-memory-usage)) | |
4103 | 128 (when-fboundp #'sort-numeric-fields |
129 (sort-numeric-fields -1 | |
130 (save-excursion | |
131 (goto-char begin) | |
132 (forward-line 3) | |
133 (point)) | |
134 (save-excursion | |
135 (forward-line -2) | |
136 (point)))) | |
787 | 137 (princ "\n") |
2618 | 138 (let ((total 0) |
139 (fmt "%-30s%10s\n")) | |
140 (setq begin (point)) | |
141 (princ (format fmt "object" "storage")) | |
142 (princ (make-string 40 ?-)) | |
143 (princ "\n") | |
144 (map-plist #'(lambda (stat num) | |
2775 | 145 (when (string-match |
3278 | 146 "\\(.*\\)-storage$" |
2775 | 147 (symbol-name stat)) |
2618 | 148 (incf total num) |
149 (princ (format fmt | |
150 (match-string 1 (symbol-name stat)) | |
151 num))) | |
152 (when (eq stat 'long-strings-total-length) | |
153 (incf total num) | |
154 (princ (format fmt stat num)))) | |
155 (sixth (garbage-collect))) | |
156 (princ "\n") | |
157 (princ (format fmt "total" total)) | |
158 (incf grandtotal total)) | |
4103 | 159 (when-fboundp #'sort-numeric-fields |
160 (sort-numeric-fields -1 | |
161 (save-excursion | |
162 (goto-char begin) | |
163 (forward-line 2) | |
164 (point)) | |
165 (save-excursion | |
166 (forward-line -2) | |
167 (point)))) | |
787 | 168 |
2618 | 169 (princ (format "\n\ngrand total: %s\n" grandtotal))) |
787 | 170 grandtotal)))) |
2720 | 171 |
172 | |
3041 | 173 (defun show-object-memory-usage-stats () |
3888 | 174 "Show statistics about object memory usage in XEmacs." |
2775 | 175 (interactive) |
176 (garbage-collect) | |
3041 | 177 (let ((buffer "*object memory usage statistics*") |
178 (plist (object-memory-usage-stats)) | |
2775 | 179 (fmt "%-30s%10s%10s\n") |
180 (grandtotal 0) | |
181 begin) | |
182 (flet ((show-stats (match-string) | |
183 (princ (format fmt "object" "count" "storage")) | |
184 (princ (make-string 50 ?-)) | |
185 (princ "\n") | |
186 (let ((total-use 0) | |
187 (total-use-overhead 0) | |
188 (total-count 0)) | |
189 (map-plist | |
190 #'(lambda (stat num) | |
191 (when (string-match match-string | |
192 (symbol-name stat)) | |
193 (let ((storage-use num) | |
194 (storage-use-overhead | |
195 (plist-get | |
196 plist | |
197 (intern (concat (match-string 1 (symbol-name stat)) | |
198 "-storage-including-overhead")))) | |
199 (storage-count | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
200 (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
|
201 for val = (plist-get |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
202 plist |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
203 (intern |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
204 (concat (match-string |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
205 1 (symbol-name stat)) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
206 str))) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
207 if val |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
208 return val) |
2775 | 209 (plist-get |
210 plist | |
211 (intern | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
212 (concat (substring |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
213 (match-string 1 (symbol-name stat)) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
214 0 -1) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
215 "ies-used"))) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
216 ))) |
2775 | 217 (incf total-use storage-use) |
218 (incf total-use-overhead (if storage-use-overhead | |
219 storage-use-overhead | |
220 storage-use)) | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
221 (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
|
222 (and (> storage-use 0) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
223 (princ (format fmt |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
224 (match-string 1 (symbol-name stat)) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
225 (or storage-count "unknown") |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
226 storage-use)))))) |
2775 | 227 plist) |
228 (princ "\n") | |
229 (princ (format fmt "total" | |
230 total-count total-use-overhead)) | |
231 (incf grandtotal total-use-overhead) | |
4103 | 232 (when-fboundp #'sort-numeric-fields |
233 (sort-numeric-fields -1 | |
234 (save-excursion | |
235 (goto-char begin) | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
4103
diff
changeset
|
236 (forward-line 3) |
4103 | 237 (point)) |
238 (save-excursion | |
239 (forward-line -2) | |
240 (point))))))) | |
2775 | 241 (with-output-to-temp-buffer buffer |
242 (save-excursion | |
243 (set-buffer buffer) | |
244 (setq begin (point)) | |
3041 | 245 (princ "Allocated with lisp allocator:\n") |
2775 | 246 (show-stats "\\(.*\\)-storage$") |
247 (princ (format "\n\ngrand total: %s\n" grandtotal))) | |
248 grandtotal)))) | |
249 | |
250 | |
2720 | 251 (defun show-mc-alloc-memory-usage () |
252 "Show statistics about memory usage of the new allocator." | |
253 (interactive) | |
254 (garbage-collect) | |
4103 | 255 (if-fboundp #'mc-alloc-memory-usage |
256 (let* ((stats (mc-alloc-memory-usage)) | |
257 (page-size (first stats)) | |
258 (heap-sects (second stats)) | |
259 (used-plhs (third stats)) | |
260 (free-plhs (fourth stats)) | |
261 (globals (fifth stats)) | |
262 (mc-malloced-bytes (sixth stats))) | |
263 (with-output-to-temp-buffer "*mc-alloc memory usage*" | |
264 (flet ((print-used-plhs (text plhs) | |
265 (let ((sum-n-pages 0) | |
266 (sum-used-n-cells 0) | |
267 (sum-used-space 0) | |
268 (sum-used-total 0) | |
269 (sum-total-n-cells 0) | |
270 (sum-total-space 0) | |
271 (sum-total-total 0) | |
272 (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) | |
273 (princ (format "%-14s|%-29s|%-29s|\n" | |
274 text | |
275 " currently in use" | |
276 " total available")) | |
277 (princ (format fmt "cell-sz" "#pages" | |
278 "#cells" "space" "total" "% " | |
279 "#cells" "space" "total" "% " "% ")) | |
280 (princ (make-string 79 ?-)) | |
281 (princ "\n") | |
282 (while plhs | |
283 (let* ((elem (car plhs)) | |
284 (cell-size (first elem)) | |
285 (n-pages (second elem)) | |
286 (used-n-cells (third elem)) | |
287 (used-space (fourth elem)) | |
288 (used-total (if (zerop cell-size) | |
289 (sixth elem) | |
290 (* cell-size used-n-cells))) | |
291 (used-eff (floor (if (not (zerop used-total)) | |
292 (* (/ (* used-space 1.0) | |
293 (* used-total 1.0)) | |
294 100.0) | |
295 0))) | |
296 (total-n-cells (fifth elem)) | |
297 (total-space (if (zerop cell-size) | |
298 used-space | |
299 (* cell-size total-n-cells))) | |
300 (total-total (sixth elem)) | |
301 (total-eff (floor (if (not (zerop total-total)) | |
302 (* (/ (* total-space 1.0) | |
303 (* total-total 1.0)) | |
304 100.0) | |
305 0))) | |
306 (eff (floor (if (not (zerop total-total)) | |
307 (* (/ (* used-space 1.0) | |
308 (* total-total 1.0)) | |
309 100.0) | |
310 0)))) | |
311 (princ (format fmt | |
312 cell-size n-pages used-n-cells used-space | |
313 used-total used-eff total-n-cells | |
314 total-space total-total total-eff eff)) | |
315 (incf sum-n-pages n-pages) | |
316 (incf sum-used-n-cells used-n-cells) | |
317 (incf sum-used-space used-space) | |
318 (incf sum-used-total used-total) | |
319 (incf sum-total-n-cells total-n-cells) | |
320 (incf sum-total-space total-space) | |
321 (incf sum-total-total total-total)) | |
322 (setq plhs (cdr plhs))) | |
323 (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) | |
324 (* (/ (* sum-used-space 1.0) | |
325 (* sum-used-total 1.0)) | |
326 100.0) | |
327 0))) | |
328 (avg-total-eff (floor (if (not (zerop sum-total-total)) | |
329 (* (/ (* sum-total-space 1.0) | |
330 (* sum-total-total 1.0)) | |
331 100.0) | |
332 0))) | |
333 (avg-eff (floor (if (not (zerop sum-total-total)) | |
334 (* (/ (* sum-used-space 1.0) | |
335 (* sum-total-total 1.0)) | |
336 100.0) | |
337 0)))) | |
338 (princ (format fmt "sum " sum-n-pages sum-used-n-cells | |
339 sum-used-space sum-used-total avg-used-eff | |
340 sum-total-n-cells sum-total-space | |
341 sum-total-total avg-total-eff avg-eff)) | |
342 (princ "\n")))) | |
2720 | 343 |
344 | |
4103 | 345 (print-free-plhs (text plhs) |
346 (let ((sum-n-pages 0) | |
347 (sum-n-sects 0) | |
348 (sum-space 0) | |
349 (sum-total 0) | |
350 (fmt "%6s%10s |%7s%10s\n")) | |
351 (princ (format "%s\n" text)) | |
352 (princ (format fmt "#pages" "space" "#sects" "total")) | |
353 (princ (make-string 35 ?-)) | |
354 (princ "\n") | |
355 (while plhs | |
356 (let* ((elem (car plhs)) | |
357 (n-pages (first elem)) | |
358 (n-sects (second elem)) | |
359 (space (* n-pages page-size)) | |
360 (total (* n-sects space))) | |
361 (princ (format fmt n-pages space n-sects total)) | |
362 (incf sum-n-pages n-pages) | |
363 (incf sum-n-sects n-sects) | |
364 (incf sum-space space) | |
365 (incf sum-total total)) | |
366 (setq plhs (cdr plhs))) | |
367 (princ (make-string 35 ?=)) | |
368 (princ "\n") | |
369 (princ (format fmt sum-n-pages sum-space | |
370 sum-n-sects sum-total)) | |
371 (princ "\n")))) | |
2720 | 372 |
4103 | 373 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size)) |
2720 | 374 |
4103 | 375 (print-used-plhs "USED HEAP" used-plhs) |
376 (princ "\n\n") | |
2720 | 377 |
4103 | 378 (print-free-plhs "FREE HEAP" free-plhs) |
379 (princ "\n\n") | |
2720 | 380 |
4103 | 381 (let ((fmt "%-30s%10s\n")) |
382 (princ (format fmt "heap sections" "")) | |
383 (princ (make-string 40 ?-)) | |
384 (princ "\n") | |
385 (princ (format fmt "number of heap sects" | |
386 (first heap-sects))) | |
387 (princ (format fmt "used size" (second heap-sects))) | |
388 (princ (make-string 40 ?-)) | |
389 (princ "\n") | |
390 (princ (format fmt "real size" (third heap-sects))) | |
391 (princ (format fmt "global allocator structs" globals)) | |
392 (princ (make-string 40 ?-)) | |
393 (princ "\n") | |
394 (princ (format fmt "real size + structs" | |
395 (+ (third heap-sects) globals))) | |
396 (princ "\n") | |
397 (princ (make-string 40 ?=)) | |
398 (princ "\n") | |
399 (princ (format fmt "grand total" mc-malloced-bytes))) | |
2720 | 400 |
4103 | 401 (+ mc-malloced-bytes)))) |
402 (message "mc-alloc not used in this XEmacs."))) | |
3092 | 403 |
404 | |
405 (defun show-gc-stats () | |
406 "Show statistics about garbage collection cycles." | |
407 (interactive) | |
4103 | 408 (if-fboundp #'gc-stats |
409 (let ((buffer "*garbage collection statistics*") | |
410 (plist (gc-stats)) | |
411 (fmt "%-9s %16s %12s %12s %12s %12s\n")) | |
412 (flet ((plist-get-stat (category field) | |
413 (let ((stat (plist-get plist | |
414 (intern (concat category field))))) | |
415 (if stat | |
416 (format "%.0f" stat) | |
417 "-"))) | |
418 (show-stats (category) | |
419 (princ (format fmt category | |
420 (plist-get-stat category "-total") | |
421 (plist-get-stat category "-in-last-gc") | |
422 (plist-get-stat category "-in-this-gc") | |
423 (plist-get-stat category "-in-last-cycle") | |
424 (plist-get-stat category "-in-this-cycle"))))) | |
425 (with-output-to-temp-buffer buffer | |
426 (save-excursion | |
427 (set-buffer buffer) | |
428 (princ (format "%s %g\n" "Current phase" | |
429 (plist-get plist 'phase))) | |
430 (princ (make-string 78 ?-)) | |
431 (princ "\n") | |
432 (princ (format fmt "stat" "total" "last-gc" "this-gc" | |
433 "last-cycle" "this-cylce")) | |
434 (princ (make-string 78 ?-)) | |
435 (princ "\n") | |
436 (show-stats "n-gc") | |
437 (show-stats "n-cycles") | |
438 (show-stats "enqueued") | |
439 (show-stats "dequeued") | |
440 (show-stats "repushed") | |
441 (show-stats "enqueued2") | |
442 (show-stats "dequeued2") | |
443 (show-stats "finalized") | |
444 (show-stats "freed") | |
445 (plist-get plist 'n-gc-total))))) | |
446 (error 'void-function "gc-stats not available."))) |