Changeset 13544


Ignore:
Timestamp:
Mar 18, 2010, 1:25:42 PM (9 years ago)
Author:
gz
Message:

Extend parse-proc-maps to use /proc/smaps if present; other tweaks/cleanups prompted by documenting some of this stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/library/leaks.lisp

    r13485 r13544  
    1919
    2020(in-package :ccl)
     21
     22(export '(find-referencers
     23          transitive-referencers
     24          map-heap-objects
     25          #+linux-target parse-proc-maps
     26          #+linux-target proc-maps-diff
     27          ))
     28
     29(defun map-heap-objects (fn &key area)
     30  (flet ((mapper (thing)
     31           (when (eq (typecode thing) target::subtag-function)
     32             (setq thing (function-vector-to-function thing)))
     33           (when (eq (typecode thing) target::subtag-symbol)
     34             (setq thing (symvector->symptr thing)))
     35           (funcall fn thing)))
     36    (declare (dynamic-extent #'mapper))
     37    (%map-areas #'mapper area)))
    2138
    2239;; Returns all objects that satisfy predicate of one of the types in
     
    7289    res))
    7390
    74 ;; Returns all references to object.
    75 ;; Note that these can contain stack-consed objects that are dead.
    76 ;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objects
    77 (defun find-references (object)
     91;; Returns all heap references to object.  By default, includes
     92;; includes references from readonly, static and dynamic areas.
     93(defun find-referencers (object &optional area)
    7894  (let ((res nil))
    7995    (ccl::%map-areas
     
    89105              (when(or (eq object (car thing))
    90106                       (eq object (cdr thing)))
    91                 (push thing res))))))
     107                (push thing res)))))
     108     area)
    92109    res))
    93110
     
    95112(defun pointer-in-some-dynamic-area-p (p)
    96113 (block found
    97    (ccl::do-consing-areas (a)
     114   (do-gc-areas (a)
    98115     (when (eql (%fixnum-ref a target::area.code) ccl::area-dynamic)
    99116       (when (ccl::%ptr-in-area-p p a)
    100117         (return-from found t))))))
    101118
    102 ;; Find all transitive referencers to object-or-list. If as-object is
    103 ;; true, just start with object-or-list. If as-object is false, then if
    104 ;; object-or-list is a list, start with its elements, and ignore its
    105 ;; cons cells.
     119;; Find all transitive referencers to any object in the list
    106120;; Returns a hash table with the references as keys.
    107 (defun transitive-referencers (object-or-list &optional as-object)
    108   (let ((found (make-hash-table :test 'eq)))
    109     (cond ((or (atom object-or-list) as-object)
    110            (setf (gethash object-or-list found) t))
    111           (t (loop for cons on object-or-list
    112                    do
    113                 (setf (gethash cons found) t
    114                       (gethash (car cons) found) t))))
     121(defun transitive-referencers (list-of-objects &key area (verbose t))
     122  (let ((found (make-hash-table :test 'eq))
     123        (objects (if (atom list-of-objects) (list list-of-objects) list-of-objects)))
     124    (loop for cons on objects
     125          do (setf (gethash cons found) t
     126                   (gethash (car cons) found) t))
    115127    (ccl:gc)
    116     (format t "Searching") (finish-output)
     128    (when verbose (format t "Searching") (finish-output))
    117129    (loop
    118130      (let ((added-one nil))
    119         (format t " ~d" (hash-table-count found)) (finish-output)
     131        (when verbose (format t " ~d" (hash-table-count found)) (finish-output))
    120132        (ccl::%map-areas
    121133         (lambda (thing)
    122            (unless (or (not (pointer-in-some-dynamic-area-p thing))
    123                        (gethash thing found))
    124              (cond ((and (not (eq thing (ccl::nhash.vector found)))
    125                          (ccl::uvectorp thing)
    126                          (not (ccl::ivectorp thing))
    127                          (not (packagep thing)))
    128                     (dotimes (i (ccl::uvsize thing))
    129                       (let ((object (ccl::uvref thing i)))
    130                         (when (gethash object found)
    131                           (setf (gethash thing found) t
    132                                 added-one t)
    133                           (return)))))
    134                    ((and (consp thing)
    135                          (pointer-in-some-dynamic-area-p (car thing))
    136                          (pointer-in-some-dynamic-area-p (cdr thing)))
    137                     (when (or (gethash (car thing) found)
    138                               (gethash (cdr thing) found))
    139                       (setf (gethash thing found) t)))))))
     134           (unless (gethash thing found)
     135             (when (cond ((eq (typecode thing) target::subtag-function)
     136                          (lfunloop for object in (function-vector-to-function thing)
     137                            thereis (gethash object found)))
     138                         ((and (gvectorp thing)
     139                               (not (eq thing (ccl::nhash.vector found)))
     140                               (not (eq thing found))
     141                               (not (packagep thing)))
     142                          (dotimes (i (ccl::uvsize thing))
     143                            (when (gethash (%svref thing i) found) (return t))))
     144                         ((consp thing)
     145                          (or (gethash (%car thing) found)
     146                              (gethash (%cdr thing) found))))
     147               (setf (gethash thing found) t
     148                     added-one t)
     149               (when (eq (typecode thing) target::subtag-function)
     150                 (setf (gethash (function-vector-to-function thing) found) t))
     151               (when (eq (typecode thing) target::subtag-symbol)
     152                 (setf (gethash (symvector->symptr thing) found) t)))))
     153         area)
    140154        (unless added-one
    141155          (return))))
    142     (format t " done.~%") (finish-output)
     156    (when verbose (format t " done.~%") (finish-output))
    143157    ;; Eliminate any cons that is referenced by another cons.
    144158    ;; Also eliminate or replace objects that nobody will want to see.
    145     (let ((cons-refs (make-hash-table :test 'eq))
    146           (additions nil))
     159    (let ((cons-refs (make-hash-table :test 'eq)))
    147160      (loop for cons being the hash-keys of found
    148161            when (consp cons)
     
    154167      (loop for key being the hash-keys of found
    155168            when (or (and (consp key) (gethash key cons-refs))
    156                      (and (consp key) (eq (car key) 'ccl::%function-source-note))
    157                      (typep key 'ccl::hash-table-vector)
    158                      (when (and key
    159                                 (typep key
    160                                   #+x8664-target 'ccl::symbol-vector
    161                                   #-x8664-target 'symbol
    162                                   ))
    163                        (push (ccl::symvector->symptr key) additions)
    164                        t)
    165                      (when (typep key
    166                                   #+x8664-target 'ccl::function-vector
    167                                   #-x8664-target 'function
    168                                   )
    169                        (push (ccl::function-vector-to-function key) additions)
    170                        t))
     169                     (and (consp key) (eq (car key) '%function-source-note))
     170                     (typep key 'hash-table-vector)
     171                     (and (typep key 'slot-vector)
     172                          (gethash (slot-vector.instance key) found))
     173                     #+x8664-target (typep key 'symbol-vector)
     174                     #+x8664-target (typep key 'function-vector)
     175                     )
    171176              do
    172177              (remhash key found))
    173       (dolist (addition additions)
    174         (setf (gethash addition found) t))
    175       (remhash object-or-list found)
    176       (unless (or (atom object-or-list) as-object)
    177         (loop for cons on object-or-list
    178              do
    179              (remhash cons found)
    180              (remhash (car cons) found)))
    181       found)))
     178      (loop for cons on objects
     179            do
     180         (remhash cons found)
     181         (remhash (car cons) found)))
     182      found))
    182183
    183184;; One convenient way to print the hash table returned by transitive-referencers
     
    356357           (fordblks (pref info :mallinfo.fordblks))
    357358           (keepcost (pref info :mallinfo.keepcost)))
    358       (format t "~& arena size: ~d/#x~x" arena arena)
     359      (format t "~& arena size: ~d (#x~x)" arena arena)
    359360      (format t "~& number of unused chunks = ~d" ordblks)
    360361      (format t "~& number of mmap'ed chunks = ~d" hblks)
    361       (format t "~& total size of mmap'ed chunks = ~d/#x~x" hblkhd hblkhd)
    362       (format t "~& total size of malloc'ed chunks = ~d/#x~x" uordblks uordblks)
    363       (format t "~& total size of free chunks = ~d/#x~x" fordblks fordblks)
    364       (format t "~& size of releaseable chunk = ~d/#x~x" keepcost keepcost))))
     362      (format t "~& total size of mmap'ed chunks = ~d (#x~x)" hblkhd hblkhd)
     363      (format t "~& total size of malloc'ed chunks = ~d (#x~x)" uordblks uordblks)
     364      (format t "~& total size of free chunks = ~d (#x~x)" fordblks fordblks)
     365      (format t "~& size of releaseable chunk = ~d (#x~x)" keepcost keepcost))))
    365366
    366367
    367368
    368369;; Parse /proc/<pid>/maps
    369 
     370;; returns a list of (address perms name total-size clean-size dirty-size)
    370371(defun parse-proc-maps (&optional (pid (ccl::getpid)))
    371372  (let ((perm-cache ())
    372373        (name-cache ()))
    373     (with-open-file (s (format nil "/proc/~d/maps" pid))
    374       (loop for line = (read-line s nil) while line
    375             as low-end = (position #\- line)
    376             as high-end = (position #\space line :start (1+ low-end))
    377             as perms-end = (position #\space line :start (1+ high-end))
    378             as offset-end = (position #\space line :start (1+ perms-end))
    379             as device-end = (position #\space line :start (1+ offset-end))
    380             as inode-end = (position #\space line :start (1+ device-end))
    381             as name-start = (position #\space line :start inode-end :test-not #'eql)
    382             as low = (parse-integer line :start 0 :end low-end :radix 16)
    383             as high = (parse-integer line :start (1+ low-end) :end high-end :radix 16)
    384             as perms = (let ((p (subseq line (1+ high-end) perms-end)))
    385                          (or (find p perm-cache :test #'equal)
    386                              (car (setq perm-cache (cons p perm-cache)))))
    387             as name = (and name-start
    388                            (let ((f (subseq line name-start)))
    389                              (or (find f name-cache :test #'equal)
    390                                  (car (setq name-cache (cons f name-cache))))))
    391             collect (list low high perms name)))))
     374    (with-open-file (s (or (probe-file (format nil "/proc/~d/smaps" pid))
     375                           (format nil "/proc/~d/maps" pid)))
     376      (loop with current = nil
     377            for line = (read-line s nil) while line
     378            if (find #\- line)
     379              collect (let* ((low-end (position #\- line))
     380                             (high-end (position #\space line :start (1+ low-end)))
     381                             (perms-end (position #\space line :start (1+ high-end)))
     382                             (offset-end (position #\space line :start (1+ perms-end)))
     383                             (device-end (position #\space line :start (1+ offset-end)))
     384                             (inode-end (position #\space line :start (1+ device-end)))
     385                             (name-start (position #\space line :start inode-end :test-not #'eql))
     386                             (low (parse-integer line :start 0 :end low-end :radix 16))
     387                             (high (parse-integer line :start (1+ low-end) :end high-end :radix 16))
     388                             (perms (let ((p (subseq line (1+ high-end) perms-end)))
     389                                      (or (find p perm-cache :test #'equal)
     390                                          (car (setq perm-cache (cons p perm-cache))))))
     391                             (name (and name-start
     392                                        (let ((f (subseq line name-start)))
     393                                          (or (find f name-cache :test #'equal)
     394                                              (car (setq name-cache (cons f name-cache))))))))
     395                        (setq current (list low perms name (- high low) nil nil)))
     396            else do (let* ((key-end (position #\: line))
     397                           (size-start (position #\space line :start (1+ key-end) :test-not #'eql))
     398                           (size-end (position #\space line :start (1+ size-start)))
     399                           (size (parse-integer line :start size-start :end size-end :radix 10)))
     400                      (assert (string-equal " kB" line :start2 size-end))
     401                      (assert current)
     402                      (setq size (* size 1024))
     403                      (macrolet ((is (string)
     404                                   `(and (eql key-end ,(length string))
     405                                         (string-equal ,string line :end2 key-end))))
     406                        (cond ((or (is "Shared_Clean") (is "Private_Clean"))
     407                               (setf (nth 4 current) (+ (or (nth 4 current) 0) size)))
     408                              ((or (is "Shared_Dirty") (is "Private_Dirty"))
     409                               (setf (nth 5 current) (+ (or (nth 5 current) 0) size))))))))))
    392410
    393411(defun proc-maps-diff (map1 map2)
    394   ;; Compute change from map1 to map2.
    395   ;;  Remove segment -> (:remove low high ...)
    396   ;;  Add segment  -> (:add low high ...)
    397   ;;  grow segment -> (:grow low high new-high ...)
     412  ;; Compute change from map1 to map2, return a list of (old-sect . new-sect)
    398413  (let ((added (copy-list map2))
    399         (changes nil))
     414        (changed nil))
    400415    (loop for m1 in map1 as match = (find (car m1) added :key #'car)
    401416          do (when match
    402                (setq added (delete match added))
    403                (unless (equal (cddr m1) (cddr match))
    404                  (warn  "Segment changed ~s -> ~s" m1 match)))
    405           do (cond ((null match)
    406                     (push `(:remove ,(- (car m1) (cadr m1)) ,@m1) changes))
    407                    ((< (cadr m1) (cadr match))
    408                     (push `(:grow ,(- (cadr match) (cadr m1)) ,@m1) changes))
    409                    ((< (cadr match) (cadr m1))
    410                     (push `(:shrink ,(- (cadr match) (cadr m1)) ,@m1) changes))
    411                    (t nil)))
    412     (loop for m in added do (push `(:new ,(- (cadr m) (car m)) ,@m) changes))
    413     changes))
    414 
    415 )  ;; end of linux-only code
     417               (if (and (equal (nth 1 m1) (nth 1 match)) (equal (nth 2 m1) (nth 2 match)))
     418                   (setq added (delete match added))
     419                   (setq match nil)))
     420          do (unless (equalp m1 match)
     421               (push (list m1 match) changed)))
     422    (loop for new in added do (push (list nil new) changed))
     423    changed))
     424
     425) ;; end of linux-only code
    416426
    417427(defun get-allocation-sentinel (&key (gc-first t))
Note: See TracChangeset for help on using the changeset viewer.