xemacs-beta: lisp/diagnose.el annotate

annotate lisp/diagnose.el @ 5940:c608d4b0b75e cygwin64 tip

rescue lost branch from 64bit.backup

author	Henry Thompson <ht@markup.co.uk>
date	Thu, 16 Dec 2021 18:48:58 +0000
parents	3bc58dc9d688
children

rev	line source
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	1 ;;; diagnose.el --- routines for debugging problems in XEmacs
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	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 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	4
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	5 ;; Maintainer: XEmacs Development Team
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	6 ;; Keywords: dumped
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	7
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	8 ;; This file is part of XEmacs.
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	9
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	10 ;; XEmacs is free software: you can redistribute it and/or modify it
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	11 ;; under the terms of the GNU General Public License as published by the
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	12 ;; Free Software Foundation, either version 3 of the License, or (at your
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	13 ;; option) any later version.
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	14
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	18 ;; for more details.
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	19
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	20 ;; You should have received a copy of the GNU General Public License
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5230 diff changeset	21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	22
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	23 ;;; Synched up with: Not in FSF.
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	24
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	25 ;;; Commentary:
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	26
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	27 ;; This file is dumped with XEmacs.
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	28
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	29 ;;; Code:
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	30
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	31
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	32 (defun show-memory-usage ()
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	33 "Show statistics about memory usage of various sorts in XEmacs."
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	34 (interactive)
242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	35 (garbage-collect)
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	36 (labels ((show-foo-stats (objtypename statname-plist cleanfun objlist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	37 &optional objnamelen)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	38 (let* ((hash (make-hash-table))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	39 (first t)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	40 types origtypes fmt
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	41 (objnamelen (or objnamelen 25))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	42 (linelen objnamelen)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	43 (totaltotal 0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	44 (loop for obj in objlist do
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	45 (let ((total 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	46 (stats (object-memory-usage obj)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	47 ;; Pop off the slice describing the object itself's
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	48 ;; memory
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	49 (while (and stats (not (eq t (pop stats)))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	50 ;; Pop off the slice describing the associated
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	51 ;; non-Lisp-Object memory from the allocation
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	52 ;; perspective, so we can get to the slice describing
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	53 ;; the memory grouped by type
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	54 (while (and stats (pop stats)))
5157 1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects Ben Wing <ben@xemacs.org> parents: 5059 diff changeset	55
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	56 (loop for (type . num) in (remq t stats) while type do
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	57 (if first (push type origtypes))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	58 (setq type (getf statname-plist type type))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	59 (puthash type (+ num (or (gethash type hash) 0)) hash)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	60 (incf total num)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	61 (if first (push type types)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	62 (incf totaltotal total)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	63 (when first
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	64 (setq types (nreverse types))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	65 (setq origtypes (nreverse origtypes))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	66 (setq fmt (concat
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	67 (format "%%-%ds" objnamelen)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	68 (mapconcat
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	69 #'(lambda (type)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	70 (let ((fieldlen
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	71 (max 7 (+ 2 (length
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	72 (symbol-name type))))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	73 (incf linelen fieldlen)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	74 (format "%%%ds" fieldlen)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	75 types "")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	76 (progn (incf linelen 9) "%9s\n")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	77 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	78 (princ (apply 'format fmt objtypename
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	79 (append types (list 'total))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	80 (princ (make-string linelen ?-))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	81 (princ "\n"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	82 (let ((objname (format "%s" (funcall cleanfun obj))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	83 (princ (apply 'format fmt (substring objname 0
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	84 (min (length objname)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	85 (1- objnamelen)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	86 (nconc (mapcar #'(lambda (type)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	87 (cdr (assq type stats)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	88 origtypes)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	89 (list total)))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	90 (setq first nil)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	91 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	92 (princ (apply 'format fmt "total"
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	93 (nconc (mapcar #'(lambda (type)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	94 (gethash type hash))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	95 types)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	96 (list totaltotal))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	97 totaltotal)))
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	98 (let ((grandtotal 0)
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	99 (buffer "memory usage")
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	100 begin)
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	101 (with-output-to-temp-buffer buffer
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	102 (save-excursion
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	103 (set-buffer buffer)
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	104 (when-fboundp 'charset-list
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	105 (setq begin (point))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	106 (incf grandtotal
5170 5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	107 (show-foo-stats 'charset nil 'charset-name
5157 1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects Ben Wing <ben@xemacs.org> parents: 5059 diff changeset	108 (mapcar 'get-charset (charset-list))))
3066 a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	109 (when-fboundp 'sort-numeric-fields
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	110 (sort-numeric-fields -1
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	111 (save-excursion
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	112 (goto-char begin)
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	113 (forward-line 2)
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	114 (point))
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	115 (save-excursion
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	116 (forward-line -2)
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	117 (point))))
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	118 (princ "\n"))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	119 (setq begin (point))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	120 (incf grandtotal
5170 5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	121 (show-foo-stats 'buffer nil 'buffer-name (buffer-list)))
3066 a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	122 (when-fboundp 'sort-numeric-fields
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	123 (sort-numeric-fields -1
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	124 (save-excursion
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	125 (goto-char begin)
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	126 (forward-line 3)
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	127 (point))
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	128 (save-excursion
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	129 (forward-line -2)
a88e6130a523 [xemacs-hg @ 2005-11-13 10:56:09 by ben] ben parents: 3041 diff changeset	130 (point))))
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	131 (princ "\n")
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	132 (setq begin (point))
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	133 (incf grandtotal
5170 5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	134 (show-foo-stats 'window
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	135 '(line-start-cache line-st.
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	136 face-cache face
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	137 glyph-cache glyph
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	138 redisplay-structs redisplay
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	139 scrollbar-instances scrollbar
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	140 window-mirror mirror)
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	141 #'(lambda (x)
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	142 (buffer-name (window-buffer x)))
5157 1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects Ben Wing <ben@xemacs.org> parents: 5059 diff changeset	143 (mapcan #'(lambda (fr)
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects Ben Wing <ben@xemacs.org> parents: 5059 diff changeset	144 (window-list fr t))
5170 5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	145 (frame-list))
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	146 16))
5368 ed74d2ca7082 Use ', not #', when a given symbol may not have a function binding at read time Aidan Kehoe <kehoea@parhasard.net> parents: 5230 diff changeset	147 (when-fboundp 'sort-numeric-fields
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	148 (sort-numeric-fields -1
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	149 (save-excursion
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	150 (goto-char begin)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	151 (forward-line 3)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	152 (point))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	153 (save-excursion
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	154 (forward-line -2)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	155 (point))))
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	156 (princ "\n")
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	157 (let ((total 0)
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	158 (fmt "%-30s%10s\n"))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	159 (setq begin (point))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	160 (princ (format fmt "object" "storage"))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	161 (princ (make-string 40 ?-))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	162 (princ "\n")
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	163 (map-plist #'(lambda (stat num)
5170 5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	164 (when (and
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	165 (not
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	166 (string-match
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	167 "\$.*\$-ancillary-storage$"
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	168 (symbol-name stat)))
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	169 (string-match
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	170 "\$.*\$-storage$"
5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	171 (symbol-name stat)))
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	172 (incf total num)
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	173 (princ (format fmt
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	174 (match-string 1 (symbol-name stat))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	175 num)))
5160 ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly Ben Wing <ben@xemacs.org> parents: 5158 diff changeset	176 )
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	177 (sixth (garbage-collect)))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	178 (princ "\n")
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	179 (princ (format fmt "total" total))
6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	180 (incf grandtotal total))
5368 ed74d2ca7082 Use ', not #', when a given symbol may not have a function binding at read time Aidan Kehoe <kehoea@parhasard.net> parents: 5230 diff changeset	181 (when-fboundp 'sort-numeric-fields
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	182 (sort-numeric-fields -1
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	183 (save-excursion
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	184 (goto-char begin)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	185 (forward-line 2)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	186 (point))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	187 (save-excursion
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	188 (forward-line -2)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	189 (point))))
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	190
2618 6db7dbf7f88b [xemacs-hg @ 2005-02-28 07:43:17 by adrian] adrian parents: 787 diff changeset	191 (princ (format "\n\ngrand total: %s\n" grandtotal)))
787 242b62e9fc59 [xemacs-hg @ 2002-03-20 10:20:48 by ben] ben parents: diff changeset	192 grandtotal))))
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	193
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	194
3041 876730d84b73 [xemacs-hg @ 2005-11-02 03:26:51 by crestani] crestani parents: 2775 diff changeset	195 (defun show-object-memory-usage-stats ()
3888 099851392ea7 [xemacs-hg @ 2007-03-30 14:38:39 by stephent] stephent parents: 3320 diff changeset	196 "Show statistics about object memory usage in XEmacs."
2775 05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	197 (interactive)
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	198 (garbage-collect)
3041 876730d84b73 [xemacs-hg @ 2005-11-02 03:26:51 by crestani] crestani parents: 2775 diff changeset	199 (let ((buffer "object memory usage statistics")
876730d84b73 [xemacs-hg @ 2005-11-02 03:26:51 by crestani] crestani parents: 2775 diff changeset	200 (plist (object-memory-usage-stats))
5170 5ddbab03b0e6 various fixes to memory-usage stats Ben Wing <ben@xemacs.org> parents: 5160 diff changeset	201 (fmt "%-28s%10s%10s%10s%10s%10s\n")
2775 05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	202 (grandtotal 0)
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	203 begin)
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	204 (labels
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	205 ((show-stats (match-string)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	206 (princ (format "%28s%10s%40s\n" "" ""
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	207 "--------------storage---------------"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	208 (princ (format fmt "object" "count" "object" "overhead"
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	209 "non-Lisp" "ancillary"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	210 (princ (make-string 78 ?-))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	211 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	212 (let ((total-use 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	213 (total-non-lisp-use 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	214 (total-use-overhead 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	215 (total-use-with-overhead 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	216 (total-count 0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	217 (map-plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	218 #'(lambda (stat num)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	219 (let ((symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	220 (and (string-match match-string (symbol-name stat))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	221 (match-string 1 (symbol-name stat)))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	222 (when (and symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	223 (or (< (length symmatch) 9)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	224 (not (equal (substring symmatch -9)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	225 "-non-lisp")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	226 (or (< (length symmatch) 15)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	227 (not (equal (substring symmatch -15)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	228 "-lisp-ancillary"))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	229 (let* ((storage-use num)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	230 (storage-use-overhead
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	231 (or (plist-get
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	232 plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	233 (intern (concat symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	234 "-storage-overhead")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	235 0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	236 (storage-use-with-overhead
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	237 (or (plist-get
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	238 plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	239 (intern (concat
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	240 symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	241 "-storage-including-overhead")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	242 (+ storage-use storage-use-overhead)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	243 (storage-use-overhead
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	244 (- storage-use-with-overhead storage-use))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	245 (non-lisp-storage
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	246 (or (plist-get
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	247 plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	248 (intern (concat symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	249 "-non-lisp-storage")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	250 0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	251 (lisp-ancillary-storage
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	252 (or (plist-get
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	253 plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	254 (intern (concat symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	255 "-lisp-ancillary-storage")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	256 0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	257 (storage-count
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	258 (or (loop for str in '("s-used" "es-used" "-used")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	259 for val = (plist-get
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	260 plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	261 (intern
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	262 (concat symmatch str)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	263 if val
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	264 return val)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	265 (plist-get
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	266 plist
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	267 (intern
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	268 (concat (substring symmatch 0 -1)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	269 "ies-used")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	270 )))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	271 (incf total-use storage-use)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	272 (incf total-use-overhead storage-use-overhead)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	273 (incf total-use-with-overhead storage-use-with-overhead)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	274 (incf total-non-lisp-use non-lisp-storage)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	275 (incf total-count (or storage-count 0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	276 (and (> storage-use-with-overhead 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	277 (princ (format fmt symmatch
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	278 (or storage-count "unknown")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	279 storage-use
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	280 storage-use-overhead
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	281 non-lisp-storage
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	282 lisp-ancillary-storage)))))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	283 plist)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	284 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	285 (princ (format fmt "total"
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	286 total-count total-use total-use-overhead
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	287 total-non-lisp-use ""))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	288 (incf grandtotal total-use-with-overhead)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	289 (incf grandtotal total-non-lisp-use)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	290 (when-fboundp 'sort-numeric-fields
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	291 (sort-numeric-fields -4
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	292 (save-excursion
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	293 (goto-char begin)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	294 (forward-line 4)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	295 (point))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	296 (save-excursion
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	297 (forward-line -2)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	298 (point)))))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	299 (with-output-to-temp-buffer buffer
2775 05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	300 (save-excursion
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	301 (set-buffer buffer)
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	302 (setq begin (point))
5158 9e0b43d3095c more cleanups to object-memory-usage stuff Ben Wing <ben@xemacs.org> parents: 5157 diff changeset	303 (princ "Allocated with lisp allocator or related:\n")
2775 05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	304 (show-stats "\$.*\$-storage$")
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	305 (princ (format "\n\ngrand total: %s\n" grandtotal)))
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	306 grandtotal))))
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	307
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani] crestani parents: 2720 diff changeset	308
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	309 (defun show-mc-alloc-memory-usage ()
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	310 "Show statistics about memory usage of the new allocator."
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	311 (interactive)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	312 (garbage-collect)
5368 ed74d2ca7082 Use ', not #', when a given symbol may not have a function binding at read time Aidan Kehoe <kehoea@parhasard.net> parents: 5230 diff changeset	313 (if-fboundp 'mc-alloc-memory-usage
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	314 (let* ((stats (mc-alloc-memory-usage))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	315 (page-size (first stats))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	316 (heap-sects (second stats))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	317 (used-plhs (third stats))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	318 (free-plhs (fourth stats))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	319 (globals (fifth stats))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	320 (mc-malloced-bytes (sixth stats)))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	321 (with-output-to-temp-buffer "mc-alloc memory usage"
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	322 (labels
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	323 ((print-used-plhs (text plhs)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	324 (let ((sum-n-pages 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	325 (sum-used-n-cells 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	326 (sum-used-space 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	327 (sum-used-total 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	328 (sum-total-n-cells 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	329 (sum-total-space 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	330 (sum-total-total 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	331 (fmt "%7s%7s\|%7s%9s%9s%4s\|%7s%9s%9s%4s\|%4s\n"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	332 (princ (format "%-14s\|%-29s\|%-29s\|\n"
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	333 text
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	334 " currently in use"
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	335 " total available"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	336 (princ (format fmt "cell-sz" "#pages"
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	337 "#cells" "space" "total" "% "
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	338 "#cells" "space" "total" "% " "% "))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	339 (princ (make-string 79 ?-))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	340 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	341 (while plhs
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	342 (let* ((elem (car plhs))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	343 (cell-size (first elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	344 (n-pages (second elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	345 (used-n-cells (third elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	346 (used-space (fourth elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	347 (used-total (if (zerop cell-size)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	348 (sixth elem)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	349 (* cell-size used-n-cells)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	350 (used-eff (floor (if (not (zerop used-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	351 (* (/ (* used-space 1.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	352 (* used-total 1.0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	353 100.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	354 0)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	355 (total-n-cells (fifth elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	356 (total-space (if (zerop cell-size)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	357 used-space
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	358 (* cell-size total-n-cells)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	359 (total-total (sixth elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	360 (total-eff (floor (if (not (zerop total-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	361 (* (/ (* total-space 1.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	362 (* total-total 1.0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	363 100.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	364 0)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	365 (eff (floor (if (not (zerop total-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	366 (* (/ (* used-space 1.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	367 (* total-total 1.0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	368 100.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	369 0))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	370 (princ (format fmt
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	371 cell-size n-pages used-n-cells used-space
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	372 used-total used-eff total-n-cells
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	373 total-space total-total total-eff eff))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	374 (incf sum-n-pages n-pages)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	375 (incf sum-used-n-cells used-n-cells)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	376 (incf sum-used-space used-space)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	377 (incf sum-used-total used-total)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	378 (incf sum-total-n-cells total-n-cells)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	379 (incf sum-total-space total-space)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	380 (incf sum-total-total total-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	381 (setq plhs (cdr plhs)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	382 (let ((avg-used-eff (floor (if (not (zerop sum-used-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	383 (* (/ (* sum-used-space 1.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	384 (* sum-used-total 1.0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	385 100.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	386 0)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	387 (avg-total-eff (floor (if (not (zerop sum-total-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	388 (* (/ (* sum-total-space 1.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	389 (* sum-total-total 1.0))
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	390 100.0)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	391 0)))
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	392 (avg-eff (floor (if (not (zerop sum-total-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	393 (* (/ (* sum-used-space 1.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	394 (* sum-total-total 1.0))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	395 100.0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	396 0))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	397 (princ (format fmt "sum " sum-n-pages sum-used-n-cells
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	398 sum-used-space sum-used-total avg-used-eff
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	399 sum-total-n-cells sum-total-space
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	400 sum-total-total avg-total-eff avg-eff))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	401 (princ "\n"))))
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	402
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	403
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	404 (print-free-plhs (text plhs)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	405 (let ((sum-n-pages 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	406 (sum-n-sects 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	407 (sum-space 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	408 (sum-total 0)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	409 (fmt "%6s%10s \|%7s%10s\n"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	410 (princ (format "%s\n" text))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	411 (princ (format fmt "#pages" "space" "#sects" "total"))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	412 (princ (make-string 35 ?-))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	413 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	414 (while plhs
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	415 (let* ((elem (car plhs))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	416 (n-pages (first elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	417 (n-sects (second elem))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	418 (space (* n-pages page-size))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	419 (total (* n-sects space)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	420 (princ (format fmt n-pages space n-sects total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	421 (incf sum-n-pages n-pages)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	422 (incf sum-n-sects n-sects)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	423 (incf sum-space space)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	424 (incf sum-total total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	425 (setq plhs (cdr plhs)))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	426 (princ (make-string 35 ?=))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	427 (princ "\n")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	428 (princ (format fmt sum-n-pages sum-space
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	429 sum-n-sects sum-total))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	430 (princ "\n"))))
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	431
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	432 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size))
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	433
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	434 (print-used-plhs "USED HEAP" used-plhs)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	435 (princ "\n\n")
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	436
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	437 (print-free-plhs "FREE HEAP" free-plhs)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	438 (princ "\n\n")
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	439
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	440 (let ((fmt "%-30s%10s\n"))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	441 (princ (format fmt "heap sections" ""))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	442 (princ (make-string 40 ?-))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	443 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	444 (princ (format fmt "number of heap sects"
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	445 (first heap-sects)))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	446 (princ (format fmt "used size" (second heap-sects)))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	447 (princ (make-string 40 ?-))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	448 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	449 (princ (format fmt "real size" (third heap-sects)))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	450 (princ (format fmt "global allocator structs" globals))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	451 (princ (make-string 40 ?-))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	452 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	453 (princ (format fmt "real size + structs"
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	454 (+ (third heap-sects) globals)))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	455 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	456 (princ (make-string 40 ?=))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	457 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	458 (princ (format fmt "grand total" mc-malloced-bytes)))
2720 6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani] crestani parents: 2618 diff changeset	459
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	460 (+ mc-malloced-bytes))))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	461 (message "mc-alloc not used in this XEmacs.")))
3092 141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani] crestani parents: 3066 diff changeset	462
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani] crestani parents: 3066 diff changeset	463
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani] crestani parents: 3066 diff changeset	464 (defun show-gc-stats ()
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani] crestani parents: 3066 diff changeset	465 "Show statistics about garbage collection cycles."
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani] crestani parents: 3066 diff changeset	466 (interactive)
5368 ed74d2ca7082 Use ', not #', when a given symbol may not have a function binding at read time Aidan Kehoe <kehoea@parhasard.net> parents: 5230 diff changeset	467 (if-fboundp 'gc-stats
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	468 (let ((buffer "garbage collection statistics")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	469 (plist (gc-stats))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	470 (fmt "%-9s %16s %12s %12s %12s %12s\n"))
5567 3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	471 (labels
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	472 ((plist-get-stat (category field)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	473 (let ((stat (plist-get plist (intern (concat category field)))))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	474 (if stat
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	475 (format "%.0f" stat)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	476 "-")))
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	477 (show-stats (category)
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	478 (princ (format fmt category
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	479 (plist-get-stat category "-total")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	480 (plist-get-stat category "-in-last-gc")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	481 (plist-get-stat category "-in-this-gc")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	482 (plist-get-stat category "-in-last-cycle")
3bc58dc9d688 Replace #'flet by #'labels where appropriate, core code. Aidan Kehoe <kehoea@parhasard.net> parents: 5473 diff changeset	483 (plist-get-stat category "-in-this-cycle")))))
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	484 (with-output-to-temp-buffer buffer
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	485 (save-excursion
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	486 (set-buffer buffer)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	487 (princ (format "%s %g\n" "Current phase"
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	488 (plist-get plist 'phase)))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	489 (princ (make-string 78 ?-))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	490 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	491 (princ (format fmt "stat" "total" "last-gc" "this-gc"
5230 4c56e7c6a704 Fix a misspelling, diagnose.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5170 diff changeset	492 "last-cycle" "this-cycle"))
4103 b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	493 (princ (make-string 78 ?-))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	494 (princ "\n")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	495 (show-stats "n-gc")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	496 (show-stats "n-cycles")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	497 (show-stats "enqueued")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	498 (show-stats "dequeued")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	499 (show-stats "repushed")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	500 (show-stats "enqueued2")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	501 (show-stats "dequeued2")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	502 (show-stats "finalized")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	503 (show-stats "freed")
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	504 (plist-get plist 'n-gc-total)))))
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan] aidan parents: 3888 diff changeset	505 (error 'void-function "gc-stats not available.")))

Mercurial > hg > xemacs-beta

annotate lisp/diagnose.el @ 5940:c608d4b0b75e cygwin64 tip