Changeset 13436


Ignore:
Timestamp:
Feb 6, 2010, 5:11:54 PM (10 years ago)
Author:
gz
Message:

Add parse-proc-maps and proc-maps-diff; extend mtrace parser a bit

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/library/leaks.lisp

    r13208 r13436  
    221221;; (ccl::stop-mtrace)
    222222;; (ccl::parse-mtrace-log LOGFILE)
    223 (defun start-mtrace (log-file)
     223(defun start-mtrace (log-file &key gc-first)
     224  (delete-file log-file)
    224225  (touch log-file)
    225   (setf log-file (probe-file log-file))
    226   (setenv "MALLOC_TRACE" (namestring log-file))
    227   (gc)
     226  (setenv "MALLOC_TRACE" (native-translated-namestring (truename log-file)))
     227  (when gc-first (gc))
    228228  (#_mtrace))
    229229
    230 (defun stop-mtrace ()
    231   (gc)
     230(defun stop-mtrace (&key gc-first)
     231  (when gc-first (gc))
    232232  (#_muntrace))
    233233
    234 (defun parse-mtrace-log (log-file)
    235   (with-open-file (s log-file)
    236     (let ((hash (make-hash-table :test 'equal))
    237           (free-list '())
    238           (eof (list :eof)))
    239       (loop for line = (read-line s nil eof)
    240             until (eq line eof)
    241             when (and (> (length line) 2)
    242                       (equal "@ " (subseq line 0 2)))
    243               do
    244            (setf line (subseq line 2))
    245            (let ((plus-pos (or (search " + " line) (search " > " line)))
    246                  (minus-pos (or (search " - " line) (search " < " line))))
    247              (cond (plus-pos
    248                     (let* ((where (subseq line 0 plus-pos))
    249                            (addr-and-size (subseq line (+ plus-pos 3)))
    250                            (space-pos (position #\space addr-and-size))
    251                            (addr (subseq addr-and-size 0 space-pos))
    252                            (size (subseq addr-and-size (1+ space-pos))))
    253                       (setf (gethash addr hash) (list where size))))
    254                    (minus-pos
    255                     (let* ((where (subseq line 0 minus-pos))
    256                            (addr (subseq line (+ minus-pos 3)))
    257                            (found (nth-value 1 (gethash addr hash))))
    258                       (if found
    259                         (remhash addr hash)
    260                         (push (list where addr) free-list)))))))
    261       (let ((res nil))
    262         (maphash (lambda (key value)
    263                    (push (append value (list key)) res))
    264                  hash)
    265         (values res free-list)))))
    266 
    267 (defun pretty-print-mtrace-summary (file)
    268   (let* ((malloc-sum 0))
    269     (multiple-value-bind (mallocs frees) (parse-mtrace-log file)
    270       (dolist (i mallocs)
    271         (incf malloc-sum (parse-integer (second i) :radix 16 :start 2))
    272         (format t "~&~A" i))
    273       (format t "~&Freed but not malloced:~%~{~A~%~}" frees)
    274       (format t "~&total-malloc-not-freed: ~A ~A free not malloc: ~A"
     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"
    275311              (/ malloc-sum 1024.0)
    276               (length mallocs)
    277               (length frees)))))
     312              malloc-count
     313              free-count)))
     314  (values))
     315
    278316
    279317;; Return the total number of bytes allocated by malloc()
     
    325363      (format t "~& total size of free chunks = ~d/#x~x" fordblks fordblks)
    326364      (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))
    327414
    328415)  ;; end of linux-only code
Note: See TracChangeset for help on using the changeset viewer.