/[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.10.1 by rtoy, Mon Feb 8 17:15:49 2010 UTC revision 1.37.10.2 by rtoy, Wed Feb 10 02:22:09 2010 UTC
# Line 491  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 509  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 _"~%~A:~%    ~:D bytes, ~:D object~:P"
513                        name total-bytes total-objects)                        name total-bytes total-objects)
514                (dolist (space (spaces))                (dolist (space (spaces))
515                  (format t ", ~D% ~(~A~)"                  (format t ", ~D% ~(~A~)"
# Line 518  Line 518 
518                (format t ".~%")                (format t ".~%")
519                (incf summary-total-bytes total-bytes)                (incf summary-total-bytes total-bytes)
520                (incf summary-total-objects total-objects))))                (incf summary-total-objects total-objects))))
521          (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"          (format t _"~%Summary total:~%    ~:D bytes, ~:D objects.~%"
522                  summary-total-bytes summary-total-objects)))))                  summary-total-bytes summary-total-objects)))))
523    
524    
# Line 528  Line 528 
528  ;;;  ;;;
529  (defun report-space-total (space-total cutoff)  (defun report-space-total (space-total cutoff)
530    (declare (list space-total) (type (or single-float null) cutoff))    (declare (list space-total) (type (or single-float null) cutoff))
531    (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))    (format t _"~2&Breakdown for ~(~A~) space:~%" (car space-total))
532    (let* ((types (cdr space-total))    (let* ((types (cdr space-total))
533           (total-bytes (reduce #'+ (mapcar #'first types)))           (total-bytes (reduce #'+ (mapcar #'first types)))
534           (total-objects (reduce #'+ (mapcar #'second types)))           (total-objects (reduce #'+ (mapcar #'second types)))
# Line 541  Line 541 
541               (type memory-size total-bytes reported-bytes))               (type memory-size total-bytes reported-bytes))
542      (loop for (bytes objects name) in types do      (loop for (bytes objects name) in types do
543        (when (<= bytes cutoff-point)        (when (<= bytes cutoff-point)
544          (format t "  ~13:D bytes for ~9:D other object~2:*~P.~%"          (format t _"  ~13:D bytes for ~9:D other object~2:*~P.~%"
545                  (- total-bytes reported-bytes)                  (- total-bytes reported-bytes)
546                  (- total-objects reported-objects))                  (- total-objects reported-objects))
547          (return))          (return))
548        (incf reported-bytes bytes)        (incf reported-bytes bytes)
549        (incf reported-objects objects)        (incf reported-objects objects)
550        (format t "  ~13:D bytes for ~9:D ~(~A~) object~2:*~P.~%"        (format t _"  ~13:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
551                bytes objects name))                bytes objects name))
552      (format t "  ~13:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"      (format t _"  ~13:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
553              total-bytes total-objects (car space-total))))              total-bytes total-objects (car space-total))))
554    
555    
# Line 557  Line 557 
557  ;;;  ;;;
558  (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))  (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
559                            (print-summary t) cutoff)                            (print-summary t) cutoff)
560    "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
561    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
562    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
563    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 585  Line 585 
585  ;;; COUNT-NO-OPS  --  Public  ;;; COUNT-NO-OPS  --  Public
586  ;;;  ;;;
587  (defun count-no-ops (space)  (defun count-no-ops (space)
588    "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."
589    (declare (type spaces space))    (declare (type spaces space))
590    (let ((code-words 0)    (let ((code-words 0)
591          (no-ops 0)          (no-ops 0)
# Line 607  Line 607 
607       space)       space)
608    
609      (format t      (format t
610              "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"              _"~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
611              total-bytes code-words no-ops              total-bytes code-words no-ops
612              (round (* no-ops 100) code-words)))              (round (* no-ops 100) code-words)))
613    
# Line 686  Line 686 
686                 #.scavenger-hook-type)                 #.scavenger-hook-type)
687                (incf descriptor-words (truncate size word-bytes)))                (incf descriptor-words (truncate size word-bytes)))
688               (t               (t
689                (error "Bogus type: ~D" type))))                (error _"Bogus type: ~D" type))))
690         space))         space))
691      (format t "~:D words allocated for descriptor objects.~%"      (format t _"~:D words allocated for descriptor objects.~%"
692              descriptor-words)              descriptor-words)
693      (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"      (format t _"~:D bytes data/~:D words header for non-descriptor objects.~%"
694              non-descriptor-bytes non-descriptor-headers)              non-descriptor-bytes non-descriptor-headers)
695      (values)))      (values)))
696    
# Line 699  Line 699 
699  ;;;  ;;;
700  (defun instance-usage (space &key (top-n 15))  (defun instance-usage (space &key (top-n 15))
701    (declare (type spaces space) (type (or fixnum null) top-n))    (declare (type spaces space) (type (or fixnum null) top-n))
702    "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
703    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
704    largest usage."    largest usage."
705    (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)    (format t _"~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
706    (let ((totals (make-hash-table :test #'eq))    (let ((totals (make-hash-table :test #'eq))
707          (total-objects 0)          (total-objects 0)
708          (total-bytes 0))          (total-bytes 0))
# Line 740  Line 740 
740                  (objects (cadr what)))                  (objects (cadr what)))
741              (incf printed-bytes bytes)              (incf printed-bytes bytes)
742              (incf printed-objects objects)              (incf printed-objects objects)
743              (format t "  ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)              (format t _"  ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)
744                      bytes objects)))                      bytes objects)))
745    
746          (let ((residual-objects (- total-objects printed-objects))          (let ((residual-objects (- total-objects printed-objects))
747                (residual-bytes (- total-bytes printed-bytes)))                (residual-bytes (- total-bytes printed-bytes)))
748            (unless (zerop residual-objects)            (unless (zerop residual-objects)
749              (format t "  Other types: ~:D bytes, ~D: object~:P.~%"              (format t _"  Other types: ~:D bytes, ~D: object~:P.~%"
750                      residual-bytes residual-objects))))                      residual-bytes residual-objects))))
751    
752        (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"        (format t _"  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
753                space total-bytes total-objects)))                space total-bytes total-objects)))
754    
755    (values))    (values))
# Line 759  Line 759 
759  ;;;  ;;;
760  (defun find-holes (&rest spaces)  (defun find-holes (&rest spaces)
761    (dolist (space (or spaces '(:read-only :static :dynamic)))    (dolist (space (or spaces '(:read-only :static :dynamic)))
762      (format t "In ~A space:~%" space)      (format t _"In ~A space:~%" space)
763      (let ((start-addr nil)      (let ((start-addr nil)
764            (total-bytes 0))            (total-bytes 0))
765        (declare (type (or null (unsigned-byte 32)) start-addr)        (declare (type (or null (unsigned-byte 32)) start-addr)
# Line 776  Line 776 
776                     (setf start-addr (di::get-lisp-obj-address object)                     (setf start-addr (di::get-lisp-obj-address object)
777                           total-bytes bytes))                           total-bytes bytes))
778                 (when start-addr                 (when start-addr
779                   (format t "~D bytes at #x~X~%" total-bytes start-addr)                   (format t _"~D bytes at #x~X~%" total-bytes start-addr)
780                   (setf start-addr nil))))                   (setf start-addr nil))))
781         space)         space)
782        (when start-addr        (when start-addr
783          (format t "~D bytes at #x~X~%" total-bytes start-addr))))          (format t _"~D bytes at #x~X~%" total-bytes start-addr))))
784    (values))    (values))
785    
786    
# Line 973  Line 973 
973                                        (c::debug-source-name source)                                        (c::debug-source-name source)
974                                        "FROM LISP")))                                        "FROM LISP")))
975                                 (t                                 (t
976                                  (warn "No source for ~S" obj)                                  (warn _"No source for ~S" obj)
977                                  "NO SOURCE")))                                  "NO SOURCE")))
978                         "UNKNOWN"))                         "UNKNOWN"))
979                    (file-info (or (gethash file pkg-info)                    (file-info (or (gethash file pkg-info)
# Line 998  Line 998 
998    
999        (loop for (pkg (pkg-count . pkg-size) . files) in        (loop for (pkg (pkg-count . pkg-size) . files) in
1000              (sort res #'> :key #'(lambda (x) (cdr (second x)))) do              (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
1001          (format t "~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"          (format t _"~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"
1002                  pkg pkg-size pkg-count)                  pkg pkg-size pkg-count)
1003          (when (eq how :file)          (when (eq how :file)
1004            (loop for (file (file-count . file-size)) in            (loop for (file (file-count . file-size)) in
1005                  (sort files #'> :key #'(lambda (x) (cdr (second x)))) do                  (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
1006              (format t "~30@A: ~9:D bytes, ~9:D object~:P.~%"              (format t _"~30@A: ~9:D bytes, ~9:D object~:P.~%"
1007                      (file-namestring file) file-size file-count))))))                      (file-namestring file) file-size file-count))))))
1008    
1009    (values))    (values))
# Line 1046  Line 1046 
1046  #+nil  #+nil
1047  (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)  (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
1048                                 (function #'identity))                                 (function #'identity))
1049    "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
1050    the value to plot when applied to the hashtable values."    the value to plot when applied to the hashtable values."
1051    (let ((function (if (eval:interpreted-function-p function)    (let ((function (if (eval:interpreted-function-p function)
1052                        (compile nil function)                        (compile nil function)
# Line 1056  Line 1056 
1056          (hist:hist-record (funcall function count))))))          (hist:hist-record (funcall function count))))))
1057    
1058  (defun report-top-n (table &key (top-n 20) (function #'identity))  (defun report-top-n (table &key (top-n 20) (function #'identity))
1059    "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
1060    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."
1061    (let ((function (if (eval:interpreted-function-p function)    (let ((function (if (eval:interpreted-function-p function)
1062                        (compile nil function)                        (compile nil function)
# Line 1080  Line 1080 
1080    
1081          (let ((residual (- (total-val) printed)))          (let ((residual (- (total-val) printed)))
1082            (unless (zerop residual)            (unless (zerop residual)
1083              (format t "~8:D: Other~%" residual))))              (format t _"~8:D: Other~%" residual))))
1084    
1085        (format t "~8:D: Total~%" (total-val))))        (format t _"~8:D: Total~%" (total-val))))
1086    (values))    (values))
1087    
1088    
# Line 1107  Line 1107 
1107    
1108    
1109  (defun find-caller-counts (space)  (defun find-caller-counts (space)
1110    "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
1111    Space to the number of times such a call appears."    Space to the number of times such a call appears."
1112    (let ((counts (make-hash-table :test #'eq)))    (let ((counts (make-hash-table :test #'eq)))
1113      (map-allocated-objects      (map-allocated-objects
# Line 1122  Line 1122 
1122      counts))      counts))
1123    
1124  (defun find-high-callers (space &key (above 10) table (threshold 2))  (defun find-high-callers (space &key (above 10) table (threshold 2))
1125    "Return a hashtable translating code objects to function constant counts for    _N"Return a hashtable translating code objects to function constant counts for
1126    all code objects in Space with more than Above function constants."    all code objects in Space with more than Above function constants."
1127    (let ((counts (make-hash-table :test #'eq)))    (let ((counts (make-hash-table :test #'eq)))
1128      (map-allocated-objects      (map-allocated-objects

Legend:
Removed from v.1.37.10.1  
changed lines
  Added in v.1.37.10.2

  ViewVC Help
Powered by ViewVC 1.1.5