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 (declaim (special sb!vm:*read-only-space-free-pointer*
15 sb!vm:*static-space-free-pointer*))
17 ;;;; type format database
19 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
21 ;; the name of this type
22 (name nil :type symbol)
23 ;; kind of type (how to reconstitute an object)
25 :type (member :other :closure :instance :list
26 :code :vector-nil :weak-pointer))))
28 (defun room-info-type-name (info)
29 (if (specialized-array-element-type-properties-p info)
30 (saetp-primitive-type-name info)
31 (room-info-name info)))
33 (eval-when (:compile-toplevel :execute)
35 (defvar *meta-room-info* (make-array 256 :initial-element nil))
37 (dolist (obj *primitive-objects*)
38 (let ((widetag (primitive-object-widetag obj))
39 (lowtag (primitive-object-lowtag obj))
40 (name (primitive-object-name obj)))
41 (when (and (eq lowtag 'other-pointer-lowtag)
42 (not (member widetag '(t nil)))
43 (not (eq name 'weak-pointer)))
44 (setf (svref *meta-room-info* (symbol-value widetag))
45 (make-room-info :name name
48 (dolist (code (list #!+sb-unicode complex-character-string-widetag
49 complex-base-string-widetag simple-array-widetag
50 complex-bit-vector-widetag complex-vector-widetag
51 complex-array-widetag complex-vector-nil-widetag))
52 (setf (svref *meta-room-info* code)
53 (make-room-info :name 'array-header
56 (setf (svref *meta-room-info* bignum-widetag)
57 (make-room-info :name 'bignum
60 (setf (svref *meta-room-info* closure-header-widetag)
61 (make-room-info :name 'closure
64 (dotimes (i (length *specialized-array-element-type-properties*))
65 (let ((saetp (aref *specialized-array-element-type-properties* i)))
66 (when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case.
67 (setf (svref *meta-room-info* (saetp-typecode saetp)) saetp))))
69 (setf (svref *meta-room-info* simple-array-nil-widetag)
70 (make-room-info :name 'simple-array-nil
73 (setf (svref *meta-room-info* code-header-widetag)
74 (make-room-info :name 'code
77 (setf (svref *meta-room-info* instance-header-widetag)
78 (make-room-info :name 'instance
81 (setf (svref *meta-room-info* funcallable-instance-header-widetag)
82 (make-room-info :name 'funcallable-instance
85 (setf (svref *meta-room-info* weak-pointer-widetag)
86 (make-room-info :name 'weak-pointer
89 (let ((cons-info (make-room-info :name 'cons
91 ;; A cons consists of two words, both of which may be either a
92 ;; pointer or immediate data. According to the runtime this means
93 ;; either a fixnum, a character, an unbound-marker, a single-float
94 ;; on a 64-bit system, or a pointer.
95 (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits)))
96 (setf (svref *meta-room-info* (ash i n-fixnum-tag-bits)) cons-info))
98 (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits)))
99 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
100 instance-pointer-lowtag))
102 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
103 list-pointer-lowtag))
105 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
108 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
109 other-pointer-lowtag))
112 (setf (svref *meta-room-info* character-widetag) cons-info)
114 (setf (svref *meta-room-info* unbound-marker-widetag) cons-info)
116 ;; Single-floats are immediate data on 64-bit systems.
117 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
118 (setf (svref *meta-room-info* single-float-widetag) cons-info))
122 (defparameter *room-info*
123 ;; SAETP instances don't dump properly from XC (or possibly
124 ;; normally), and we'd rather share structure with the master copy
125 ;; if we can anyway, so...
131 (if (specialized-array-element-type-properties-p info)
132 `(aref *specialized-array-element-type-properties*
133 ,(position info *specialized-array-element-type-properties*))
136 (deftype spaces () '(member :static :dynamic :read-only))
138 ;;;; MAP-ALLOCATED-OBJECTS
140 ;;; Since they're represented as counts of words, we should never
141 ;;; need bignums to represent these:
142 (declaim (type fixnum
143 *static-space-free-pointer*
144 *read-only-space-free-pointer*))
146 (defun space-bounds (space)
147 (declare (type spaces space))
150 (values (int-sap static-space-start)
151 (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))
153 (values (int-sap read-only-space-start)
154 (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))
156 (values (int-sap (current-dynamic-space-start))
157 (dynamic-space-free-pointer)))))
159 ;;; Return the total number of bytes used in SPACE.
160 (defun space-bytes (space)
161 (multiple-value-bind (start end) (space-bounds space)
162 (- (sap-int end) (sap-int start))))
164 ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
165 ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
166 ;;; platforms with 64-bit word size.
167 #!-sb-fluid (declaim (inline round-to-dualword))
168 (defun round-to-dualword (size)
169 (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))
171 ;;; Return the vector OBJ, its WIDETAG, and the number of octets
172 ;;; required for its storage (including padding and alignment).
173 (defun reconstitute-vector (obj saetp)
174 (declare (type (simple-array * (*)) obj)
175 (type specialized-array-element-type-properties saetp))
176 (let* ((length (+ (length obj)
177 (saetp-n-pad-elements saetp)))
178 (n-bits (saetp-n-bits saetp))
179 (alignment-pad (floor 7 n-bits))
180 (n-data-octets (if (>= n-bits 8)
181 (* length (ash n-bits -3))
182 (ash (* (+ length alignment-pad)
186 (saetp-typecode saetp)
187 (round-to-dualword (+ (* vector-data-offset n-word-bytes)
190 ;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
191 ;;; of a lisp object, return the object, its "type code" (either
192 ;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
193 ;;; required for its storage (including padding and alignment). Note
194 ;;; that this function is designed to NOT CONS, even if called
196 (defun reconstitute-object (address)
197 (let* ((object-sap (int-sap (get-lisp-obj-address address)))
198 (header (sap-ref-word object-sap 0))
199 (widetag (logand header widetag-mask))
200 (header-value (ash header (- n-widetag-bits)))
201 (info (svref *room-info* widetag)))
203 ((boxed-size (round-to-dualword (ash (1+ header-value) word-shift))))
205 ((tagged-object (tag)
206 `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address)))))
208 ;; Pick off arrays, as they're the only plausible cause for
209 ;; a non-nil, non-ROOM-INFO object as INFO.
210 ((specialized-array-element-type-properties-p info)
211 (reconstitute-vector (tagged-object other-pointer-lowtag) info))
214 (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
217 ((eq (room-info-kind info) :list)
218 (values (tagged-object list-pointer-lowtag)
222 ((eq (room-info-kind info) :closure)
223 (values (tagged-object fun-pointer-lowtag)
227 ((eq (room-info-kind info) :instance)
228 (values (tagged-object instance-pointer-lowtag)
232 ((eq (room-info-kind info) :other)
233 (values (tagged-object other-pointer-lowtag)
237 ((eq (room-info-kind info) :vector-nil)
238 (values (tagged-object other-pointer-lowtag)
239 simple-array-nil-widetag
242 ((eq (room-info-kind info) :weak-pointer)
243 (values (tagged-object other-pointer-lowtag)
249 ((eq (room-info-kind info) :code)
250 (values (tagged-object other-pointer-lowtag)
255 (sap-ref-lispobj object-sap
256 (* code-code-size-slot
261 (error "Unrecognized room-info-kind ~S in reconstitute-object"
262 (room-info-kind info))))))))
264 ;;; Iterate over all the objects in the contiguous block of memory
265 ;;; with the low address at START and the high address just before
266 ;;; END, calling FUN with the object, the object's type code, and the
267 ;;; object's total size in bytes, including any header and padding.
268 ;;; START and END are untagged, aligned memory addresses interpreted
269 ;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
270 (defun map-objects-in-range (fun start end)
271 (declare (type function fun))
272 ;; If START is (unsigned) greater than END, then we have somehow
273 ;; blown past our endpoint.
274 (aver (<= (get-lisp-obj-address start)
275 (get-lisp-obj-address end)))
276 (unless (= start end)
279 (reconstitute-object start)
280 (aver (zerop (logand n-lowtag-bits size)))
282 ;; This special little dance is to add a number of octets
283 ;; (and it had best be a number evenly divisible by our
284 ;; allocation granularity) to an unboxed, aligned address
285 ;; masquerading as a fixnum. Without consing.
287 (mask-field (byte #.n-word-bits 0)
288 (+ (get-lisp-obj-address start)
290 (funcall fun obj typecode size)
291 (map-objects-in-range fun next-start end)))))
293 ;;; Access to the GENCGC page table for better precision in
294 ;;; MAP-ALLOCATED-OBJECTS
297 (define-alien-type (struct page)
300 ;; On platforms with small enough GC pages, this field
301 ;; will be a short. On platforms with larger ones, it'll
303 (bytes-used (unsigned
304 #.(if (typep sb!vm:gencgc-card-bytes
310 (declaim (inline find-page-index))
311 (define-alien-routine "find_page_index" long (index signed))
312 (define-alien-variable "last_free_page" sb!kernel::page-index-t)
313 (define-alien-variable "heap_base" (* t))
314 (define-alien-variable "page_table" (* (struct page))))
316 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
317 ;;; the object, the object's type code, and the object's total size in
318 ;;; bytes, including any header and padding. CAREFUL makes
319 ;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it
320 ;;; is intended for slightly more demanding uses of heap groveling
322 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
323 (defun map-allocated-objects (fun space)
324 (declare (type function fun)
329 ;; Static space starts with NIL, which requires special
330 ;; handling, as the header and alignment are slightly off.
331 (multiple-value-bind (start end) (space-bounds space)
332 (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
333 (map-objects-in-range fun
334 (%make-lisp-obj (+ (* 8 n-word-bytes)
336 (%make-lisp-obj (sap-int end)))))
338 ((:read-only #!-gencgc :dynamic)
339 ;; Read-only space (and dynamic space on cheneygc) is a block
340 ;; of contiguous allocations.
341 (multiple-value-bind (start end) (space-bounds space)
342 (map-objects-in-range fun
343 (%make-lisp-obj (sap-int start))
344 (%make-lisp-obj (sap-int end)))))
348 ;; Dynamic space on gencgc requires walking the GC page tables
349 ;; in order to determine what regions contain objects.
351 ;; We explicitly presume that any pages in an allocation region
352 ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
353 ;; (indicating a full page) or an otherwise-valid BYTES-USED.
354 ;; We also presume that the pages of an open allocation region
355 ;; after the first page, and any pages that are unallocated,
356 ;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
358 ;; Our procedure is to scan forward through the page table,
359 ;; maintaining an "end pointer" until we reach a page where
360 ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
361 ;; LAST-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
362 ;; is not empty, and proceed to the next page (unless we've hit
363 ;; LAST-FREE-PAGE). We happily take advantage of the fact that
364 ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
365 ;; coincident pointers for the range.
367 ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
368 ;; closing allocation regions and opening new ones. This may
369 ;; prove to be an issue with concurrent systems, or with
370 ;; spectacularly poor timing for closing an allocation region
371 ;; in a single-threaded system.
374 with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
375 ;; This magic dance gets us an unboxed aligned pointer as a
377 with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
380 ;; This is our page range.
381 for page-index from 0 below last-free-page
382 for next-page-addr from (+ start page-size) by page-size
383 for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)
385 when (< page-bytes-used gencgc-card-bytes)
387 (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
388 (map-objects-in-range fun start end)
389 (setf start next-page-addr)
390 (setf end next-page-addr))
391 else do (incf end page-size)
393 finally (map-objects-in-range fun start end))))))
397 ;;; Return a list of 3-lists (bytes object type-name) for the objects
398 ;;; allocated in Space.
399 (defun type-breakdown (space)
400 (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
401 (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
402 (map-allocated-objects
403 (lambda (obj type size)
404 (declare (word size) (optimize (speed 3)) (ignore obj))
405 (incf (aref sizes type) size)
406 (incf (aref counts type)))
409 (let ((totals (make-hash-table :test 'eq)))
411 (let ((total-count (aref counts i)))
412 (unless (zerop total-count)
413 (let* ((total-size (aref sizes i))
414 (name (room-info-type-name (aref *room-info* i)))
415 (found (gethash name totals)))
417 (incf (first found) total-size)
418 (incf (second found) total-count))
420 (setf (gethash name totals)
421 (list total-size total-count name))))))))
423 (collect ((totals-list))
424 (maphash (lambda (k v)
428 (sort (totals-list) #'> :key #'first)))))
430 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
431 ;;; (space-name . totals-for-space), where totals-for-space is the list
432 ;;; returned by TYPE-BREAKDOWN.
433 (defun print-summary (spaces totals)
434 (let ((summary (make-hash-table :test 'eq)))
435 (dolist (space-total totals)
436 (dolist (total (cdr space-total))
437 (push (cons (car space-total) total)
438 (gethash (third total) summary))))
440 (collect ((summary-totals))
441 (maphash (lambda (k v)
444 (declare (unsigned-byte sum))
445 (dolist (space-total v)
446 (incf sum (first (cdr space-total))))
447 (summary-totals (cons sum v))))
450 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
451 (let ((summary-total-bytes 0)
452 (summary-total-objects 0))
453 (declare (unsigned-byte summary-total-bytes summary-total-objects))
454 (dolist (space-totals
455 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
456 (let ((total-objects 0)
459 (declare (unsigned-byte total-objects total-bytes))
461 (dolist (space-total space-totals)
462 (let ((total (cdr space-total)))
463 (setq name (third total))
464 (incf total-bytes (first total))
465 (incf total-objects (second total))
466 (spaces (cons (car space-total) (first total)))))
467 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
468 name total-bytes total-objects)
469 (dolist (space (spaces))
470 (format t ", ~W% ~(~A~)"
471 (round (* (cdr space) 100) total-bytes)
474 (incf summary-total-bytes total-bytes)
475 (incf summary-total-objects total-objects))))
476 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
477 summary-total-bytes summary-total-objects)))))
479 ;;; Report object usage for a single space.
480 (defun report-space-total (space-total cutoff)
481 (declare (list space-total) (type (or single-float null) cutoff))
482 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
483 (let* ((types (cdr space-total))
484 (total-bytes (reduce #'+ (mapcar #'first types)))
485 (total-objects (reduce #'+ (mapcar #'second types)))
486 (cutoff-point (if cutoff
487 (truncate (* (float total-bytes) cutoff))
490 (reported-objects 0))
491 (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
493 (loop for (bytes objects name) in types do
494 (when (<= bytes cutoff-point)
495 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
496 (- total-bytes reported-bytes)
497 (- total-objects reported-objects))
499 (incf reported-bytes bytes)
500 (incf reported-objects objects)
501 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
503 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
504 total-bytes total-objects (car space-total))))
506 ;;; Print information about the heap memory in use. PRINT-SPACES is a
507 ;;; list of the spaces to print detailed information for.
508 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
509 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
510 ;;; PRINT-SUMMARY is true, then summary information will be printed.
511 ;;; The defaults print only summary information for dynamic space. If
512 ;;; true, CUTOFF is a fraction of the usage in a report below which
513 ;;; types will be combined as OTHER.
514 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
515 (print-summary t) cutoff)
516 (declare (type (or single-float null) cutoff))
517 (let* ((spaces (if (eq count-spaces t)
518 '(:static :dynamic :read-only)
520 (totals (mapcar (lambda (space)
521 (cons space (type-breakdown space)))
524 (dolist (space-total totals)
525 (when (or (eq print-spaces t)
526 (member (car space-total) print-spaces))
527 (report-space-total space-total cutoff)))
529 (when print-summary (print-summary spaces totals)))
533 ;;; Print info about how much code and no-ops there are in SPACE.
534 (defun count-no-ops (space)
535 (declare (type spaces space))
539 (declare (fixnum code-words no-ops)
540 (type unsigned-byte total-bytes))
541 (map-allocated-objects
542 (lambda (obj type size)
543 (when (eql type code-header-widetag)
544 (let ((words (truly-the fixnum (%code-code-size obj)))
545 (sap (%primitive code-instructions obj))
547 (declare (fixnum size))
548 (incf total-bytes size)
549 (incf code-words words)
551 (when (zerop (sap-ref-word sap (* i n-word-bytes)))
556 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
557 total-bytes code-words no-ops
558 (round (* no-ops 100) code-words)))
562 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
563 (let ((descriptor-words 0)
564 (non-descriptor-headers 0)
565 (non-descriptor-bytes 0))
566 (declare (type unsigned-byte descriptor-words non-descriptor-headers
567 non-descriptor-bytes))
568 (dolist (space (or spaces '(:read-only :static :dynamic)))
569 (declare (inline map-allocated-objects))
570 (map-allocated-objects
571 (lambda (obj type size)
573 (#.code-header-widetag
574 (let ((inst-words (truly-the fixnum (%code-code-size obj)))
576 (declare (type fixnum size inst-words))
577 (incf non-descriptor-bytes (* inst-words n-word-bytes))
578 (incf descriptor-words
579 (- (truncate size n-word-bytes) inst-words))))
581 #.single-float-widetag
582 #.double-float-widetag
583 #.simple-base-string-widetag
584 #!+sb-unicode #.simple-character-string-widetag
585 #.simple-array-nil-widetag
586 #.simple-bit-vector-widetag
587 #.simple-array-unsigned-byte-2-widetag
588 #.simple-array-unsigned-byte-4-widetag
589 #.simple-array-unsigned-byte-8-widetag
590 #.simple-array-unsigned-byte-16-widetag
591 #.simple-array-unsigned-byte-32-widetag
592 #.simple-array-signed-byte-8-widetag
593 #.simple-array-signed-byte-16-widetag
594 #.simple-array-signed-byte-32-widetag
595 #.simple-array-single-float-widetag
596 #.simple-array-double-float-widetag
597 #.simple-array-complex-single-float-widetag
598 #.simple-array-complex-double-float-widetag)
599 (incf non-descriptor-headers)
600 (incf non-descriptor-bytes (- size n-word-bytes)))
601 ((#.list-pointer-lowtag
602 #.instance-pointer-lowtag
605 #.simple-array-widetag
606 #.simple-vector-widetag
607 #.complex-base-string-widetag
608 #.complex-vector-nil-widetag
609 #.complex-bit-vector-widetag
610 #.complex-vector-widetag
611 #.complex-array-widetag
612 #.closure-header-widetag
613 #.funcallable-instance-header-widetag
614 #.value-cell-header-widetag
615 #.symbol-header-widetag
617 #.weak-pointer-widetag
618 #.instance-header-widetag)
619 (incf descriptor-words (truncate (the fixnum size) n-word-bytes)))
621 (error "bogus widetag: ~W" type))))
623 (format t "~:D words allocated for descriptor objects.~%"
625 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
626 non-descriptor-bytes non-descriptor-headers)
629 ;;; Print a breakdown by instance type of all the instances allocated
630 ;;; in SPACE. If TOP-N is true, print only information for the
631 ;;; TOP-N types with largest usage.
632 (defun instance-usage (space &key (top-n 15))
633 (declare (type spaces space) (type (or fixnum null) top-n))
634 (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
635 (let ((totals (make-hash-table :test 'eq))
638 (declare (unsigned-byte total-objects total-bytes))
639 (map-allocated-objects
640 (lambda (obj type size)
641 (declare (optimize (speed 3)))
642 (when (eql type instance-header-widetag)
644 (let* ((classoid (layout-classoid (%instance-ref obj 0)))
645 (found (gethash classoid totals))
647 (declare (fixnum size))
648 (incf total-bytes size)
650 (incf (the fixnum (car found)))
651 (incf (the fixnum (cdr found)) size))
653 (setf (gethash classoid totals) (cons 1 size)))))))
656 (collect ((totals-list))
657 (maphash (lambda (classoid what)
658 (totals-list (cons (prin1-to-string
659 (classoid-proper-name classoid))
662 (let ((sorted (sort (totals-list) #'> :key #'cddr))
665 (declare (unsigned-byte printed-bytes printed-objects))
666 (dolist (what (if top-n
667 (subseq sorted 0 (min (length sorted) top-n))
669 (let ((bytes (cddr what))
670 (objects (cadr what)))
671 (incf printed-bytes bytes)
672 (incf printed-objects objects)
673 (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what)
676 (let ((residual-objects (- total-objects printed-objects))
677 (residual-bytes (- total-bytes printed-bytes)))
678 (unless (zerop residual-objects)
679 (format t " Other types: ~:D bytes, ~:D object~:P.~%"
680 residual-bytes residual-objects))))
682 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
683 space total-bytes total-objects)))
687 ;;;; PRINT-ALLOCATED-OBJECTS
689 (defun print-allocated-objects (space &key (percent 0) (pages 5)
690 type larger smaller count
691 (stream *standard-output*))
692 (declare (type (integer 0 99) percent) (type index pages)
693 (type stream stream) (type spaces space)
694 (type (or index null) type larger smaller count))
695 (multiple-value-bind (start-sap end-sap) (space-bounds space)
696 (let* ((space-start (sap-int start-sap))
697 (space-end (sap-int end-sap))
698 (space-size (- space-end space-start))
699 (pagesize (sb!sys:get-page-size))
700 (start (+ space-start (round (* space-size percent) 100)))
701 (printed-conses (make-hash-table :test 'eq))
705 (declare (type (unsigned-byte 32) last-page start)
706 (fixnum pages-so-far count-so-far pagesize))
707 (labels ((note-conses (x)
708 (unless (or (atom x) (gethash x printed-conses))
709 (setf (gethash x printed-conses) t)
710 (note-conses (car x))
711 (note-conses (cdr x)))))
712 (map-allocated-objects
713 (lambda (obj obj-type size)
714 (let ((addr (get-lisp-obj-address obj)))
715 (when (>= addr start)
717 (> count-so-far count)
718 (> pages-so-far pages))
719 (return-from print-allocated-objects (values)))
722 (let ((this-page (* (the (values (unsigned-byte 32) t)
723 (truncate addr pagesize))
725 (declare (type (unsigned-byte 32) this-page))
726 (when (/= this-page last-page)
727 (when (< pages-so-far pages)
728 ;; FIXME: What is this? (ERROR "Argh..")? or
729 ;; a warning? or code that can be removed
730 ;; once the system is stable? or what?
731 (format stream "~2&**** Page ~W, address ~X:~%"
733 (setq last-page this-page)
734 (incf pages-so-far))))
736 (when (and (or (not type) (eql obj-type type))
737 (or (not smaller) (<= size smaller))
738 (or (not larger) (>= size larger)))
741 (#.code-header-widetag
742 (let ((dinfo (%code-debug-info obj)))
743 (format stream "~&Code object: ~S~%"
745 (sb!c::compiled-debug-info-name dinfo)
747 (#.symbol-header-widetag
748 (format stream "~&~S~%" obj))
749 (#.list-pointer-lowtag
750 (unless (gethash obj printed-conses)
752 (let ((*print-circle* t)
755 (format stream "~&~S~%" obj))))
758 (let ((str (write-to-string obj :level 5 :length 10
760 (unless (eql type instance-header-widetag)
761 (format stream "~S: " (type-of obj)))
762 (format stream "~A~%"
763 (subseq str 0 (min (length str) 60))))))))))
767 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
769 (defvar *ignore-after* nil)
771 (defun valid-obj (space x)
772 (or (not (eq space :dynamic))
773 ;; this test looks bogus if the allocator doesn't work linearly,
774 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
775 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
777 (defun maybe-cons (space x stuff)
778 (if (valid-obj space x)
782 (defun list-allocated-objects (space &key type larger smaller count
784 (declare (type spaces space)
785 (type (or index null) larger smaller type count)
786 (type (or function null) test)
787 (inline map-allocated-objects))
788 (unless *ignore-after*
789 (setq *ignore-after* (cons 1 2)))
790 (collect ((counted 0 1+))
792 (map-allocated-objects
793 (lambda (obj obj-type size)
794 (when (and (or (not type) (eql obj-type type))
795 (or (not smaller) (<= size smaller))
796 (or (not larger) (>= size larger))
797 (or (not test) (funcall test obj)))
798 (setq res (maybe-cons space obj res))
799 (when (and count (>= (counted) count))
800 (return-from list-allocated-objects res))))
804 ;;; Calls FUNCTION with all object that have (possibly conservative)
805 ;;; references to them on current stack.
806 (defun map-stack-references (function)
808 (sb!di::descriptor-sap
809 #!+stack-grows-downward-not-upward *control-stack-end*
810 #!-stack-grows-downward-not-upward *control-stack-start*))
813 (loop until #!+stack-grows-downward-not-upward (sap> sp end)
814 #!-stack-grows-downward-not-upward (sap< sp end)
815 do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
816 (when (and ok (typep obj '(not (or fixnum character))))
817 (unless (member obj seen :test #'eq)
818 (funcall function obj)
821 #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
822 #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
824 (defun map-referencing-objects (fun space object)
825 (declare (type spaces space) (inline map-allocated-objects))
826 (unless *ignore-after*
827 (setq *ignore-after* (cons 1 2)))
828 (flet ((maybe-call (fun obj)
829 (when (valid-obj space obj)
831 (map-allocated-objects
832 (lambda (obj obj-type size)
833 (declare (ignore obj-type size))
836 (when (or (eq (car obj) object)
837 (eq (cdr obj) object))
838 (maybe-call fun obj)))
840 (dotimes (i (%instance-length obj))
841 (when (eq (%instance-ref obj i) object)
845 (let ((length (get-header-data obj)))
846 (do ((i code-constants-offset (1+ i)))
848 (when (eq (code-header-ref obj i) object)
852 (dotimes (i (length obj))
853 (when (eq (svref obj i) object)
857 (when (or (eq (symbol-name obj) object)
858 (eq (symbol-package obj) object)
859 (eq (symbol-plist obj) object)
861 (eq (symbol-value obj) object)))
862 (maybe-call fun obj)))))
865 (defun list-referencing-objects (space object)
867 (map-referencing-objects
868 (lambda (obj) (res obj)) space object)