Changeset 13208

Timestamp:

Nov 17, 2009, 8:07:02 AM (15 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:

• lib/misc.lisp (modified) (5 diffs)
• library/leaks.lisp (modified) (1 diff)

branches/working-0711/ccl/lib/misc.lisp

@@ -895 +895 @@
                               (unit nil)
                               (sort :size)
-                              (classes nil))
+                              (classes nil)
+                              (start nil))
   "Show statistic about types of objects in the heap.
    If :GC-FIRST is true (the default), do a full gc before scanning the heap.
+   If :START is non-nil, it should be an object returned by GET-ALLOCATION-SENTINEL, only
+     objects at higher address are scanned (i.e. roughly, only objects allocated after it).
    :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size.
    :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.
@@ -904 +907 @@
    (including stacks) are examined.
    If :CLASSES is true, classifies by class rather than just typecode"
-  (let ((data (collect-heap-utilization :gc-first gc-first :area area :classes classes)))
+  (let ((data (collect-heap-utilization :gc-first gc-first :start start :area area :classes classes)))
     (report-heap-utilization data :stream stream :unit unit :sort sort)))
 
-(defun collect-heap-utilization (&key (gc-first t) area classes)
+(defun collect-heap-utilization (&key (gc-first t) start area classes)
   ;; returns list of (type-name count logical-sizes-total physical-sizes-total)
+  (when start
+    (unless (or (null area)
+                (eq (heap-area-code area) area-dynamic)
+                (and (consp area) (every (lambda (a) (eq (heap-area-code a) area-dynamic)) area)))
+      (error "~s ~s and ~s ~s are incompatible" :start start :area area))
+    (setq area area-dynamic))
   (if classes
-    (collect-heap-utilization-by-class gc-first area)
-    (collect-heap-utilization-by-typecode gc-first area)))
-
-(defun collect-heap-utilization-by-typecode (gc-first area)
+    (collect-heap-utilization-by-class gc-first area start)
+    (collect-heap-utilization-by-typecode gc-first area start)))
+
+(defun collect-heap-utilization-by-typecode (gc-first area start)
   (let* ((nconses 0)
          (counts (make-array 257))
@@ -924 +933 @@
              (dynamic-extent counts sizes physical-sizes))
     (flet ((collect (thing)
-             (if (listp thing)
-               (incf nconses)
-               (let* ((typecode (typecode thing))
-                      (logsize (funcall array-size-function typecode (uvsize thing)))
-                      (physize (logandc2 (+ logsize
-                                            #+64-bit-target (+ 8 15)
-                                            #+32-bit-target (+ 4 7))
-                                         #+64-bit-target 15
-                                         #+32-bit-target 7)))
-                 (incf (aref counts typecode))
-                 (incf (aref sizes typecode) logsize)
-                 (incf (aref physical-sizes typecode) physize)))))
+             (when (or (null start)
+                       (locally (declare (optimize (speed 3) (safety 0))) ;; lie
+                         (%i< start thing)))
+               (if (listp thing)
+                 (incf nconses)
+                 (let* ((typecode (typecode thing))
+                        (logsize (funcall array-size-function typecode (uvsize thing)))
+                        (physize (logandc2 (+ logsize
+                                              #+64-bit-target (+ 8 15)
+                                              #+32-bit-target (+ 4 7))
+                                           #+64-bit-target 15
+                                           #+32-bit-target 7)))
+                   (incf (aref counts typecode))
+                   (incf (aref sizes typecode) logsize)
+                   (incf (aref physical-sizes typecode) physize))))))
       (declare (dynamic-extent #'collect))
       (when gc-first (gc))
@@ -949 +961 @@
                     (aref physical-sizes i)))))
 
-(defun collect-heap-utilization-by-class (gc-first area)
+(defun collect-heap-utilization-by-class (gc-first area start)
   (let* ((nconses 0)
          (max-classes (+ 100 (hash-table-count %find-classes%)))
@@ -966 +978 @@
     (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes))
     (flet ((collect (thing)
-             (if (listp thing)
-               (incf nconses)
-               (unless (or (eq thing map)
-                           (eq thing (nhash.vector map))
-                           (eq thing inst-counts)
-                           (eq thing slotv-counts)
-                           (eq thing inst-sizes)
-                           (eq thing slotv-sizes)
-                           (eq thing inst-psizes)
-                           (eq thing slotv-psizes))
-                 (let* ((typecode (typecode thing))
-                        (logsize (funcall array-size-function typecode (uvsize thing)))
-                        (physize (logandc2 (+ logsize
-                                              #+64-bit-target (+ 8 15)
-                                              #+32-bit-target (+ 4 7))
-                                           #+64-bit-target 15
-                                           #+32-bit-target 7))
-                        (class (class-of (if (eql typecode target::subtag-slot-vector)
-                                           (uvref thing slot-vector.instance)
-                                           thing)))
-                        (index (or (gethash class map)
-                                   (let ((count (hash-table-count map)))
-                                     (if (eql count max-classes)
-                                       (setq overflow t count (1- max-classes))
-                                       (setf (gethash class map) count))))))
+             (when (or (null start)
+                       (locally (declare (optimize (speed 3) (safety 0))) ;; lie
+                         (%i< start thing)))
+               (if (listp thing)
+                 (incf nconses)
+                 (unless (or (eq thing map)
+                             (eq thing (nhash.vector map))
+                             (eq thing inst-counts)
+                             (eq thing slotv-counts)
+                             (eq thing inst-sizes)
+                             (eq thing slotv-sizes)
+                             (eq thing inst-psizes)
+                             (eq thing slotv-psizes))
+                   (let* ((typecode (typecode thing))
+                          (logsize (funcall array-size-function typecode (uvsize thing)))
+                          (physize (logandc2 (+ logsize
+                                                #+64-bit-target (+ 8 15)
+                                                #+32-bit-target (+ 4 7))
+                                             #+64-bit-target 15
+                                             #+32-bit-target 7))
+                          (class (class-of (if (eql typecode target::subtag-slot-vector)
+                                             (uvref thing slot-vector.instance)
+                                             thing)))
+                          (index (or (gethash class map)
+                                     (let ((count (hash-table-count map)))
+                                       (if (eql count max-classes)
+                                         (setq overflow t count (1- max-classes))
+                                         (setf (gethash class map) count))))))
                    
-                   (if (eql typecode target::subtag-slot-vector)
-                     (progn
-                       (incf (aref slotv-counts index))
-                       (incf (aref slotv-sizes index) logsize)
-                       (incf (aref slotv-psizes index) physize))
-                     (progn
-                       (incf (aref inst-counts index))
-                       (incf (aref inst-sizes index) logsize)
-                       (incf (aref inst-psizes index) physize))))))))
+                     (if (eql typecode target::subtag-slot-vector)
+                       (progn
+                         (incf (aref slotv-counts index))
+                         (incf (aref slotv-sizes index) logsize)
+                         (incf (aref slotv-psizes index) physize))
+                       (progn
+                         (incf (aref inst-counts index))
+                         (incf (aref inst-sizes index) logsize)
+                         (incf (aref inst-psizes index) physize)))))))))
       (declare (dynamic-extent #'collect))
       (when gc-first (gc))

branches/working-0711/ccl/library/leaks.lisp

@@ -327 +327 @@
 
 )  ;; end of linux-only code
+
+(defun get-allocation-sentinel (&key (gc-first t))
+  ;; Return the object with the highest address that can be guaranteed to be at a lower
+  ;; address than any newer objects.
+  ;; If gc-first is true, can also conversely guarantee that all older objects are at a
+  ;; lower address than the sentinel.  If gc-first is false, than there may be some
+  ;; already-allocated objects at higher addresses, though no more than the size of the
+  ;; youngest generation (and usually even less than that). Second value returned is the
+  ;; size of the active region above the sentinel.
+  (with-other-threads-suspended
+    (when gc-first (gc)) ;; get rid of thread allocation chunks.  Wish could just egc...
+    ;; This mustn't cons.
+    (let* ((first-area (%normalize-areas)) ;; youngest generation
+           (min-base (loop with current = (%current-tcr)
+                           for tcr = (%fixnum-ref current target::tcr.next)
+                             then (%fixnum-ref tcr target::tcr.next)
+                           as base fixnum = (%fixnum-ref tcr target::tcr.save-allocbase)
+                           when (> base 0)
+                             minimize base
+                           until (eql tcr current)))
+           (active (%fixnum-ref first-area  target::area.active))
+           (limit (if (eql min-base 0) active min-base))
+           (last-obj nil))
+      ;; Normally will find it in the youngest generation, but loop in case limit = area.low.
+      (block walk
+        (flet ((skip (obj)
+                 (declare (optimize (speed 3) (safety 0))) ;; lie
+                 (unless (%i< obj limit)
+                   (return-from walk))
+                 (setq last-obj obj)))
+          (declare (dynamic-extent #'skip))
+          (loop for area = first-area then (%fixnum-ref area target::area.succ)
+                until (neq (%fixnum-ref area target::area.code) area-dynamic)
+                when (< (%fixnum-ref area target::area.low) (%fixnum-ref area target::area.active))
+                  do (walk-static-area area #'skip))))
+      (values last-obj (%i- active limit)))))
+