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

Last change on this file since 13485 was 13485, checked in by gz, 10 years ago

Merge r13436 into trunk: parse-proc-maps, proc-maps-diff, mtrace extensions.

File size: 19.6 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;; 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)))
39
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)))
53
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))
61
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))
73
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))
93
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))))))
101
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)))
182
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)))
204
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))
214
215;; Linux-only malloc leak finding
216#+linux-target
217(progn
218
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 &key gc-first)
224  (delete-file log-file)
225  (touch log-file)
226  (setenv "MALLOC_TRACE" (native-translated-namestring (truename log-file)))
227  (when gc-first (gc))
228  (#_mtrace))
229
230(defun stop-mtrace (&key gc-first)
231  (when gc-first (gc))
232  (#_muntrace))
233
234(defun parse-mtrace-log (log-file &key (duplicate-alloc :show)
235                                       (unmatched-free :collect)
236                                       (failed-realloc :show)
237                                       (hash (make-hash-table :test 'eql))
238                                       (id nil))
239  (let ((errors nil))
240    (with-open-file (stream log-file)
241      (loop for line = (read-line stream nil nil) while line
242            as pos = (if (and (> (length line) 2) (eql (aref line 0) #\@) (eql (aref line 1) #\space))
243                         (1+ (position #\space line :start 2))
244                         0)
245            as address = (let ((npos (+ pos 2)))
246                           (when (and (< (+ npos 2) (length line))
247                                      (eql (aref line npos) #\0)
248                                      (eql (aref line (1+ npos)) #\x))
249                             (parse-integer line :radix 16
250                                            :start (+ npos 2)
251                                            :end (position #\space line :start npos))))
252            as last-data = (gethash address hash)
253            do (ecase (aref line pos)
254                 ((#\+ #\>)
255                    (let ((this-data (if id (cons id line) line)))
256                      (if last-data
257                          (ecase duplicate-alloc
258                            (:collect (push (list :duplicate
259                                                  (if (eq (aref line pos) #\+) :alloc :realloc)
260                                                  last-data this-data)
261                                            errors))
262                            ((:show nil) (format t "Duplicate ~a:~%~a~%~a~%"
263                                                 (if (eq (aref line pos) #\+) "alloc" "realloc")
264                                                 last-data this-data))
265                            (:ignore nil))
266                          (setf (gethash address hash) this-data))))
267                 ((#\- #\<)
268                    (if last-data
269                        (remhash address hash)
270                        (let ((this-data (if id (cons id line) line)))
271                          (ecase unmatched-free
272                            (:collect (push (list :unmatched
273                                                  (if (eq (aref line pos) #\-) :free :realloc)
274                                                  this-data)
275                                            errors))
276                            ((:show nil) (format t "Unmatched ~a: ~a~%"
277                                                 (if (eq (aref line pos) #\-) "free" "realloc")
278                                                 this-data))
279                            (:ignore nil)))))
280                 ((#\=) ;; ignore start/end
281                    ;; (format t "~&~a" line)
282                    nil)
283                 ((#\!)
284                    (let ((this-data (if id (cons id line) line)))
285                      (ecase failed-realloc
286                        (:collect (push (list :failed :realloc this-data) errors))
287                        ((:show nil) (format t "Failed realloc: ~a" this-data))
288                        (:ignore nil)))))))
289    (values (nreverse errors) hash)))
290
291(defun pretty-print-mtrace-summary (log-file)
292  (multiple-value-bind (errors malloc-hash) (parse-mtrace-log log-file)
293    (let* ((malloc-sum 0)
294           (malloc-count 0)
295           (free-count 0))
296      (when (> (hash-table-count malloc-hash) 0)
297        (format t "~&Malloced but not freed:~%")
298        (loop for line being the hash-value of malloc-hash
299              do (let* ((plus-pos (or (search " + " line) (search " > " line)))
300                        (size-pos (position #\space line :start (+ plus-pos 3))))
301                   (incf malloc-count)
302                   (incf malloc-sum (parse-integer line :radix 16 :start (+ size-pos 3)))
303                   (format t "~& ~A" line))))
304      (when (find :unmatched errors :key #'car)
305        (format t "~&Freed but not malloced:~%")
306        (loop for (type nil line) in errors
307              do (when (eq type :unmatched)
308                   (incf free-count)
309                   (format t " ~a" line))))
310      (format t "~&~aK in ~a mallocs not freed, ~A frees not malloced"
311              (/ malloc-sum 1024.0)
312              malloc-count
313              free-count)))
314  (values))
315
316
317;; Return the total number of bytes allocated by malloc()
318(defun mallinfo ()
319  (ccl:rlet ((mallinfo :mallinfo))
320    (#_mallinfo mallinfo)
321    (ccl::rref mallinfo :mallinfo.uordblks)))
322
323#||
324http://www.gnu.org/s/libc/manual/html_node/Statistics-of-Malloc.html
325
326int arena
327    This is the total size of memory allocated with sbrk by malloc, in bytes.
328int ordblks
329    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.)
330int smblks
331    This field is unused.
332int hblks
333    This is the total number of chunks allocated with mmap.
334int hblkhd
335    This is the total size of memory allocated with mmap, in bytes.
336int usmblks
337    This field is unused.
338int fsmblks
339    This field is unused.
340int uordblks
341    This is the total size of memory occupied by chunks handed out by malloc.
342int fordblks
343    This is the total size of memory occupied by free (not in use) chunks.
344int keepcost
345    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).
346||#   
347
348(defun show-malloc-info ()
349  (rlet ((info :mallinfo))
350    (#_mallinfo info)                   ;struct return invisible arg.
351    (let* ((arena (pref info :mallinfo.arena))
352           (ordblks (pref info :mallinfo.ordblks))
353           (hblks (pref info :mallinfo.hblks))
354           (hblkhd (pref info :mallinfo.hblkhd))
355           (uordblks (pref info :mallinfo.uordblks))
356           (fordblks (pref info :mallinfo.fordblks))
357           (keepcost (pref info :mallinfo.keepcost)))
358      (format t "~& arena size: ~d/#x~x" arena arena)
359      (format t "~& number of unused chunks = ~d" ordblks)
360      (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))))
365
366
367
368;; Parse /proc/<pid>/maps
369
370(defun parse-proc-maps (&optional (pid (ccl::getpid)))
371  (let ((perm-cache ())
372        (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)))))
392
393(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 ...)
398  (let ((added (copy-list map2))
399        (changes nil))
400    (loop for m1 in map1 as match = (find (car m1) added :key #'car)
401          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
416
417(defun get-allocation-sentinel (&key (gc-first t))
418  ;; Return the object with the highest address that can be guaranteed to be at a lower
419  ;; address than any newer objects.
420  ;; If gc-first is true, can also conversely guarantee that all older objects are at a
421  ;; lower address than the sentinel.  If gc-first is false, than there may be some
422  ;; already-allocated objects at higher addresses, though no more than the size of the
423  ;; youngest generation (and usually even less than that). Second value returned is the
424  ;; size of the active region above the sentinel.
425  (with-other-threads-suspended
426    (when gc-first (gc)) ;; get rid of thread allocation chunks.  Wish could just egc...
427    ;; This mustn't cons.
428    (let* ((first-area (%normalize-areas)) ;; youngest generation
429           (min-base (loop with current = (%current-tcr)
430                           for tcr = (%fixnum-ref current target::tcr.next)
431                             then (%fixnum-ref tcr target::tcr.next)
432                           as base fixnum = (%fixnum-ref tcr target::tcr.save-allocbase)
433                           when (> base 0)
434                             minimize base
435                           until (eql tcr current)))
436           (active (%fixnum-ref first-area  target::area.active))
437           (limit (if (eql min-base 0) active min-base))
438           (last-obj nil))
439      ;; Normally will find it in the youngest generation, but loop in case limit = area.low.
440      (block walk
441        (flet ((skip (obj)
442                 (declare (optimize (speed 3) (safety 0))) ;; lie
443                 (unless (%i< obj limit)
444                   (return-from walk))
445                 (setq last-obj obj)))
446          (declare (dynamic-extent #'skip))
447          (loop for area = first-area then (%fixnum-ref area target::area.succ)
448                until (neq (%fixnum-ref area target::area.code) area-dynamic)
449                when (< (%fixnum-ref area target::area.low) (%fixnum-ref area target::area.active))
450                  do (walk-static-area area #'skip))))
451      (values last-obj (%i- active limit)))))
452
Note: See TracBrowser for help on using the repository browser.