[Openmcl-cvs-notifications] r11165 - in /trunk/source: level-1/l1-boot-2.lisp lib/compile-ccl.lisp lib/systems.lisp library/leaks.lisp
gz at clozure.com
gz at clozure.com
Sat Oct 18 15:51:09 EDT 2008
Author: gz
Date: Sat Oct 18 15:51:09 2008
New Revision: 11165
Log:
Propagate r10403 from working-0711 branch to trunk: add some functions usef=
ul in finding memory leaks
Added:
trunk/source/library/leaks.lisp
Modified:
trunk/source/level-1/l1-boot-2.lisp
trunk/source/lib/compile-ccl.lisp
trunk/source/lib/systems.lisp
Modified: trunk/source/level-1/l1-boot-2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-boot-2.lisp (original)
+++ trunk/source/level-1/l1-boot-2.lisp Sat Oct 18 15:51:09 2008
@@ -294,6 +294,7 @@
(bin-load-provide "ARGLIST" "arglist")
(bin-load-provide "EDIT-CALLERS" "edit-callers")
(bin-load-provide "DESCRIBE" "describe")
+ (bin-load-provide "LEAKS" "leaks")
(bin-load-provide "MCL-COMPAT" "mcl-compat")
(require "LOOP")
(bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
Modified: trunk/source/lib/compile-ccl.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/compile-ccl.lisp (original)
+++ trunk/source/lib/compile-ccl.lisp Sat Oct 18 15:51:09 2008
@@ -204,6 +204,7 @@
arglist
edit-callers
describe
+ leaks
asdf
defsystem
))
Modified: trunk/source/lib/systems.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/systems.lisp (original)
+++ trunk/source/lib/systems.lisp Sat Oct 18 15:51:09 2008
@@ -203,6 +203,7 @@
(loop "ccl:library;loop" ("ccl:library;loop.lisp"))
(linux-files "ccl:l1f;linux-files" ("ccl:level-1;linux-files=
.lisp"))
(source-files "ccl:bin;source-files" ("ccl:lib;source-files.li=
sp"))
+ (leaks "ccl:bin;leaks" ("ccl:library;leaks.lisp"=
))
=
(prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;p=
repare-mcl-environment.lisp"))
(defsystem "ccl:tools;defsystem" ("ccl:tools;defsystem.lis=
p"))
Added: trunk/source/library/leaks.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/library/leaks.lisp (added)
+++ trunk/source/library/leaks.lisp Sat Oct 18 15:51:09 2008
@@ -1,0 +1,261 @@
+;;;-*-Mode: LISP; Package: ccl -*-
+;;;
+;;; Copyright (C) 2008, Clozure Associates and contributors
+;;; This file is part of OpenMCL. =
+;;;
+;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;; License , known as the LLGPL and distributed with OpenMCL as the
+;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
+;;; which is distributed with OpenMCL as the file "LGPL". Where these
+;;; conflict, the preamble takes precedence. =
+;;;
+;;; OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+; leaks.lisp
+; A few functions to help in finding memory leaks
+
+(in-package :ccl)
+
+;; Returns all objects that satisfy predicate of one of the types in
+;; ccl::*heap-utilization-vector-type-names*
+;; Note that these can contain stack-consed objects that are dead.
+;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objec=
ts
+;; (ccl::heap-utilization) prints a useful list of object counts and sizes
+;; per type.
+(defun all-objects-of-type (type &optional predicate)
+ (let ((typecode (position type ccl::*heap-utilization-vector-type-names*=
))
+ (res nil))
+ (when typecode
+ (flet ((mapper (thing)
+ (when (and (eq typecode (ccl::typecode thing))
+ (or (null predicate) (funcall predicate thing)))
+ (push thing res))))
+ (declare (dynamic-extent #'mapper))
+ (ccl::%map-areas #'mapper))
+ res)))
+
+;; Counts objects that satisfy predicate of one of the types in
+;; ccl::*heap-utilization-vector-type-names*
+(defun count-objects-of-type (type &optional predicate)
+ (let ((typecode (position type ccl::*heap-utilization-vector-type-names*=
))
+ (res 0))
+ (when typecode
+ (flet ((mapper (thing)
+ (when (and (eq typecode (ccl::typecode thing))
+ (or (null predicate) (funcall predicate thing)))
+ (incf res))))
+ (declare (dynamic-extent #'mapper))
+ (ccl::%map-areas #'mapper))
+ res)))
+
+(defun count-conses ()
+ (let ((res 0))
+ (flet ((mapper (thing)
+ (when (consp thing) (incf res))))
+ (declare (dynamic-extent #'mapper))
+ (ccl::%map-areas #'mapper))
+ res))
+
+;; Like set-difference, but uses a hash table to go faster.
+(defun fast-set-difference (list1 list2 &optional (test #'eq))
+ (let ((hash (make-hash-table :test test))
+ (res nil))
+ (dolist (e1 list1) (setf (gethash e1 hash) t))
+ (dolist (e2 list2) (remhash e2 hash))
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (push k res))
+ hash)
+ res))
+
+;; Returns all references to object.
+;; Note that these can contain stack-consed objects that are dead.
+;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objec=
ts
+(defun find-references (object)
+ (let ((res nil))
+ (ccl::%map-areas
+ (lambda (thing)
+ (cond ((and (not (eq thing object))
+ (ccl::uvectorp thing)
+ (not (ccl::ivectorp thing)))
+ (dotimes (i (ccl::uvsize thing))
+ (when (eq object (ccl::uvref thing i))
+ (push thing res)
+ (return))))
+ ((consp thing)
+ (when(or (eq object (car thing))
+ (eq object (cdr thing)))
+ (push thing res))))))
+ res))
+
+;; Return true if P is heap-consed
+(defun pointer-in-some-dynamic-area-p (p)
+ (block found
+ (ccl::do-consing-areas (a)
+ (when (eql (%fixnum-ref a target::area.code) ccl::area-dynamic)
+ (when (ccl::%ptr-in-area-p p a)
+ (return-from found t))))))
+
+;; Find all transitive referencers to object-or-list. If as-object is
+;; true, just start with object-or-list. If as-object is false, then if
+;; object-or-list is a list, start with its elements, and ignore its
+;; cons cells.
+;; Returns a hash table with the references as keys.
+(defun transitive-referencers (object-or-list &optional as-object)
+ (let ((found (make-hash-table :test 'eq)))
+ (cond ((or (atom object-or-list) as-object)
+ (setf (gethash object-or-list found) t))
+ (t (loop for cons on object-or-list
+ do
+ (setf (gethash cons found) t
+ (gethash (car cons) found) t))))
+ (ccl:gc)
+ (format t "Searching") (finish-output)
+ (loop
+ (let ((added-one nil))
+ (format t " ~d" (hash-table-count found)) (finish-output)
+ (ccl::%map-areas
+ (lambda (thing)
+ (unless (or (not (pointer-in-some-dynamic-area-p thing))
+ (gethash thing found))
+ (cond ((and (not (eq thing (ccl::nhash.vector found)))
+ (ccl::uvectorp thing)
+ (not (ccl::ivectorp thing))
+ (not (packagep thing)))
+ (dotimes (i (ccl::uvsize thing))
+ (let ((object (ccl::uvref thing i)))
+ (when (gethash object found)
+ (setf (gethash thing found) t
+ added-one t)
+ (return)))))
+ ((and (consp thing)
+ (pointer-in-some-dynamic-area-p (car thing))
+ (pointer-in-some-dynamic-area-p (cdr thing)))
+ (when (or (gethash (car thing) found)
+ (gethash (cdr thing) found))
+ (setf (gethash thing found) t)))))))
+ (unless added-one
+ (return))))
+ (format t " done.~%") (finish-output)
+ ;; Eliminate any cons that is referenced by another cons.
+ ;; Also eliminate or replace objects that nobody will want to see.
+ (let ((cons-refs (make-hash-table :test 'eq))
+ (additions nil))
+ (loop for cons being the hash-keys of found
+ when (consp cons)
+ do
+ (when (consp (car cons))
+ (setf (gethash (car cons) cons-refs) t))
+ (when (consp (cdr cons))
+ (setf (gethash (cdr cons) cons-refs) t)))
+ (loop for key being the hash-keys of found
+ when (or (and (consp key) (gethash key cons-refs))
+ (and (consp key) (eq (car key) 'ccl::function-source-=
note))
+ (typep key 'ccl::hash-table-vector)
+ (when (typep key 'ccl::symbol-vector)
+ (push (ccl::%symvector->symptr key) additions)
+ t)
+ (when (typep key 'ccl::function-vector)
+ (push (ccl::%function-vector-to-function key) addit=
ions)
+ t))
+ do
+ (remhash key found))
+ (dolist (addition additions)
+ (setf (gethash addition found) t))
+ (remhash object-or-list found)
+ (unless (or (atom object-or-list) as-object)
+ (loop for cons on object-or-list
+ do
+ (remhash cons found)
+ (remhash (car cons) found)))
+ found)))
+
+;; One convenient way to print the hash table returned by transitive-refer=
encers
+(defun print-referencers (hash &key
+ predicate
+ (pause-period 20)
+ (print-circle t)
+ (print-length 20)
+ (print-level 5))
+ (let ((cnt 0)
+ (*print-circle* print-circle)
+ (*print-length* print-length)
+ (*print-level* print-level))
+ (maphash (lambda (key value)
+ (declare (ignore value))
+ (when (or (null predicate) (funcall predicate key))
+ (format t "~s~%" key)
+ (when (> (incf cnt) pause-period)
+ (format t "Continue (Y/N)? ")
+ (unless (equalp (read-line) "Y")
+ (return-from print-referencers))
+ (setq cnt 0))))
+ hash)))
+
+;; Returns all the obsolete CLOS instances, those whose class has been
+;; changed since they were created. Each will be updated as soon as
+;; method dispatch is done on it."
+(defun obsolete-instances (list)
+ (let ((res nil))
+ (dolist (i list)
+ (when (eq 0 (ccl::%wrapper-hash-index (ccl::instance-class-wrapper i=
)))
+ (push i res)))
+ res))
+
+;; Linux-only malloc leak finding
+#+linux-target
+(progn
+
+;; (ccl::start-mtrace LOGFILE)
+;; Do some work.
+;; (ccl::stop-mtrace)
+;; (ccl::parse-mtrace-log LOGFILE)
+(defun start-mtrace (log-file)
+ (touch log-file)
+ (setf log-file (probe-file log-file))
+ (setenv "MALLOC_TRACE" (namestring log-file))
+ (gc)
+ (#_mtrace))
+
+(defun stop-mtrace ()
+ (gc)
+ (#_muntrace))
+
+(defun parse-mtrace-log (log-file)
+ (with-open-file (s log-file)
+ (let ((hash (make-hash-table :test 'equal))
+ (eof (list :eof)))
+ (loop for line =3D (read-line s nil eof)
+ until (eq line eof)
+ when (and (> (length line) 2)
+ (equal "@ " (subseq line 0 2)))
+ do
+ (setf line (subseq line 2))
+ (let ((plus-pos (search " + " line))
+ (minus-pos (search " - " line)))
+ (cond (plus-pos
+ (let* ((where (subseq line 0 plus-pos))
+ (addr-and-size (subseq line (+ plus-pos 3)))
+ (space-pos (position #\space addr-and-size))
+ (addr (subseq addr-and-size 0 space-pos))
+ (size (subseq addr-and-size (1+ space-pos))))
+ (setf (gethash addr hash) (list where size))))
+ (minus-pos
+ (let ((addr (subseq line (+ minus-pos 3))))
+ (remhash addr hash))))))
+ (let ((res nil))
+ (maphash (lambda (key value)
+ (push (append value (list key)) res))
+ hash)
+ res))))
+
+;; Return the total number of bytes allocated by malloc()
+(defun mallinfo ()
+ (ccl:rlet ((mallinfo :mallinfo))
+ (#_mallinfo mallinfo)
+ (ccl::rref mallinfo :mallinfo.uordblks)))
+
+) ;; end of linux-only code
More information about the Openmcl-cvs-notifications
mailing list