[Openmcl-cvs-notifications] r13485 - in /trunk/source: ./ library/leaks.lisp
gz at clozure.com
gz at clozure.com
Fri Mar 5 17:31:34 UTC 2010
Author: gz
Date: Fri Mar 5 11:31:33 2010
New Revision: 13485
Log:
Merge r13436 into trunk: parse-proc-maps, proc-maps-diff, mtrace extensions.
Modified:
trunk/source/ (props changed)
trunk/source/library/leaks.lisp
Propchange: trunk/source/
---------------------------------------------------------------------------=
---
--- svn:mergeinfo (original)
+++ svn:mergeinfo Fri Mar 5 11:31:33 2010
@@ -1,2 +1,2 @@
/branches/new-random:13310-13326
-/branches/working-0711/ccl:7620-13192,13197-13198,13202,13208,13214,13235-=
13236,13239,13263,13277-13278,13290,13293-13294,13302-13306
+/branches/working-0711/ccl:7620-13192,13197-13198,13202,13208,13214,13235-=
13236,13239,13263,13277-13278,13290,13293-13294,13302-13306,13436
Modified: 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 (original)
+++ trunk/source/library/leaks.lisp Fri Mar 5 11:31:33 2010
@@ -220,61 +220,99 @@
;; Do some work.
;; (ccl::stop-mtrace)
;; (ccl::parse-mtrace-log LOGFILE)
-(defun start-mtrace (log-file)
+(defun start-mtrace (log-file &key gc-first)
+ (delete-file log-file)
(touch log-file)
- (setf log-file (probe-file log-file))
- (setenv "MALLOC_TRACE" (namestring log-file))
- (gc)
+ (setenv "MALLOC_TRACE" (native-translated-namestring (truename log-file)=
))
+ (when gc-first (gc))
(#_mtrace))
=
-(defun stop-mtrace ()
- (gc)
+(defun stop-mtrace (&key gc-first)
+ (when gc-first (gc))
(#_muntrace))
=
-(defun parse-mtrace-log (log-file)
- (with-open-file (s log-file)
- (let ((hash (make-hash-table :test 'equal))
- (free-list '())
- (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 (or (search " + " line) (search " > " line)))
- (minus-pos (or (search " - " line) (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* ((where (subseq line 0 minus-pos))
- (addr (subseq line (+ minus-pos 3)))
- (found (nth-value 1 (gethash addr hash))))
- (if found
- (remhash addr hash)
- (push (list where addr) free-list)))))))
- (let ((res nil))
- (maphash (lambda (key value)
- (push (append value (list key)) res))
- hash)
- (values res free-list)))))
-
-(defun pretty-print-mtrace-summary (file)
- (let* ((malloc-sum 0))
- (multiple-value-bind (mallocs frees) (parse-mtrace-log file)
- (dolist (i mallocs)
- (incf malloc-sum (parse-integer (second i) :radix 16 :start 2))
- (format t "~&~A" i))
- (format t "~&Freed but not malloced:~%~{~A~%~}" frees)
- (format t "~&total-malloc-not-freed: ~A ~A free not malloc: ~A"
+(defun parse-mtrace-log (log-file &key (duplicate-alloc :show)
+ (unmatched-free :collect)
+ (failed-realloc :show)
+ (hash (make-hash-table :test 'eql))
+ (id nil))
+ (let ((errors nil))
+ (with-open-file (stream log-file)
+ (loop for line =3D (read-line stream nil nil) while line
+ as pos =3D (if (and (> (length line) 2) (eql (aref line 0) #\@=
) (eql (aref line 1) #\space))
+ (1+ (position #\space line :start 2))
+ 0)
+ as address =3D (let ((npos (+ pos 2)))
+ (when (and (< (+ npos 2) (length line))
+ (eql (aref line npos) #\0)
+ (eql (aref line (1+ npos)) #\x))
+ (parse-integer line :radix 16
+ :start (+ npos 2)
+ :end (position #\space line :s=
tart npos))))
+ as last-data =3D (gethash address hash)
+ do (ecase (aref line pos)
+ ((#\+ #\>)
+ (let ((this-data (if id (cons id line) line)))
+ (if last-data
+ (ecase duplicate-alloc
+ (:collect (push (list :duplicate
+ (if (eq (aref line pos) =
#\+) :alloc :realloc)
+ last-data this-data)
+ errors))
+ ((:show nil) (format t "Duplicate ~a:~%~a~%~a~=
%"
+ (if (eq (aref line pos) #=
\+) "alloc" "realloc")
+ last-data this-data))
+ (:ignore nil))
+ (setf (gethash address hash) this-data))))
+ ((#\- #\<)
+ (if last-data
+ (remhash address hash)
+ (let ((this-data (if id (cons id line) line)))
+ (ecase unmatched-free
+ (:collect (push (list :unmatched
+ (if (eq (aref line pos) =
#\-) :free :realloc)
+ this-data)
+ errors))
+ ((:show nil) (format t "Unmatched ~a: ~a~%"
+ (if (eq (aref line pos) #=
\-) "free" "realloc")
+ this-data))
+ (:ignore nil)))))
+ ((#\=3D) ;; ignore start/end
+ ;; (format t "~&~a" line)
+ nil)
+ ((#\!)
+ (let ((this-data (if id (cons id line) line)))
+ (ecase failed-realloc
+ (:collect (push (list :failed :realloc this-data) =
errors))
+ ((:show nil) (format t "Failed realloc: ~a" this-d=
ata))
+ (:ignore nil)))))))
+ (values (nreverse errors) hash)))
+
+(defun pretty-print-mtrace-summary (log-file)
+ (multiple-value-bind (errors malloc-hash) (parse-mtrace-log log-file)
+ (let* ((malloc-sum 0)
+ (malloc-count 0)
+ (free-count 0))
+ (when (> (hash-table-count malloc-hash) 0)
+ (format t "~&Malloced but not freed:~%")
+ (loop for line being the hash-value of malloc-hash
+ do (let* ((plus-pos (or (search " + " line) (search " > " li=
ne)))
+ (size-pos (position #\space line :start (+ plus-po=
s 3))))
+ (incf malloc-count)
+ (incf malloc-sum (parse-integer line :radix 16 :start (=
+ size-pos 3)))
+ (format t "~& ~A" line))))
+ (when (find :unmatched errors :key #'car)
+ (format t "~&Freed but not malloced:~%")
+ (loop for (type nil line) in errors
+ do (when (eq type :unmatched)
+ (incf free-count)
+ (format t " ~a" line))))
+ (format t "~&~aK in ~a mallocs not freed, ~A frees not malloced"
(/ malloc-sum 1024.0)
- (length mallocs)
- (length frees)))))
+ malloc-count
+ free-count)))
+ (values))
+
=
;; Return the total number of bytes allocated by malloc()
(defun mallinfo ()
@@ -324,6 +362,55 @@
(format t "~& total size of malloc'ed chunks =3D ~d/#x~x" uordblks u=
ordblks)
(format t "~& total size of free chunks =3D ~d/#x~x" fordblks fordbl=
ks)
(format t "~& size of releaseable chunk =3D ~d/#x~x" keepcost keepco=
st))))
+
+
+
+;; Parse /proc/<pid>/maps
+
+(defun parse-proc-maps (&optional (pid (ccl::getpid)))
+ (let ((perm-cache ())
+ (name-cache ()))
+ (with-open-file (s (format nil "/proc/~d/maps" pid))
+ (loop for line =3D (read-line s nil) while line
+ as low-end =3D (position #\- line)
+ as high-end =3D (position #\space line :start (1+ low-end))
+ as perms-end =3D (position #\space line :start (1+ high-end))
+ as offset-end =3D (position #\space line :start (1+ perms-end))
+ as device-end =3D (position #\space line :start (1+ offset-end=
))
+ as inode-end =3D (position #\space line :start (1+ device-end))
+ as name-start =3D (position #\space line :start inode-end :tes=
t-not #'eql)
+ as low =3D (parse-integer line :start 0 :end low-end :radix 16)
+ as high =3D (parse-integer line :start (1+ low-end) :end high-=
end :radix 16)
+ as perms =3D (let ((p (subseq line (1+ high-end) perms-end)))
+ (or (find p perm-cache :test #'equal)
+ (car (setq perm-cache (cons p perm-cache)))))
+ as name =3D (and name-start
+ (let ((f (subseq line name-start)))
+ (or (find f name-cache :test #'equal)
+ (car (setq name-cache (cons f name-cache)=
)))))
+ collect (list low high perms name)))))
+
+(defun proc-maps-diff (map1 map2)
+ ;; Compute change from map1 to map2.
+ ;; Remove segment -> (:remove low high ...)
+ ;; Add segment -> (:add low high ...)
+ ;; grow segment -> (:grow low high new-high ...)
+ (let ((added (copy-list map2))
+ (changes nil))
+ (loop for m1 in map1 as match =3D (find (car m1) added :key #'car)
+ do (when match
+ (setq added (delete match added))
+ (unless (equal (cddr m1) (cddr match))
+ (warn "Segment changed ~s -> ~s" m1 match)))
+ do (cond ((null match)
+ (push `(:remove ,(- (car m1) (cadr m1)) , at m1) changes))
+ ((< (cadr m1) (cadr match))
+ (push `(:grow ,(- (cadr match) (cadr m1)) , at m1) change=
s)) =
+ ((< (cadr match) (cadr m1))
+ (push `(:shrink ,(- (cadr match) (cadr m1)) , at m1) chan=
ges)) =
+ (t nil)))
+ (loop for m in added do (push `(:new ,(- (cadr m) (car m)) , at m) change=
s))
+ changes))
=
) ;; end of linux-only code
=
More information about the Openmcl-cvs-notifications
mailing list