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

Last change on this file since 14507 was 14507, checked in by gb, 8 years ago

Different.

File size: 20.8 KB
Line 
1;;;-*-Mode: LISP; Package: ccl -*-
2;;;
3;;;   Copyright (C) 2008-2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17; leaks.lisp
18; A few functions to help in finding memory leaks
19
20(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)))
38
39;; Returns all objects that satisfy predicate of one of the types in
40;; ccl::*heap-utilization-vector-type-names*
41;; Note that these can contain stack-consed objects that are dead.
42;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objects
43;; (ccl::heap-utilization) prints a useful list of object counts and sizes
44;; per type.
45(defun all-objects-of-type (type &optional predicate)
46  (let ((typecode (position type ccl::*heap-utilization-vector-type-names*))
47        (res nil))
48    (when typecode
49      (flet ((mapper (thing)
50               (when (and (eq typecode (ccl::typecode thing))
51                          (or (null predicate) (funcall predicate thing)))
52                 (push thing res))))
53        (declare (dynamic-extent #'mapper))
54        (ccl::%map-areas #'mapper))
55      res)))
56
57;; Counts objects that satisfy predicate of one of the types in
58;; ccl::*heap-utilization-vector-type-names*
59(defun count-objects-of-type (type &optional predicate)
60  (let ((typecode (position type ccl::*heap-utilization-vector-type-names*))
61        (res 0))
62    (when typecode
63      (flet ((mapper (thing)
64               (when (and (eq typecode (ccl::typecode thing))
65                          (or (null predicate) (funcall predicate thing)))
66                 (incf res))))
67        (declare (dynamic-extent #'mapper))
68        (ccl::%map-areas #'mapper))
69      res)))
70
71(defun count-conses ()
72  (let ((res 0))
73    (flet ((mapper (thing)
74             (when (consp thing) (incf res))))
75      (declare (dynamic-extent #'mapper))
76      (ccl::%map-areas #'mapper))
77    res))
78
79;; Like set-difference, but uses a hash table to go faster.
80(defun fast-set-difference (list1 list2 &optional (test #'eq))
81  (let ((hash (make-hash-table :test test))
82        (res nil))
83    (dolist (e1 list1) (setf (gethash e1 hash) t))
84    (dolist (e2 list2) (remhash e2 hash))
85    (maphash (lambda (k v)
86               (declare (ignore v))
87               (push k res))
88             hash)
89    res))
90
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)
94  (let ((res nil))
95    (ccl::%map-areas
96     (lambda (thing)
97       (cond ((and (not (eq thing object))
98                   (ccl::uvectorp thing)
99                   (not (ccl::ivectorp thing)))
100              (dotimes (i (ccl::uvsize thing))
101                (when (eq object (ccl::uvref thing i))
102                  (push thing res)
103                  (return))))
104             ((consp thing)
105              (when(or (eq object (car thing))
106                       (eq object (cdr thing)))
107                (push thing res)))))
108     area)
109    res))
110
111;; Return true if P is heap-consed
112(defun pointer-in-some-dynamic-area-p (p)
113 (block found
114   (do-gc-areas (a)
115     (when (eql (%fixnum-ref a target::area.code) ccl::area-dynamic)
116       (when (ccl::%ptr-in-area-p p a)
117         (return-from found t))))))
118
119;; Find all transitive referencers to any object in the list
120;; Returns a hash table with the references as keys.
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))
127    (ccl:gc)
128    (when verbose (format t "Searching") (finish-output))
129    (loop
130      (let ((added-one nil))
131        (when verbose (format t " ~d" (hash-table-count found)) (finish-output))
132        (ccl::%map-areas
133         (lambda (thing)
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)
154        (unless added-one
155          (return))))
156    (when verbose (format t " done.~%") (finish-output))
157    ;; Eliminate any cons that is referenced by another cons.
158    ;; Also eliminate or replace objects that nobody will want to see.
159    (let ((cons-refs (make-hash-table :test 'eq)))
160      (loop for cons being the hash-keys of found
161            when (consp cons)
162              do
163           (when (consp (car cons))
164             (setf (gethash (car cons) cons-refs) t))
165           (when (consp (cdr cons))
166             (setf (gethash (cdr cons) cons-refs) t)))
167      (loop for key being the hash-keys of found
168            when (or (and (consp key) (gethash key cons-refs))
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                     )
176              do
177              (remhash key found))
178      (loop for cons on objects
179            do
180         (remhash cons found)
181         (remhash (car cons) found)))
182      found))
183
184;; One convenient way to print the hash table returned by transitive-referencers
185(defun print-referencers (hash &key
186                          predicate
187                          (pause-period 20)
188                          (print-circle t)
189                          (print-length 20)
190                          (print-level 5))
191  (let ((cnt 0)
192        (*print-circle* print-circle)
193        (*print-length* print-length)
194        (*print-level* print-level))
195    (maphash (lambda (key value)
196               (declare (ignore value))
197               (when (or (null predicate) (funcall predicate key))
198                 (format t "~s~%" key)
199                 (when (> (incf cnt) pause-period)
200                   (format t "Continue (Y/N)? ")
201                   (unless (equalp (read-line) "Y")
202                     (return-from print-referencers))
203                   (setq cnt 0))))
204             hash)))
205
206;; Returns all the obsolete CLOS instances, those whose class has been
207;; changed since they were created. Each will be updated as soon as
208;; method dispatch is done on it."
209(defun obsolete-instances (list)
210  (let ((res nil))
211    (dolist (i list)
212      (when (eq 0 (ccl::%wrapper-hash-index (ccl::instance-class-wrapper i)))
213        (push i res)))
214    res))
215
216;; Linux-only malloc leak finding
217#+(and linux-target (not android-target))
218(progn
219
220;; (ccl::start-mtrace LOGFILE)
221;; Do some work.
222;; (ccl::stop-mtrace)
223;; (ccl::parse-mtrace-log LOGFILE)
224(defun start-mtrace (log-file &key gc-first)
225  (delete-file log-file)
226  (touch log-file)
227  (setenv "MALLOC_TRACE" (native-translated-namestring (truename log-file)))
228  (when gc-first (gc))
229  (#_mtrace))
230
231(defun stop-mtrace (&key gc-first)
232  (when gc-first (gc))
233  (#_muntrace))
234
235(defun parse-mtrace-log (log-file &key (duplicate-alloc :show)
236                                       (unmatched-free :collect)
237                                       (failed-realloc :show)
238                                       (hash (make-hash-table :test 'eql))
239                                       (id nil))
240  (let ((errors nil))
241    (with-open-file (stream log-file)
242      (loop for line = (read-line stream nil nil) while line
243            as pos = (if (and (> (length line) 2) (eql (aref line 0) #\@) (eql (aref line 1) #\space))
244                         (1+ (position #\space line :start 2))
245                         0)
246            as address = (let ((npos (+ pos 2)))
247                           (when (and (< (+ npos 2) (length line))
248                                      (eql (aref line npos) #\0)
249                                      (eql (aref line (1+ npos)) #\x))
250                             (parse-integer line :radix 16
251                                            :start (+ npos 2)
252                                            :end (position #\space line :start npos))))
253            as last-data = (gethash address hash)
254            do (ecase (aref line pos)
255                 ((#\+ #\>)
256                    (let ((this-data (if id (cons id line) line)))
257                      (if last-data
258                          (ecase duplicate-alloc
259                            (:collect (push (list :duplicate
260                                                  (if (eq (aref line pos) #\+) :alloc :realloc)
261                                                  last-data this-data)
262                                            errors))
263                            ((:show nil) (format t "Duplicate ~a:~%~a~%~a~%"
264                                                 (if (eq (aref line pos) #\+) "alloc" "realloc")
265                                                 last-data this-data))
266                            (:ignore nil))
267                          (setf (gethash address hash) this-data))))
268                 ((#\- #\<)
269                    (if last-data
270                        (remhash address hash)
271                        (let ((this-data (if id (cons id line) line)))
272                          (ecase unmatched-free
273                            (:collect (push (list :unmatched
274                                                  (if (eq (aref line pos) #\-) :free :realloc)
275                                                  this-data)
276                                            errors))
277                            ((:show nil) (format t "Unmatched ~a: ~a~%"
278                                                 (if (eq (aref line pos) #\-) "free" "realloc")
279                                                 this-data))
280                            (:ignore nil)))))
281                 ((#\=) ;; ignore start/end
282                    ;; (format t "~&~a" line)
283                    nil)
284                 ((#\!)
285                    (let ((this-data (if id (cons id line) line)))
286                      (ecase failed-realloc
287                        (:collect (push (list :failed :realloc this-data) errors))
288                        ((:show nil) (format t "Failed realloc: ~a" this-data))
289                        (:ignore nil)))))))
290    (values (nreverse errors) hash)))
291
292(defun pretty-print-mtrace-summary (log-file)
293  (multiple-value-bind (errors malloc-hash) (parse-mtrace-log log-file)
294    (let* ((malloc-sum 0)
295           (malloc-count 0)
296           (free-count 0))
297      (when (> (hash-table-count malloc-hash) 0)
298        (format t "~&Malloced but not freed:~%")
299        (loop for line being the hash-value of malloc-hash
300              do (let* ((plus-pos (or (search " + " line) (search " > " line)))
301                        (size-pos (position #\space line :start (+ plus-pos 3))))
302                   (incf malloc-count)
303                   (incf malloc-sum (parse-integer line :radix 16 :start (+ size-pos 3)))
304                   (format t "~& ~A" line))))
305      (when (find :unmatched errors :key #'car)
306        (format t "~&Freed but not malloced:~%")
307        (loop for (type nil line) in errors
308              do (when (eq type :unmatched)
309                   (incf free-count)
310                   (format t " ~a" line))))
311      (format t "~&~aK in ~a mallocs not freed, ~A frees not malloced"
312              (/ malloc-sum 1024.0)
313              malloc-count
314              free-count)))
315  (values))
316
317
318;; Return the total number of bytes allocated by malloc()
319(defun mallinfo ()
320  (ccl:rlet ((mallinfo :mallinfo))
321    (#_mallinfo mallinfo)
322    (ccl::rref mallinfo :mallinfo.uordblks)))
323
324#||
325http://www.gnu.org/s/libc/manual/html_node/Statistics-of-Malloc.html
326
327int arena
328    This is the total size of memory allocated with sbrk by malloc, in bytes.
329int ordblks
330    This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.)
331int smblks
332    This field is unused.
333int hblks
334    This is the total number of chunks allocated with mmap.
335int hblkhd
336    This is the total size of memory allocated with mmap, in bytes.
337int usmblks
338    This field is unused.
339int fsmblks
340    This field is unused.
341int uordblks
342    This is the total size of memory occupied by chunks handed out by malloc.
343int fordblks
344    This is the total size of memory occupied by free (not in use) chunks.
345int keepcost
346    This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space's data segment).
347||#   
348
349(defun show-malloc-info ()
350  (rlet ((info :mallinfo))
351    (#_mallinfo info)                   ;struct return invisible arg.
352    (let* ((arena (pref info :mallinfo.arena))
353           (ordblks (pref info :mallinfo.ordblks))
354           (hblks (pref info :mallinfo.hblks))
355           (hblkhd (pref info :mallinfo.hblkhd))
356           (uordblks (pref info :mallinfo.uordblks))
357           (fordblks (pref info :mallinfo.fordblks))
358           (keepcost (pref info :mallinfo.keepcost)))
359      (format t "~& arena size: ~d (#x~x)" arena arena)
360      (format t "~& number of unused chunks = ~d" ordblks)
361      (format t "~& number of mmap'ed chunks = ~d" hblks)
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))))
366
367
368
369;; Parse /proc/<pid>/maps
370;; returns a list of (address perms name total-size clean-size dirty-size)
371(defun parse-proc-maps (&optional (pid (ccl::getpid)))
372  (let ((perm-cache ())
373        (name-cache ()))
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))))))))))
410
411(defun proc-maps-diff (map1 map2)
412  ;; Compute change from map1 to map2, return a list of (old-sect . new-sect)
413  (let ((added (copy-list map2))
414        (changed nil))
415    (loop for m1 in map1 as match = (find (car m1) added :key #'car)
416          do (when match
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
426
427(defun get-allocation-sentinel (&key (gc-first t))
428  ;; Return the object with the highest address that can be guaranteed to be at a lower
429  ;; address than any newer objects.
430  ;; If gc-first is true, can also conversely guarantee that all older objects are at a
431  ;; lower address than the sentinel.  If gc-first is false, than there may be some
432  ;; already-allocated objects at higher addresses, though no more than the size of the
433  ;; youngest generation (and usually even less than that). Second value returned is the
434  ;; size of the active region above the sentinel.
435  (with-other-threads-suspended
436    (when gc-first (gc)) ;; get rid of thread allocation chunks.  Wish could just egc...
437    ;; This mustn't cons.
438    (let* ((first-area (%normalize-areas)) ;; youngest generation
439           (min-base (loop with current = (%current-tcr)
440                           for tcr = (%fixnum-ref current target::tcr.next)
441                             then (%fixnum-ref tcr target::tcr.next)
442                           as base fixnum = (%fixnum-ref tcr target::tcr.save-allocbase)
443                           when (> base 0)
444                             minimize base
445                           until (eql tcr current)))
446           (active (%fixnum-ref first-area  target::area.active))
447           (limit (if (eql min-base 0) active min-base))
448           (last-obj nil))
449      ;; Normally will find it in the youngest generation, but loop in case limit = area.low.
450      (block walk
451        (flet ((skip (obj)
452                 (declare (optimize (speed 3) (safety 0))) ;; lie
453                 (unless (%i< obj limit)
454                   (return-from walk))
455                 (setq last-obj obj)))
456          (declare (dynamic-extent #'skip))
457          (loop for area = first-area then (%fixnum-ref area target::area.succ)
458                until (neq (%fixnum-ref area target::area.code) area-dynamic)
459                when (< (%fixnum-ref area target::area.low) (%fixnum-ref area target::area.active))
460                  do (walk-static-area area #'skip))))
461      (values last-obj (%i- active limit)))))
462
Note: See TracBrowser for help on using the repository browser.