Mercurial > hg > xemacs-beta
diff lisp/diagnose.el @ 5567:3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
lisp/ChangeLog addition:
2011-09-07 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (transpose-subr):
* specifier.el (let-specifier):
* specifier.el (derive-device-type-from-tag-set):
* test-harness.el (batch-test-emacs):
* x-compose.el (alias-colon-to-doublequote):
* mule/chinese.el (make-chinese-cns11643-charset):
* mule/mule-cmds.el (set-locale-for-language-environment):
* mule/mule-cmds.el (set-language-environment-coding-systems):
* mule/mule-x-init.el (x-use-halfwidth-roman-font):
* about.el (about-xemacs):
* about.el (about-hackers):
* diagnose.el (show-memory-usage):
* diagnose.el (show-object-memory-usage-stats):
* diagnose.el (show-mc-alloc-memory-usage):
* diagnose.el (show-gc-stats):
* dialog.el (make-dialog-box):
* faces.el:
* faces.el (Face-frob-property):
* faces.el (set-face-stipple):
* glyphs.el:
* glyphs.el (init-glyphs): Removed.
* help-macro.el (make-help-screen):
* info.el (Info-construct-menu):
* keymap.el (key-sequence-list-description):
* lisp-mode.el (construct-lisp-mode-menu):
* loadhist.el (unload-feature):
* minibuf.el (get-user-response):
* mouse.el (default-mouse-track-check-for-activation):
* mouse.el (mouse-track-insert-1):
Follow my own advice from the last commit and use #'labels instead
of #'flet in core code.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 07 Sep 2011 21:21:36 +0100 |
| parents | ac37a5f7e5be |
| children |
line wrap: on
line diff
--- a/lisp/diagnose.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/diagnose.el Wed Sep 07 21:21:36 2011 +0100 @@ -33,69 +33,68 @@ "Show statistics about memory usage of various sorts in XEmacs." (interactive) (garbage-collect) - (flet ((show-foo-stats (objtypename statname-plist cleanfun objlist - &optional objnamelen) - (let* ((hash (make-hash-table)) - (first t) - types origtypes fmt - (objnamelen (or objnamelen 25)) - (linelen objnamelen) - (totaltotal 0)) - (loop for obj in objlist do - (let ((total 0) - (stats (object-memory-usage obj))) - ;; Pop off the slice describing the object itself's - ;; memory - (while (and stats (not (eq t (pop stats))))) - ;; Pop off the slice describing the associated - ;; non-Lisp-Object memory from the allocation - ;; perspective, so we can get to the slice describing - ;; the memory grouped by type - (while (and stats (pop stats))) + (labels ((show-foo-stats (objtypename statname-plist cleanfun objlist + &optional objnamelen) + (let* ((hash (make-hash-table)) + (first t) + types origtypes fmt + (objnamelen (or objnamelen 25)) + (linelen objnamelen) + (totaltotal 0)) + (loop for obj in objlist do + (let ((total 0) + (stats (object-memory-usage obj))) + ;; Pop off the slice describing the object itself's + ;; memory + (while (and stats (not (eq t (pop stats))))) + ;; Pop off the slice describing the associated + ;; non-Lisp-Object memory from the allocation + ;; perspective, so we can get to the slice describing + ;; the memory grouped by type + (while (and stats (pop stats))) - (loop for (type . num) in (remq t stats) while type do - (if first (push type origtypes)) - (setq type (getf statname-plist type type)) - (puthash type (+ num (or (gethash type hash) 0)) hash) - (incf total num) - (if first (push type types))) - (incf totaltotal total) - (when first - (setq types (nreverse types)) - (setq origtypes (nreverse origtypes)) - (setq fmt (concat - (format "%%-%ds" objnamelen) - (mapconcat - #'(lambda (type) - (let ((fieldlen - (max 7 (+ 2 (length - (symbol-name type)))))) - (incf linelen fieldlen) - (format "%%%ds" fieldlen))) - types "") - (progn (incf linelen 9) "%9s\n"))) - (princ "\n") - (princ (apply 'format fmt objtypename - (append types (list 'total)))) - (princ (make-string linelen ?-)) - (princ "\n")) - (let ((objname (format "%s" (funcall cleanfun obj)))) - (princ (apply 'format fmt (substring objname 0 - (min (length objname) - (1- objnamelen))) - (nconc (mapcar #'(lambda (type) - (cdr (assq type stats))) - origtypes) - (list total))))) - (setq first nil))) - (princ "\n") - (princ (apply 'format fmt "total" - (nconc (mapcar #'(lambda (type) - (gethash type hash)) - types) - (list totaltotal)))) - totaltotal))) - + (loop for (type . num) in (remq t stats) while type do + (if first (push type origtypes)) + (setq type (getf statname-plist type type)) + (puthash type (+ num (or (gethash type hash) 0)) hash) + (incf total num) + (if first (push type types))) + (incf totaltotal total) + (when first + (setq types (nreverse types)) + (setq origtypes (nreverse origtypes)) + (setq fmt (concat + (format "%%-%ds" objnamelen) + (mapconcat + #'(lambda (type) + (let ((fieldlen + (max 7 (+ 2 (length + (symbol-name type)))))) + (incf linelen fieldlen) + (format "%%%ds" fieldlen))) + types "") + (progn (incf linelen 9) "%9s\n"))) + (princ "\n") + (princ (apply 'format fmt objtypename + (append types (list 'total)))) + (princ (make-string linelen ?-)) + (princ "\n")) + (let ((objname (format "%s" (funcall cleanfun obj)))) + (princ (apply 'format fmt (substring objname 0 + (min (length objname) + (1- objnamelen))) + (nconc (mapcar #'(lambda (type) + (cdr (assq type stats))) + origtypes) + (list total))))) + (setq first nil))) + (princ "\n") + (princ (apply 'format fmt "total" + (nconc (mapcar #'(lambda (type) + (gethash type hash)) + types) + (list totaltotal)))) + totaltotal))) (let ((grandtotal 0) (buffer "*memory usage*") begin) @@ -202,101 +201,102 @@ (fmt "%-28s%10s%10s%10s%10s%10s\n") (grandtotal 0) begin) - (flet ((show-stats (match-string) - (princ (format "%28s%10s%40s\n" "" "" - "--------------storage---------------")) - (princ (format fmt "object" "count" "object" "overhead" - "non-Lisp" "ancillary")) - (princ (make-string 78 ?-)) - (princ "\n") - (let ((total-use 0) - (total-non-lisp-use 0) - (total-use-overhead 0) - (total-use-with-overhead 0) - (total-count 0)) - (map-plist - #'(lambda (stat num) - (let ((symmatch - (and (string-match match-string (symbol-name stat)) - (match-string 1 (symbol-name stat))))) - (when (and symmatch - (or (< (length symmatch) 9) - (not (equal (substring symmatch -9) - "-non-lisp"))) - (or (< (length symmatch) 15) - (not (equal (substring symmatch -15) - "-lisp-ancillary")))) - (let* ((storage-use num) - (storage-use-overhead - (or (plist-get - plist - (intern (concat symmatch - "-storage-overhead"))) - 0)) - (storage-use-with-overhead - (or (plist-get - plist - (intern (concat - symmatch - "-storage-including-overhead"))) - (+ storage-use storage-use-overhead))) - (storage-use-overhead - (- storage-use-with-overhead storage-use)) - (non-lisp-storage - (or (plist-get - plist - (intern (concat symmatch - "-non-lisp-storage"))) - 0)) - (lisp-ancillary-storage - (or (plist-get - plist - (intern (concat symmatch - "-lisp-ancillary-storage"))) - 0)) - (storage-count - (or (loop for str in '("s-used" "es-used" "-used") - for val = (plist-get - plist - (intern - (concat symmatch str))) - if val - return val) - (plist-get - plist - (intern - (concat (substring symmatch 0 -1) - "ies-used"))) - ))) - (incf total-use storage-use) - (incf total-use-overhead storage-use-overhead) - (incf total-use-with-overhead storage-use-with-overhead) - (incf total-non-lisp-use non-lisp-storage) - (incf total-count (or storage-count 0)) - (and (> storage-use-with-overhead 0) - (princ (format fmt symmatch - (or storage-count "unknown") - storage-use - storage-use-overhead - non-lisp-storage - lisp-ancillary-storage))))))) - plist) - (princ "\n") - (princ (format fmt "total" - total-count total-use total-use-overhead - total-non-lisp-use "")) - (incf grandtotal total-use-with-overhead) - (incf grandtotal total-non-lisp-use) - (when-fboundp 'sort-numeric-fields - (sort-numeric-fields -4 - (save-excursion - (goto-char begin) - (forward-line 4) - (point)) - (save-excursion - (forward-line -2) - (point))))))) - (with-output-to-temp-buffer buffer + (labels + ((show-stats (match-string) + (princ (format "%28s%10s%40s\n" "" "" + "--------------storage---------------")) + (princ (format fmt "object" "count" "object" "overhead" + "non-Lisp" "ancillary")) + (princ (make-string 78 ?-)) + (princ "\n") + (let ((total-use 0) + (total-non-lisp-use 0) + (total-use-overhead 0) + (total-use-with-overhead 0) + (total-count 0)) + (map-plist + #'(lambda (stat num) + (let ((symmatch + (and (string-match match-string (symbol-name stat)) + (match-string 1 (symbol-name stat))))) + (when (and symmatch + (or (< (length symmatch) 9) + (not (equal (substring symmatch -9) + "-non-lisp"))) + (or (< (length symmatch) 15) + (not (equal (substring symmatch -15) + "-lisp-ancillary")))) + (let* ((storage-use num) + (storage-use-overhead + (or (plist-get + plist + (intern (concat symmatch + "-storage-overhead"))) + 0)) + (storage-use-with-overhead + (or (plist-get + plist + (intern (concat + symmatch + "-storage-including-overhead"))) + (+ storage-use storage-use-overhead))) + (storage-use-overhead + (- storage-use-with-overhead storage-use)) + (non-lisp-storage + (or (plist-get + plist + (intern (concat symmatch + "-non-lisp-storage"))) + 0)) + (lisp-ancillary-storage + (or (plist-get + plist + (intern (concat symmatch + "-lisp-ancillary-storage"))) + 0)) + (storage-count + (or (loop for str in '("s-used" "es-used" "-used") + for val = (plist-get + plist + (intern + (concat symmatch str))) + if val + return val) + (plist-get + plist + (intern + (concat (substring symmatch 0 -1) + "ies-used"))) + ))) + (incf total-use storage-use) + (incf total-use-overhead storage-use-overhead) + (incf total-use-with-overhead storage-use-with-overhead) + (incf total-non-lisp-use non-lisp-storage) + (incf total-count (or storage-count 0)) + (and (> storage-use-with-overhead 0) + (princ (format fmt symmatch + (or storage-count "unknown") + storage-use + storage-use-overhead + non-lisp-storage + lisp-ancillary-storage))))))) + plist) + (princ "\n") + (princ (format fmt "total" + total-count total-use total-use-overhead + total-non-lisp-use "")) + (incf grandtotal total-use-with-overhead) + (incf grandtotal total-non-lisp-use) + (when-fboundp 'sort-numeric-fields + (sort-numeric-fields -4 + (save-excursion + (goto-char begin) + (forward-line 4) + (point)) + (save-excursion + (forward-line -2) + (point))))))) + (with-output-to-temp-buffer buffer (save-excursion (set-buffer buffer) (setq begin (point)) @@ -319,114 +319,115 @@ (globals (fifth stats)) (mc-malloced-bytes (sixth stats))) (with-output-to-temp-buffer "*mc-alloc memory usage*" - (flet ((print-used-plhs (text plhs) - (let ((sum-n-pages 0) - (sum-used-n-cells 0) - (sum-used-space 0) - (sum-used-total 0) - (sum-total-n-cells 0) - (sum-total-space 0) - (sum-total-total 0) - (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) - (princ (format "%-14s|%-29s|%-29s|\n" - text - " currently in use" - " total available")) - (princ (format fmt "cell-sz" "#pages" - "#cells" "space" "total" "% " - "#cells" "space" "total" "% " "% ")) - (princ (make-string 79 ?-)) - (princ "\n") - (while plhs - (let* ((elem (car plhs)) - (cell-size (first elem)) - (n-pages (second elem)) - (used-n-cells (third elem)) - (used-space (fourth elem)) - (used-total (if (zerop cell-size) - (sixth elem) - (* cell-size used-n-cells))) - (used-eff (floor (if (not (zerop used-total)) - (* (/ (* used-space 1.0) - (* used-total 1.0)) + (labels + ((print-used-plhs (text plhs) + (let ((sum-n-pages 0) + (sum-used-n-cells 0) + (sum-used-space 0) + (sum-used-total 0) + (sum-total-n-cells 0) + (sum-total-space 0) + (sum-total-total 0) + (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) + (princ (format "%-14s|%-29s|%-29s|\n" + text + " currently in use" + " total available")) + (princ (format fmt "cell-sz" "#pages" + "#cells" "space" "total" "% " + "#cells" "space" "total" "% " "% ")) + (princ (make-string 79 ?-)) + (princ "\n") + (while plhs + (let* ((elem (car plhs)) + (cell-size (first elem)) + (n-pages (second elem)) + (used-n-cells (third elem)) + (used-space (fourth elem)) + (used-total (if (zerop cell-size) + (sixth elem) + (* cell-size used-n-cells))) + (used-eff (floor (if (not (zerop used-total)) + (* (/ (* used-space 1.0) + (* used-total 1.0)) + 100.0) + 0))) + (total-n-cells (fifth elem)) + (total-space (if (zerop cell-size) + used-space + (* cell-size total-n-cells))) + (total-total (sixth elem)) + (total-eff (floor (if (not (zerop total-total)) + (* (/ (* total-space 1.0) + (* total-total 1.0)) + 100.0) + 0))) + (eff (floor (if (not (zerop total-total)) + (* (/ (* used-space 1.0) + (* total-total 1.0)) + 100.0) + 0)))) + (princ (format fmt + cell-size n-pages used-n-cells used-space + used-total used-eff total-n-cells + total-space total-total total-eff eff)) + (incf sum-n-pages n-pages) + (incf sum-used-n-cells used-n-cells) + (incf sum-used-space used-space) + (incf sum-used-total used-total) + (incf sum-total-n-cells total-n-cells) + (incf sum-total-space total-space) + (incf sum-total-total total-total)) + (setq plhs (cdr plhs))) + (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) + (* (/ (* sum-used-space 1.0) + (* sum-used-total 1.0)) + 100.0) + 0))) + (avg-total-eff (floor (if (not (zerop sum-total-total)) + (* (/ (* sum-total-space 1.0) + (* sum-total-total 1.0)) 100.0) 0))) - (total-n-cells (fifth elem)) - (total-space (if (zerop cell-size) - used-space - (* cell-size total-n-cells))) - (total-total (sixth elem)) - (total-eff (floor (if (not (zerop total-total)) - (* (/ (* total-space 1.0) - (* total-total 1.0)) - 100.0) - 0))) - (eff (floor (if (not (zerop total-total)) - (* (/ (* used-space 1.0) - (* total-total 1.0)) - 100.0) - 0)))) - (princ (format fmt - cell-size n-pages used-n-cells used-space - used-total used-eff total-n-cells - total-space total-total total-eff eff)) - (incf sum-n-pages n-pages) - (incf sum-used-n-cells used-n-cells) - (incf sum-used-space used-space) - (incf sum-used-total used-total) - (incf sum-total-n-cells total-n-cells) - (incf sum-total-space total-space) - (incf sum-total-total total-total)) - (setq plhs (cdr plhs))) - (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) - (* (/ (* sum-used-space 1.0) - (* sum-used-total 1.0)) - 100.0) - 0))) - (avg-total-eff (floor (if (not (zerop sum-total-total)) - (* (/ (* sum-total-space 1.0) - (* sum-total-total 1.0)) - 100.0) - 0))) - (avg-eff (floor (if (not (zerop sum-total-total)) - (* (/ (* sum-used-space 1.0) - (* sum-total-total 1.0)) - 100.0) - 0)))) - (princ (format fmt "sum " sum-n-pages sum-used-n-cells - sum-used-space sum-used-total avg-used-eff - sum-total-n-cells sum-total-space - sum-total-total avg-total-eff avg-eff)) - (princ "\n")))) + (avg-eff (floor (if (not (zerop sum-total-total)) + (* (/ (* sum-used-space 1.0) + (* sum-total-total 1.0)) + 100.0) + 0)))) + (princ (format fmt "sum " sum-n-pages sum-used-n-cells + sum-used-space sum-used-total avg-used-eff + sum-total-n-cells sum-total-space + sum-total-total avg-total-eff avg-eff)) + (princ "\n")))) - (print-free-plhs (text plhs) - (let ((sum-n-pages 0) - (sum-n-sects 0) - (sum-space 0) - (sum-total 0) - (fmt "%6s%10s |%7s%10s\n")) - (princ (format "%s\n" text)) - (princ (format fmt "#pages" "space" "#sects" "total")) - (princ (make-string 35 ?-)) - (princ "\n") - (while plhs - (let* ((elem (car plhs)) - (n-pages (first elem)) - (n-sects (second elem)) - (space (* n-pages page-size)) - (total (* n-sects space))) - (princ (format fmt n-pages space n-sects total)) - (incf sum-n-pages n-pages) - (incf sum-n-sects n-sects) - (incf sum-space space) - (incf sum-total total)) - (setq plhs (cdr plhs))) - (princ (make-string 35 ?=)) - (princ "\n") - (princ (format fmt sum-n-pages sum-space - sum-n-sects sum-total)) - (princ "\n")))) + (print-free-plhs (text plhs) + (let ((sum-n-pages 0) + (sum-n-sects 0) + (sum-space 0) + (sum-total 0) + (fmt "%6s%10s |%7s%10s\n")) + (princ (format "%s\n" text)) + (princ (format fmt "#pages" "space" "#sects" "total")) + (princ (make-string 35 ?-)) + (princ "\n") + (while plhs + (let* ((elem (car plhs)) + (n-pages (first elem)) + (n-sects (second elem)) + (space (* n-pages page-size)) + (total (* n-sects space))) + (princ (format fmt n-pages space n-sects total)) + (incf sum-n-pages n-pages) + (incf sum-n-sects n-sects) + (incf sum-space space) + (incf sum-total total)) + (setq plhs (cdr plhs))) + (princ (make-string 35 ?=)) + (princ "\n") + (princ (format fmt sum-n-pages sum-space + sum-n-sects sum-total)) + (princ "\n")))) (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size)) @@ -467,19 +468,19 @@ (let ((buffer "*garbage collection statistics*") (plist (gc-stats)) (fmt "%-9s %16s %12s %12s %12s %12s\n")) - (flet ((plist-get-stat (category field) - (let ((stat (plist-get plist - (intern (concat category field))))) - (if stat - (format "%.0f" stat) - "-"))) - (show-stats (category) - (princ (format fmt category - (plist-get-stat category "-total") - (plist-get-stat category "-in-last-gc") - (plist-get-stat category "-in-this-gc") - (plist-get-stat category "-in-last-cycle") - (plist-get-stat category "-in-this-cycle"))))) + (labels + ((plist-get-stat (category field) + (let ((stat (plist-get plist (intern (concat category field))))) + (if stat + (format "%.0f" stat) + "-"))) + (show-stats (category) + (princ (format fmt category + (plist-get-stat category "-total") + (plist-get-stat category "-in-last-gc") + (plist-get-stat category "-in-this-gc") + (plist-get-stat category "-in-last-cycle") + (plist-get-stat category "-in-this-cycle"))))) (with-output-to-temp-buffer buffer (save-excursion (set-buffer buffer)