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