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.
15 ;;;; type format database
17 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
19 (def!struct
(room-info (:constructor make-room-info
(name kind
))
21 ;; the name of this type
22 (name nil
:type symbol
:read-only t
)
23 ;; kind of type (how to reconstitute an object)
25 :type
(member :other
:tiny-other
:closure
:instance
:list
26 :code
:vector-nil
:weak-pointer
)
28 (!set-load-form-method room-info
(:xc
))
30 (defun room-info-type-name (info)
31 (if (specialized-array-element-type-properties-p info
)
32 (saetp-primitive-type-name info
)
33 (room-info-name info
))))
35 (eval-when (:compile-toplevel
:execute
)
37 (defvar *meta-room-info
* (make-array 256 :initial-element nil
))
39 (dolist (obj *primitive-objects
*)
40 (let ((widetag (primitive-object-widetag obj
))
41 (lowtag (primitive-object-lowtag obj
))
42 (name (primitive-object-name obj
)))
43 (when (and (eq lowtag
'other-pointer-lowtag
)
44 (not (member widetag
'(t nil
)))
45 (not (eq name
'weak-pointer
)))
46 (setf (svref *meta-room-info
* (symbol-value widetag
))
47 (make-room-info name
(if (member name
'(fdefn symbol
))
51 (dolist (code (list #!+sb-unicode complex-character-string-widetag
52 complex-base-string-widetag simple-array-widetag
53 complex-bit-vector-widetag complex-vector-widetag
54 complex-array-widetag complex-vector-nil-widetag
))
55 (setf (svref *meta-room-info
* code
)
56 (make-room-info 'array-header
:other
)))
58 (setf (svref *meta-room-info
* bignum-widetag
)
59 (make-room-info 'bignum
:other
))
61 (setf (svref *meta-room-info
* closure-widetag
)
62 (make-room-info 'closure
: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 'simple-array-nil
:vector-nil
))
72 (setf (svref *meta-room-info
* code-header-widetag
)
73 (make-room-info 'code
:code
))
75 (setf (svref *meta-room-info
* instance-widetag
)
76 (make-room-info 'instance
:instance
))
78 (setf (svref *meta-room-info
* funcallable-instance-widetag
)
79 (make-room-info 'funcallable-instance
:closure
))
81 (setf (svref *meta-room-info
* weak-pointer-widetag
)
82 (make-room-info 'weak-pointer
:weak-pointer
))
84 (let ((cons-info (make-room-info 'cons
:list
)))
85 ;; A cons consists of two words, both of which may be either a
86 ;; pointer or immediate data. According to the runtime this means
87 ;; either a fixnum, a character, an unbound-marker, a single-float
88 ;; on a 64-bit system, or a pointer.
89 (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits
)))
90 (setf (svref *meta-room-info
* (ash i n-fixnum-tag-bits
)) cons-info
))
92 (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits
)))
93 (setf (svref *meta-room-info
* (logior (ash i n-lowtag-bits
)
94 instance-pointer-lowtag
))
96 (setf (svref *meta-room-info
* (logior (ash i n-lowtag-bits
)
99 (setf (svref *meta-room-info
* (logior (ash i n-lowtag-bits
)
102 (setf (svref *meta-room-info
* (logior (ash i n-lowtag-bits
)
103 other-pointer-lowtag
))
106 (setf (svref *meta-room-info
* character-widetag
) cons-info
)
108 (setf (svref *meta-room-info
* unbound-marker-widetag
) cons-info
)
110 ;; Single-floats are immediate data on 64-bit systems.
112 (setf (svref *meta-room-info
* single-float-widetag
) cons-info
))
116 (define-load-time-global *room-info
*
117 ;; SAETP instances don't dump properly from XC (or possibly
118 ;; normally), and we'd rather share structure with the master copy
119 ;; if we can anyway, so...
125 (if (specialized-array-element-type-properties-p info
)
126 `(aref *specialized-array-element-type-properties
*
127 ,(position info
*specialized-array-element-type-properties
*))
131 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
133 (defglobal **heap-spaces
**
134 #1='((:dynamic
"Dynamic space" sb
!kernel
:dynamic-usage
)
136 (:immobile
"Immobile space" sb
!kernel
::immobile-space-usage
)
137 (:read-only
"Read-only space" sb
!kernel
::read-only-space-usage
)
138 (:static
"Static space" sb
!kernel
::static-space-usage
)))
140 (defglobal **stack-spaces
**
141 #2='((:control-stack
"Control stack" sb
!kernel
::control-stack-usage
)
142 (:binding-stack
"Binding stack" sb
!kernel
::binding-stack-usage
)))
144 (defglobal **spaces
**
148 `(member ,@(mapcar #'first
**heap-spaces
**)))
151 ;;;; MAP-ALLOCATED-OBJECTS
154 (declaim (inline current-dynamic-space-start
))
155 (defun current-dynamic-space-start ()
156 #!+(and gencgc relocatable-heap
)
157 (extern-alien "DYNAMIC_SPACE_START" unsigned-long
)
158 #!+(and gencgc
(not relocatable-heap
))
159 sb
!vm
:dynamic-space-start
160 #!-gencgc
(extern-alien "current_dynamic_space" unsigned-long
))
164 (declaim (inline dynamic-space-free-pointer
))
165 (defun dynamic-space-free-pointer ()
166 (extern-alien "dynamic_space_free_pointer" system-area-pointer
)))
168 ;;; Return the lower limit and current free-pointer of SPACE as fixnums
169 ;;; whose raw bits (at the register level) represent a pointer.
170 ;;; This makes it "off" by a factor of (EXPT 2 N-FIXNUM-TAG-BITS) - and/or
171 ;;; possibly negative - if you look at the value in Lisp,
172 ;;; but avoids potentially needing a bignum on 32-bit machines.
173 ;;; 64-bit machines have no problem since most current generation CPUs
174 ;;; use an address width that is narrower than 64 bits.
175 ;;; This function is private because of the wacky representation.
176 (defun %space-bounds
(space)
177 (declare (type spaces space
))
180 (values (%make-lisp-obj static-space-start
)
181 (%make-lisp-obj
(sap-int *static-space-free-pointer
*))))
183 (values (%make-lisp-obj read-only-space-start
)
184 (%make-lisp-obj
(sap-int *read-only-space-free-pointer
*))))
187 (values (%make-lisp-obj immobile-space-start
)
188 (%make-lisp-obj
(sap-int *immobile-space-free-pointer
*))))
190 (values (%make-lisp-obj
(current-dynamic-space-start))
191 (%make-lisp-obj
(sap-int (dynamic-space-free-pointer)))))))
193 ;;; Return the total number of bytes used in SPACE.
194 (defun space-bytes (space)
195 (multiple-value-bind (start end
) (%space-bounds space
)
196 (ash (- end start
) n-fixnum-tag-bits
)))
198 ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
199 ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
200 ;;; platforms with 64-bit word size.
201 #!-sb-fluid
(declaim (inline round-to-dualword
))
202 (defun round-to-dualword (size)
203 (logand (the word
(+ size lowtag-mask
)) (lognot lowtag-mask
)))
205 ;;; Return the vector OBJ, its WIDETAG, and the number of octets
206 ;;; required for its storage (including padding and alignment).
207 (defun reconstitute-vector (obj saetp
)
208 (declare (type (simple-array * (*)) obj
)
209 (type specialized-array-element-type-properties saetp
))
210 (let* ((length (+ (length obj
)
211 (saetp-n-pad-elements saetp
)))
212 (n-bits (saetp-n-bits saetp
))
213 (alignment-pad (floor 7 n-bits
))
214 (n-data-octets (if (>= n-bits
8)
215 (* length
(ash n-bits -
3))
216 (ash (* (+ length alignment-pad
)
220 (saetp-typecode saetp
)
221 (round-to-dualword (+ (* vector-data-offset n-word-bytes
)
224 ;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
225 ;;; of a lisp object, return the object, its "type code" (either
226 ;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
227 ;;; required for its storage (including padding and alignment). Note
228 ;;; that this function is designed to NOT CONS, even if called
230 (defun reconstitute-object (address)
231 (let* ((object-sap (int-sap (get-lisp-obj-address address
)))
232 (header (sap-ref-word object-sap
0))
233 (widetag (logand header widetag-mask
))
234 (header-value (ash header
(- n-widetag-bits
)))
235 (info (svref *room-info
* widetag
)))
237 ((boxed-size (header-value)
238 `(round-to-dualword (ash (1+ ,header-value
) word-shift
)))
240 `(%make-lisp-obj
(logior ,tag
(get-lisp-obj-address address
)))))
242 ;; Pick off arrays, as they're the only plausible cause for
243 ;; a non-nil, non-ROOM-INFO object as INFO.
244 ((specialized-array-element-type-properties-p info
)
245 (reconstitute-vector (tagged-object other-pointer-lowtag
) info
))
248 (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
252 (case (room-info-kind info
)
254 (values (tagged-object list-pointer-lowtag
)
258 (:closure
; also funcallable-instance
259 (values (tagged-object fun-pointer-lowtag
)
261 (boxed-size (logand header-value short-header-max-words
))))
264 (values (tagged-object instance-pointer-lowtag
)
266 (boxed-size (logand header-value short-header-max-words
))))
269 (values (tagged-object other-pointer-lowtag
)
271 (boxed-size header-value
)))
274 (values (tagged-object other-pointer-lowtag
)
276 (boxed-size (logand header-value
#xFF
))))
279 (values (tagged-object other-pointer-lowtag
)
280 simple-array-nil-widetag
284 (values (tagged-object other-pointer-lowtag
)
291 (let ((c (tagged-object other-pointer-lowtag
)))
295 (+ (* (logand header-value short-header-max-words
)
297 (%code-code-size
(truly-the code-component c
)))))))
299 (error "Unrecognized room-info-kind ~S in reconstitute-object"
300 (room-info-kind info
)))))))))
302 ;;; Iterate over all the objects in the contiguous block of memory
303 ;;; with the low address at START and the high address just before
304 ;;; END, calling FUN with the object, the object's type code, and the
305 ;;; object's total size in bytes, including any header and padding.
306 ;;; START and END are untagged, aligned memory addresses interpreted
307 ;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
308 (defun map-objects-in-range (fun start end
)
309 (declare (type function fun
))
310 ;; If START is (unsigned) greater than END, then we have somehow
311 ;; blown past our endpoint.
312 (aver (<= (get-lisp-obj-address start
)
313 (get-lisp-obj-address end
)))
314 (unless (= start end
)
317 (reconstitute-object start
)
318 (aver (zerop (logand n-lowtag-bits size
)))
320 ;; This special little dance is to add a number of octets
321 ;; (and it had best be a number evenly divisible by our
322 ;; allocation granularity) to an unboxed, aligned address
323 ;; masquerading as a fixnum. Without consing.
325 (mask-field (byte #.n-word-bits
0)
326 (+ (get-lisp-obj-address start
)
328 (funcall fun obj typecode size
)
329 (map-objects-in-range fun next-start end
)))))
331 ;;; Access to the GENCGC page table for better precision in
332 ;;; MAP-ALLOCATED-OBJECTS
335 (define-alien-type (struct page
)
337 ;; To cut down the size of the page table, the scan_start_offset
338 ;; - a/k/a "start" - is measured in 4-byte integers regardless
339 ;; of word size. This is fine for 32-bit address space,
340 ;; but if 64-bit then we have to scale the value. Additionally
341 ;; there is a fallback for when even the scaled value is too big.
342 ;; (None of this matters to Lisp code for the most part)
343 (start #!+64-bit
(unsigned 32) #!-
64-bit signed
)
344 ;; On platforms with small enough GC pages, this field
345 ;; will be a short. On platforms with larger ones, it'll
347 ;; Measured in bytes; the low bit has to be masked off.
348 (bytes-used (unsigned
349 #.
(if (typep gencgc-card-bytes
'(unsigned-byte 16))
356 (define-alien-type (struct immobile-page
)
357 ;; ... and yet another place for Lisp to become out-of-sync with C.
358 (struct immobile-page
360 (obj-spacing (unsigned 8))
361 (obj-size (unsigned 8))
362 (generations (unsigned 8))
363 (free-index (unsigned 32))
364 (page-link (unsigned 16))
365 (prior-free-index (unsigned 16))))
366 (define-alien-variable "fixedobj_pages" (* (struct immobile-page
))))
367 (declaim (inline find-page-index
))
368 (define-alien-routine ("ext_find_page_index" find-page-index
)
370 (define-alien-variable "last_free_page" sb
!kernel
::page-index-t
)
371 (define-alien-variable "page_table" (* (struct page
))))
373 (declaim (inline code-header-words
))
374 (defun code-header-words (code)
375 (logand (get-header-data code
) short-header-max-words
))
377 ;;; Iterate over all the objects allocated in each of the SPACES, calling FUN
378 ;;; with the object, the object's type code, and the object's total size in
379 ;;; bytes, including any header and padding. As a special case, if exactly one
380 ;;; space named :ALL is requested, then map over the known spaces.
381 (defun map-allocated-objects (fun &rest spaces
)
382 (declare (type function fun
))
383 (when (and (= (length spaces
) 1) (eq (first spaces
) :all
))
384 (return-from map-allocated-objects
385 (map-allocated-objects fun
387 #!+immobile-space
:immobile
389 ;; You can't specify :ALL and also a list of spaces. Check that up front.
390 (do-rest-arg ((space) spaces
) (the spaces space
))
391 (flet ((do-1-space (space)
394 ;; Static space starts with NIL, which requires special
395 ;; handling, as the header and alignment are slightly off.
396 (multiple-value-bind (start end
) (%space-bounds space
)
397 ;; This "8" is very magical. It happens to work for both
398 ;; word sizes, even though symbols differ in length
399 ;; (they can be either 6 or 7 words).
400 (funcall fun nil symbol-widetag
(* 8 n-word-bytes
))
401 (map-objects-in-range fun
402 (+ (ash (* 8 n-word-bytes
) (- n-fixnum-tag-bits
))
406 ((:read-only
#!-gencgc
:dynamic
)
407 ;; Read-only space (and dynamic space on cheneygc) is a block
408 ;; of contiguous allocations.
409 (multiple-value-bind (start end
) (%space-bounds space
)
410 (map-objects-in-range fun start end
)))
413 ;; Filter out filler objects. These either look like cons cells
414 ;; in fixedobj subspace, or code without enough header words
415 ;; in varyobj subspace. (cf 'immobile_filler_p' in gc-internal.h)
416 (dx-flet ((filter (obj type size
)
418 (funcall fun obj type size
))))
419 (map-immobile-objects #'filter
:fixed
))
420 (dx-flet ((filter (obj type size
)
421 (unless (and (code-component-p obj
)
422 (eql (code-header-words obj
) 2))
423 (funcall fun obj type size
))))
424 (map-immobile-objects #'filter
:variable
)))
428 ;; Dynamic space on gencgc requires walking the GC page tables
429 ;; in order to determine what regions contain objects.
431 ;; We explicitly presume that any pages in an allocation region
432 ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
433 ;; (indicating a full page) or an otherwise-valid BYTES-USED.
434 ;; We also presume that the pages of an open allocation region
435 ;; after the first page, and any pages that are unallocated,
436 ;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
438 ;; Our procedure is to scan forward through the page table,
439 ;; maintaining an "end pointer" until we reach a page where
440 ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
441 ;; LAST-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
442 ;; is not empty, and proceed to the next page (unless we've hit
443 ;; LAST-FREE-PAGE). We happily take advantage of the fact that
444 ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
445 ;; coincident pointers for the range.
447 ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
448 ;; closing allocation regions and opening new ones. This may
449 ;; prove to be an issue with concurrent systems, or with
450 ;; spectacularly poor timing for closing an allocation region
451 ;; in a single-threaded system.
454 with page-size
= (ash gencgc-card-bytes
(- n-fixnum-tag-bits
))
455 ;; This magic dance gets us an unboxed aligned pointer as a
457 with start
= (%make-lisp-obj
(current-dynamic-space-start))
460 ;; This is our page range. The type constraint is far too generous,
461 ;; but it does its job of producing efficient code.
463 of-type
(integer -
1 (#.
(/ (ash 1 n-machine-word-bits
) gencgc-card-bytes
)))
464 from
0 below last-free-page
465 for next-page-addr from
(+ start page-size
) by page-size
467 ;; The low bits of bytes-used is the need-to-zero flag.
468 = (logandc1 1 (slot (deref page-table page-index
) 'bytes-used
))
470 when
(< page-bytes-used gencgc-card-bytes
)
472 (incf end
(ash page-bytes-used
(- n-fixnum-tag-bits
)))
473 (map-objects-in-range fun start end
)
474 (setf start next-page-addr
)
475 (setf end next-page-addr
))
476 else do
(incf end page-size
)
478 finally
(map-objects-in-range fun start end
))))))
479 (do-rest-arg ((space) spaces
)
480 (if (eq space
:dynamic
)
481 (without-gcing (do-1-space space
))
482 (do-1-space space
)))))
486 ;;; Return a list of 3-lists (bytes object type-name) for the objects
487 ;;; allocated in Space.
488 (defun type-breakdown (space)
489 (declare (muffle-conditions t
))
490 (let ((sizes (make-array 256 :initial-element
0 :element-type
'(unsigned-byte #.n-word-bits
)))
491 (counts (make-array 256 :initial-element
0 :element-type
'(unsigned-byte #.n-word-bits
))))
492 (map-allocated-objects
493 (lambda (obj type size
)
494 (declare (word size
) (optimize (speed 3)) (ignore obj
))
495 (incf (aref sizes type
) size
)
496 (incf (aref counts type
)))
499 (let ((totals (make-hash-table :test
'eq
)))
501 (let ((total-count (aref counts i
)))
502 (unless (zerop total-count
)
503 (let* ((total-size (aref sizes i
))
504 (name (room-info-type-name (aref *room-info
* i
)))
505 (found (ensure-gethash name totals
(list 0 0 name
))))
506 (incf (first found
) total-size
)
507 (incf (second found
) total-count
)))))
509 (collect ((totals-list))
510 (maphash (lambda (k v
)
514 (sort (totals-list) #'> :key
#'first
)))))
516 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
517 ;;; (space-name . totals-for-space), where totals-for-space is the list
518 ;;; returned by TYPE-BREAKDOWN.
519 (defun print-summary (spaces totals
)
520 (let ((summary (make-hash-table :test
'eq
))
521 (space-count (length spaces
)))
522 (dolist (space-total totals
)
523 (dolist (total (cdr space-total
))
524 (push (cons (car space-total
) total
)
525 (gethash (third total
) summary
))))
527 (collect ((summary-totals))
528 (maphash (lambda (k v
)
531 (declare (unsigned-byte sum
))
532 (dolist (space-total v
)
533 (incf sum
(first (cdr space-total
))))
534 (summary-totals (cons sum v
))))
537 (format t
"~2&Summary of space~P: ~(~{~A ~}~)~%" space-count spaces
)
538 (let ((summary-total-bytes 0)
539 (summary-total-objects 0))
540 (declare (unsigned-byte summary-total-bytes summary-total-objects
))
541 (dolist (space-totals
542 (mapcar #'cdr
(sort (summary-totals) #'> :key
#'car
)))
543 (let ((total-objects 0)
546 (declare (unsigned-byte total-objects total-bytes
))
548 (dolist (space-total space-totals
)
549 (let ((total (cdr space-total
)))
550 (setq name
(third total
))
551 (incf total-bytes
(first total
))
552 (incf total-objects
(second total
))
553 (spaces (cons (car space-total
) (first total
)))))
554 (format t
"~%~A:~% ~:D bytes, ~:D object~:P"
555 name total-bytes total-objects
)
556 (unless (= 1 space-count
)
557 (dolist (space (spaces))
558 (format t
", ~D% ~(~A~)"
559 (round (* (cdr space
) 100) total-bytes
) (car space
))))
561 (incf summary-total-bytes total-bytes
)
562 (incf summary-total-objects total-objects
))))
563 (format t
"~%Summary total:~% ~:D bytes, ~:D objects.~%"
564 summary-total-bytes summary-total-objects
)))))
566 ;;; Report object usage for a single space.
567 (defun report-space-total (space-info cutoff
)
568 (declare (list space-info
) (type (or single-float null
) cutoff
))
569 (destructuring-bind (space . types
) space-info
570 (format t
"~2&Breakdown for ~(~A~) space:~%" space
)
571 (let* ((total-bytes (reduce #'+ (mapcar #'first types
)))
572 (bytes-width (decimal-with-grouped-digits-width total-bytes
))
573 (total-objects (reduce #'+ (mapcar #'second types
)))
574 (objects-width (decimal-with-grouped-digits-width total-objects
))
575 (cutoff-point (if cutoff
576 (truncate (* (float total-bytes
) cutoff
))
579 (reported-objects 0))
580 (declare (unsigned-byte total-objects total-bytes cutoff-point
581 reported-objects reported-bytes
))
582 (flet ((type-usage (bytes objects name
&optional note
)
583 (format t
" ~V:D bytes for ~V:D ~(~A~) object~2:*~P~*~
585 bytes-width bytes objects-width objects name note
)))
586 (loop for
(bytes objects name
) in types do
587 (when (<= bytes cutoff-point
)
588 (type-usage (- total-bytes reported-bytes
)
589 (- total-objects reported-objects
)
592 (incf reported-bytes bytes
)
593 (incf reported-objects objects
)
594 (type-usage bytes objects name
))
596 (type-usage total-bytes total-objects space
"space total")))))
598 ;;; Print information about the heap memory in use. PRINT-SPACES is a
599 ;;; list of the spaces to print detailed information for.
600 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
601 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
602 ;;; PRINT-SUMMARY is true, then summary information will be printed.
603 ;;; The defaults print only summary information for dynamic space. If
604 ;;; true, CUTOFF is a fraction of the usage in a report below which
605 ;;; types will be combined as OTHER.
606 (defun memory-usage (&key print-spaces
(count-spaces '(:dynamic
#!+immobile-space
:immobile
))
607 (print-summary t
) cutoff
)
608 (declare (type (or single-float null
) cutoff
))
609 (let* ((spaces (if (eq count-spaces t
)
610 (mapcar #'first
**heap-spaces
**)
612 (totals (mapcar (lambda (space)
613 (cons space
(type-breakdown space
)))
616 (dolist (space-total totals
)
617 (when (or (eq print-spaces t
)
618 (member (car space-total
) print-spaces
))
619 (report-space-total space-total cutoff
)))
621 (when print-summary
(print-summary spaces totals
)))
625 ;;; Print a breakdown by instance type of all the instances allocated
626 ;;; in SPACE. If TOP-N is true, print only information for the
627 ;;; TOP-N types with largest usage.
628 (defun instance-usage (space &key
(top-n 15))
629 (declare (type spaces space
) (type (or fixnum null
) top-n
))
630 (format t
"~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space
)
631 (let ((totals (make-hash-table :test
'eq
))
634 (declare (unsigned-byte total-objects total-bytes
))
635 (map-allocated-objects
636 (lambda (obj type size
)
637 (declare (optimize (speed 3)))
638 (when (eql type instance-widetag
)
640 (let* ((classoid (layout-classoid (%instance-layout obj
)))
641 (found (ensure-gethash classoid totals
(cons 0 0)))
643 (declare (fixnum size
))
644 (incf total-bytes size
)
645 (incf (the fixnum
(car found
)))
646 (incf (the fixnum
(cdr found
)) size
))))
648 (let* ((sorted (sort (%hash-table-alist totals
) #'> :key
#'cddr
))
649 (interesting (if top-n
650 (subseq sorted
0 (min (length sorted
) top-n
))
652 (bytes-width (decimal-with-grouped-digits-width total-bytes
))
653 (objects-width (decimal-with-grouped-digits-width total-objects
))
654 (types-width (reduce #'max interesting
655 :key
(lambda (x) (length (symbol-name (classoid-name (first x
)))))
659 (declare (unsigned-byte printed-bytes printed-objects
))
660 (flet ((type-usage (type objects bytes
)
661 (let ((name (etypecase type
663 (classoid (symbol-name (classoid-name type
))))))
664 (format t
" ~V@<~A~> ~V:D bytes, ~V:D object~:P.~%"
665 (1+ types-width
) name bytes-width bytes
666 objects-width objects
))))
667 (loop for
(type .
(objects . bytes
)) in interesting do
668 (incf printed-bytes bytes
)
669 (incf printed-objects objects
)
670 (type-usage type objects bytes
))
671 (let ((residual-objects (- total-objects printed-objects
))
672 (residual-bytes (- total-bytes printed-bytes
)))
673 (unless (zerop residual-objects
)
674 (type-usage "Other types" residual-bytes residual-objects
)))
675 (type-usage (format nil
"~:(~A~) instance total" space
)
676 total-bytes total-objects
))))
679 ;;;; PRINT-ALLOCATED-OBJECTS
681 (defun print-allocated-objects (space &key
(percent 0) (pages 5)
682 type larger smaller count
683 (stream *standard-output
*))
684 (declare (type (integer 0 99) percent
) (type index pages
)
685 (type stream stream
) (type spaces space
)
686 (type (or index null
) type larger smaller count
))
687 (multiple-value-bind (start end
) (%space-bounds space
)
688 (let* ((space-start (ash start n-fixnum-tag-bits
))
689 (space-end (ash end n-fixnum-tag-bits
))
690 (space-size (- space-end space-start
))
691 (pagesize (get-page-size))
692 (start (+ space-start
(round (* space-size percent
) 100)))
693 (printed-conses (make-hash-table :test
'eq
))
697 (declare (type word last-page start
)
698 (fixnum pages-so-far count-so-far pagesize
))
699 (labels ((note-conses (x)
700 (unless (or (atom x
) (gethash x printed-conses
))
701 (setf (gethash x printed-conses
) t
)
702 (note-conses (car x
))
703 (note-conses (cdr x
)))))
704 (map-allocated-objects
705 (lambda (obj obj-type size
)
706 (let ((addr (get-lisp-obj-address obj
)))
707 (when (>= addr start
)
709 (> count-so-far count
)
710 (> pages-so-far pages
))
711 (return-from print-allocated-objects
(values)))
714 (let ((this-page (* (the (values word t
)
715 (truncate addr pagesize
))
717 (declare (type word this-page
))
718 (when (/= this-page last-page
)
719 (when (< pages-so-far pages
)
720 ;; FIXME: What is this? (ERROR "Argh..")? or
721 ;; a warning? or code that can be removed
722 ;; once the system is stable? or what?
723 (format stream
"~2&**** Page ~W, address ~X:~%"
725 (setq last-page this-page
)
726 (incf pages-so-far
))))
728 (when (and (or (not type
) (eql obj-type type
))
729 (or (not smaller
) (<= size smaller
))
730 (or (not larger
) (>= size larger
)))
733 (#.code-header-widetag
734 (let ((dinfo (%code-debug-info obj
)))
735 (format stream
"~&Code object: ~S~%"
737 (sb!c
::compiled-debug-info-name dinfo
)
740 (format stream
"~&~S~%" obj
))
741 (#.list-pointer-lowtag
742 (unless (gethash obj printed-conses
)
744 (let ((*print-circle
* t
)
747 (format stream
"~&~S~%" obj
))))
750 (let ((str (write-to-string obj
:level
5 :length
10
752 (unless (eql type instance-widetag
)
753 (format stream
"~S: " (type-of obj
)))
754 (format stream
"~A~%"
755 (subseq str
0 (min (length str
) 60))))))))))
759 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
761 (defvar *ignore-after
* nil
)
763 (defun valid-obj (space x
)
764 (or (not (eq space
:dynamic
))
765 ;; this test looks bogus if the allocator doesn't work linearly,
766 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
767 (< (get-lisp-obj-address x
) (get-lisp-obj-address *ignore-after
*))))
769 (defun maybe-cons (space x stuff
)
770 (if (valid-obj space x
)
774 (defun list-allocated-objects (space &key type larger smaller count
776 (declare (type spaces space
)
777 (type (or index null
) larger smaller type count
)
778 (type (or function null
) test
))
779 (unless *ignore-after
*
780 (setq *ignore-after
* (cons 1 2)))
781 (collect ((counted 0 1+))
783 (map-allocated-objects
784 (lambda (obj obj-type size
)
785 (when (and (or (not type
) (eql obj-type type
))
786 (or (not smaller
) (<= size smaller
))
787 (or (not larger
) (>= size larger
))
788 (or (not test
) (funcall test obj
)))
789 (setq res
(maybe-cons space obj res
))
790 (when (and count
(>= (counted) count
))
791 (return-from list-allocated-objects res
))))
795 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
796 ;;; change our notion of what we think they are.
798 ;;; Defining this here (as opposed to in 'debug-int' where it belongs)
799 ;;; is the path of least resistance to avoiding an inlining failure warning.
800 #!-sb-fluid
(declaim (inline sb
!di
::descriptor-sap
))
801 (defun sb!di
::descriptor-sap
(x)
802 (int-sap (get-lisp-obj-address x
)))
804 ;;; Calls FUNCTION with all objects 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 ;;; This interface allows one either to be agnostic of the referencing space,
825 ;;; or specify exactly one space, but not specify a list of spaces.
826 ;;; An upward-compatible change would be to assume a list, and call ENSURE-LIST.
827 (defun map-referencing-objects (fun space object
)
828 (declare (type (or (eql :all
) spaces
) space
))
829 (unless *ignore-after
*
830 (setq *ignore-after
* (cons 1 2)))
831 (flet ((ref-p (this widetag nwords
) ; return T if 'this' references object
834 (or (eq (car this
) object
) (eq (cdr this
) object
))))
836 ;; purely boxed objects
837 ((#.ratio-widetag
#.complex-widetag
#.value-cell-widetag
838 #.symbol-widetag
#.weak-pointer-widetag
839 #.simple-array-widetag
#.simple-vector-widetag
840 #.complex-array-widetag
#.complex-vector-widetag
841 #.complex-bit-vector-widetag
#.complex-vector-nil-widetag
842 #.complex-base-string-widetag
843 #!+sb-unicode
#.complex-character-string-widetag
))
844 ;; mixed boxed/unboxed objects
845 (#.code-header-widetag
846 (dotimes (i (code-n-entries this
))
847 (let ((f (%code-entry-point this i
)))
848 (when (or (eq f object
)
849 (eq (%simple-fun-name f
) object
)
850 (eq (%simple-fun-arglist f
) object
)
851 (eq (%simple-fun-type f
) object
)
852 (eq (%simple-fun-info f
) object
))
853 (return-from ref-p t
))))
854 (setq nwords
(code-header-words this
)))
857 (or (eq (%instance-layout this
) object
)
858 (do-instance-tagged-slot (i this
)
859 (when (eq (%instance-ref this i
) object
)
861 (#.funcallable-instance-widetag
862 (let ((l (%funcallable-instance-layout this
)))
864 (return-from ref-p t
))
865 (let ((bitmap (layout-bitmap l
)))
866 (unless (eql bitmap -
1)
867 ;; tagged slots precede untagged slots,
868 ;; so integer-length is the count of tagged slots.
869 (setq nwords
(1+ (integer-length bitmap
)))))))
871 (when (eq (%closure-fun this
) object
)
872 (return-from ref-p t
)))
875 (when (eq (make-lisp-obj
877 (extern-alien "fdefn_raw_referent" (function unsigned unsigned
))
878 (logandc2 (get-lisp-obj-address this
) lowtag-mask
)))
880 (return-from ref-p t
))
881 ;; Without immobile-code the 'raw-addr' slot either holds the same thing
882 ;; as the 'fun' slot, or holds a trampoline address. We'll overlook the
883 ;; minor issue that due to concurrent writes, two representations of the
884 ;; allegedly same referent may diverge; thus the last slot is skipped
885 ;; even if it refers to a different simple-fun.
888 (return-from ref-p nil
)))
889 ;; gencgc has WITHOUT-GCING in map-allocated-objects over dynamic space,
890 ;; so we don't have to pin each object inside REF-P.
891 (#!+cheneygc with-pinned-objects
#!+cheneygc
(this)
893 (do ((sap (int-sap (logandc2 (get-lisp-obj-address this
) lowtag-mask
)))
894 (i (* (1- nwords
) n-word-bytes
) (- i n-word-bytes
)))
896 (when (eq (sap-ref-lispobj sap i
) object
)
898 (let ((fun (%coerce-callable-to-fun fun
)))
899 (dx-flet ((mapfun (obj widetag size
)
900 (when (and (ref-p obj widetag
(/ size n-word-bytes
))
901 (valid-obj space obj
))
903 (map-allocated-objects #'mapfun space
)))))
905 (defun list-referencing-objects (space object
)
907 (map-referencing-objects
908 (lambda (obj) (res obj
)) space object
)
912 #+nil
; for debugging
913 (defun dump-dynamic-space-code (&optional
(stream *standard-output
*)
914 &aux
(n-pages 0) (n-code-bytes 0))
915 (flet ((dump-page (page-num)
917 (format stream
"~&Page ~D~%" page-num
)
918 (let ((where (+ dynamic-space-start
(* page-num gencgc-card-bytes
)))
921 (multiple-value-bind (obj type size
)
922 (reconstitute-object (ash where
(- n-fixnum-tag-bits
)))
923 (when (= type code-header-widetag
)
924 (incf n-code-bytes size
))
925 (when (if (and (consp obj
) (eq (car obj
) 0) (eq (cdr obj
) 0))
927 (progn (write-char #\. stream
) nil
)
928 (setq seen-filler t
))
929 (progn (setq seen-filler nil
) t
))
930 (let ((*print-pretty
* nil
))
931 (format stream
"~& ~X ~4X ~S " where size obj
)))
933 (let ((next-page (find-page-index where
)))
934 (cond ((= (logand where
(1- gencgc-card-bytes
)) 0)
935 (format stream
"~&-- END OF PAGE --~%")
937 ((eq next-page page-num
))
940 (setq page-num next-page seen-filler nil
))))))))
942 (loop while
(< i last-free-page
)
943 do
(let ((allocation (ldb (byte 2 0)
944 (slot (deref page-table i
) 'flags
))))
946 (setq i
(dump-page i
))
948 (let* ((tot (* n-pages gencgc-card-bytes
))
949 (waste (- tot n-code-bytes
)))
950 (format t
"~&Used=~D Waste=~D (~F%)~%" n-code-bytes waste
951 (* 100 (/ waste tot
))))))