Changeset 13208


Ignore:
Timestamp:
Nov 17, 2009, 4:07:02 PM (10 years ago)
Author:
gz
Message:

Added a new function GET-ALLOCATION-SENTINEL and a new :START arg to
HEAP-UTILIZATION. get-allocation-sentinel returns an object which can
be passed as the :start arg to heap-utilization, in which case
heap-utilization will only scan objects allocated after the call to
get-allocation-sentinel. I.e.

(let ((sentinel (get-allocation-sentinel)))

(do-things)
(heap-utilization :start sentinel))

will show a breakdown of still-reachable objects allocated by (do-things).

Note that both get-allocation-sentinel and heap-utilization do a full
gc by default. They both take a gc-first arg that can be used to turn
that off. This will result in some fuzziness in the results, no larger
than the size of the youngest ephemeral generation, so is only useful
when the overall allocation is significantly larger than that.

Location:
branches/working-0711/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/misc.lisp

    r13179 r13208  
    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))
  • branches/working-0711/ccl/library/leaks.lisp

    r13197 r13208  
    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.