Changeset 13174


Ignore:
Timestamp:
Nov 6, 2009, 10:18:51 PM (10 years ago)
Author:
gz
Message:

heap utilization tweaks:

Changed %MAP-AREAS to take an area or list of areas, rather than min/max area codes. Make it accept symbolic area names as well.

Made HEAP-UTILIZATION accept some new keyword args:

  • :AREA can be used to restrict the area or areas walked, as in %map-areas.
  • :CLASSES, if true, causes it to classify objects by actual class rather than typecode.
  • :SORT specifies the order in which to print results, default is by name
  • :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.

Added COLLECT-HEAP-UTILIZATION, which returns a list of (type count logical-size physical-size) instead of printing anything.

Location:
trunk/source
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/l0-utils.lisp

    r13067 r13174  
    2727
    2828
     29(defun heap-area-name (code)
     30  (cond ((eq code area-void) :void)
     31        ((eq code area-cstack) :cstack)
     32        ((eq code area-vstack) :vstack)
     33        ((eq code area-tstack) :tstack)
     34        ((eq code area-readonly) :readonly)
     35        ((eq code area-watched) :watched)
     36        ((eq code area-managed-static) :managed-static)
     37        ((eq code area-static) :static)
     38        ((eq code area-dynamic) :dynamic)
     39        (t code)))
     40
     41(defun heap-area-code (name)
     42  (case name
     43    (:void area-void)
     44    (:cstack area-cstack)
     45    (:vstack area-vstack)
     46    (:tstack area-tstack)
     47    (:readonly area-readonly)
     48    (:watched area-watched)
     49    (:managed-static area-managed-static)
     50    (:static area-static)
     51    (:dynamic area-dynamic)
     52    (t (if (and (fixnump name)
     53                (<= area-readonly name area-dynamic))
     54         name
     55         (heap-area-code (require-type name '(member :void :cstack :vstack :tstack
     56                                                     :readonly :managed-static :static :dynamic)))))))
     57
    2958
    3059;;; We MAY need a scheme for finding all of the areas in a lisp library.
    31 (defun %map-areas (function &optional (maxcode area-dynamic) (mincode area-readonly))
     60(defun %map-areas (function &optional area)
     61  (let* ((area (cond ((or (eq area t) (eq area nil)) nil)
     62                     ((consp area) (mapcar #'heap-area-code area)) ;; list of areas
     63                     (t (heap-area-code area))))
     64         (mincode area-readonly)
     65         (maxcode area-dynamic))
    3266  (declare (fixnum maxcode mincode))
    3367  (do* ((a (%normalize-areas) (%lisp-word-ref a (ash target::area.succ (- target::fixnumshift))))
     
    3771    (declare (fixnum code))
    3872    (if (and (<= code maxcode)
    39              (>= code mincode))
     73             (>= code mincode)
     74             (or (null area)
     75                 (eql code area)
     76                 (and (consp area) (member code area))))
    4077      (if dynamic
    4178        (walk-dynamic-area a function)
    4279        (unless (= code area-dynamic)        ; ignore egc areas, 'cause walk-dynamic-area sees them.
    43           (walk-static-area a function))))))
     80          (walk-static-area a function)))))))
    4481
    4582
     
    5289                                   (funcall f (lfun-vector-lfun obj))))))
    5390    (declare (dynamic-extent filter))
    54     (%map-areas filter area-dynamic area-managed-static)))
     91    (%map-areas filter '(:dynamic :static :managed-static))))
    5592
    5693
  • trunk/source/level-1/x86-trap-support.lisp

    r13067 r13174  
    456456                                               (when (eq object x)
    457457                                                 (return-from watchedp t)))
    458                                            area-watched area-watched)))
     458                                           area-watched)))
    459459                        (let ((result nil))
    460460                          (with-other-threads-suspended
  • trunk/source/lib/ccl-export-syms.lisp

    r13067 r13174  
    707707     ;; Miscellany
    708708     heap-utilization
     709     collect-heap-utilization
    709710
    710711     external-process-creation-failure
  • trunk/source/lib/misc.lisp

    r13067 r13174  
    891891
    892892(defun heap-utilization (&key (stream *debug-io*)
    893                               (gc-first t))
     893                              (gc-first t)
     894                              (area nil)
     895                              (unit nil)
     896                              (sort :size)
     897                              (classes nil))
     898  "Show statistic about types of objects in the heap.
     899   If :GC-FIRST is true (the default), do a full gc before scanning the heap.
     900   :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size.
     901   :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.
     902   :AREA can be used to restrict the walk to one area or a list of areas.  Some possible
     903   values are :DYNAMIC, :STATIC, :MANAGED-STATIC, :READONLY.  By default, all areas
     904   (including stacks) are examined.
     905   If :CLASSES is true, classifies by class rather than just typecode"
     906  (let ((data (collect-heap-utilization :gc-first gc-first :area area :classes classes)))
     907    (report-heap-utilization data :stream stream :unit unit :sort sort)))
     908
     909(defun collect-heap-utilization (&key (gc-first t) area classes)
     910  ;; returns list of (type-name count logical-sizes-total physical-sizes-total)
     911  (if classes
     912    (collect-heap-utilization-by-class gc-first area)
     913    (collect-heap-utilization-by-typecode gc-first area)))
     914
     915(defun collect-heap-utilization-by-typecode (gc-first area)
    894916  (let* ((nconses 0)
    895          (nvectors (make-array 256))
    896          (vector-sizes (make-array 256))
    897          (vector-physical-sizes (make-array 256))
     917         (counts (make-array 257))
     918         (sizes (make-array 257))
     919         (physical-sizes (make-array 257))
    898920         (array-size-function (arch::target-array-data-size-function
    899921                               (backend-target-arch *host-backend*))))
    900     (declare (type (simple-vector 256) nvectors vector-sizes)
    901              (dynamic-extent nvectors vector-sizes vector-physical-sizes))
    902     (when gc-first (gc))
    903     (%map-areas (lambda (thing)
    904                   (if (listp thing)
    905                     (incf nconses)
    906                     (let* ((typecode (typecode thing))
    907                            (logsize (funcall array-size-function typecode (uvsize thing))))
    908                       (incf (aref nvectors typecode))
    909                       (incf (aref vector-sizes typecode) logsize)
    910                       (incf (aref vector-physical-sizes typecode)
    911                             (logandc2 (+ logsize
    912                                          #+64-bit-target (+ 8 15)
    913                                          #+32-bit-target (+ 4 7))
    914                                       #+64-bit-target 15
    915                                       #+32-bit-target 7))))))
    916                                          
    917     (report-heap-utilization stream nconses nvectors vector-sizes vector-physical-sizes)
    918     (values)))
     922    (declare (type (simple-vector 257) counts sizes physical-sizes)
     923             (fixnum nconses)
     924             (dynamic-extent counts sizes physical-sizes))
     925    (flet ((collect (thing)
     926             (if (listp thing)
     927               (incf nconses)
     928               (let* ((typecode (typecode thing))
     929                      (logsize (funcall array-size-function typecode (uvsize thing)))
     930                      (physize (logandc2 (+ logsize
     931                                            #+64-bit-target (+ 8 15)
     932                                            #+32-bit-target (+ 4 7))
     933                                         #+64-bit-target 15
     934                                         #+32-bit-target 7)))
     935                 (incf (aref counts typecode))
     936                 (incf (aref sizes typecode) logsize)
     937                 (incf (aref physical-sizes typecode) physize)))))
     938      (declare (dynamic-extent #'collect))
     939      (when gc-first (gc))
     940      (%map-areas #'collect area))
     941    (setf (aref counts 256) nconses)
     942    (setf (aref sizes 256) (* nconses target::cons.size))
     943    (setf (aref physical-sizes 256) (aref sizes 256))
     944    (loop for i from 0 upto 256
     945      when (plusp (aref counts i))
     946      collect (list (if (eql i 256) 'cons (aref *heap-utilization-vector-type-names* i))
     947                    (aref counts i)
     948                    (aref sizes i)
     949                    (aref physical-sizes i)))))
     950
     951(defun collect-heap-utilization-by-class (gc-first area)
     952  (let* ((nconses 0)
     953         (max-classes (+ 100 (hash-table-count %find-classes%)))
     954         (map (make-hash-table :shared nil
     955                               :test 'eq
     956                               :size max-classes))
     957         (inst-counts (make-array max-classes :initial-element 0))
     958         (slotv-counts (make-array max-classes :initial-element 0))
     959         (inst-sizes (make-array max-classes :initial-element 0))
     960         (slotv-sizes (make-array max-classes :initial-element 0))
     961         (inst-psizes (make-array max-classes :initial-element 0))
     962         (slotv-psizes (make-array max-classes :initial-element 0))
     963         (overflow nil)
     964         (array-size-function (arch::target-array-data-size-function
     965                               (backend-target-arch *host-backend*))))
     966    (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes))
     967    (flet ((collect (thing)
     968             (if (listp thing)
     969               (incf nconses)
     970               (unless (or (eq thing map)
     971                           (eq thing (nhash.vector map))
     972                           (eq thing inst-counts)
     973                           (eq thing slotv-counts)
     974                           (eq thing inst-sizes)
     975                           (eq thing slotv-sizes)
     976                           (eq thing inst-psizes)
     977                           (eq thing slotv-psizes))
     978                 (let* ((typecode (typecode thing))
     979                        (logsize (funcall array-size-function typecode (uvsize thing)))
     980                        (physize (logandc2 (+ logsize
     981                                              #+64-bit-target (+ 8 15)
     982                                              #+32-bit-target (+ 4 7))
     983                                           #+64-bit-target 15
     984                                           #+32-bit-target 7))
     985                        (class (class-of (if (eql typecode target::subtag-slot-vector)
     986                                           (uvref thing slot-vector.instance)
     987                                           thing)))
     988                        (index (or (gethash class map)
     989                                   (let ((count (hash-table-count map)))
     990                                     (if (eql count max-classes)
     991                                       (setq overflow t count (1- max-classes))
     992                                       (setf (gethash class map) count))))))
     993                   
     994                   (if (eql typecode target::subtag-slot-vector)
     995                     (progn
     996                       (incf (aref slotv-counts index))
     997                       (incf (aref slotv-sizes index) logsize)
     998                       (incf (aref slotv-psizes index) physize))
     999                     (progn
     1000                       (incf (aref inst-counts index))
     1001                       (incf (aref inst-sizes index) logsize)
     1002                       (incf (aref inst-psizes index) physize))))))))
     1003      (declare (dynamic-extent #'collect))
     1004      (when gc-first (gc))
     1005      (%map-areas #'collect area))
     1006    (let ((data ()))
     1007      (when (plusp nconses)
     1008        (push (list 'cons nconses (* nconses target::cons.size) (* nconses target::cons.size)) data))
     1009      (maphash (lambda (class index)
     1010                 (let* ((icount (aref inst-counts index))
     1011                        (scount (aref slotv-counts index))
     1012                        (name (if (and overflow (eql index (1- max-classes)))
     1013                                "All others"
     1014                                (or (%class-proper-name class) class))))
     1015                   (declare (fixnum icount) (fixnum scount))
     1016                   ;; When printing class names, the package matters.  report-heap-utilization
     1017                   ;; uses ~a, so print here.
     1018                   (when (plusp icount)
     1019                     (push (list (prin1-to-string name)
     1020                                 icount (aref inst-sizes index) (aref inst-psizes index)) data))
     1021                   (when (plusp scount)
     1022                     (push (list (format nil "(SLOT-VECTOR ~s)" name)
     1023                                 scount (aref slotv-sizes index) (aref slotv-psizes index)) data))))
     1024               map)
     1025      data)))
    9191026
    9201027(defvar *heap-utilization-vector-type-names*
     
    9611068
    9621069 
    963    
    964 (defun report-heap-utilization (out nconses nvectors vector-sizes vector-physical-sizes)
    965   (let* ((total-cons-size  (* nconses target::cons.size))
    966          (total-vector-size 0)
    967          (total-physical-vector-size 0)
    968          (total-size 0))
    969     (format out "~&Object type~42tCount~50tTotal Size in Bytes~72tTotal Size~82t % of Heap")
    970     (dotimes( i (length nvectors))
    971       (incf total-vector-size (aref vector-sizes i))
    972       (incf total-physical-vector-size (aref vector-physical-sizes i)))
    973     (setq total-size (+ total-cons-size total-physical-vector-size))
    974     (unless (zerop nconses)
    975       (format out "~&CONS~36t~12d~48t~16d~16d~8,2f%" nconses total-cons-size total-cons-size
    976               (* 100 (/ total-cons-size total-size))))
    977     (dotimes (i (length nvectors))
    978       (let ((count (aref nvectors i))
    979             (sizes (aref vector-sizes i))
    980             (psizes (aref vector-physical-sizes i)))
    981         (unless (zerop count)
    982           (format out "~&~a~36t~12d~48t~16d~16d~8,2f%"
    983                   (aref *heap-utilization-vector-type-names* i)
    984                   count sizes psizes
    985                   (* 100.0 (/ psizes total-size))))))
    986     (format out "~&   Total sizes: ~49t~16d~16d" (+ total-cons-size total-vector-size) (+ total-cons-size total-physical-vector-size))))
     1070(defun report-heap-utilization (data &key stream unit sort)
     1071  (let* ((div (ecase unit
     1072                ((nil) 1)
     1073                (:kb 1024.0d0)
     1074                (:mb (* 1024.0d0 1024.0d0))
     1075                (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
     1076         (sort-key (ecase sort
     1077                     (:count #'cadr)
     1078                     (:logical-size #'caddr)
     1079                     ((:physical-size :size) #'cadddr)
     1080                     ((:name nil) nil)))
     1081         (total-count 0)
     1082         (total-lsize 0)
     1083         (total-psize 0)
     1084         (max-name 0))
     1085    (loop for (name count lsize psize) in data
     1086      do (incf total-count count)
     1087      do (incf total-lsize lsize)
     1088      do (incf total-psize psize)
     1089      do (setq max-name (max max-name
     1090                             (length (if (stringp name)
     1091                                       name
     1092                                       (if (symbolp name)
     1093                                         (symbol-name name)
     1094                                         (princ-to-string name)))))))
     1095    (setq data
     1096          (if sort-key
     1097            (sort data #'> :key sort-key)
     1098            (sort data #'string-lessp :key #'(lambda (name)
     1099                                               (if (stringp name)
     1100                                                 name
     1101                                                 (if (symbolp name)
     1102                                                   (symbol-name name)
     1103                                                   (princ-to-string name)))))))
     1104                                                   
     1105    (format stream "~&Object type~vtCount     Logical size   Physical size   % of Heap~%~vt ~a~vt ~2:*~a"
     1106            (+ max-name 7)
     1107            (+ max-name 15)
     1108            (ecase unit
     1109              ((nil) "  (in bytes)")
     1110              (:kb   "(in kilobytes)")
     1111              (:mb   "(in megabytes)")
     1112              (:gb   "(in gigabytes)"))
     1113            (+ max-name 31))
     1114    (loop for (type count logsize physsize) in data
     1115      do (if unit
     1116           (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%"
     1117                   type
     1118                   (1+ max-name)
     1119                   count
     1120                   (/ logsize div)
     1121                   (/ physsize div)
     1122                   (* 100.0 (/ physsize total-psize)))
     1123           (format stream "~&~a~vt~11d~16d~16d~11,2f%"
     1124                   type
     1125                   (1+ max-name)
     1126                   count
     1127                   logsize
     1128                   physsize
     1129                   (* 100.0 (/ physsize total-psize)))))
     1130    (if unit
     1131      (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%"
     1132              "Total"
     1133              (1+ max-name)
     1134              total-count
     1135              (/ total-lsize div)
     1136              (/ total-psize div)
     1137              100.0d0)
     1138      (format stream "~&~a~vt~11d~16d~16d~11,2f%"
     1139              "Total"
     1140              (1+ max-name)
     1141              total-count
     1142              total-lsize
     1143              total-psize
     1144              100.0d0)))
     1145  (values))
    9871146
    9881147;; The number of words to allocate for static conses when the user requests
     
    10561215  (let (result)
    10571216    (with-other-threads-suspended
    1058       (%map-areas #'(lambda (x) (push x result)) area-watched area-watched))
     1217      (%map-areas #'(lambda (x) (push x result)) area-watched))
    10591218    result))
    10601219
     
    10841243                                   (cons nil nil))))
    10851244                        (return-from unwatch (%unwatch thing new)))))
    1086                 area-watched area-watched)))
     1245                area-watched)))
  • trunk/source/library/chud-metering.lisp

    r13067 r13174  
    141141                             (functions (ccl::function-vector-to-function o))))
    142142                         ccl::area-dynamic
    143                          ccl::area-dynamic
    144143                         )))
    145144    (functions)))
     
    156155                           (when (typep o 'function)
    157156                             (functions o)))
    158                          ccl::area-dynamic
    159157                         ccl::area-dynamic
    160158                         )))
  • trunk/source/library/core-files.lisp

    r13167 r13174  
    269269     (- target::fulltag-symbol target::fulltag-nil)))
    270270
    271 (defun gc-area-name (code)
    272   (cond ((eq code area-void) :void)
    273         ((eq code area-cstack) :cstack)
    274         ((eq code area-vstack) :vstack)
    275         ((eq code area-tstack) :tstack)
    276         ((eq code area-readonly) :readonly)
    277         ((eq code area-watched) :watched)
    278         ((eq code area-managed-static) :managed-static)
    279         ((eq code area-static) :static)
    280         ((eq code area-dynamic) :dynamic)
    281         ((eql 0 (logand code (1- (ash 1 target::fixnum-shift))))
    282          (gc-area-name (ash code (- target::fixnum-shift))))
    283         (t code)))
    284 
    285 (defun gc-area-code (name)
    286   (case name
    287     (:void area-void)
    288     (:cstack area-cstack)
    289     (:vstack area-vstack)
    290     (:tstack area-tstack)
    291     (:readonly area-readonly)
    292     (:watched area-watched)
    293     (:managed-static area-managed-static)
    294     (:static area-static)
    295     (:dynamic area-dynamic)
    296     (t (if (and (fixnump name)
    297                 (<= area-readonly name area-dynamic))
    298          name
    299          (gc-area-code (require-type name '(member :void :cstack :vstack :tstack :readonly :managed-static :static :dynamic)))))))
    300 
     271(defun core-area-name (code)
     272  (or (heap-area-name code)
     273      (and (integerp code)
     274           (not (logtest code (1- (ash 1 target::fixnum-shift))))
     275           (heap-area-name (ash code (- target::fixnum-shift))))))
    301276
    302277(defx86lapfunction %%raw-obj ((address arg_z))
     
    359334(defun map-core-areas (function &key area)
    360335  (setq area (cond ((or (eq area t) (eq area nil)) nil)
    361                    ((consp area) (mapcar #'gc-area-code area))
    362                    (t (list (gc-area-code area)))))
     336                   ((consp area) (mapcar #'heap-area-code area))
     337                   (t (list (heap-area-code area)))))
    363338  (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
    364339          then (core-q area-ptr target::area.succ)
     
    371346             #+debug
    372347             (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
    373                      area-ptr (gc-area-name code)
     348                     area-ptr (core-area-name code)
    374349                     (core-q area-ptr target::area.low)
    375350                     (core-q area-ptr target::area.active)
  • trunk/source/library/elf.lisp

    r13067 r13174  
    194194                                   #-x8664-target 'function)
    195195                        (functions (function-vector-to-function o))))
    196                     ccl::area-dynamic
    197196                    ccl::area-dynamic
    198197                    )))
Note: See TracChangeset for help on using the changeset viewer.