source: trunk/source/library/leaks.lisp @ 11373

Last change on this file since 11373 was 11373, checked in by gz, 12 years ago

Finish source location and pc -> source mapping support, from working-0711 but with some modifications.


Source location are recorded in CCL:SOURCE-NOTE's, which are objects with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end positions are file positions (not character positions). The text will be NIL unless text recording was on at read-time. If the original file is still available, you can force missing source text to be read from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.

Source-note's are associated with definitions (via record-source-file) and also stored in function objects (including anonymous and nested functions). The former can be retrieved via CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.

The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-LOCATIONS*:

If NIL, don't store source-notes in function objects, and store only the filename for definitions (the latter only if *record-source-file* is true).
If T, store source-notes, including a copy of the original source text, for function objects and definitions (the latter only if *record-source-file* is true).
If :NO-TEXT, store source-notes, but without saved text, for function objects and defintions (the latter only if *record-source-file* is true). This is the default.

PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a compressed table mapping pc offsets to corresponding source locations. This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the source at offset pc in the function.

Currently the only thing that makes use of any of this is the disassembler. ILISP and current version of Slime still use backward-compatible functions that deal with filenames only. The plan is to make Slime, and our IDE, use this eventually.

Known bug: most of this only works through the file compiler. Still need to make it work with loading from source (not hard, just haven't gotten to it yet).

This checkin incidentally includes bits and pieces of support for code coverage, which is still
incomplete and untested. Ignore it.

The PPC version is untested. I need to check it in so I can move to a PPC for testing.


18387152 Nov 16 10:00 lx86cl64.image-no-loc-no-pc
19296464 Nov 16 10:11 lx86cl64.image-loc-no-text-no-pc
20517072 Nov 16 09:58 lx86cl64.image-loc-no-text-with-pc [default]
25514192 Nov 16 09:55 lx86cl64.image-loc-with-text-with-pc

File size: 10.0 KB
1;;;-*-Mode: LISP; Package: ccl -*-
3;;;   Copyright (C) 2008, Clozure Associates and contributors
4;;;   This file is part of OpenMCL. 
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;   The LLGPL is also available online at
17; leaks.lisp
18; A few functions to help in finding memory leaks
20(in-package :ccl)
22;; Returns all objects that satisfy predicate of one of the types in
23;; ccl::*heap-utilization-vector-type-names*
24;; Note that these can contain stack-consed objects that are dead.
25;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objects
26;; (ccl::heap-utilization) prints a useful list of object counts and sizes
27;; per type.
28(defun all-objects-of-type (type &optional predicate)
29  (let ((typecode (position type ccl::*heap-utilization-vector-type-names*))
30        (res nil))
31    (when typecode
32      (flet ((mapper (thing)
33               (when (and (eq typecode (ccl::typecode thing))
34                          (or (null predicate) (funcall predicate thing)))
35                 (push thing res))))
36        (declare (dynamic-extent #'mapper))
37        (ccl::%map-areas #'mapper))
38      res)))
40;; Counts objects that satisfy predicate of one of the types in
41;; ccl::*heap-utilization-vector-type-names*
42(defun count-objects-of-type (type &optional predicate)
43  (let ((typecode (position type ccl::*heap-utilization-vector-type-names*))
44        (res 0))
45    (when typecode
46      (flet ((mapper (thing)
47               (when (and (eq typecode (ccl::typecode thing))
48                          (or (null predicate) (funcall predicate thing)))
49                 (incf res))))
50        (declare (dynamic-extent #'mapper))
51        (ccl::%map-areas #'mapper))
52      res)))
54(defun count-conses ()
55  (let ((res 0))
56    (flet ((mapper (thing)
57             (when (consp thing) (incf res))))
58      (declare (dynamic-extent #'mapper))
59      (ccl::%map-areas #'mapper))
60    res))
62;; Like set-difference, but uses a hash table to go faster.
63(defun fast-set-difference (list1 list2 &optional (test #'eq))
64  (let ((hash (make-hash-table :test test))
65        (res nil))
66    (dolist (e1 list1) (setf (gethash e1 hash) t))
67    (dolist (e2 list2) (remhash e2 hash))
68    (maphash (lambda (k v)
69               (declare (ignore v))
70               (push k res))
71             hash)
72    res))
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)
78  (let ((res nil))
79    (ccl::%map-areas
80     (lambda (thing)
81       (cond ((and (not (eq thing object))
82                   (ccl::uvectorp thing)
83                   (not (ccl::ivectorp thing)))
84              (dotimes (i (ccl::uvsize thing))
85                (when (eq object (ccl::uvref thing i))
86                  (push thing res)
87                  (return))))
88             ((consp thing)
89              (when(or (eq object (car thing))
90                       (eq object (cdr thing)))
91                (push thing res))))))
92    res))
94;; Return true if P is heap-consed
95(defun pointer-in-some-dynamic-area-p (p)
96 (block found
97   (ccl::do-consing-areas (a)
98     (when (eql (%fixnum-ref a target::area.code) ccl::area-dynamic)
99       (when (ccl::%ptr-in-area-p p a)
100         (return-from found t))))))
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.
106;; 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))))
115    (ccl:gc)
116    (format t "Searching") (finish-output)
117    (loop
118      (let ((added-one nil))
119        (format t " ~d" (hash-table-count found)) (finish-output)
120        (ccl::%map-areas
121         (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)))))))
140        (unless added-one
141          (return))))
142    (format t " done.~%") (finish-output)
143    ;; Eliminate any cons that is referenced by another cons.
144    ;; Also eliminate or replace objects that nobody will want to see.
145    (let ((cons-refs (make-hash-table :test 'eq))
146          (additions nil))
147      (loop for cons being the hash-keys of found
148            when (consp cons)
149              do
150           (when (consp (car cons))
151             (setf (gethash (car cons) cons-refs) t))
152           (when (consp (cdr cons))
153             (setf (gethash (cdr cons) cons-refs) t)))
154      (loop for key being the hash-keys of found
155            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))
171              do
172              (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)))
183;; One convenient way to print the hash table returned by transitive-referencers
184(defun print-referencers (hash &key
185                          predicate
186                          (pause-period 20)
187                          (print-circle t)
188                          (print-length 20)
189                          (print-level 5))
190  (let ((cnt 0)
191        (*print-circle* print-circle)
192        (*print-length* print-length)
193        (*print-level* print-level))
194    (maphash (lambda (key value)
195               (declare (ignore value))
196               (when (or (null predicate) (funcall predicate key))
197                 (format t "~s~%" key)
198                 (when (> (incf cnt) pause-period)
199                   (format t "Continue (Y/N)? ")
200                   (unless (equalp (read-line) "Y")
201                     (return-from print-referencers))
202                   (setq cnt 0))))
203             hash)))
205;; Returns all the obsolete CLOS instances, those whose class has been
206;; changed since they were created. Each will be updated as soon as
207;; method dispatch is done on it."
208(defun obsolete-instances (list)
209  (let ((res nil))
210    (dolist (i list)
211      (when (eq 0 (ccl::%wrapper-hash-index (ccl::instance-class-wrapper i)))
212        (push i res)))
213    res))
215;; Linux-only malloc leak finding
219;; (ccl::start-mtrace LOGFILE)
220;; Do some work.
221;; (ccl::stop-mtrace)
222;; (ccl::parse-mtrace-log LOGFILE)
223(defun start-mtrace (log-file)
224  (touch log-file)
225  (setf log-file (probe-file log-file))
226  (setenv "MALLOC_TRACE" (namestring log-file))
227  (gc)
228  (#_mtrace))
230(defun stop-mtrace ()
231  (gc)
232  (#_muntrace))
234(defun parse-mtrace-log (log-file)
235  (with-open-file (s log-file)
236    (let ((hash (make-hash-table :test 'equal))
237          (eof (list :eof)))
238      (loop for line = (read-line s nil eof)
239            until (eq line eof)
240            when (and (> (length line) 2)
241                      (equal "@ " (subseq line 0 2)))
242              do
243           (setf line (subseq line 2))
244           (let ((plus-pos (search " + " line))
245                 (minus-pos (search " - " line)))
246             (cond (plus-pos
247                    (let* ((where (subseq line 0 plus-pos))
248                           (addr-and-size (subseq line (+ plus-pos 3)))
249                           (space-pos (position #\space addr-and-size))
250                           (addr (subseq addr-and-size 0 space-pos))
251                           (size (subseq addr-and-size (1+ space-pos))))
252                      (setf (gethash addr hash) (list where size))))
253                   (minus-pos
254                    (let ((addr (subseq line (+ minus-pos 3))))
255                      (remhash addr hash))))))
256      (let ((res nil))
257        (maphash (lambda (key value)
258                   (push (append value (list key)) res))
259                 hash)
260        res))))
262;; Return the total number of bytes allocated by malloc()
263(defun mallinfo ()
264  (ccl:rlet ((mallinfo :mallinfo))
265    (#_mallinfo mallinfo)
266    (ccl::rref mallinfo :mallinfo.uordblks)))
268)  ;; end of linux-only code
Note: See TracBrowser for help on using the repository browser.