/[cmucl]/src/tools/heapanal.lisp
ViewVC logotype

Contents of /src/tools/heapanal.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Mon Mar 1 18:48:40 1993 UTC (21 years, 1 month ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Initial revision
1 ;;; -*- Package: HEAPANAL -*-
2
3 (in-package "HEAPANAL")
4 (use-package "SYSTEM")
5 (use-package "EXT")
6 (use-package "MACH")
7 (use-package "ALIEN")
8 (use-package "C-CALL")
9
10
11 ;;;; MACH primitives we need.
12
13 (def-alien-routine ("vm_read" vm_read) int
14 (task port)
15 (address unsigned-long)
16 (size unsigned-long)
17 (data system-area-pointer :out)
18 (data-size unsigned-long :out))
19
20 (def-alien-routine ("task_by_unix_pid" task_by_unix_pid) int
21 (task port)
22 (pid unsigned-long)
23 (result port :out))
24
25
26
27 ;;;; Data structures for holding the info.
28
29 (defstruct (heap-info
30 (:constructor make-heap-info (pid))
31 (:print-function %print-heap-info))
32 ;;
33 ;; The UNIX pid for the task we are interested in.
34 (pid (required-argument))
35 ;;
36 ;; The MACH port for the task.
37 (task (gr-call* task_by_unix_pid *task-self* pid))
38 ;;
39 ;; Cache used by read-heap.
40 (prev-addr nil :type (or null (unsigned-byte 32)))
41 (prev-sap nil :type (or null system-area-pointer))
42 ;;
43 ;; Symbol table used by the task, or NIL if it's the same as ours.
44 (symbol-table nil :type (or null hash-table))
45 ;;
46 ;; The range of dynamic space, so we can tell dynamic pointers.
47 (dynamic-start nil :type (or null (unsigned-byte 32)))
48 (dynamic-end nil :type (or null (unsigned-byte 32)))
49 ;;
50 ;; Hash table mapping addresses to objects.
51 (objects (make-hash-table :test #'equal :size 1000 :rehash-size 1000))
52 ;;
53 ;; Queue of ungroveled objects. Objects are added at the head, and poped
54 ;; from the tail.
55 (queue-head nil :type list)
56 (queue-tail nil :type list))
57
58 (defun %print-heap-info (info stream depth)
59 (declare (ignore depth))
60 (print-unreadable-object (info stream :type t :identity t)
61 (format stream "for pid ~D" (heap-info-pid info))))
62
63 (defstruct (object
64 (:print-function %print-object)
65 (:constructor make-object (address)))
66 ;;
67 ;; The address this object lives at.
68 (address (required-argument) :type (unsigned-byte 32))
69 ;;
70 ;; List of references to this object. Each entry is either an object,
71 ;; or an ub-32 stack address.
72 (references nil :type list))
73
74 (defun %print-object (object stream depth)
75 (declare (ignore depth))
76 (print-unreadable-object (object stream :type t)
77 (format stream "#x~8,'0X" (object-address object))))
78
79
80
81 ;;;; Interface to importing stuff.
82
83 (defparameter page-size (get-page-size))
84
85 (defun read-heap (info address)
86 (declare (type heap-info info))
87 (multiple-value-bind (page offset) (truncate address page-size)
88 (let ((address (* page page-size)))
89 (cond
90 ((and (heap-info-prev-addr info)
91 (= (heap-info-prev-addr info) address))
92 (values (sap+ (heap-info-prev-sap info) offset)
93 (- (* page-size 2) offset)))
94 (t
95 (when (heap-info-prev-sap info)
96 (gr-call vm_deallocate *task-self* (heap-info-prev-sap info)
97 (* page-size 2))
98 (setf (heap-info-prev-addr info) nil)
99 (setf (heap-info-prev-sap info) nil))
100 (gr-bind (base size)
101 (vm_read (heap-info-task info) address (* page-size 2))
102 (declare (ignore size))
103 (setf (heap-info-prev-addr info) address)
104 (setf (heap-info-prev-sap info) base)
105 (values (sap+ base offset)
106 (- (* page-size 2) offset))))))))
107
108
109 ;;;; Symbol table interface.
110
111 (defun load-symbol-table (info pathname)
112 (with-open-file (stream pathname)
113 (setf (heap-info-symbol-table info) (make-hash-table :test #'equal))
114 ))
115
116 (defun extract-foreign-symbol-value (info name)
117 (let ((sym-tab (heap-info-symbol-table info)))
118 (sap-ref-32 (read-heap info
119 (if sym-tab
120 (or (gethash name sym-tab)
121 (error "Unknown foreign symbol: ~S" name))
122 (sap-int (foreign-symbol-address name))))
123 0)))
124
125
126
127 ;;;; Utilities.
128
129 (defun find-object (info addr &optional create)
130 (let ((object (gethash addr (heap-info-objects info))))
131 (when (and (null object) create)
132 (setf object (make-object addr))
133 (let ((new (list object)))
134 (if (heap-info-queue-head info)
135 (setf (cdr (heap-info-queue-head info)) new
136 (heap-info-queue-head info) new)
137 (setf (heap-info-queue-head info) new
138 (heap-info-queue-tail info) new)))
139 (setf (gethash addr (heap-info-objects info)) object))
140 object))
141
142 (defun next-object (info)
143 (let ((tail (heap-info-queue-tail info)))
144 (when tail
145 (let ((result (pop tail)))
146 (setf (heap-info-queue-tail info) tail)
147 (unless tail
148 (setf (heap-info-queue-head info) nil))
149 result))))
150
151 (declaim (inline dynamic-pointer-p))
152 (defun dynamic-pointer-p (info ptr)
153 (and (logbitp 0 ptr)
154 (<= (heap-info-dynamic-start info) ptr)
155 (< ptr (heap-info-dynamic-end info))))
156
157
158 ;;;;
159
160 (defun grovel-stack (info start end)
161 (let ((addr start))
162 (loop
163 (when (>= addr end)
164 (return))
165 (multiple-value-bind (sap bytes) (read-heap info addr)
166 (let ((count (min bytes (- end addr))))
167 (dotimes (index (floor count 4))
168 (let ((value (sap-ref-32 sap (* index 4))))
169 (when (dynamic-pointer-p info value)
170 (push (+ addr (* index 4))
171 (object-references (find-object info value t))))))
172 (incf addr count))))))
173
174 (defun grovel-control-stack (info)
175 (format t "Groveling control stack...~%")
176 (grovel-stack
177 info
178 (extract-foreign-symbol-value info "control_stack")
179 (extract-foreign-symbol-value info "current_control_stack_pointer")))
180
181 (defun grovel-binding-stack (info)
182 (format t "Groveling binding stack...~%")
183 (grovel-stack
184 info
185 (extract-foreign-symbol-value info "binding_stack")
186 (extract-foreign-symbol-value info "current_binding_stack_pointer")))
187
188 (defun grovel-object (info object)
189 (let* ((orig-addr (object-address object))
190 (lowtag (logand orig-addr vm:lowtag-mask))
191 (address (- orig-addr lowtag)))
192 (multiple-value-bind
193 (sap available)
194 (read-heap info address)
195 (multiple-value-bind
196 (words words-to-grovel)
197 (ecase lowtag
198 (#.vm:list-pointer-type
199 (values 2 2))
200 (#.vm:instance-pointer-type
201 (let* ((header (sap-ref-32 sap 0))
202 (length (1+ (ash header (- vm:type-bits)))))
203 (values length length)))
204 (#.vm:other-pointer-type
205 (let* ((header (sap-ref-32 sap 0))
206 (type (logand header vm:type-mask)))
207 (flet ((vector-len (bits-per-element &optional (extra 0))
208 (+ (ceiling (* (+ (ash (sap-ref-32
209 sap
210 (* vm:vector-length-slot 4))
211 -2)
212 extra)
213 bits-per-element)
214 vm:word-bits)
215 vm:vector-data-offset)))
216 (declare (inline vector-len))
217 (ecase type
218 ((#.vm:bignum-type
219 #.vm:single-float-type
220 #.vm:double-float-type
221 #.vm:sap-type)
222 (values (1+ (ash header (- vm:type-bits))) 0))
223 ((#.vm:ratio-type
224 #.vm:complex-type
225 #.vm:simple-array-type
226 #.vm:complex-string-type
227 #.vm:complex-bit-vector-type
228 #.vm:complex-vector-type
229 #.vm:complex-array-type
230 #.vm:value-cell-header-type
231 #.vm:symbol-header-type
232 #.vm:weak-pointer-type
233 #.vm:fdefn-type)
234 (let ((length (1+ (ash header (- vm:type-bits)))))
235 (values length length)))
236 (#.vm:simple-string-type
237 (values (vector-len 8 1) 0))
238 (#.vm:simple-bit-vector-type
239 (values (vector-len 1) 0))
240 (#.vm:simple-array-unsigned-byte-2-type
241 (values (vector-len 2) 0))
242 (#.vm:simple-array-unsigned-byte-4-type
243 (values (vector-len 4) 0))
244 (#.vm:simple-array-unsigned-byte-8-type
245 (values (vector-len 8) 0))
246 (#.vm:simple-array-unsigned-byte-16-type
247 (values (vector-len 16) 0))
248 ((#.vm:simple-array-unsigned-byte-32-type
249 #.vm:simple-array-single-float-type)
250 (values (vector-len 32) 0))
251 (#.vm:simple-array-double-float-type
252 (values (vector-len 64) 0))
253 (#.vm:simple-vector-type
254 (let ((length (vector-len 32)))
255 (values length length)))
256 (#.vm:code-header-type
257 (values
258 (ash (sap-ref-32 sap (* vm:code-code-size-slot 8)) -2)
259 (ash header (- vm:type-bits))))
260 (#.vm:return-pc-header-type
261 (push object
262 (object-references
263 (find-object info
264 (- orig-addr
265 (* (ash header (- vm:type-bits)) 4))
266 t)))
267 (values 2 0))))))
268 (#.vm:function-pointer-type
269 (let* ((header (sap-ref-32 sap 0))
270 (type (logand header vm:type-mask)))
271 (ecase type
272 ((#.vm:closure-header-type
273 #.vm:funcallable-instance-header-type)
274 (let ((length (1+ (ash header (- vm:type-bits)))))
275 (values length length)))
276 ((#.vm:function-header-type
277 #.vm:closure-function-header-type)
278 (push object
279 (object-references
280 (find-object
281 info
282 (+ (- address
283 (* (ash header (- vm:type-bits)) 4))
284 vm:other-pointer-type)
285 t)))
286 (values vm:function-code-offset
287 vm:function-code-offset))))))
288 (unless (zerop words-to-grovel)
289 (loop
290 (let ((count (min (floor available 4) words-to-grovel)))
291 (dotimes (i count)
292 (let ((value (sap-ref-32 sap (* i 4))))
293 (when (dynamic-pointer-p info value)
294 (push object
295 (object-references (find-object info value t))))))
296 (decf words-to-grovel count)
297 (when (<= words-to-grovel 0)
298 (return))
299 (incf address (* count 4))
300 (multiple-value-setq (sap available) (read-heap info address)))))
301 words))))
302
303 (defun grovel-static-space (info)
304 (format t "Groveling static space")
305 (force-output)
306 (let ((addr
307 (extract-foreign-symbol-value info "static_space"))
308 (end
309 (sap-ref-32 (read-heap info
310 (logandc2 (kernel:get-lisp-obj-address
311 'lisp::*static-space-free-pointer*)
312 vm:lowtag-mask))
313 (* vm:symbol-value-slot 4)))
314 (count 0))
315 (loop
316 (when (>= addr end)
317 (return))
318 (incf count)
319 (when (>= count 1000)
320 (write-char #\.)
321 (force-output)
322 (setf count 0))
323 (let* ((header (sap-ref-32 (read-heap info addr) 0))
324 (object
325 (if (= (logand header 3) 2)
326 ;; There is an other-immedate there, maybe it's a header.
327 (let ((type (logand header vm:type-mask)))
328 (cond ((= type vm:instance-header-type)
329 (logior addr vm:instance-pointer-type))
330 ((<= type vm:code-header-type)
331 (logior addr vm:other-pointer-type))
332 ((<= type vm:closure-function-header-type)
333 (logior addr vm:function-pointer-type))
334 ((or (= type vm:base-char-type)
335 (= type vm:unbound-marker-type))
336 ;; Assume we've got a cons pointing to it.
337 (logior addr vm:list-pointer-type))
338 (t
339 (logior addr vm:other-pointer-type))))
340 ;; It doesn't point to a header, so assume it's a cons cell.
341 (logior addr vm:list-pointer-type)))
342 (words (grovel-object info (make-object object))))
343 (incf addr (ash (ash (1+ words) -1) 3))))))
344
345 (defun grovel-objects (info)
346 (format t "~&Groveling dynamic space")
347 (let ((count 0))
348 (loop
349 (incf count)
350 (when (>= count 1000)
351 (write-char #\.)
352 (force-output)
353 (setf count 0))
354 (let ((object (next-object info)))
355 (if object
356 (grovel-object info object)
357 (return))))))
358
359 (defun grovel-heap (pid &key symbol-table)
360 (let ((info (make-heap-info pid)))
361 (when symbol-table
362 (load-symbol-table info symbol-table))
363 (setf (heap-info-dynamic-start info)
364 (extract-foreign-symbol-value info "current_dynamic_space"))
365 (setf (heap-info-dynamic-end info)
366 (extract-foreign-symbol-value info
367 "current_dynamic_space_free_pointer"))
368 (grovel-control-stack info)
369 (grovel-binding-stack info)
370 (grovel-static-space info)
371 (grovel-objects info)
372 info))
373
374 (defun find-instances-of-type (info type-address)
375 (let ((results nil))
376 (maphash #'(lambda (key object)
377 (declare (ignore key))
378 (let ((address (object-address object)))
379 (when (and (= (logand address vm:lowtag-mask)
380 vm:instance-pointer-type)
381 (= (sap-ref-32
382 (read-heap info
383 (- address
384 vm:instance-pointer-type))
385 4)
386 type-address))
387 (push object results))))
388 (heap-info-objects info))
389 results))
390
391 (defun find-roots-for (info address)
392 (let ((object (find-object info address)))
393 (unless object
394 (error "#x~8,'0X does not appear to be reachable in ~S" address info))
395 (let ((queue (list (list object)))
396 (depth 0))
397 (loop
398 (let ((list queue)
399 (any-results nil))
400 (setf queue nil)
401 (format t "Searching at depth ~D~%" depth)
402 (dolist (entry list)
403 (let ((object (car entry)))
404 (cond ((and (object-p object)
405 (dynamic-pointer-p info (object-address object)))
406 (dolist (reference (object-references object))
407 (unless (member reference entry)
408 (push (cons reference entry) queue))))
409 (t
410 (unless any-results
411 (terpri))
412 (setf any-results t)
413 (describe-path info entry)))))
414 (unless queue
415 (return))
416 (when any-results
417 (return))
418 (incf depth)))))
419 nil)
420
421 (defun describe-path (info path)
422 (dolist (object path)
423 (describe-object info object))
424 (terpri))
425
426 (defun extract-symbol-name (info address)
427 (let* ((pname-addr (sap-ref-32 (read-heap info
428 (- address
429 vm:other-pointer-type))
430 (* vm:symbol-name-slot 4)))
431 (sap (read-heap info (- pname-addr vm:other-pointer-type)))
432 (len (ash (sap-ref-32 sap 1) -2))
433 (result (make-string len)))
434 (dotimes (i len)
435 (setf (schar result i)
436 (code-char (sap-ref-8 sap
437 (+ i
438 (* vm:vector-data-offset
439 vm:word-bytes))))))
440 result))
441
442 (defun describe-object (info object)
443 (if (object-p object)
444 (let* ((orig-addr (object-address object))
445 (lowtag (logand orig-addr vm:lowtag-mask))
446 (addr (- orig-addr lowtag)))
447 (ecase lowtag
448 (#.vm:list-pointer-type
449 (format t "Cons cell #x~8,'0X~%" orig-addr))
450 (#.vm:instance-pointer-type
451 (format t "Instance ~A at #x~8,'0X~%"
452 (extract-symbol-name info
453 (sap-ref-32 (read-heap info addr) 4))
454 orig-addr))
455 ((#.vm:other-pointer-type
456 #.vm:function-pointer-type)
457 (let ((header (sap-ref-32 (read-heap info addr) 0)))
458 (format t "~A at #x~8,'0X~%"
459 (ecase (logand header vm:type-mask)
460 (#.vm:symbol-header-type
461 (format nil "Symbol ~A"
462 (extract-symbol-name info orig-addr)))
463 (#.vm:bignum-type "bignum")
464 (#.vm:ratio-type "ratio")
465 (#.vm:single-float-type "single-float")
466 (#.vm:double-float-type "double-float")
467 (#.vm:complex-type "complex")
468 (#.vm:simple-array-type "simple-array")
469 (#.vm:simple-string-type "simple-string")
470 (#.vm:simple-bit-vector-type "simple-bit-vector")
471 (#.vm:simple-vector-type "simple-vector")
472 (#.vm:simple-array-unsigned-byte-2-type
473 "simple-array-unsigned-byte-2")
474 (#.vm:simple-array-unsigned-byte-4-type
475 "simple-array-unsigned-byte-4")
476 (#.vm:simple-array-unsigned-byte-8-type
477 "simple-array-unsigned-byte-8")
478 (#.vm:simple-array-unsigned-byte-16-type
479 "simple-array-unsigned-byte-16")
480 (#.vm:simple-array-unsigned-byte-32-type
481 "simple-array-unsigned-byte-32")
482 (#.vm:simple-array-single-float-type
483 "simple-array-single-float")
484 (#.vm:simple-array-double-float-type
485 "simple-array-double-float")
486 (#.vm:complex-string-type "complex-string")
487 (#.vm:complex-bit-vector-type "complex-bit-vector")
488 (#.vm:complex-vector-type "complex-vector")
489 (#.vm:complex-array-type "complex-array")
490 (#.vm:code-header-type "code-header")
491 (#.vm:function-header-type "function")
492 (#.vm:closure-header-type "closure-header")
493 (#.vm:funcallable-instance-header-type
494 "funcallable-instance-header")
495 (#.vm:closure-function-header-type
496 "closure-function")
497 (#.vm:return-pc-header-type "return-pc-header")
498 (#.vm:value-cell-header-type "value-cell-header")
499 (#.vm:symbol-header-type "symbol-header")
500 (#.vm:sap-type "sap")
501 (#.vm:weak-pointer-type "weak-pointer")
502 (#.vm:fdefn-type "fdefn"))
503 orig-addr)))))
504 (format t "Stack reference at #x~8,'0X~%" object)))

  ViewVC Help
Powered by ViewVC 1.1.5