1 ;;;; heap-grovelling memory usage stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; type format database
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
18 ;; the name of this type
19 (name nil :type symbol)
20 ;; kind of type (how we determine length)
22 :type (member :lowtag :fixed :header :vector
23 :string :code :closure :instance))
24 ;; length if fixed-length, shift amount for element size if :VECTOR
25 (length nil :type (or fixnum null))))
27 (eval-when (:compile-toplevel :execute)
29 (defvar *meta-room-info* (make-array 256 :initial-element nil))
31 (dolist (obj *primitive-objects*)
32 (let ((widetag (primitive-object-widetag obj))
33 (lowtag (primitive-object-lowtag obj))
34 (name (primitive-object-name obj))
35 (variable (primitive-object-variable-length-p obj))
36 (size (primitive-object-size obj)))
39 (;; KLUDGE described in dan_b message "Another one for the
40 ;; collection [bug 108]" (sbcl-devel 2004-01-22)
42 ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T)) causes
43 ;; debugger invoked on a SB-INT:BUG in thread 5911:
44 ;; failed AVER: "(SAP= CURRENT END)"
45 ;; [WHN: Similar things happened on one but not the other of my
46 ;; machines when I just run ROOM a lot in a loop.]
48 ;; This appears to be due to my [DB] abuse of the primitive
49 ;; object macros to define a thread object that shares a lowtag
50 ;; with fixnums and has no widetag: it looks like the code that
51 ;; generates *META-ROOM-INFO* infers from this that even fixnums
52 ;; are thread-sized - probably undesirable.
54 ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the
55 ;; nature of a workaround than a really good fix. I'm not sure
56 ;; what a really good fix is: I /think/ it's probably to remove
57 ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach
58 ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros
59 ;; for assembly source in the runtime/genesis/*.h files.
62 (let ((info (make-room-info :name name
64 (lowtag (symbol-value lowtag)))
65 (declare (fixnum lowtag))
67 (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
70 (setf (svref *meta-room-info* (symbol-value widetag))
71 (make-room-info :name name
75 (dolist (code (list #!+sb-unicode complex-character-string-widetag
76 complex-base-string-widetag simple-array-widetag
77 complex-bit-vector-widetag complex-vector-widetag
78 complex-array-widetag complex-vector-nil-widetag))
79 (setf (svref *meta-room-info* code)
80 (make-room-info :name 'array-header
83 (setf (svref *meta-room-info* bignum-widetag)
84 (make-room-info :name 'bignum
87 (setf (svref *meta-room-info* closure-header-widetag)
88 (make-room-info :name 'closure
91 (dolist (stuff '((simple-bit-vector-widetag . -3)
92 (simple-vector-widetag . 2)
93 (simple-array-unsigned-byte-2-widetag . -2)
94 (simple-array-unsigned-byte-4-widetag . -1)
95 (simple-array-unsigned-byte-7-widetag . 0)
96 (simple-array-unsigned-byte-8-widetag . 0)
97 (simple-array-unsigned-byte-15-widetag . 1)
98 (simple-array-unsigned-byte-16-widetag . 1)
99 (simple-array-unsigned-byte-31-widetag . 2)
100 (simple-array-unsigned-byte-32-widetag . 2)
101 (simple-array-unsigned-byte-60-widetag . 3)
102 (simple-array-unsigned-byte-63-widetag . 3)
103 (simple-array-unsigned-byte-64-widetag . 3)
104 (simple-array-signed-byte-8-widetag . 0)
105 (simple-array-signed-byte-16-widetag . 1)
106 (simple-array-unsigned-byte-29-widetag . 2)
107 (simple-array-signed-byte-30-widetag . 2)
108 (simple-array-signed-byte-32-widetag . 2)
109 (simple-array-signed-byte-61-widetag . 3)
110 (simple-array-signed-byte-64-widetag . 3)
111 (simple-array-single-float-widetag . 2)
112 (simple-array-double-float-widetag . 3)
113 (simple-array-complex-single-float-widetag . 3)
114 (simple-array-complex-double-float-widetag . 4)))
115 (let* ((name (car stuff))
117 (sname (string name)))
119 (setf (svref *meta-room-info* (symbol-value name))
120 (make-room-info :name (intern (subseq sname
122 (mismatch sname "-WIDETAG"
127 (setf (svref *meta-room-info* simple-base-string-widetag)
128 (make-room-info :name 'simple-base-string
133 (setf (svref *meta-room-info* simple-character-string-widetag)
134 (make-room-info :name 'simple-character-string
138 (setf (svref *meta-room-info* simple-array-nil-widetag)
139 (make-room-info :name 'simple-array-nil
143 (setf (svref *meta-room-info* code-header-widetag)
144 (make-room-info :name 'code
147 (setf (svref *meta-room-info* instance-header-widetag)
148 (make-room-info :name 'instance
153 (defparameter *room-info* '#.*meta-room-info*)
154 (deftype spaces () '(member :static :dynamic :read-only))
156 ;;;; MAP-ALLOCATED-OBJECTS
158 ;;; Since they're represented as counts of words, we should never
159 ;;; need bignums to represent these:
160 (declaim (type fixnum
161 *static-space-free-pointer*
162 *read-only-space-free-pointer*))
164 (defun space-bounds (space)
165 (declare (type spaces space))
168 (values (int-sap static-space-start)
169 (int-sap (* *static-space-free-pointer* n-word-bytes))))
171 (values (int-sap read-only-space-start)
172 (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
174 (values (int-sap (current-dynamic-space-start))
175 (dynamic-space-free-pointer)))))
177 ;;; Return the total number of bytes used in SPACE.
178 (defun space-bytes (space)
179 (multiple-value-bind (start end) (space-bounds space)
180 (- (sap-int end) (sap-int start))))
182 ;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
183 #!-sb-fluid (declaim (inline round-to-dualword))
184 (defun round-to-dualword (size)
185 (declare (fixnum size))
186 (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
188 ;;; Return the total size of a vector in bytes, including any pad.
189 #!-sb-fluid (declaim (inline vector-total-size))
190 (defun vector-total-size (obj info)
191 (let ((shift (room-info-length info))
192 (len (+ (length (the (simple-array * (*)) obj))
193 (ecase (room-info-kind info)
197 (+ (* vector-data-offset n-word-bytes)
199 (ash (+ len (1- (ash 1 (- shift))))
203 ;;; Access to the GENCGC page table for better precision in
204 ;;; MAP-ALLOCATED-OBJECTS
207 (define-alien-type (struct page)
210 ;; On platforms with small enough GC pages, this field
211 ;; will be a short. On platforms with larger ones, it'll
213 (bytes-used (unsigned
214 #.(if (typep sb!vm:gencgc-page-size
220 (declaim (inline find-page-index))
221 (define-alien-routine "find_page_index" long (index long))
222 (define-alien-variable "page_table" (* (struct page))))
224 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
225 ;;; the object, the object's type code, and the object's total size in
226 ;;; bytes, including any header and padding.
227 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
228 (defun map-allocated-objects (fun space)
229 (declare (type function fun) (type spaces space))
231 (multiple-value-bind (start end) (space-bounds space)
232 (declare (type system-area-pointer start end))
233 (declare (optimize (speed 3)))
234 (let ((current start)
235 #!+gencgc (skip-tests-until-addr 0))
236 (labels ((maybe-finish-mapping ()
237 (unless (sap< current end)
238 (aver (sap= current end))
239 (return-from map-allocated-objects)))
240 ;; GENCGC doesn't allocate linearly, which means that the
241 ;; dynamic space can contain large blocks zeros that get
242 ;; accounted as conses in ROOM (and slow down other
243 ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
244 ;; check the GC page structure for the current address.
245 ;; If the page is free or the address is beyond the page-
246 ;; internal allocation offset (bytes-used) skip to the
247 ;; next page immediately.
250 (when (eq space :dynamic)
251 (loop with page-mask = #.(1- sb!vm:gencgc-page-size)
252 for addr of-type sb!vm:word = (sap-int current)
253 while (>= addr skip-tests-until-addr)
255 ;; For some reason binding PAGE with LET
256 ;; conses like mad (but gives no compiler notes...)
257 ;; Work around the problem with SYMBOL-MACROLET
258 ;; instead of trying to figure out the real
259 ;; issue. -- JES, 2005-05-17
261 ((page (deref page-table
262 (find-page-index addr))))
263 ;; Don't we have any nicer way to access C struct
265 (let ((alloc-flag (ldb (byte 3 2)
267 (bytes-used (slot page 'bytes-used)))
268 ;; If the page is not free and the current
269 ;; pointer is still below the allocation offset
271 (when (and (not (zerop alloc-flag))
272 (<= (logand page-mask addr)
274 ;; Don't bother testing again until we
275 ;; get past that allocation offset
276 (setf skip-tests-until-addr
277 (+ (logandc2 addr page-mask)
278 (the fixnum bytes-used)))
279 ;; And then continue with the scheduled
281 (return-from maybe-skip-page))
282 ;; Move CURRENT to start of next page
283 (setf current (int-sap (+ (logandc2 addr page-mask)
284 sb!vm:gencgc-page-size)))
285 (maybe-finish-mapping)))))))
286 (declare (inline maybe-finish-mapping maybe-skip-page))
288 (maybe-finish-mapping)
290 (let* ((header (sap-ref-word current 0))
291 (header-widetag (logand header #xFF))
292 (info (svref *room-info* header-widetag)))
295 (eq (room-info-kind info) :lowtag))
296 (let ((size (* cons-size n-word-bytes)))
298 (make-lisp-obj (logior (sap-int current)
299 list-pointer-lowtag))
302 (setq current (sap+ current size))))
303 ((eql header-widetag closure-header-widetag)
304 (let* ((obj (make-lisp-obj (logior (sap-int current)
305 fun-pointer-lowtag)))
306 (size (round-to-dualword
307 (* (the fixnum (1+ (get-closure-length obj)))
309 (funcall fun obj header-widetag size)
310 (setq current (sap+ current size))))
311 ((eq (room-info-kind info) :instance)
312 (let* ((obj (make-lisp-obj
313 (logior (sap-int current) instance-pointer-lowtag)))
314 (size (round-to-dualword
315 (* (+ (%instance-length obj) 1) n-word-bytes))))
316 (declare (fixnum size))
317 (funcall fun obj header-widetag size)
318 (aver (zerop (logand size lowtag-mask)))
319 (setq current (sap+ current size))))
321 (let* ((obj (make-lisp-obj
322 (logior (sap-int current) other-pointer-lowtag)))
323 (size (ecase (room-info-kind info)
325 (aver (or (eql (room-info-length info)
326 (1+ (get-header-data obj)))
328 (simple-array-nil-p obj)))
330 (* (room-info-length info) n-word-bytes)))
332 (vector-total-size obj info))
335 (* (1+ (get-header-data obj)) n-word-bytes)))
338 (* (get-header-data obj) n-word-bytes))
340 (* (the fixnum (%code-code-size obj))
342 (declare (fixnum size))
343 (funcall fun obj header-widetag size)
344 (aver (zerop (logand size lowtag-mask)))
345 (setq current (sap+ current size))))))))))))
350 ;;; Return a list of 3-lists (bytes object type-name) for the objects
351 ;;; allocated in Space.
352 (defun type-breakdown (space)
353 (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
354 (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
355 (map-allocated-objects
356 (lambda (obj type size)
357 (declare (fixnum size) (optimize (speed 3)) (ignore obj))
358 (incf (aref sizes type) size)
359 (incf (aref counts type)))
362 (let ((totals (make-hash-table :test 'eq)))
364 (let ((total-count (aref counts i)))
365 (unless (zerop total-count)
366 (let* ((total-size (aref sizes i))
367 (name (room-info-name (aref *room-info* i)))
368 (found (gethash name totals)))
370 (incf (first found) total-size)
371 (incf (second found) total-count))
373 (setf (gethash name totals)
374 (list total-size total-count name))))))))
376 (collect ((totals-list))
377 (maphash (lambda (k v)
381 (sort (totals-list) #'> :key #'first)))))
383 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
384 ;;; (space-name . totals-for-space), where totals-for-space is the list
385 ;;; returned by TYPE-BREAKDOWN.
386 (defun print-summary (spaces totals)
387 (let ((summary (make-hash-table :test 'eq)))
388 (dolist (space-total totals)
389 (dolist (total (cdr space-total))
390 (push (cons (car space-total) total)
391 (gethash (third total) summary))))
393 (collect ((summary-totals))
394 (maphash (lambda (k v)
397 (declare (fixnum sum))
398 (dolist (space-total v)
399 (incf sum (first (cdr space-total))))
400 (summary-totals (cons sum v))))
403 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
404 (let ((summary-total-bytes 0)
405 (summary-total-objects 0))
406 (declare (fixnum summary-total-bytes summary-total-objects))
407 (dolist (space-totals
408 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
409 (let ((total-objects 0)
412 (declare (fixnum total-objects total-bytes))
414 (dolist (space-total space-totals)
415 (let ((total (cdr space-total)))
416 (setq name (third total))
417 (incf total-bytes (first total))
418 (incf total-objects (second total))
419 (spaces (cons (car space-total) (first total)))))
420 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
421 name total-bytes total-objects)
422 (dolist (space (spaces))
423 (format t ", ~W% ~(~A~)"
424 (round (* (cdr space) 100) total-bytes)
427 (incf summary-total-bytes total-bytes)
428 (incf summary-total-objects total-objects))))
429 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
430 summary-total-bytes summary-total-objects)))))
432 ;;; Report object usage for a single space.
433 (defun report-space-total (space-total cutoff)
434 (declare (list space-total) (type (or single-float null) cutoff))
435 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
436 (let* ((types (cdr space-total))
437 (total-bytes (reduce #'+ (mapcar #'first types)))
438 (total-objects (reduce #'+ (mapcar #'second types)))
439 (cutoff-point (if cutoff
440 (truncate (* (float total-bytes) cutoff))
443 (reported-objects 0))
444 (declare (fixnum total-objects total-bytes cutoff-point reported-objects
446 (loop for (bytes objects name) in types do
447 (when (<= bytes cutoff-point)
448 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
449 (- total-bytes reported-bytes)
450 (- total-objects reported-objects))
452 (incf reported-bytes bytes)
453 (incf reported-objects objects)
454 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
456 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
457 total-bytes total-objects (car space-total))))
459 ;;; Print information about the heap memory in use. PRINT-SPACES is a
460 ;;; list of the spaces to print detailed information for.
461 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
462 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
463 ;;; PRINT-SUMMARY is true, then summary information will be printed.
464 ;;; The defaults print only summary information for dynamic space. If
465 ;;; true, CUTOFF is a fraction of the usage in a report below which
466 ;;; types will be combined as OTHER.
467 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
468 (print-summary t) cutoff)
469 (declare (type (or single-float null) cutoff))
470 (let* ((spaces (if (eq count-spaces t)
471 '(:static :dynamic :read-only)
473 (totals (mapcar (lambda (space)
474 (cons space (type-breakdown space)))
477 (dolist (space-total totals)
478 (when (or (eq print-spaces t)
479 (member (car space-total) print-spaces))
480 (report-space-total space-total cutoff)))
482 (when print-summary (print-summary spaces totals)))
486 ;;; Print info about how much code and no-ops there are in SPACE.
487 (defun count-no-ops (space)
488 (declare (type spaces space))
492 (declare (fixnum code-words no-ops)
493 (type unsigned-byte total-bytes))
494 (map-allocated-objects
495 (lambda (obj type size)
496 (declare (fixnum size))
497 (when (eql type code-header-widetag)
498 (incf total-bytes size)
499 (let ((words (truly-the fixnum (%code-code-size obj)))
500 (sap (truly-the system-area-pointer
501 (%primitive code-instructions obj))))
502 (incf code-words words)
504 (when (zerop (sap-ref-word sap (* i n-word-bytes)))
509 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
510 total-bytes code-words no-ops
511 (round (* no-ops 100) code-words)))
515 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
516 (let ((descriptor-words 0)
517 (non-descriptor-headers 0)
518 (non-descriptor-bytes 0))
519 (declare (type unsigned-byte descriptor-words non-descriptor-headers
520 non-descriptor-bytes))
521 (dolist (space (or spaces '(:read-only :static :dynamic)))
522 (declare (inline map-allocated-objects))
523 (map-allocated-objects
524 (lambda (obj type size)
525 (declare (fixnum size))
527 (#.code-header-widetag
528 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
529 (declare (type fixnum inst-words))
530 (incf non-descriptor-bytes (* inst-words n-word-bytes))
531 (incf descriptor-words
532 (- (truncate size n-word-bytes) inst-words))))
534 #.single-float-widetag
535 #.double-float-widetag
536 #.simple-base-string-widetag
537 #!+sb-unicode #.simple-character-string-widetag
538 #.simple-array-nil-widetag
539 #.simple-bit-vector-widetag
540 #.simple-array-unsigned-byte-2-widetag
541 #.simple-array-unsigned-byte-4-widetag
542 #.simple-array-unsigned-byte-8-widetag
543 #.simple-array-unsigned-byte-16-widetag
544 #.simple-array-unsigned-byte-32-widetag
545 #.simple-array-signed-byte-8-widetag
546 #.simple-array-signed-byte-16-widetag
547 ; #.simple-array-signed-byte-30-widetag
548 #.simple-array-signed-byte-32-widetag
549 #.simple-array-single-float-widetag
550 #.simple-array-double-float-widetag
551 #.simple-array-complex-single-float-widetag
552 #.simple-array-complex-double-float-widetag)
553 (incf non-descriptor-headers)
554 (incf non-descriptor-bytes (- size n-word-bytes)))
555 ((#.list-pointer-lowtag
556 #.instance-pointer-lowtag
559 #.simple-array-widetag
560 #.simple-vector-widetag
561 #.complex-base-string-widetag
562 #.complex-vector-nil-widetag
563 #.complex-bit-vector-widetag
564 #.complex-vector-widetag
565 #.complex-array-widetag
566 #.closure-header-widetag
567 #.funcallable-instance-header-widetag
568 #.value-cell-header-widetag
569 #.symbol-header-widetag
571 #.weak-pointer-widetag
572 #.instance-header-widetag)
573 (incf descriptor-words (truncate size n-word-bytes)))
575 (error "bogus widetag: ~W" type))))
577 (format t "~:D words allocated for descriptor objects.~%"
579 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
580 non-descriptor-bytes non-descriptor-headers)
583 ;;; Print a breakdown by instance type of all the instances allocated
584 ;;; in SPACE. If TOP-N is true, print only information for the
585 ;;; TOP-N types with largest usage.
586 (defun instance-usage (space &key (top-n 15))
587 (declare (type spaces space) (type (or fixnum null) top-n))
588 (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
589 (let ((totals (make-hash-table :test 'eq))
592 (declare (fixnum total-objects total-bytes))
593 (map-allocated-objects
594 (lambda (obj type size)
595 (declare (fixnum size) (optimize (speed 3)))
596 (when (eql type instance-header-widetag)
598 (incf total-bytes size)
599 (let* ((classoid (layout-classoid (%instance-ref obj 0)))
600 (found (gethash classoid totals)))
602 (incf (the fixnum (car found)))
603 (incf (the fixnum (cdr found)) size))
605 (setf (gethash classoid totals) (cons 1 size)))))))
608 (collect ((totals-list))
609 (maphash (lambda (classoid what)
610 (totals-list (cons (prin1-to-string
611 (classoid-proper-name classoid))
614 (let ((sorted (sort (totals-list) #'> :key #'cddr))
617 (declare (fixnum printed-bytes printed-objects))
618 (dolist (what (if top-n
619 (subseq sorted 0 (min (length sorted) top-n))
621 (let ((bytes (cddr what))
622 (objects (cadr what)))
623 (incf printed-bytes bytes)
624 (incf printed-objects objects)
625 (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what)
628 (let ((residual-objects (- total-objects printed-objects))
629 (residual-bytes (- total-bytes printed-bytes)))
630 (unless (zerop residual-objects)
631 (format t " Other types: ~:D bytes, ~:D object~:P.~%"
632 residual-bytes residual-objects))))
634 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
635 space total-bytes total-objects)))
639 ;;;; PRINT-ALLOCATED-OBJECTS
641 (defun print-allocated-objects (space &key (percent 0) (pages 5)
642 type larger smaller count
643 (stream *standard-output*))
644 (declare (type (integer 0 99) percent) (type index pages)
645 (type stream stream) (type spaces space)
646 (type (or index null) type larger smaller count))
647 (multiple-value-bind (start-sap end-sap) (space-bounds space)
648 (let* ((space-start (sap-int start-sap))
649 (space-end (sap-int end-sap))
650 (space-size (- space-end space-start))
651 (pagesize (sb!sys:get-page-size))
652 (start (+ space-start (round (* space-size percent) 100)))
653 (printed-conses (make-hash-table :test 'eq))
657 (declare (type (unsigned-byte 32) last-page start)
658 (fixnum pages-so-far count-so-far pagesize))
659 (labels ((note-conses (x)
660 (unless (or (atom x) (gethash x printed-conses))
661 (setf (gethash x printed-conses) t)
662 (note-conses (car x))
663 (note-conses (cdr x)))))
664 (map-allocated-objects
665 (lambda (obj obj-type size)
666 (let ((addr (get-lisp-obj-address obj)))
667 (when (>= addr start)
669 (> count-so-far count)
670 (> pages-so-far pages))
671 (return-from print-allocated-objects (values)))
674 (let ((this-page (* (the (values (unsigned-byte 32) t)
675 (truncate addr pagesize))
677 (declare (type (unsigned-byte 32) this-page))
678 (when (/= this-page last-page)
679 (when (< pages-so-far pages)
680 ;; FIXME: What is this? (ERROR "Argh..")? or
681 ;; a warning? or code that can be removed
682 ;; once the system is stable? or what?
683 (format stream "~2&**** Page ~W, address ~X:~%"
685 (setq last-page this-page)
686 (incf pages-so-far))))
688 (when (and (or (not type) (eql obj-type type))
689 (or (not smaller) (<= size smaller))
690 (or (not larger) (>= size larger)))
693 (#.code-header-widetag
694 (let ((dinfo (%code-debug-info obj)))
695 (format stream "~&Code object: ~S~%"
697 (sb!c::compiled-debug-info-name dinfo)
699 (#.symbol-header-widetag
700 (format stream "~&~S~%" obj))
701 (#.list-pointer-lowtag
702 (unless (gethash obj printed-conses)
704 (let ((*print-circle* t)
707 (format stream "~&~S~%" obj))))
710 (let ((str (write-to-string obj :level 5 :length 10
712 (unless (eql type instance-header-widetag)
713 (format stream "~S: " (type-of obj)))
714 (format stream "~A~%"
715 (subseq str 0 (min (length str) 60))))))))))
719 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
721 (defvar *ignore-after* nil)
723 (defun valid-obj (space x)
724 (or (not (eq space :dynamic))
725 ;; this test looks bogus if the allocator doesn't work linearly,
726 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
727 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
729 (defun maybe-cons (space x stuff)
730 (if (valid-obj space x)
734 (defun list-allocated-objects (space &key type larger smaller count
736 (declare (type spaces space)
737 (type (or index null) larger smaller type count)
738 (type (or function null) test)
739 (inline map-allocated-objects))
740 (unless *ignore-after*
741 (setq *ignore-after* (cons 1 2)))
742 (collect ((counted 0 1+))
744 (map-allocated-objects
745 (lambda (obj obj-type size)
746 (when (and (or (not type) (eql obj-type type))
747 (or (not smaller) (<= size smaller))
748 (or (not larger) (>= size larger))
749 (or (not test) (funcall test obj)))
750 (setq res (maybe-cons space obj res))
751 (when (and count (>= (counted) count))
752 (return-from list-allocated-objects res))))
756 (defun map-referencing-objects (fun space object)
757 (declare (type spaces space) (inline map-allocated-objects))
758 (unless *ignore-after*
759 (setq *ignore-after* (cons 1 2)))
760 (flet ((maybe-call (fun obj)
761 (when (valid-obj space obj)
763 (map-allocated-objects
764 (lambda (obj obj-type size)
765 (declare (ignore obj-type size))
768 (when (or (eq (car obj) object)
769 (eq (cdr obj) object))
770 (maybe-call fun obj)))
772 (dotimes (i (%instance-length obj))
773 (when (eq (%instance-ref obj i) object)
777 (let ((length (get-header-data obj)))
778 (do ((i code-constants-offset (1+ i)))
780 (when (eq (code-header-ref obj i) object)
784 (dotimes (i (length obj))
785 (when (eq (svref obj i) object)
789 (when (or (eq (symbol-name obj) object)
790 (eq (symbol-package obj) object)
791 (eq (symbol-plist obj) object)
792 (eq (symbol-value obj) object))
793 (maybe-call fun obj)))))
796 (defun list-referencing-objects (space object)
798 (map-referencing-objects
799 (lambda (obj) (res obj)) space object)