Mercurial > hg > xemacs-beta

comparison lisp/diagnose.el @ 5567:3bc58dc9d688

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Replace #'flet by #'labels where appropriate, core code. lisp/ChangeLog addition: 2011-09-07 Aidan Kehoe <kehoea@parhasard.net> * simple.el (transpose-subr): * specifier.el (let-specifier): * specifier.el (derive-device-type-from-tag-set): * test-harness.el (batch-test-emacs): * x-compose.el (alias-colon-to-doublequote): * mule/chinese.el (make-chinese-cns11643-charset): * mule/mule-cmds.el (set-locale-for-language-environment): * mule/mule-cmds.el (set-language-environment-coding-systems): * mule/mule-x-init.el (x-use-halfwidth-roman-font): * about.el (about-xemacs): * about.el (about-hackers): * diagnose.el (show-memory-usage): * diagnose.el (show-object-memory-usage-stats): * diagnose.el (show-mc-alloc-memory-usage): * diagnose.el (show-gc-stats): * dialog.el (make-dialog-box): * faces.el: * faces.el (Face-frob-property): * faces.el (set-face-stipple): * glyphs.el: * glyphs.el (init-glyphs): Removed. * help-macro.el (make-help-screen): * info.el (Info-construct-menu): * keymap.el (key-sequence-list-description): * lisp-mode.el (construct-lisp-mode-menu): * loadhist.el (unload-feature): * minibuf.el (get-user-response): * mouse.el (default-mouse-track-check-for-activation): * mouse.el (mouse-track-insert-1): Follow my own advice from the last commit and use #'labels instead of #'flet in core code.
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 07 Sep 2011 21:21:36 +0100
parents ac37a5f7e5be
children
comparison
equal deleted inserted replaced
5566:4654c01af32b 5567:3bc58dc9d688
31 31
32 (defun show-memory-usage () 32 (defun show-memory-usage ()
33 "Show statistics about memory usage of various sorts in XEmacs." 33 "Show statistics about memory usage of various sorts in XEmacs."
34 (interactive) 34 (interactive)
35 (garbage-collect) 35 (garbage-collect)
36 (flet ((show-foo-stats (objtypename statname-plist cleanfun objlist 36 (labels ((show-foo-stats (objtypename statname-plist cleanfun objlist
37 &optional objnamelen) 37 &optional objnamelen)
38 (let* ((hash (make-hash-table)) 38 (let* ((hash (make-hash-table))
39 (first t) 39 (first t)
40 types origtypes fmt 40 types origtypes fmt
41 (objnamelen (or objnamelen 25)) 41 (objnamelen (or objnamelen 25))
42 (linelen objnamelen) 42 (linelen objnamelen)
43 (totaltotal 0)) 43 (totaltotal 0))
44 (loop for obj in objlist do 44 (loop for obj in objlist do
45 (let ((total 0) 45 (let ((total 0)
46 (stats (object-memory-usage obj))) 46 (stats (object-memory-usage obj)))
47 ;; Pop off the slice describing the object itself's 47 ;; Pop off the slice describing the object itself's
48 ;; memory 48 ;; memory
49 (while (and stats (not (eq t (pop stats))))) 49 (while (and stats (not (eq t (pop stats)))))
50 ;; Pop off the slice describing the associated 50 ;; Pop off the slice describing the associated
51 ;; non-Lisp-Object memory from the allocation 51 ;; non-Lisp-Object memory from the allocation
52 ;; perspective, so we can get to the slice describing 52 ;; perspective, so we can get to the slice describing
53 ;; the memory grouped by type 53 ;; the memory grouped by type
54 (while (and stats (pop stats))) 54 (while (and stats (pop stats)))
55 55
56 (loop for (type . num) in (remq t stats) while type do 56 (loop for (type . num) in (remq t stats) while type do
57 (if first (push type origtypes)) 57 (if first (push type origtypes))
58 (setq type (getf statname-plist type type)) 58 (setq type (getf statname-plist type type))
59 (puthash type (+ num (or (gethash type hash) 0)) hash) 59 (puthash type (+ num (or (gethash type hash) 0)) hash)
60 (incf total num) 60 (incf total num)
61 (if first (push type types))) 61 (if first (push type types)))
62 (incf totaltotal total) 62 (incf totaltotal total)
63 (when first 63 (when first
64 (setq types (nreverse types)) 64 (setq types (nreverse types))
65 (setq origtypes (nreverse origtypes)) 65 (setq origtypes (nreverse origtypes))
66 (setq fmt (concat 66 (setq fmt (concat
67 (format "%%-%ds" objnamelen) 67 (format "%%-%ds" objnamelen)
68 (mapconcat 68 (mapconcat
69 #'(lambda (type) 69 #'(lambda (type)
70 (let ((fieldlen 70 (let ((fieldlen
71 (max 7 (+ 2 (length 71 (max 7 (+ 2 (length
72 (symbol-name type)))))) 72 (symbol-name type))))))
73 (incf linelen fieldlen) 73 (incf linelen fieldlen)
74 (format "%%%ds" fieldlen))) 74 (format "%%%ds" fieldlen)))
75 types "") 75 types "")
76 (progn (incf linelen 9) "%9s\n"))) 76 (progn (incf linelen 9) "%9s\n")))
77 (princ "\n") 77 (princ "\n")
78 (princ (apply 'format fmt objtypename 78 (princ (apply 'format fmt objtypename
79 (append types (list 'total)))) 79 (append types (list 'total))))
80 (princ (make-string linelen ?-)) 80 (princ (make-string linelen ?-))
81 (princ "\n")) 81 (princ "\n"))
82 (let ((objname (format "%s" (funcall cleanfun obj)))) 82 (let ((objname (format "%s" (funcall cleanfun obj))))
83 (princ (apply 'format fmt (substring objname 0 83 (princ (apply 'format fmt (substring objname 0
84 (min (length objname) 84 (min (length objname)
85 (1- objnamelen))) 85 (1- objnamelen)))
86 (nconc (mapcar #'(lambda (type) 86 (nconc (mapcar #'(lambda (type)
87 (cdr (assq type stats))) 87 (cdr (assq type stats)))
88 origtypes) 88 origtypes)
89 (list total))))) 89 (list total)))))
90 (setq first nil))) 90 (setq first nil)))
91 (princ "\n") 91 (princ "\n")
92 (princ (apply 'format fmt "total" 92 (princ (apply 'format fmt "total"
93 (nconc (mapcar #'(lambda (type) 93 (nconc (mapcar #'(lambda (type)
94 (gethash type hash)) 94 (gethash type hash))
95 types) 95 types)
96 (list totaltotal)))) 96 (list totaltotal))))
97 totaltotal))) 97 totaltotal)))
98
99 (let ((grandtotal 0) 98 (let ((grandtotal 0)
100 (buffer "*memory usage*") 99 (buffer "*memory usage*")
101 begin) 100 begin)
102 (with-output-to-temp-buffer buffer 101 (with-output-to-temp-buffer buffer
103 (save-excursion 102 (save-excursion
200 (let ((buffer "*object memory usage statistics*") 199 (let ((buffer "*object memory usage statistics*")
201 (plist (object-memory-usage-stats)) 200 (plist (object-memory-usage-stats))
202 (fmt "%-28s%10s%10s%10s%10s%10s\n") 201 (fmt "%-28s%10s%10s%10s%10s%10s\n")
203 (grandtotal 0) 202 (grandtotal 0)
204 begin) 203 begin)
205 (flet ((show-stats (match-string) 204 (labels
206 (princ (format "%28s%10s%40s\n" "" "" 205 ((show-stats (match-string)
207 "--------------storage---------------")) 206 (princ (format "%28s%10s%40s\n" "" ""
208 (princ (format fmt "object" "count" "object" "overhead" 207 "--------------storage---------------"))
209 "non-Lisp" "ancillary")) 208 (princ (format fmt "object" "count" "object" "overhead"
210 (princ (make-string 78 ?-)) 209 "non-Lisp" "ancillary"))
211 (princ "\n") 210 (princ (make-string 78 ?-))
212 (let ((total-use 0) 211 (princ "\n")
213 (total-non-lisp-use 0) 212 (let ((total-use 0)
214 (total-use-overhead 0) 213 (total-non-lisp-use 0)
215 (total-use-with-overhead 0) 214 (total-use-overhead 0)
216 (total-count 0)) 215 (total-use-with-overhead 0)
217 (map-plist 216 (total-count 0))
218 #'(lambda (stat num) 217 (map-plist
219 (let ((symmatch 218 #'(lambda (stat num)
220 (and (string-match match-string (symbol-name stat)) 219 (let ((symmatch
221 (match-string 1 (symbol-name stat))))) 220 (and (string-match match-string (symbol-name stat))
222 (when (and symmatch 221 (match-string 1 (symbol-name stat)))))
223 (or (< (length symmatch) 9) 222 (when (and symmatch
224 (not (equal (substring symmatch -9) 223 (or (< (length symmatch) 9)
225 "-non-lisp"))) 224 (not (equal (substring symmatch -9)
226 (or (< (length symmatch) 15) 225 "-non-lisp")))
227 (not (equal (substring symmatch -15) 226 (or (< (length symmatch) 15)
228 "-lisp-ancillary")))) 227 (not (equal (substring symmatch -15)
229 (let* ((storage-use num) 228 "-lisp-ancillary"))))
230 (storage-use-overhead 229 (let* ((storage-use num)
231 (or (plist-get 230 (storage-use-overhead
232 plist 231 (or (plist-get
233 (intern (concat symmatch 232 plist
234 "-storage-overhead"))) 233 (intern (concat symmatch
235 0)) 234 "-storage-overhead")))
236 (storage-use-with-overhead 235 0))
237 (or (plist-get 236 (storage-use-with-overhead
238 plist 237 (or (plist-get
239 (intern (concat 238 plist
240 symmatch 239 (intern (concat
241 "-storage-including-overhead"))) 240 symmatch
242 (+ storage-use storage-use-overhead))) 241 "-storage-including-overhead")))
243 (storage-use-overhead 242 (+ storage-use storage-use-overhead)))
244 (- storage-use-with-overhead storage-use)) 243 (storage-use-overhead
245 (non-lisp-storage 244 (- storage-use-with-overhead storage-use))
246 (or (plist-get 245 (non-lisp-storage
247 plist 246 (or (plist-get
248 (intern (concat symmatch 247 plist
249 "-non-lisp-storage"))) 248 (intern (concat symmatch
250 0)) 249 "-non-lisp-storage")))
251 (lisp-ancillary-storage 250 0))
252 (or (plist-get 251 (lisp-ancillary-storage
253 plist 252 (or (plist-get
254 (intern (concat symmatch 253 plist
255 "-lisp-ancillary-storage"))) 254 (intern (concat symmatch
256 0)) 255 "-lisp-ancillary-storage")))
257 (storage-count 256 0))
258 (or (loop for str in '("s-used" "es-used" "-used") 257 (storage-count
259 for val = (plist-get 258 (or (loop for str in '("s-used" "es-used" "-used")
260 plist 259 for val = (plist-get
261 (intern 260 plist
262 (concat symmatch str))) 261 (intern
263 if val 262 (concat symmatch str)))
264 return val) 263 if val
265 (plist-get 264 return val)
266 plist 265 (plist-get
267 (intern 266 plist
268 (concat (substring symmatch 0 -1) 267 (intern
269 "ies-used"))) 268 (concat (substring symmatch 0 -1)
270 ))) 269 "ies-used")))
271 (incf total-use storage-use) 270 )))
272 (incf total-use-overhead storage-use-overhead) 271 (incf total-use storage-use)
273 (incf total-use-with-overhead storage-use-with-overhead) 272 (incf total-use-overhead storage-use-overhead)
274 (incf total-non-lisp-use non-lisp-storage) 273 (incf total-use-with-overhead storage-use-with-overhead)
275 (incf total-count (or storage-count 0)) 274 (incf total-non-lisp-use non-lisp-storage)
276 (and (> storage-use-with-overhead 0) 275 (incf total-count (or storage-count 0))
277 (princ (format fmt symmatch 276 (and (> storage-use-with-overhead 0)
278 (or storage-count "unknown") 277 (princ (format fmt symmatch
279 storage-use 278 (or storage-count "unknown")
280 storage-use-overhead 279 storage-use
281 non-lisp-storage 280 storage-use-overhead
282 lisp-ancillary-storage))))))) 281 non-lisp-storage
283 plist) 282 lisp-ancillary-storage)))))))
284 (princ "\n") 283 plist)
285 (princ (format fmt "total" 284 (princ "\n")
286 total-count total-use total-use-overhead 285 (princ (format fmt "total"
287 total-non-lisp-use "")) 286 total-count total-use total-use-overhead
288 (incf grandtotal total-use-with-overhead) 287 total-non-lisp-use ""))
289 (incf grandtotal total-non-lisp-use) 288 (incf grandtotal total-use-with-overhead)
290 (when-fboundp 'sort-numeric-fields 289 (incf grandtotal total-non-lisp-use)
291 (sort-numeric-fields -4 290 (when-fboundp 'sort-numeric-fields
292 (save-excursion 291 (sort-numeric-fields -4
293 (goto-char begin) 292 (save-excursion
294 (forward-line 4) 293 (goto-char begin)
295 (point)) 294 (forward-line 4)
296 (save-excursion 295 (point))
297 (forward-line -2) 296 (save-excursion
298 (point))))))) 297 (forward-line -2)
299 (with-output-to-temp-buffer buffer 298 (point)))))))
299 (with-output-to-temp-buffer buffer
300 (save-excursion 300 (save-excursion
301 (set-buffer buffer) 301 (set-buffer buffer)
302 (setq begin (point)) 302 (setq begin (point))
303 (princ "Allocated with lisp allocator or related:\n") 303 (princ "Allocated with lisp allocator or related:\n")
304 (show-stats "\\(.*\\)-storage$") 304 (show-stats "\\(.*\\)-storage$")
317 (used-plhs (third stats)) 317 (used-plhs (third stats))
318 (free-plhs (fourth stats)) 318 (free-plhs (fourth stats))
319 (globals (fifth stats)) 319 (globals (fifth stats))
320 (mc-malloced-bytes (sixth stats))) 320 (mc-malloced-bytes (sixth stats)))
321 (with-output-to-temp-buffer "*mc-alloc memory usage*" 321 (with-output-to-temp-buffer "*mc-alloc memory usage*"
322 (flet ((print-used-plhs (text plhs) 322 (labels
323 (let ((sum-n-pages 0) 323 ((print-used-plhs (text plhs)
324 (sum-used-n-cells 0) 324 (let ((sum-n-pages 0)
325 (sum-used-space 0) 325 (sum-used-n-cells 0)
326 (sum-used-total 0) 326 (sum-used-space 0)
327 (sum-total-n-cells 0) 327 (sum-used-total 0)
328 (sum-total-space 0) 328 (sum-total-n-cells 0)
329 (sum-total-total 0) 329 (sum-total-space 0)
330 (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) 330 (sum-total-total 0)
331 (princ (format "%-14s|%-29s|%-29s|\n" 331 (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n"))
332 text 332 (princ (format "%-14s|%-29s|%-29s|\n"
333 " currently in use" 333 text
334 " total available")) 334 " currently in use"
335 (princ (format fmt "cell-sz" "#pages" 335 " total available"))
336 "#cells" "space" "total" "% " 336 (princ (format fmt "cell-sz" "#pages"
337 "#cells" "space" "total" "% " "% ")) 337 "#cells" "space" "total" "% "
338 (princ (make-string 79 ?-)) 338 "#cells" "space" "total" "% " "% "))
339 (princ "\n") 339 (princ (make-string 79 ?-))
340 (while plhs 340 (princ "\n")
341 (let* ((elem (car plhs)) 341 (while plhs
342 (cell-size (first elem)) 342 (let* ((elem (car plhs))
343 (n-pages (second elem)) 343 (cell-size (first elem))
344 (used-n-cells (third elem)) 344 (n-pages (second elem))
345 (used-space (fourth elem)) 345 (used-n-cells (third elem))
346 (used-total (if (zerop cell-size) 346 (used-space (fourth elem))
347 (sixth elem) 347 (used-total (if (zerop cell-size)
348 (* cell-size used-n-cells))) 348 (sixth elem)
349 (used-eff (floor (if (not (zerop used-total)) 349 (* cell-size used-n-cells)))
350 (* (/ (* used-space 1.0) 350 (used-eff (floor (if (not (zerop used-total))
351 (* used-total 1.0)) 351 (* (/ (* used-space 1.0)
352 (* used-total 1.0))
353 100.0)
354 0)))
355 (total-n-cells (fifth elem))
356 (total-space (if (zerop cell-size)
357 used-space
358 (* cell-size total-n-cells)))
359 (total-total (sixth elem))
360 (total-eff (floor (if (not (zerop total-total))
361 (* (/ (* total-space 1.0)
362 (* total-total 1.0))
363 100.0)
364 0)))
365 (eff (floor (if (not (zerop total-total))
366 (* (/ (* used-space 1.0)
367 (* total-total 1.0))
368 100.0)
369 0))))
370 (princ (format fmt
371 cell-size n-pages used-n-cells used-space
372 used-total used-eff total-n-cells
373 total-space total-total total-eff eff))
374 (incf sum-n-pages n-pages)
375 (incf sum-used-n-cells used-n-cells)
376 (incf sum-used-space used-space)
377 (incf sum-used-total used-total)
378 (incf sum-total-n-cells total-n-cells)
379 (incf sum-total-space total-space)
380 (incf sum-total-total total-total))
381 (setq plhs (cdr plhs)))
382 (let ((avg-used-eff (floor (if (not (zerop sum-used-total))
383 (* (/ (* sum-used-space 1.0)
384 (* sum-used-total 1.0))
385 100.0)
386 0)))
387 (avg-total-eff (floor (if (not (zerop sum-total-total))
388 (* (/ (* sum-total-space 1.0)
389 (* sum-total-total 1.0))
352 100.0) 390 100.0)
353 0))) 391 0)))
354 (total-n-cells (fifth elem)) 392 (avg-eff (floor (if (not (zerop sum-total-total))
355 (total-space (if (zerop cell-size) 393 (* (/ (* sum-used-space 1.0)
356 used-space 394 (* sum-total-total 1.0))
357 (* cell-size total-n-cells))) 395 100.0)
358 (total-total (sixth elem)) 396 0))))
359 (total-eff (floor (if (not (zerop total-total)) 397 (princ (format fmt "sum " sum-n-pages sum-used-n-cells
360 (* (/ (* total-space 1.0) 398 sum-used-space sum-used-total avg-used-eff
361 (* total-total 1.0)) 399 sum-total-n-cells sum-total-space
362 100.0) 400 sum-total-total avg-total-eff avg-eff))
363 0)))
364 (eff (floor (if (not (zerop total-total))
365 (* (/ (* used-space 1.0)
366 (* total-total 1.0))
367 100.0)
368 0))))
369 (princ (format fmt
370 cell-size n-pages used-n-cells used-space
371 used-total used-eff total-n-cells
372 total-space total-total total-eff eff))
373 (incf sum-n-pages n-pages)
374 (incf sum-used-n-cells used-n-cells)
375 (incf sum-used-space used-space)
376 (incf sum-used-total used-total)
377 (incf sum-total-n-cells total-n-cells)
378 (incf sum-total-space total-space)
379 (incf sum-total-total total-total))
380 (setq plhs (cdr plhs)))
381 (let ((avg-used-eff (floor (if (not (zerop sum-used-total))
382 (* (/ (* sum-used-space 1.0)
383 (* sum-used-total 1.0))
384 100.0)
385 0)))
386 (avg-total-eff (floor (if (not (zerop sum-total-total))
387 (* (/ (* sum-total-space 1.0)
388 (* sum-total-total 1.0))
389 100.0)
390 0)))
391 (avg-eff (floor (if (not (zerop sum-total-total))
392 (* (/ (* sum-used-space 1.0)
393 (* sum-total-total 1.0))
394 100.0)
395 0))))
396 (princ (format fmt "sum " sum-n-pages sum-used-n-cells
397 sum-used-space sum-used-total avg-used-eff
398 sum-total-n-cells sum-total-space
399 sum-total-total avg-total-eff avg-eff))
400 (princ "\n"))))
401
402
403 (print-free-plhs (text plhs)
404 (let ((sum-n-pages 0)
405 (sum-n-sects 0)
406 (sum-space 0)
407 (sum-total 0)
408 (fmt "%6s%10s |%7s%10s\n"))
409 (princ (format "%s\n" text))
410 (princ (format fmt "#pages" "space" "#sects" "total"))
411 (princ (make-string 35 ?-))
412 (princ "\n")
413 (while plhs
414 (let* ((elem (car plhs))
415 (n-pages (first elem))
416 (n-sects (second elem))
417 (space (* n-pages page-size))
418 (total (* n-sects space)))
419 (princ (format fmt n-pages space n-sects total))
420 (incf sum-n-pages n-pages)
421 (incf sum-n-sects n-sects)
422 (incf sum-space space)
423 (incf sum-total total))
424 (setq plhs (cdr plhs)))
425 (princ (make-string 35 ?=))
426 (princ "\n")
427 (princ (format fmt sum-n-pages sum-space
428 sum-n-sects sum-total))
429 (princ "\n")))) 401 (princ "\n"))))
402
403
404 (print-free-plhs (text plhs)
405 (let ((sum-n-pages 0)
406 (sum-n-sects 0)
407 (sum-space 0)
408 (sum-total 0)
409 (fmt "%6s%10s |%7s%10s\n"))
410 (princ (format "%s\n" text))
411 (princ (format fmt "#pages" "space" "#sects" "total"))
412 (princ (make-string 35 ?-))
413 (princ "\n")
414 (while plhs
415 (let* ((elem (car plhs))
416 (n-pages (first elem))
417 (n-sects (second elem))
418 (space (* n-pages page-size))
419 (total (* n-sects space)))
420 (princ (format fmt n-pages space n-sects total))
421 (incf sum-n-pages n-pages)
422 (incf sum-n-sects n-sects)
423 (incf sum-space space)
424 (incf sum-total total))
425 (setq plhs (cdr plhs)))
426 (princ (make-string 35 ?=))
427 (princ "\n")
428 (princ (format fmt sum-n-pages sum-space
429 sum-n-sects sum-total))
430 (princ "\n"))))
430 431
431 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size)) 432 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size))
432 433
433 (print-used-plhs "USED HEAP" used-plhs) 434 (print-used-plhs "USED HEAP" used-plhs)
434 (princ "\n\n") 435 (princ "\n\n")
465 (interactive) 466 (interactive)
466 (if-fboundp 'gc-stats 467 (if-fboundp 'gc-stats
467 (let ((buffer "*garbage collection statistics*") 468 (let ((buffer "*garbage collection statistics*")
468 (plist (gc-stats)) 469 (plist (gc-stats))
469 (fmt "%-9s %16s %12s %12s %12s %12s\n")) 470 (fmt "%-9s %16s %12s %12s %12s %12s\n"))
470 (flet ((plist-get-stat (category field) 471 (labels
471 (let ((stat (plist-get plist 472 ((plist-get-stat (category field)
472 (intern (concat category field))))) 473 (let ((stat (plist-get plist (intern (concat category field)))))
473 (if stat 474 (if stat
474 (format "%.0f" stat) 475 (format "%.0f" stat)
475 "-"))) 476 "-")))
476 (show-stats (category) 477 (show-stats (category)
477 (princ (format fmt category 478 (princ (format fmt category
478 (plist-get-stat category "-total") 479 (plist-get-stat category "-total")
479 (plist-get-stat category "-in-last-gc") 480 (plist-get-stat category "-in-last-gc")
480 (plist-get-stat category "-in-this-gc") 481 (plist-get-stat category "-in-this-gc")
481 (plist-get-stat category "-in-last-cycle") 482 (plist-get-stat category "-in-last-cycle")
482 (plist-get-stat category "-in-this-cycle"))))) 483 (plist-get-stat category "-in-this-cycle")))))
483 (with-output-to-temp-buffer buffer 484 (with-output-to-temp-buffer buffer
484 (save-excursion 485 (save-excursion
485 (set-buffer buffer) 486 (set-buffer buffer)
486 (princ (format "%s %g\n" "Current phase" 487 (princ (format "%s %g\n" "Current phase"
487 (plist-get plist 'phase))) 488 (plist-get plist 'phase)))