Changeset 13301 for trunk/source


Ignore:
Timestamp:
Dec 17, 2009, 2:02:57 PM (10 years ago)
Author:
gz
Message:

Merge r13208: extend heap-utilization to show allocation between two points in time

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source

  • trunk/source/lib/misc.lisp

    r13279 r13301  
    895895                              (unit nil)
    896896                              (sort :size)
    897                               (classes nil))
     897                              (classes nil)
     898                              (start nil))
    898899  "Show statistic about types of objects in the heap.
    899900   If :GC-FIRST is true (the default), do a full gc before scanning the heap.
     901   If :START is non-nil, it should be an object returned by GET-ALLOCATION-SENTINEL, only
     902     objects at higher address are scanned (i.e. roughly, only objects allocated after it).
    900903   :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size.
    901904   :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.
     
    904907   (including stacks) are examined.
    905908   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)))
     909  (let ((data (collect-heap-utilization :gc-first gc-first :start start :area area :classes classes)))
    907910    (report-heap-utilization data :stream stream :unit unit :sort sort)))
    908911
    909 (defun collect-heap-utilization (&key (gc-first t) area classes)
     912(defun collect-heap-utilization (&key (gc-first t) start area classes)
    910913  ;; returns list of (type-name count logical-sizes-total physical-sizes-total)
     914  (when start
     915    (unless (or (null area)
     916                (eq (heap-area-code area) area-dynamic)
     917                (and (consp area) (every (lambda (a) (eq (heap-area-code a) area-dynamic)) area)))
     918      (error "~s ~s and ~s ~s are incompatible" :start start :area area))
     919    (setq area area-dynamic))
    911920  (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)
     921    (collect-heap-utilization-by-class gc-first area start)
     922    (collect-heap-utilization-by-typecode gc-first area start)))
     923
     924(defun collect-heap-utilization-by-typecode (gc-first area start)
    916925  (let* ((nconses 0)
    917926         (counts (make-array 257))
     
    924933             (dynamic-extent counts sizes physical-sizes))
    925934    (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)))))
     935             (when (or (null start)
     936                       (locally (declare (optimize (speed 3) (safety 0))) ;; lie
     937                         (%i< start thing)))
     938               (if (listp thing)
     939                 (incf nconses)
     940                 (let* ((typecode (typecode thing))
     941                        (logsize (funcall array-size-function typecode (uvsize thing)))
     942                        (physize (logandc2 (+ logsize
     943                                              #+64-bit-target (+ 8 15)
     944                                              #+32-bit-target (+ 4 7))
     945                                           #+64-bit-target 15
     946                                           #+32-bit-target 7)))
     947                   (incf (aref counts typecode))
     948                   (incf (aref sizes typecode) logsize)
     949                   (incf (aref physical-sizes typecode) physize))))))
    938950      (declare (dynamic-extent #'collect))
    939951      (when gc-first (gc))
     
    949961                    (aref physical-sizes i)))))
    950962
    951 (defun collect-heap-utilization-by-class (gc-first area)
     963(defun collect-heap-utilization-by-class (gc-first area start)
    952964  (let* ((nconses 0)
    953965         (max-classes (+ 100 (hash-table-count %find-classes%)))
     
    966978    (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes))
    967979    (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))))))
     980             (when (or (null start)
     981                       (locally (declare (optimize (speed 3) (safety 0))) ;; lie
     982                         (%i< start thing)))
     983               (if (listp thing)
     984                 (incf nconses)
     985                 (unless (or (eq thing map)
     986                             (eq thing (nhash.vector map))
     987                             (eq thing inst-counts)
     988                             (eq thing slotv-counts)
     989                             (eq thing inst-sizes)
     990                             (eq thing slotv-sizes)
     991                             (eq thing inst-psizes)
     992                             (eq thing slotv-psizes))
     993                   (let* ((typecode (typecode thing))
     994                          (logsize (funcall array-size-function typecode (uvsize thing)))
     995                          (physize (logandc2 (+ logsize
     996                                                #+64-bit-target (+ 8 15)
     997                                                #+32-bit-target (+ 4 7))
     998                                             #+64-bit-target 15
     999                                             #+32-bit-target 7))
     1000                          (class (class-of (if (eql typecode target::subtag-slot-vector)
     1001                                             (uvref thing slot-vector.instance)
     1002                                             thing)))
     1003                          (index (or (gethash class map)
     1004                                     (let ((count (hash-table-count map)))
     1005                                       (if (eql count max-classes)
     1006                                         (setq overflow t count (1- max-classes))
     1007                                         (setf (gethash class map) count))))))
    9931008                   
    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))))))))
     1009                     (if (eql typecode target::subtag-slot-vector)
     1010                       (progn
     1011                         (incf (aref slotv-counts index))
     1012                         (incf (aref slotv-sizes index) logsize)
     1013                         (incf (aref slotv-psizes index) physize))
     1014                       (progn
     1015                         (incf (aref inst-counts index))
     1016                         (incf (aref inst-sizes index) logsize)
     1017                         (incf (aref inst-psizes index) physize)))))))))
    10031018      (declare (dynamic-extent #'collect))
    10041019      (when gc-first (gc))
  • trunk/source/library/leaks.lisp

    r13196 r13301  
    327327
    328328)  ;; end of linux-only code
     329
     330(defun get-allocation-sentinel (&key (gc-first t))
     331  ;; Return the object with the highest address that can be guaranteed to be at a lower
     332  ;; address than any newer objects.
     333  ;; If gc-first is true, can also conversely guarantee that all older objects are at a
     334  ;; lower address than the sentinel.  If gc-first is false, than there may be some
     335  ;; already-allocated objects at higher addresses, though no more than the size of the
     336  ;; youngest generation (and usually even less than that). Second value returned is the
     337  ;; size of the active region above the sentinel.
     338  (with-other-threads-suspended
     339    (when gc-first (gc)) ;; get rid of thread allocation chunks.  Wish could just egc...
     340    ;; This mustn't cons.
     341    (let* ((first-area (%normalize-areas)) ;; youngest generation
     342           (min-base (loop with current = (%current-tcr)
     343                           for tcr = (%fixnum-ref current target::tcr.next)
     344                             then (%fixnum-ref tcr target::tcr.next)
     345                           as base fixnum = (%fixnum-ref tcr target::tcr.save-allocbase)
     346                           when (> base 0)
     347                             minimize base
     348                           until (eql tcr current)))
     349           (active (%fixnum-ref first-area  target::area.active))
     350           (limit (if (eql min-base 0) active min-base))
     351           (last-obj nil))
     352      ;; Normally will find it in the youngest generation, but loop in case limit = area.low.
     353      (block walk
     354        (flet ((skip (obj)
     355                 (declare (optimize (speed 3) (safety 0))) ;; lie
     356                 (unless (%i< obj limit)
     357                   (return-from walk))
     358                 (setq last-obj obj)))
     359          (declare (dynamic-extent #'skip))
     360          (loop for area = first-area then (%fixnum-ref area target::area.succ)
     361                until (neq (%fixnum-ref area target::area.code) area-dynamic)
     362                when (< (%fixnum-ref area target::area.low) (%fixnum-ref area target::area.active))
     363                  do (walk-static-area area #'skip))))
     364      (values last-obj (%i- active limit)))))
     365
Note: See TracChangeset for help on using the changeset viewer.