/[cmucl]/src/code/room.lisp
ViewVC logotype

Diff of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.37 by rtoy, Wed Aug 19 16:51:36 2009 UTC revision 1.38 by rtoy, Fri Mar 19 15:18:59 2010 UTC
# Line 13  Line 13 
13  ;;;  ;;;
14  (in-package "VM")  (in-package "VM")
15  (use-package "SYSTEM")  (use-package "SYSTEM")
16    (intl:textdomain "cmucl")
17    
18  (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage  (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
19                         instance-usage find-holes print-allocated-objects                         instance-usage find-holes print-allocated-objects
20                         code-breakdown uninterned-symbol-count                         code-breakdown uninterned-symbol-count
# Line 489  Line 491 
491                       (summary-totals (cons sum v))))                       (summary-totals (cons sum v))))
492                 summary)                 summary)
493    
494        (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)        (format t _"~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
495        (let ((summary-total-bytes 0)        (let ((summary-total-bytes 0)
496              (summary-total-objects 0))              (summary-total-objects 0))
497          (declare (type memory-size summary-total-bytes summary-total-objects))          (declare (type memory-size summary-total-bytes summary-total-objects))
# Line 507  Line 509 
509                    (incf total-bytes (first total))                    (incf total-bytes (first total))
510                    (incf total-objects (second total))                    (incf total-objects (second total))
511                    (spaces (cons (car space-total) (first total)))))                    (spaces (cons (car space-total) (first total)))))
512                (format t "~%~A:~%    ~:D bytes, ~:D object~:P"                (format t (intl:ngettext "~%~A:~%    ~:D bytes, ~:D object"
513                                           "~%~A:~%    ~:D bytes, ~:D objects"
514                                           total-objects)
515                        name total-bytes total-objects)                        name total-bytes total-objects)
516                (dolist (space (spaces))                (dolist (space (spaces))
517                  (format t ", ~D% ~(~A~)"                  (format t ", ~D% ~(~A~)"
# Line 516  Line 520 
520                (format t ".~%")                (format t ".~%")
521                (incf summary-total-bytes total-bytes)                (incf summary-total-bytes total-bytes)
522                (incf summary-total-objects total-objects))))                (incf summary-total-objects total-objects))))
523          (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"          (format t _"~%Summary total:~%    ~:D bytes, ~:D objects.~%"
524                  summary-total-bytes summary-total-objects)))))                  summary-total-bytes summary-total-objects)))))
525    
526    
# Line 526  Line 530 
530  ;;;  ;;;
531  (defun report-space-total (space-total cutoff)  (defun report-space-total (space-total cutoff)
532    (declare (list space-total) (type (or single-float null) cutoff))    (declare (list space-total) (type (or single-float null) cutoff))
533    (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))    (format t _"~2&Breakdown for ~(~A~) space:~%" (car space-total))
534    (let* ((types (cdr space-total))    (let* ((types (cdr space-total))
535           (total-bytes (reduce #'+ (mapcar #'first types)))           (total-bytes (reduce #'+ (mapcar #'first types)))
536           (total-objects (reduce #'+ (mapcar #'second types)))           (total-objects (reduce #'+ (mapcar #'second types)))
# Line 539  Line 543 
543               (type memory-size total-bytes reported-bytes))               (type memory-size total-bytes reported-bytes))
544      (loop for (bytes objects name) in types do      (loop for (bytes objects name) in types do
545        (when (<= bytes cutoff-point)        (when (<= bytes cutoff-point)
546          (format t "  ~13:D bytes for ~9:D other object~2:*~P.~%"          (format t (intl:ngettext "  ~13:D bytes for ~9:D other object.~%"
547                                     "  ~13:D bytes for ~9:D other objects.~%"
548                                     (- total-objects reported-objects))
549                  (- total-bytes reported-bytes)                  (- total-bytes reported-bytes)
550                  (- total-objects reported-objects))                  (- total-objects reported-objects))
551          (return))          (return))
552        (incf reported-bytes bytes)        (incf reported-bytes bytes)
553        (incf reported-objects objects)        (incf reported-objects objects)
554        (format t "  ~13:D bytes for ~9:D ~(~A~) object~2:*~P.~%"        (format t (intl:ngettext "  ~13:D bytes for ~9:D ~(~A~) object.~%"
555                                   "  ~13:D bytes for ~9:D ~(~A~) objects.~%"
556                                   objects)
557                bytes objects name))                bytes objects name))
558      (format t "  ~13:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"      (format t (intl:ngettext "  ~13:D bytes for ~9:D ~(~A~) object (space total.)~%"
559                                 "  ~13:D bytes for ~9:D ~(~A~) objects (space total.)~%"
560                                 total-objects)
561              total-bytes total-objects (car space-total))))              total-bytes total-objects (car space-total))))
562    
563    
# Line 555  Line 565 
565  ;;;  ;;;
566  (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))  (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
567                            (print-summary t) cutoff)                            (print-summary t) cutoff)
568    "Print out information about the heap memory in use.  :Print-Spaces is a list    _N"Print out information about the heap memory in use.  :Print-Spaces is a list
569    of the spaces to print detailed information for.  :Count-Spaces is a list of    of the spaces to print detailed information for.  :Count-Spaces is a list of
570    the spaces to scan.  For either one, T means all spaces (:Static, :Dyanmic    the spaces to scan.  For either one, T means all spaces (:Static, :Dyanmic
571    and :Read-Only.)  If :Print-Summary is true, then summary information will be    and :Read-Only.)  If :Print-Summary is true, then summary information will be
# Line 583  Line 593 
593  ;;; COUNT-NO-OPS  --  Public  ;;; COUNT-NO-OPS  --  Public
594  ;;;  ;;;
595  (defun count-no-ops (space)  (defun count-no-ops (space)
596    "Print info about how much code and no-ops there are in Space."    _N"Print info about how much code and no-ops there are in Space."
597    (declare (type spaces space))    (declare (type spaces space))
598    (let ((code-words 0)    (let ((code-words 0)
599          (no-ops 0)          (no-ops 0)
# Line 605  Line 615 
615       space)       space)
616    
617      (format t      (format t
618              "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"              _"~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
619              total-bytes code-words no-ops              total-bytes code-words no-ops
620              (round (* no-ops 100) code-words)))              (round (* no-ops 100) code-words)))
621    
# Line 684  Line 694 
694                 #.scavenger-hook-type)                 #.scavenger-hook-type)
695                (incf descriptor-words (truncate size word-bytes)))                (incf descriptor-words (truncate size word-bytes)))
696               (t               (t
697                (error "Bogus type: ~D" type))))                (error _"Bogus type: ~D" type))))
698         space))         space))
699      (format t "~:D words allocated for descriptor objects.~%"      (format t _"~:D words allocated for descriptor objects.~%"
700              descriptor-words)              descriptor-words)
701      (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"      (format t _"~:D bytes data/~:D words header for non-descriptor objects.~%"
702              non-descriptor-bytes non-descriptor-headers)              non-descriptor-bytes non-descriptor-headers)
703      (values)))      (values)))
704    
# Line 697  Line 707 
707  ;;;  ;;;
708  (defun instance-usage (space &key (top-n 15))  (defun instance-usage (space &key (top-n 15))
709    (declare (type spaces space) (type (or fixnum null) top-n))    (declare (type spaces space) (type (or fixnum null) top-n))
710    "Print a breakdown by instance type of all the instances allocated in    _N"Print a breakdown by instance type of all the instances allocated in
711    Space.  If TOP-N is true, print only information for the the TOP-N types with    Space.  If TOP-N is true, print only information for the the TOP-N types with
712    largest usage."    largest usage."
713    (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)    (format t _"~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
714    (let ((totals (make-hash-table :test #'eq))    (let ((totals (make-hash-table :test #'eq))
715          (total-objects 0)          (total-objects 0)
716          (total-bytes 0))          (total-bytes 0))
# Line 738  Line 748 
748                  (objects (cadr what)))                  (objects (cadr what)))
749              (incf printed-bytes bytes)              (incf printed-bytes bytes)
750              (incf printed-objects objects)              (incf printed-objects objects)
751              (format t "  ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)              (format t (intl:ngettext "  ~32A: ~7:D bytes, ~5D object.~%"
752                                         "  ~32A: ~7:D bytes, ~5D objects.~%"
753                                         objects)
754                        (car what)
755                      bytes objects)))                      bytes objects)))
756    
757          (let ((residual-objects (- total-objects printed-objects))          (let ((residual-objects (- total-objects printed-objects))
758                (residual-bytes (- total-bytes printed-bytes)))                (residual-bytes (- total-bytes printed-bytes)))
759            (unless (zerop residual-objects)            (unless (zerop residual-objects)
760              (format t "  Other types: ~:D bytes, ~D: object~:P.~%"              (format t (intl:ngettext "  Other types: ~:D bytes, ~D: object~:P.~%"
761                                         "  Other types: ~:D bytes, ~D: object~:P.~%"
762                                         residual-objects)
763                      residual-bytes residual-objects))))                      residual-bytes residual-objects))))
764    
765        (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"        (format t (intl:ngettext "  ~:(~A~) instance total: ~:D bytes, ~:D object.~%"
766                                   "  ~:(~A~) instance total: ~:D bytes, ~:D objects.~%"
767                                   total-objects)
768                space total-bytes total-objects)))                space total-bytes total-objects)))
769    
770    (values))    (values))
# Line 757  Line 774 
774  ;;;  ;;;
775  (defun find-holes (&rest spaces)  (defun find-holes (&rest spaces)
776    (dolist (space (or spaces '(:read-only :static :dynamic)))    (dolist (space (or spaces '(:read-only :static :dynamic)))
777      (format t "In ~A space:~%" space)      (format t _"In ~A space:~%" space)
778      (let ((start-addr nil)      (let ((start-addr nil)
779            (total-bytes 0))            (total-bytes 0))
780        (declare (type (or null (unsigned-byte 32)) start-addr)        (declare (type (or null (unsigned-byte 32)) start-addr)
# Line 774  Line 791 
791                     (setf start-addr (di::get-lisp-obj-address object)                     (setf start-addr (di::get-lisp-obj-address object)
792                           total-bytes bytes))                           total-bytes bytes))
793                 (when start-addr                 (when start-addr
794                   (format t "~D bytes at #x~X~%" total-bytes start-addr)                   (format t _"~D bytes at #x~X~%" total-bytes start-addr)
795                   (setf start-addr nil))))                   (setf start-addr nil))))
796         space)         space)
797        (when start-addr        (when start-addr
798          (format t "~D bytes at #x~X~%" total-bytes start-addr))))          (format t _"~D bytes at #x~X~%" total-bytes start-addr))))
799    (values))    (values))
800    
801    
# Line 971  Line 988 
988                                        (c::debug-source-name source)                                        (c::debug-source-name source)
989                                        "FROM LISP")))                                        "FROM LISP")))
990                                 (t                                 (t
991                                  (warn "No source for ~S" obj)                                  (warn _"No source for ~S" obj)
992                                  "NO SOURCE")))                                  "NO SOURCE")))
993                         "UNKNOWN"))                         "UNKNOWN"))
994                    (file-info (or (gethash file pkg-info)                    (file-info (or (gethash file pkg-info)
# Line 996  Line 1013 
1013    
1014        (loop for (pkg (pkg-count . pkg-size) . files) in        (loop for (pkg (pkg-count . pkg-size) . files) in
1015              (sort res #'> :key #'(lambda (x) (cdr (second x)))) do              (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
1016          (format t "~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"          (format t (intl:ngettext "~%Package ~A: ~32T~9:D bytes, ~9:D object.~%"
1017                                     "~%Package ~A: ~32T~9:D bytes, ~9:D objects.~%"
1018                                     pkg-count)
1019                  pkg pkg-size pkg-count)                  pkg pkg-size pkg-count)
1020          (when (eq how :file)          (when (eq how :file)
1021            (loop for (file (file-count . file-size)) in            (loop for (file (file-count . file-size)) in
1022                  (sort files #'> :key #'(lambda (x) (cdr (second x)))) do                  (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
1023              (format t "~30@A: ~9:D bytes, ~9:D object~:P.~%"              (format t (intl:ngettext "~30@A: ~9:D bytes, ~9:D object.~%"
1024                                         "~30@A: ~9:D bytes, ~9:D objects.~%"
1025                                         file-count)
1026                      (file-namestring file) file-size file-count))))))                      (file-namestring file) file-size file-count))))))
1027    
1028    (values))    (values))
# Line 1044  Line 1065 
1065  #+nil  #+nil
1066  (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)  (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
1067                                 (function #'identity))                                 (function #'identity))
1068    "Given a hashtable, print a histogram of the contents.  Function should give    _N"Given a hashtable, print a histogram of the contents.  Function should give
1069    the value to plot when applied to the hashtable values."    the value to plot when applied to the hashtable values."
1070    (let ((function (if (eval:interpreted-function-p function)    (let ((function (if (eval:interpreted-function-p function)
1071                        (compile nil function)                        (compile nil function)
# Line 1054  Line 1075 
1075          (hist:hist-record (funcall function count))))))          (hist:hist-record (funcall function count))))))
1076    
1077  (defun report-top-n (table &key (top-n 20) (function #'identity))  (defun report-top-n (table &key (top-n 20) (function #'identity))
1078    "Report the Top-N entries in the hashtable Table, when sorted by Function    _N"Report the Top-N entries in the hashtable Table, when sorted by Function
1079    applied to the hash value.  If Top-N is NIL, report all entries."    applied to the hash value.  If Top-N is NIL, report all entries."
1080    (let ((function (if (eval:interpreted-function-p function)    (let ((function (if (eval:interpreted-function-p function)
1081                        (compile nil function)                        (compile nil function)
# Line 1078  Line 1099 
1099    
1100          (let ((residual (- (total-val) printed)))          (let ((residual (- (total-val) printed)))
1101            (unless (zerop residual)            (unless (zerop residual)
1102              (format t "~8:D: Other~%" residual))))              (format t _"~8:D: Other~%" residual))))
1103    
1104        (format t "~8:D: Total~%" (total-val))))        (format t _"~8:D: Total~%" (total-val))))
1105    (values))    (values))
1106    
1107    
# Line 1105  Line 1126 
1126    
1127    
1128  (defun find-caller-counts (space)  (defun find-caller-counts (space)
1129    "Return a hashtable mapping each function in for which a call appears in    _N"Return a hashtable mapping each function in for which a call appears in
1130    Space to the number of times such a call appears."    Space to the number of times such a call appears."
1131    (let ((counts (make-hash-table :test #'eq)))    (let ((counts (make-hash-table :test #'eq)))
1132      (map-allocated-objects      (map-allocated-objects
# Line 1120  Line 1141 
1141      counts))      counts))
1142    
1143  (defun find-high-callers (space &key (above 10) table (threshold 2))  (defun find-high-callers (space &key (above 10) table (threshold 2))
1144    "Return a hashtable translating code objects to function constant counts for    _N"Return a hashtable translating code objects to function constant counts for
1145    all code objects in Space with more than Above function constants."    all code objects in Space with more than Above function constants."
1146    (let ((counts (make-hash-table :test #'eq)))    (let ((counts (make-hash-table :test #'eq)))
1147      (map-allocated-objects      (map-allocated-objects

Legend:
Removed from v.1.37  
changed lines
  Added in v.1.38

  ViewVC Help
Powered by ViewVC 1.1.5