Mercurial > hg > xemacs-beta

comparison lisp/debug.el @ 783:6fadd0a2230b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-03-19 02:38:51 by ben] memory usage fun
author ben
date Tue, 19 Mar 2002 02:38:51 +0000
parents
children
comparison
equal deleted inserted replaced
782:616e133a0ce6 783:6fadd0a2230b
1 ;;; debug.el --- routines for debugging problems in XEmacs
2
3 ;; Copyright (C) 2002 Ben Wing.
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 "")
65 (progn (incf linelen 8) "%8s\n")))
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
88 (let ((grandtotal 0))
89 (with-output-to-temp-buffer "*memory usage*"
90 (when-fboundp 'charset-list
91 (incf grandtotal
92 (show-foo-stats 'charset (charset-list)
93 #'charset-memory-usage))
94 (princ "\n"))
95 (incf grandtotal
96 (show-foo-stats 'buffer (buffer-list) #'buffer-memory-usage))
97 (princ "\n")
98 (incf grandtotal
99 (show-foo-stats 'window (mapcan #'(lambda (fr)
100 (window-list fr t))
101 (frame-list))
102 #'window-memory-usage))
103 (princ "\n")
104 (let ((total 0)
105 (fmt "%-30s%10s\n"))
106 (princ (format fmt "object" "storage"))
107 (princ (make-string 40 ?-))
108 (princ "\n")
109 (map-plist #'(lambda (stat num)
110 (when (string-match "\\(.*\\)-storage$"
111 (symbol-name stat))
112 (incf total num)
113 (princ (format fmt
114 (match-string 1 (symbol-name stat))
115 num)))
116 (when (eq stat 'long-strings-total-length)
117 (incf total num)
118 (princ (format fmt stat num))))
119 (sixth (garbage-collect)))
120 (princ "\n")
121 (princ (format fmt "total" total))
122 (incf grandtotal total))
123
124 (princ (format "\n\ngrand total: %s\n" grandtotal))
125 grandtotal))))