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. Disregarding the possibility of an
93 ;; unbound-marker (permitted, according to the GC), this means
94 ;; either a fixnum, a character, a single-float on a 64-bit system,
96 (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits)))
97 (setf (svref *meta-room-info* (ash i n-fixnum-tag-bits)) cons-info))
99 (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits)))
100 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
101 instance-pointer-lowtag))
103 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
104 list-pointer-lowtag))
106 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
109 (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
110 other-pointer-lowtag))
113 (setf (svref *meta-room-info* character-widetag) cons-info)
115 ;; Single-floats are immediate data on 64-bit systems.
116 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
117 (setf (svref *meta-room-info* single-float-widetag) cons-info))
121 (defparameter *room-info*
122 ;; SAETP instances don't dump properly from XC (or possibly
123 ;; normally), and we'd rather share structure with the master copy
124 ;; if we can anyway, so...
130 (if (specialized-array-element-type-properties-p info)
131 `(aref *specialized-array-element-type-properties*
132 ,(position info *specialized-array-element-type-properties*))
135 (deftype spaces () '(member :static :dynamic :read-only))
137 ;;;; MAP-ALLOCATED-OBJECTS
139 ;;; Since they're represented as counts of words, we should never
140 ;;; need bignums to represent these:
141 (declaim (type fixnum
142 *static-space-free-pointer*
143 *read-only-space-free-pointer*))
145 (defun space-bounds (space)
146 (declare (type spaces space))
149 (values (int-sap static-space-start)
150 (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))
152 (values (int-sap read-only-space-start)
153 (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))
155 (values (int-sap (current-dynamic-space-start))
156 (dynamic-space-free-pointer)))))
158 ;;; Return the total number of bytes used in SPACE.
159 (defun space-bytes (space)
160 (multiple-value-bind (start end) (space-bounds space)
161 (- (sap-int end) (sap-int start))))
163 ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
164 ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
165 ;;; platforms with 64-bit word size.
166 #!-sb-fluid (declaim (inline round-to-dualword))
167 (defun round-to-dualword (size)
168 (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))
170 ;;; Return the vector OBJ, its WIDETAG, and the number of octets
171 ;;; required for its storage (including padding and alignment).
172 (defun reconstitute-vector (obj saetp)
173 (declare (type (simple-array * (*)) obj)
174 (type specialized-array-element-type-properties saetp))
175 (let* ((length (+ (length obj)
176 (saetp-n-pad-elements saetp)))
177 (n-bits (saetp-n-bits saetp))
178 (alignment-pad (floor 7 n-bits))
179 (n-data-octets (if (>= n-bits 8)
180 (* length (ash n-bits -3))
181 (ash (* (+ length alignment-pad)
185 (saetp-typecode saetp)
186 (round-to-dualword (+ (* vector-data-offset n-word-bytes)
189 ;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
190 ;;; of a lisp object, return the object, its "type code" (either
191 ;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
192 ;;; required for its storage (including padding and alignment). Note
193 ;;; that this function is designed to NOT CONS, even if called
195 (defun reconstitute-object (address)
196 (let* ((object-sap (int-sap (get-lisp-obj-address address)))
197 (header (sap-ref-word object-sap 0))
198 (widetag (logand header widetag-mask))
199 (header-value (ash header (- n-widetag-bits)))
200 (info (svref *room-info* widetag)))
202 ((boxed-size (round-to-dualword (ash (1+ header-value) word-shift))))
204 ((tagged-object (tag)
205 `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address)))))
207 ;; Pick off arrays, as they're the only plausible cause for
208 ;; a non-nil, non-ROOM-INFO object as INFO.
209 ((specialized-array-element-type-properties-p info)
210 (reconstitute-vector (tagged-object other-pointer-lowtag) info))
213 (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
216 ((eq (room-info-kind info) :list)
217 (values (tagged-object list-pointer-lowtag)
221 ((eq (room-info-kind info) :closure)
222 (values (tagged-object fun-pointer-lowtag)
226 ((eq (room-info-kind info) :instance)
227 (values (tagged-object instance-pointer-lowtag)
231 ((eq (room-info-kind info) :other)
232 (values (tagged-object other-pointer-lowtag)
236 ((eq (room-info-kind info) :vector-nil)
237 (values (tagged-object other-pointer-lowtag)
238 simple-array-nil-widetag
241 ((eq (room-info-kind info) :weak-pointer)
242 (values (tagged-object other-pointer-lowtag)
248 ((eq (room-info-kind info) :code)
249 (values (tagged-object other-pointer-lowtag)
254 (sap-ref-lispobj object-sap
255 (* code-code-size-slot
260 (error "Unrecognized room-info-kind ~S in reconstitute-object"
261 (room-info-kind info))))))))
263 ;;; Iterate over all the objects in the contiguous block of memory
264 ;;; with the low address at START and the high address just before
265 ;;; END, calling FUN with the object, the object's type code, and the
266 ;;; object's total size in bytes, including any header and padding.
267 ;;; START and END are untagged, aligned memory addresses interpreted
268 ;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
269 (defun map-objects-in-range (fun start end)
270 (declare (type function fun))
271 ;; If START is (unsigned) greater than END, then we have somehow
272 ;; blown past our endpoint.
273 (aver (<= (get-lisp-obj-address start)
274 (get-lisp-obj-address end)))
275 (unless (= start end)
278 (reconstitute-object start)
279 (aver (zerop (logand n-lowtag-bits size)))
281 ;; This special little dance is to add a number of octets
282 ;; (and it had best be a number evenly divisible by our
283 ;; allocation granularity) to an unboxed, aligned address
284 ;; masquerading as a fixnum. Without consing.
286 (mask-field (byte #.n-word-bits 0)
287 (+ (get-lisp-obj-address start)
289 (funcall fun obj typecode size)
290 (map-objects-in-range fun next-start end)))))
292 ;;; Access to the GENCGC page table for better precision in
293 ;;; MAP-ALLOCATED-OBJECTS
296 (define-alien-type (struct page)
299 ;; On platforms with small enough GC pages, this field
300 ;; will be a short. On platforms with larger ones, it'll
302 (bytes-used (unsigned
303 #.(if (typep sb!vm:gencgc-card-bytes
309 (declaim (inline find-page-index))
310 (define-alien-routine "find_page_index" long (index signed))
311 (define-alien-variable "last_free_page" sb!kernel::page-index-t)
312 (define-alien-variable "heap_base" (* t))
313 (define-alien-variable "page_table" (* (struct page))))
315 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
316 ;;; the object, the object's type code, and the object's total size in
317 ;;; bytes, including any header and padding. CAREFUL makes
318 ;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it
319 ;;; is intended for slightly more demanding uses of heap groveling
321 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
322 (defun map-allocated-objects (fun space)
323 (declare (type function fun)
328 ;; Static space starts with NIL, which requires special
329 ;; handling, as the header and alignment are slightly off.
330 (multiple-value-bind (start end) (space-bounds space)
331 (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
332 (map-objects-in-range fun
333 (%make-lisp-obj (+ (* 8 n-word-bytes)
335 (%make-lisp-obj (sap-int end)))))
337 ((:read-only #!-gencgc :dynamic)
338 ;; Read-only space (and dynamic space on cheneygc) is a block
339 ;; of contiguous allocations.
340 (multiple-value-bind (start end) (space-bounds space)
341 (map-objects-in-range fun
342 (%make-lisp-obj (sap-int start))
343 (%make-lisp-obj (sap-int end)))))
347 ;; Dynamic space on gencgc requires walking the GC page tables
348 ;; in order to determine what regions contain objects.
350 ;; We explicitly presume that any pages in an allocation region
351 ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
352 ;; (indicating a full page) or an otherwise-valid BYTES-USED.
353 ;; We also presume that the pages of an open allocation region
354 ;; after the first page, and any pages that are unallocated,
355 ;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
357 ;; Our procedure is to scan forward through the page table,
358 ;; maintaining an "end pointer" until we reach a page where
359 ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
360 ;; LAST-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
361 ;; is not empty, and proceed to the next page (unless we've hit
362 ;; LAST-FREE-PAGE). We happily take advantage of the fact that
363 ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
364 ;; coincident pointers for the range.
366 ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
367 ;; closing allocation regions and opening new ones. This may
368 ;; prove to be an issue with concurrent systems, or with
369 ;; spectacularly poor timing for closing an allocation region
370 ;; in a single-threaded system.
373 with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
374 ;; This magic dance gets us an unboxed aligned pointer as a
376 with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
379 ;; This is our page range.
380 for page-index from 0 below last-free-page
381 for next-page-addr from (+ start page-size) by page-size
382 for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)
384 when (< page-bytes-used gencgc-card-bytes)
386 (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
387 (map-objects-in-range fun start end)
388 (setf start next-page-addr)
389 (setf end next-page-addr))
390 else do (incf end page-size)
392 finally (map-objects-in-range fun start end))))))
396 ;;; Return a list of 3-lists (bytes object type-name) for the objects
397 ;;; allocated in Space.
398 (defun type-breakdown (space)
399 (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
400 (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
401 (map-allocated-objects
402 (lambda (obj type size)
403 (declare (word size) (optimize (speed 3)) (ignore obj))
404 (incf (aref sizes type) size)
405 (incf (aref counts type)))
408 (let ((totals (make-hash-table :test 'eq)))
410 (let ((total-count (aref counts i)))
411 (unless (zerop total-count)
412 (let* ((total-size (aref sizes i))
413 (name (room-info-type-name (aref *room-info* i)))
414 (found (gethash name totals)))
416 (incf (first found) total-size)
417 (incf (second found) total-count))
419 (setf (gethash name totals)
420 (list total-size total-count name))))))))
422 (collect ((totals-list))
423 (maphash (lambda (k v)
427 (sort (totals-list) #'> :key #'first)))))
429 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
430 ;;; (space-name . totals-for-space), where totals-for-space is the list
431 ;;; returned by TYPE-BREAKDOWN.
432 (defun print-summary (spaces totals)
433 (let ((summary (make-hash-table :test 'eq)))
434 (dolist (space-total totals)
435 (dolist (total (cdr space-total))
436 (push (cons (car space-total) total)
437 (gethash (third total) summary))))
439 (collect ((summary-totals))
440 (maphash (lambda (k v)
443 (declare (unsigned-byte sum))
444 (dolist (space-total v)
445 (incf sum (first (cdr space-total))))
446 (summary-totals (cons sum v))))
449 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
450 (let ((summary-total-bytes 0)
451 (summary-total-objects 0))
452 (declare (unsigned-byte summary-total-bytes summary-total-objects))
453 (dolist (space-totals
454 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
455 (let ((total-objects 0)
458 (declare (unsigned-byte total-objects total-bytes))
460 (dolist (space-total space-totals)
461 (let ((total (cdr space-total)))
462 (setq name (third total))
463 (incf total-bytes (first total))
464 (incf total-objects (second total))
465 (spaces (cons (car space-total) (first total)))))
466 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
467 name total-bytes total-objects)
468 (dolist (space (spaces))
469 (format t ", ~W% ~(~A~)"
470 (round (* (cdr space) 100) total-bytes)
473 (incf summary-total-bytes total-bytes)
474 (incf summary-total-objects total-objects))))
475 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
476 summary-total-bytes summary-total-objects)))))
478 ;;; Report object usage for a single space.
479 (defun report-space-total (space-total cutoff)
480 (declare (list space-total) (type (or single-float null) cutoff))
481 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
482 (let* ((types (cdr space-total))
483 (total-bytes (reduce #'+ (mapcar #'first types)))
484 (total-objects (reduce #'+ (mapcar #'second types)))
485 (cutoff-point (if cutoff
486 (truncate (* (float total-bytes) cutoff))
489 (reported-objects 0))
490 (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
492 (loop for (bytes objects name) in types do
493 (when (<= bytes cutoff-point)
494 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
495 (- total-bytes reported-bytes)
496 (- total-objects reported-objects))
498 (incf reported-bytes bytes)
499 (incf reported-objects objects)
500 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
502 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
503 total-bytes total-objects (car space-total))))
505 ;;; Print information about the heap memory in use. PRINT-SPACES is a
506 ;;; list of the spaces to print detailed information for.
507 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
508 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
509 ;;; PRINT-SUMMARY is true, then summary information will be printed.
510 ;;; The defaults print only summary information for dynamic space. If
511 ;;; true, CUTOFF is a fraction of the usage in a report below which
512 ;;; types will be combined as OTHER.
513 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
514 (print-summary t) cutoff)
515 (declare (type (or single-float null) cutoff))
516 (let* ((spaces (if (eq count-spaces t)
517 '(:static :dynamic :read-only)
519 (totals (mapcar (lambda (space)
520 (cons space (type-breakdown space)))
523 (dolist (space-total totals)
524 (when (or (eq print-spaces t)
525 (member (car space-total) print-spaces))
526 (report-space-total space-total cutoff)))
528 (when print-summary (print-summary spaces totals)))
532 ;;; Print info about how much code and no-ops there are in SPACE.
533 (defun count-no-ops (space)
534 (declare (type spaces space))
538 (declare (fixnum code-words no-ops)
539 (type unsigned-byte total-bytes))
540 (map-allocated-objects
541 (lambda (obj type size)
542 (when (eql type code-header-widetag)
543 (let ((words (truly-the fixnum (%code-code-size obj)))
544 (sap (%primitive code-instructions obj))
546 (declare (fixnum size))
547 (incf total-bytes size)
548 (incf code-words words)
550 (when (zerop (sap-ref-word sap (* i n-word-bytes)))
555 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
556 total-bytes code-words no-ops
557 (round (* no-ops 100) code-words)))
561 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
562 (let ((descriptor-words 0)
563 (non-descriptor-headers 0)
564 (non-descriptor-bytes 0))
565 (declare (type unsigned-byte descriptor-words non-descriptor-headers
566 non-descriptor-bytes))
567 (dolist (space (or spaces '(:read-only :static :dynamic)))
568 (declare (inline map-allocated-objects))
569 (map-allocated-objects
570 (lambda (obj type size)
572 (#.code-header-widetag
573 (let ((inst-words (truly-the fixnum (%code-code-size obj)))
575 (declare (type fixnum size inst-words))
576 (incf non-descriptor-bytes (* inst-words n-word-bytes))
577 (incf descriptor-words
578 (- (truncate size n-word-bytes) inst-words))))
580 #.single-float-widetag
581 #.double-float-widetag
582 #.simple-base-string-widetag
583 #!+sb-unicode #.simple-character-string-widetag
584 #.simple-array-nil-widetag
585 #.simple-bit-vector-widetag
586 #.simple-array-unsigned-byte-2-widetag
587 #.simple-array-unsigned-byte-4-widetag
588 #.simple-array-unsigned-byte-8-widetag
589 #.simple-array-unsigned-byte-16-widetag
590 #.simple-array-unsigned-byte-32-widetag
591 #.simple-array-signed-byte-8-widetag
592 #.simple-array-signed-byte-16-widetag
593 #.simple-array-signed-byte-32-widetag
594 #.simple-array-single-float-widetag
595 #.simple-array-double-float-widetag
596 #.simple-array-complex-single-float-widetag
597 #.simple-array-complex-double-float-widetag)
598 (incf non-descriptor-headers)
599 (incf non-descriptor-bytes (- size n-word-bytes)))
600 ((#.list-pointer-lowtag
601 #.instance-pointer-lowtag
604 #.simple-array-widetag
605 #.simple-vector-widetag
606 #.complex-base-string-widetag
607 #.complex-vector-nil-widetag
608 #.complex-bit-vector-widetag
609 #.complex-vector-widetag
610 #.complex-array-widetag
611 #.closure-header-widetag
612 #.funcallable-instance-header-widetag
613 #.value-cell-header-widetag
614 #.symbol-header-widetag
616 #.weak-pointer-widetag
617 #.instance-header-widetag)
618 (incf descriptor-words (truncate (the fixnum size) n-word-bytes)))
620 (error "bogus widetag: ~W" type))))
622 (format t "~:D words allocated for descriptor objects.~%"
624 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
625 non-descriptor-bytes non-descriptor-headers)
628 ;;; Print a breakdown by instance type of all the instances allocated
629 ;;; in SPACE. If TOP-N is true, print only information for the
630 ;;; TOP-N types with largest usage.
631 (defun instance-usage (space &key (top-n 15))
632 (declare (type spaces space) (type (or fixnum null) top-n))
633 (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
634 (let ((totals (make-hash-table :test 'eq))
637 (declare (unsigned-byte total-objects total-bytes))
638 (map-allocated-objects
639 (lambda (obj type size)
640 (declare (optimize (speed 3)))
641 (when (eql type instance-header-widetag)
643 (let* ((classoid (layout-classoid (%instance-ref obj 0)))
644 (found (gethash classoid totals))
646 (declare (fixnum size))
647 (incf total-bytes size)
649 (incf (the fixnum (car found)))
650 (incf (the fixnum (cdr found)) size))
652 (setf (gethash classoid totals) (cons 1 size)))))))
655 (collect ((totals-list))
656 (maphash (lambda (classoid what)
657 (totals-list (cons (prin1-to-string
658 (classoid-proper-name classoid))
661 (let ((sorted (sort (totals-list) #'> :key #'cddr))
664 (declare (unsigned-byte printed-bytes printed-objects))
665 (dolist (what (if top-n
666 (subseq sorted 0 (min (length sorted) top-n))
668 (let ((bytes (cddr what))
669 (objects (cadr what)))
670 (incf printed-bytes bytes)
671 (incf printed-objects objects)
672 (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what)
675 (let ((residual-objects (- total-objects printed-objects))
676 (residual-bytes (- total-bytes printed-bytes)))
677 (unless (zerop residual-objects)
678 (format t " Other types: ~:D bytes, ~:D object~:P.~%"
679 residual-bytes residual-objects))))
681 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
682 space total-bytes total-objects)))
686 ;;;; PRINT-ALLOCATED-OBJECTS
688 (defun print-allocated-objects (space &key (percent 0) (pages 5)
689 type larger smaller count
690 (stream *standard-output*))
691 (declare (type (integer 0 99) percent) (type index pages)
692 (type stream stream) (type spaces space)
693 (type (or index null) type larger smaller count))
694 (multiple-value-bind (start-sap end-sap) (space-bounds space)
695 (let* ((space-start (sap-int start-sap))
696 (space-end (sap-int end-sap))
697 (space-size (- space-end space-start))
698 (pagesize (sb!sys:get-page-size))
699 (start (+ space-start (round (* space-size percent) 100)))
700 (printed-conses (make-hash-table :test 'eq))
704 (declare (type (unsigned-byte 32) last-page start)
705 (fixnum pages-so-far count-so-far pagesize))
706 (labels ((note-conses (x)
707 (unless (or (atom x) (gethash x printed-conses))
708 (setf (gethash x printed-conses) t)
709 (note-conses (car x))
710 (note-conses (cdr x)))))
711 (map-allocated-objects
712 (lambda (obj obj-type size)
713 (let ((addr (get-lisp-obj-address obj)))
714 (when (>= addr start)
716 (> count-so-far count)
717 (> pages-so-far pages))
718 (return-from print-allocated-objects (values)))
721 (let ((this-page (* (the (values (unsigned-byte 32) t)
722 (truncate addr pagesize))
724 (declare (type (unsigned-byte 32) this-page))
725 (when (/= this-page last-page)
726 (when (< pages-so-far pages)
727 ;; FIXME: What is this? (ERROR "Argh..")? or
728 ;; a warning? or code that can be removed
729 ;; once the system is stable? or what?
730 (format stream "~2&**** Page ~W, address ~X:~%"
732 (setq last-page this-page)
733 (incf pages-so-far))))
735 (when (and (or (not type) (eql obj-type type))
736 (or (not smaller) (<= size smaller))
737 (or (not larger) (>= size larger)))
740 (#.code-header-widetag
741 (let ((dinfo (%code-debug-info obj)))
742 (format stream "~&Code object: ~S~%"
744 (sb!c::compiled-debug-info-name dinfo)
746 (#.symbol-header-widetag
747 (format stream "~&~S~%" obj))
748 (#.list-pointer-lowtag
749 (unless (gethash obj printed-conses)
751 (let ((*print-circle* t)
754 (format stream "~&~S~%" obj))))
757 (let ((str (write-to-string obj :level 5 :length 10
759 (unless (eql type instance-header-widetag)
760 (format stream "~S: " (type-of obj)))
761 (format stream "~A~%"
762 (subseq str 0 (min (length str) 60))))))))))
766 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
768 (defvar *ignore-after* nil)
770 (defun valid-obj (space x)
771 (or (not (eq space :dynamic))
772 ;; this test looks bogus if the allocator doesn't work linearly,
773 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
774 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
776 (defun maybe-cons (space x stuff)
777 (if (valid-obj space x)
781 (defun list-allocated-objects (space &key type larger smaller count
783 (declare (type spaces space)
784 (type (or index null) larger smaller type count)
785 (type (or function null) test)
786 (inline map-allocated-objects))
787 (unless *ignore-after*
788 (setq *ignore-after* (cons 1 2)))
789 (collect ((counted 0 1+))
791 (map-allocated-objects
792 (lambda (obj obj-type size)
793 (when (and (or (not type) (eql obj-type type))
794 (or (not smaller) (<= size smaller))
795 (or (not larger) (>= size larger))
796 (or (not test) (funcall test obj)))
797 (setq res (maybe-cons space obj res))
798 (when (and count (>= (counted) count))
799 (return-from list-allocated-objects res))))
803 ;;; Calls FUNCTION with all object that have (possibly conservative)
804 ;;; references to them on current stack.
805 (defun map-stack-references (function)
807 (sb!di::descriptor-sap
808 #!+stack-grows-downward-not-upward *control-stack-end*
809 #!-stack-grows-downward-not-upward *control-stack-start*))
812 (loop until #!+stack-grows-downward-not-upward (sap> sp end)
813 #!-stack-grows-downward-not-upward (sap< sp end)
814 do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
815 (when (and ok (typep obj '(not (or fixnum character))))
816 (unless (member obj seen :test #'eq)
817 (funcall function obj)
820 #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
821 #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
823 (defun map-referencing-objects (fun space object)
824 (declare (type spaces space) (inline map-allocated-objects))
825 (unless *ignore-after*
826 (setq *ignore-after* (cons 1 2)))
827 (flet ((maybe-call (fun obj)
828 (when (valid-obj space obj)
830 (map-allocated-objects
831 (lambda (obj obj-type size)
832 (declare (ignore obj-type size))
835 (when (or (eq (car obj) object)
836 (eq (cdr obj) object))
837 (maybe-call fun obj)))
839 (dotimes (i (%instance-length obj))
840 (when (eq (%instance-ref obj i) object)
844 (let ((length (get-header-data obj)))
845 (do ((i code-constants-offset (1+ i)))
847 (when (eq (code-header-ref obj i) object)
851 (dotimes (i (length obj))
852 (when (eq (svref obj i) object)
856 (when (or (eq (symbol-name obj) object)
857 (eq (symbol-package obj) object)
858 (eq (symbol-plist obj) object)
860 (eq (symbol-value obj) object)))
861 (maybe-call fun obj)))))
864 (defun list-referencing-objects (space object)
866 (map-referencing-objects
867 (lambda (obj) (res obj)) space object)