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 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
15 (export 'sb-sys
::get-page-size
"SB-SYS"))
17 ;;;; type format database
19 (defstruct (room-info (:constructor make-room-info
(mask name kind
))
21 ;; the mask applied to HeaderValue to compute object size
22 (mask 0 :type
(and fixnum unsigned-byte
))
23 ;; the name of this type
24 (name nil
:type symbol
:read-only t
)
25 ;; kind of type (how to reconstitute an object)
27 :type
(member :other
:closure
:instance
:list
:code
:vector-nil
)
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 (defun !compute-room-infos
()
36 (let ((infos (make-array 256 :initial-element nil
))
37 (default-size-mask (mask-field (byte 23 0) -
1)))
38 (dolist (obj *primitive-objects
*)
39 (let ((widetag (primitive-object-widetag obj
))
40 (lowtag (primitive-object-lowtag obj
))
41 (name (primitive-object-name obj
)))
42 (when (and (eq lowtag
'other-pointer-lowtag
)
43 (not (member widetag
'(t nil
))))
44 (setf (svref infos
(symbol-value widetag
))
45 (make-room-info (if (member name
'(fdefn symbol
))
50 (dolist (code (list #+sb-unicode complex-character-string-widetag
51 complex-base-string-widetag simple-array-widetag
52 complex-bit-vector-widetag complex-vector-widetag
53 complex-array-widetag complex-vector-nil-widetag
))
54 (setf (svref infos code
)
55 (make-room-info default-size-mask
'array-header
:other
)))
57 (setf (svref infos bignum-widetag
)
58 ;; Lose 1 more bit than n-widetag-bits because fullcgc robs 1 bit,
59 ;; not that this is expected to work concurrently with gc.
60 (make-room-info (ash most-positive-word
(- (1+ n-widetag-bits
)))
63 (setf (svref infos closure-widetag
)
64 (make-room-info 0 'closure
:closure
))
66 (dotimes (i (length *specialized-array-element-type-properties
*))
67 (let ((saetp (aref *specialized-array-element-type-properties
* i
)))
68 (when (saetp-specifier saetp
) ;; SIMPLE-ARRAY-NIL is a special case.
69 (setf (svref infos
(saetp-typecode saetp
)) saetp
))))
71 (setf (svref infos simple-array-nil-widetag
)
72 (make-room-info 0 'simple-array-nil
:vector-nil
))
74 (setf (svref infos code-header-widetag
)
75 (make-room-info 0 'code
:code
))
77 (setf (svref infos instance-widetag
)
78 (make-room-info 0 'instance
:instance
))
80 (setf (svref infos funcallable-instance-widetag
)
81 (make-room-info 0 'funcallable-instance
:closure
))
83 (let ((cons-info (make-room-info 0 'cons
:list
)))
84 ;; A cons consists of two words, both of which may be either a
85 ;; pointer or immediate data. According to the runtime this means
86 ;; either a fixnum, a character, an unbound-marker, a single-float
87 ;; on a 64-bit system, or a pointer.
88 (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits
)))
89 (setf (svref infos
(ash i n-fixnum-tag-bits
)) cons-info
))
91 (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits
)))
92 (setf (svref infos
(logior (ash i n-lowtag-bits
) instance-pointer-lowtag
))
94 (setf (svref infos
(logior (ash i n-lowtag-bits
) list-pointer-lowtag
))
96 (setf (svref infos
(logior (ash i n-lowtag-bits
) fun-pointer-lowtag
))
98 (setf (svref infos
(logior (ash i n-lowtag-bits
) other-pointer-lowtag
))
101 (setf (svref infos character-widetag
) cons-info
)
103 (setf (svref infos unbound-marker-widetag
) cons-info
)
105 ;; Single-floats are immediate data on 64-bit systems.
106 #+64-bit
(setf (svref infos single-float-widetag
) cons-info
))
110 (define-load-time-global *room-info
* (!compute-room-infos
))
112 (defconstant-eqx +heap-spaces
+
113 '((:dynamic
"Dynamic space" sb-kernel
:dynamic-usage
)
115 (:immobile
"Immobile space" sb-kernel
::immobile-space-usage
)
116 (:read-only
"Read-only space" sb-kernel
::read-only-space-usage
)
117 (:static
"Static space" sb-kernel
::static-space-usage
))
120 (defconstant-eqx +stack-spaces
+
121 '((:control-stack
"Control stack" sb-kernel
::control-stack-usage
)
122 (:binding-stack
"Binding stack" sb-kernel
::binding-stack-usage
))
125 (defconstant-eqx +all-spaces
+ (append +heap-spaces
+ +stack-spaces
+) #'equal
)
127 (defconstant-eqx +heap-space-keywords
+ (mapcar #'first
+heap-spaces
+) #'equal
)
128 (deftype spaces
() `(member .
,+heap-space-keywords
+))
131 ;;;; MAP-ALLOCATED-OBJECTS
133 ;;; Return the lower limit and current free-pointer of SPACE as fixnums
134 ;;; whose raw bits (at the register level) represent a pointer.
135 ;;; This makes it "off" by a factor of (EXPT 2 N-FIXNUM-TAG-BITS) - and/or
136 ;;; possibly negative - if you look at the value in Lisp,
137 ;;; but avoids potentially needing a bignum on 32-bit machines.
138 ;;; 64-bit machines have no problem since most current generation CPUs
139 ;;; use an address width that is narrower than 64 bits.
140 ;;; This function is private because of the wacky representation.
141 (defun %space-bounds
(space)
142 (declare (type spaces space
))
145 (values (%make-lisp-obj static-space-start
)
146 (%make-lisp-obj
(sap-int *static-space-free-pointer
*))))
148 (values (%make-lisp-obj read-only-space-start
)
149 (%make-lisp-obj
(sap-int *read-only-space-free-pointer
*))))
152 (values (%make-lisp-obj immobile-space-start
)
153 (%make-lisp-obj
(sap-int *immobile-space-free-pointer
*))))
155 (values (%make-lisp-obj
(current-dynamic-space-start))
156 (%make-lisp-obj
(sap-int (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 (ash (- end start
) n-fixnum-tag-bits
)))
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 (header-value)
203 `(round-to-dualword (ash (1+ ,header-value
) word-shift
)))
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"
217 (case (room-info-kind info
)
219 (values (tagged-object list-pointer-lowtag
)
223 (:closure
; also funcallable-instance
224 (values (tagged-object fun-pointer-lowtag
)
226 (boxed-size (logand header-value short-header-max-words
))))
229 (values (tagged-object instance-pointer-lowtag
)
231 (boxed-size (logand header-value short-header-max-words
))))
234 (values (tagged-object other-pointer-lowtag
)
236 (boxed-size (logand header-value
(room-info-mask info
)))))
239 (values (tagged-object other-pointer-lowtag
)
240 simple-array-nil-widetag
244 (let ((c (tagged-object other-pointer-lowtag
)))
248 (+ (* (logand header-value short-header-max-words
)
250 (%code-code-size
(truly-the code-component c
)))))))))))))
252 ;;; Iterate over all the objects in the contiguous block of memory
253 ;;; with the low address at START and the high address just before
254 ;;; END, calling FUN with the object, the object's type code, and the
255 ;;; object's total size in bytes, including any header and padding.
256 ;;; START and END are untagged, aligned memory addresses interpreted
257 ;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
258 (defun map-objects-in-range (fun start end
&optional
(strict-bound t
))
259 (declare (type function fun
))
260 (named-let iter
((start start
))
262 ((< (get-lisp-obj-address start
) (get-lisp-obj-address end
))
263 (multiple-value-bind (obj typecode size
) (reconstitute-object start
)
264 ;; SIZE is almost surely a fixnum. Non-fixnum would mean at least
265 ;; a 512MB object if 32-bit words, and is inconceivable if 64-bit.
266 (aver (not (logtest (the word size
) lowtag-mask
)))
267 (funcall fun obj typecode size
)
268 ;; This special little dance is to add a number of octets
269 ;; (and it had best be a number evenly divisible by our
270 ;; allocation granularity) to an unboxed, aligned address
271 ;; masquerading as a fixnum. Without consing.
272 (iter (%make-lisp-obj
273 (mask-field (byte #.n-word-bits
0)
274 (+ (get-lisp-obj-address start
)
277 ;; If START is not eq to END, then we have blown past our endpoint.
278 (aver (eq start end
))))))
280 ;;; Access to the GENCGC page table for better precision in
281 ;;; MAP-ALLOCATED-OBJECTS
284 (define-alien-type (struct page
)
286 ;; To cut down the size of the page table, the scan_start_offset
287 ;; - a/k/a "start" - is measured in 4-byte integers regardless
288 ;; of word size. This is fine for 32-bit address space,
289 ;; but if 64-bit then we have to scale the value. Additionally
290 ;; there is a fallback for when even the scaled value is too big.
291 ;; (None of this matters to Lisp code for the most part)
292 (start #+64-bit
(unsigned 32) #-
64-bit signed
)
293 ;; On platforms with small enough GC pages, this field
294 ;; will be a short. On platforms with larger ones, it'll
296 ;; Measured in bytes; the low bit has to be masked off.
297 (bytes-used (unsigned
298 #.
(if (typep gencgc-card-bytes
'(unsigned-byte 16))
305 (define-alien-type (struct immobile-page
)
306 ;; ... and yet another place for Lisp to become out-of-sync with C.
307 (struct immobile-page
309 (obj-spacing (unsigned 8))
310 (obj-size (unsigned 8))
311 (generations (unsigned 8))
312 (free-index (unsigned 32))
313 (page-link (unsigned 16))
314 (prior-free-index (unsigned 16))))
315 (define-alien-variable "fixedobj_pages" (* (struct immobile-page
))))
316 (declaim (inline find-page-index
))
317 (define-alien-routine ("ext_find_page_index" find-page-index
)
319 (define-alien-variable "last_free_page" sb-kernel
::page-index-t
)
320 (define-alien-variable "page_table" (* (struct page
))))
324 (declaim (inline immobile-subspace-bounds
))
325 ;;; Return fixnums in the same fashion as %SPACE-BOUNDS.
326 (defun immobile-subspace-bounds (subspace)
328 (:fixed
(values (%make-lisp-obj immobile-space-start
)
329 (%make-lisp-obj
(sap-int *immobile-fixedobj-free-pointer
*))))
330 (:variable
(values (%make-lisp-obj
(+ immobile-space-start
331 immobile-fixedobj-subspace-size
))
332 (%make-lisp-obj
(sap-int *immobile-space-free-pointer
*))))))
334 (declaim (ftype (sfunction (function &rest immobile-subspaces
) null
)
335 map-immobile-objects
))
336 (defun map-immobile-objects (function &rest subspaces
) ; Perform no filtering
337 (do-rest-arg ((subspace) subspaces
)
338 (multiple-value-bind (start end
) (immobile-subspace-bounds subspace
)
339 (map-objects-in-range function start end
)))))
342 MAP-ALLOCATED-OBJECTS is fundamentally unsafe to use if the user-supplied
343 function allocates anything. Consider what can happens when LAST-FREE-PAGE
[sic]
344 points to a partially filled page, and one more object is created extending
345 an allocation region that began on the formerly "last" page:
347 0x10027cfff0: 0x00000000000000d9 <-- this was Lisp's view of
348 0x10027cfff8: 0x0000000000000006 the last page (page 1273)
349 ---- page boundary ----
350 0x10027d0000: 0x0000001000005ecf <-- last_free_page moves here (page 1274)
351 0x10027d0008: 0x00000000000000ba
352 0x10027d0010: 0x0000000000000040
353 0x10027d0018: 0x0000000000000000
355 Lisp did not think that the page starting at 0x10027d0000 was allocated,
356 so it believes the stopping point is page 1273. When we read the bytes-used
357 on that page, we see a totally full page, but do not consider adjoining any
358 additional pages into the contiguous block.
359 However the object, a vector, that started on page 1273 ends on page 1274,
360 causing MAP-OBJECTS-IN-RANGE to assert that it overran 0x10027d0000.
362 We could try a few things to mitigate this:
363 * Try to "chase" the value of last-free-page. This is literally impossible -
364 it's a moving target, and it's extremely likely to exhaust memory doing so,
365 especially if the supplied lambda is an interpreted function.
366 (Each object scanned causes consing of more bytes, and we never
367 "catch up" to the moving last-free-page)
369 * If the page that we're looking at is full but the FINALLY clause is hit,
370 don't stop looking for more pages in that one case. Instead keep looking
371 for the end of the contiguous block, but stop as soon any potential
372 stopping point is found; don't chase last-free-page. This is tricky
373 as well and just about as infeasible.
375 * Pass a flag to MAP-OBJECTS-IN-RANGE specifying that it's OK to
376 surpass the expected bound - silently accept our fate.
377 This is what we do since it's simple, and seems to work.
380 ;;; Iterate over all the objects allocated in each of the SPACES, calling FUN
381 ;;; with the object, the object's type code, and the object's total size in
382 ;;; bytes, including any header and padding. As a special case, if exactly one
383 ;;; space named :ALL is requested, then map over the known spaces.
384 (defun map-allocated-objects (fun &rest spaces)
385 (declare (type function fun))
386 (when (and (= (length spaces) 1) (eq (first spaces) :all))
387 (return-from map-allocated-objects
388 (map-allocated-objects fun
390 #+immobile-space :immobile
392 ;; You can't specify :ALL and also a list of spaces. Check that up front.
393 (do-rest-arg ((space) spaces) (the spaces space))
394 (flet ((do-1-space (space)
397 ;; Static space starts with NIL, which requires special
398 ;; handling, as the header and alignment are slightly off.
399 (multiple-value-bind (start end) (%space-bounds space)
400 ;; This "8" is very magical. It happens to work for both
401 ;; word sizes, even though symbols differ in length
402 ;; (they can be either 6 or 7 words).
403 (funcall fun nil symbol-widetag (* 8 n-word-bytes))
404 (map-objects-in-range fun
405 (+ (ash (* 8 n-word-bytes) (- n-fixnum-tag-bits))
409 ((:read-only #-gencgc :dynamic)
410 ;; Read-only space (and dynamic space on cheneygc) is a block
411 ;; of contiguous allocations.
412 (multiple-value-bind (start end) (%space-bounds space)
413 (map-objects-in-range fun start end)))
416 ;; Filter out filler objects. These either look like cons cells
417 ;; in fixedobj subspace, or code without enough header words
418 ;; in varyobj subspace. (cf 'filler_obj_p' in gc-internal.h)
419 (dx-flet ((filter (obj type size)
421 (funcall fun obj type size))))
422 (map-immobile-objects #'filter :fixed))
423 (dx-flet ((filter (obj type size)
424 (unless (and (code-component-p obj)
425 (eql (code-header-words obj) 2))
426 (funcall fun obj type size))))
427 (map-immobile-objects #'filter :variable)))
431 ;; Dynamic space on gencgc requires walking the GC page tables
432 ;; in order to determine what regions contain objects.
434 ;; We explicitly presume that any pages in an allocation region
435 ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
436 ;; (indicating a full page) or an otherwise-valid BYTES-USED.
437 ;; We also presume that the pages of an open allocation region
438 ;; after the first page, and any pages that are unallocated,
439 ;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
441 ;; Our procedure is to scan forward through the page table,
442 ;; maintaining an "end pointer" until we reach a page where
443 ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
444 ;; LAST-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
445 ;; is not empty, and proceed to the next page (unless we've hit
446 ;; LAST-FREE-PAGE). We happily take advantage of the fact that
447 ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
448 ;; coincident pointers for the range.
450 ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
451 ;; closing allocation regions and opening new ones. This may
452 ;; prove to be an issue with concurrent systems, or with
453 ;; spectacularly poor timing for closing an allocation region
454 ;; in a single-threaded system.
457 with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
458 ;; This magic dance gets us an unboxed aligned pointer as a
460 with start = (%make-lisp-obj (current-dynamic-space-start))
463 ;; This is our page range. The type constraint is far too generous,
464 ;; but it does its job of producing efficient code.
466 of-type (integer -1 (#.(/ (ash 1 n-machine-word-bits) gencgc-card-bytes)))
467 from 0 below last-free-page
468 for next-page-addr from (+ start page-size) by page-size
470 ;; The low bits of bytes-used is the need-to-zero flag.
471 = (logandc1 1 (slot (deref page-table page-index) 'bytes-used))
473 when (< page-bytes-used gencgc-card-bytes)
475 (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
476 (map-objects-in-range fun start end)
477 (setf start next-page-addr)
478 (setf end next-page-addr))
479 else do (incf end page-size)
481 finally (map-objects-in-range fun start end nil))))))
482 (do-rest-arg ((space) spaces)
483 (if (eq space :dynamic)
484 (without-gcing (do-1-space space))
485 (do-1-space space)))))
491 (deftype immobile-subspaces ()
492 '(member :fixed :variable))
494 (declaim (ftype (function (immobile-subspaces) (values t t t &optional))
495 immobile-fragmentation-information))
496 (defun immobile-fragmentation-information (subspace)
497 (binding* (((start free-pointer) (immobile-subspace-bounds subspace))
498 (used-bytes (ash (- free-pointer start) n-fixnum-tag-bits))
501 (map-immobile-objects
502 (lambda (obj type size)
503 (declare (ignore type))
504 (let ((address (logandc2 (get-lisp-obj-address obj) lowtag-mask)))
507 (:variable (hole-p address)))
508 (push (cons address size) holes)
509 (incf hole-bytes size))))
511 (values holes hole-bytes used-bytes)))
513 (defun show-fragmentation (&key (subspaces '(:fixed :variable))
514 (stream *standard-output*))
515 (dolist (subspace subspaces)
516 (format stream "~(~A~) subspace fragmentation:~%" subspace)
517 (multiple-value-bind (holes hole-bytes total-space-used)
518 (immobile-fragmentation-information subspace)
519 (loop for (start . size) in holes
520 do (format stream "~2@T~X..~X ~8:D~%" start (+ start size) size))
521 (format stream "~2@T~18@<~:D hole~:P~> ~8:D (~,2,2F% of ~:D ~
523 (length holes) hole-bytes
524 (/ hole-bytes total-space-used) total-space-used))))
526 (defun sb-kernel::immobile-space-usage ()
527 (binding* (((nil fixed-hole-bytes fixed-used-bytes)
528 (immobile-fragmentation-information :fixed))
529 ((nil variable-hole-bytes variable-used-bytes)
530 (immobile-fragmentation-information :variable))
531 (total-used-bytes (+ fixed-used-bytes variable-used-bytes))
532 (total-hole-bytes (+ fixed-hole-bytes variable-hole-bytes)))
533 (values total-used-bytes total-hole-bytes)))
536 ;;; Return a list of 3-lists (bytes object type-name) for the objects
537 ;;; allocated in Space.
538 (defun type-breakdown (space)
539 (declare (muffle-conditions t))
540 (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.n-word-bits)))
541 (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.n-word-bits))))
542 (map-allocated-objects
543 (lambda (obj type size)
544 (declare (word size) (optimize (speed 3)) (ignore obj))
545 (incf (aref sizes type) size)
546 (incf (aref counts type)))
549 (let ((totals (make-hash-table :test 'eq)))
551 (let ((total-count (aref counts i)))
552 (unless (zerop total-count)
553 (let* ((total-size (aref sizes i))
554 (name (room-info-type-name (aref *room-info* i)))
555 (found (ensure-gethash name totals (list 0 0 name))))
556 (incf (first found) total-size)
557 (incf (second found) total-count)))))
559 (collect ((totals-list))
560 (maphash (lambda (k v)
564 (sort (totals-list) #'> :key #'first)))))
566 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
567 ;;; (space-name . totals-for-space), where totals-for-space is the list
568 ;;; returned by TYPE-BREAKDOWN.
569 (defun print-summary (spaces totals)
570 (let ((summary (make-hash-table :test 'eq))
571 (space-count (length spaces)))
572 (dolist (space-total totals)
573 (dolist (total (cdr space-total))
574 (push (cons (car space-total) total)
575 (gethash (third total) summary))))
577 (collect ((summary-totals))
578 (maphash (lambda (k v)
581 (declare (unsigned-byte sum))
582 (dolist (space-total v)
583 (incf sum (first (cdr space-total))))
584 (summary-totals (cons sum v))))
587 (format t "~2&Summary of space~P: ~(~{~A ~}~)~%" space-count spaces)
588 (let ((summary-total-bytes 0)
589 (summary-total-objects 0))
590 (declare (unsigned-byte summary-total-bytes summary-total-objects))
591 (dolist (space-totals
592 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
593 (let ((total-objects 0)
596 (declare (unsigned-byte total-objects total-bytes))
598 (dolist (space-total space-totals)
599 (let ((total (cdr space-total)))
600 (setq name (third total))
601 (incf total-bytes (first total))
602 (incf total-objects (second total))
603 (spaces (cons (car space-total) (first total)))))
604 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
605 name total-bytes total-objects)
606 (unless (= 1 space-count)
607 (dolist (space (spaces))
608 (format t ", ~D% ~(~A~)"
609 (round (* (cdr space) 100) total-bytes) (car space))))
611 (incf summary-total-bytes total-bytes)
612 (incf summary-total-objects total-objects))))
613 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
614 summary-total-bytes summary-total-objects)))))
616 ;;; Report object usage for a single space.
617 (defun report-space-total (space-info cutoff)
618 (declare (list space-info) (type (or single-float null) cutoff))
619 (destructuring-bind (space . types) space-info
620 (format t "~2&Breakdown for ~(~A~) space:~%" space)
621 (let* ((total-bytes (reduce #'+ (mapcar #'first types)))
622 (bytes-width (decimal-with-grouped-digits-width total-bytes))
623 (total-objects (reduce #'+ (mapcar #'second types)))
624 (objects-width (decimal-with-grouped-digits-width total-objects))
625 (cutoff-point (if cutoff
626 (truncate (* (float total-bytes) cutoff))
629 (reported-objects 0))
630 (declare (unsigned-byte total-objects total-bytes cutoff-point
631 reported-objects reported-bytes))
632 (flet ((type-usage (bytes objects name &optional note)
633 (format t " ~V:D bytes for ~V:D ~(~A~) object~2:*~P~*~
635 bytes-width bytes objects-width objects name note)))
636 (loop for (bytes objects name) in types do
637 (when (<= bytes cutoff-point)
638 (type-usage (- total-bytes reported-bytes)
639 (- total-objects reported-objects)
642 (incf reported-bytes bytes)
643 (incf reported-objects objects)
644 (type-usage bytes objects name))
646 (type-usage total-bytes total-objects space "space total")))))
648 ;;; Print information about the heap memory in use. PRINT-SPACES is a
649 ;;; list of the spaces to print detailed information for.
650 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
651 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
652 ;;; PRINT-SUMMARY is true, then summary information will be printed.
653 ;;; The defaults print only summary information for dynamic space. If
654 ;;; true, CUTOFF is a fraction of the usage in a report below which
655 ;;; types will be combined as OTHER.
656 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic #+immobile-space :immobile))
657 (print-summary t) cutoff)
658 (declare (type (or single-float null) cutoff))
659 (let* ((spaces (if (eq count-spaces t) +heap-space-keywords+ count-spaces))
660 (totals (mapcar (lambda (space)
661 (cons space (type-breakdown space)))
664 (dolist (space-total totals)
665 (when (or (eq print-spaces t)
666 (member (car space-total) print-spaces))
667 (report-space-total space-total cutoff)))
669 (when print-summary (print-summary spaces totals)))
673 ;;; Print a breakdown by instance type of all the instances allocated
674 ;;; in SPACE. If TOP-N is true, print only information for the
675 ;;; TOP-N types with largest usage.
676 (defun instance-usage (space &key (top-n 15))
677 (declare (type spaces space) (type (or fixnum null) top-n))
678 (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
679 (let ((totals (make-hash-table :test 'eq))
682 (declare (unsigned-byte total-objects total-bytes))
683 (map-allocated-objects
684 (lambda (obj type size)
685 (declare (optimize (speed 3)))
686 (when (eql type instance-widetag)
688 (let* ((classoid (layout-classoid (%instance-layout obj)))
689 (found (ensure-gethash classoid totals (cons 0 0)))
691 (declare (fixnum size))
692 (incf total-bytes size)
693 (incf (the fixnum (car found)))
694 (incf (the fixnum (cdr found)) size))))
696 (let* ((sorted (sort (%hash-table-alist totals) #'> :key #'cddr))
697 (interesting (if top-n
698 (subseq sorted 0 (min (length sorted) top-n))
700 (bytes-width (decimal-with-grouped-digits-width total-bytes))
701 (objects-width (decimal-with-grouped-digits-width total-objects))
702 (types-width (reduce #'max interesting
703 :key (lambda (x) (length (symbol-name (classoid-name (first x)))))
707 (declare (unsigned-byte printed-bytes printed-objects))
708 (flet ((type-usage (type objects bytes)
709 (let ((name (etypecase type
711 (classoid (symbol-name (classoid-name type))))))
712 (format t " ~V@<~A~> ~V:D bytes, ~V:D object~:P.~%"
713 (1+ types-width) name bytes-width bytes
714 objects-width objects))))
715 (loop for (type . (objects . bytes)) in interesting do
716 (incf printed-bytes bytes)
717 (incf printed-objects objects)
718 (type-usage type objects bytes))
719 (let ((residual-objects (- total-objects printed-objects))
720 (residual-bytes (- total-bytes printed-bytes)))
721 (unless (zerop residual-objects)
722 (type-usage "Other types" residual-bytes residual-objects)))
723 (type-usage (format nil "~:(~A~) instance total" space)
724 total-bytes total-objects))))
727 ;;;; PRINT-ALLOCATED-OBJECTS
729 ;;; This notion of page-size is completely arbitrary - it affects 2 things:
730 ;;; (1) how much output to print "per page" in print-allocated-objects
731 ;;; (2) sb-sprof deciding how many regions [sic] were made if
#+cheneygc
732 (defun get-page-size () sb-c
:+backend-page-bytes
+)
734 (defun print-allocated-objects (space &key
(percent 0) (pages 5)
735 type larger smaller count
736 (stream *standard-output
*))
737 (declare (type (integer 0 99) percent
) (type index pages
)
738 (type stream stream
) (type spaces space
)
739 (type (or index null
) type larger smaller count
))
740 (multiple-value-bind (start end
) (%space-bounds space
)
741 (let* ((space-start (ash start n-fixnum-tag-bits
))
742 (space-end (ash end n-fixnum-tag-bits
))
743 (space-size (- space-end space-start
))
744 (pagesize (get-page-size))
745 (start (+ space-start
(round (* space-size percent
) 100)))
746 (printed-conses (make-hash-table :test
'eq
))
750 (declare (type word last-page start
)
751 (fixnum pages-so-far count-so-far pagesize
))
752 (labels ((note-conses (x)
753 (unless (or (atom x
) (gethash x printed-conses
))
754 (setf (gethash x printed-conses
) t
)
755 (note-conses (car x
))
756 (note-conses (cdr x
)))))
757 (map-allocated-objects
758 (lambda (obj obj-type size
)
759 (let ((addr (get-lisp-obj-address obj
)))
760 (when (>= addr start
)
762 (> count-so-far count
)
763 (> pages-so-far pages
))
764 (return-from print-allocated-objects
(values)))
767 (let ((this-page (* (the (values word t
)
768 (truncate addr pagesize
))
770 (declare (type word this-page
))
771 (when (/= this-page last-page
)
772 (when (< pages-so-far pages
)
773 ;; FIXME: What is this? (ERROR "Argh..")? or
774 ;; a warning? or code that can be removed
775 ;; once the system is stable? or what?
776 (format stream
"~2&**** Page ~W, address ~X:~%"
778 (setq last-page this-page
)
779 (incf pages-so-far
))))
781 (when (and (or (not type
) (eql obj-type type
))
782 (or (not smaller
) (<= size smaller
))
783 (or (not larger
) (>= size larger
)))
786 (#.code-header-widetag
787 (let ((dinfo (%code-debug-info obj
)))
788 (format stream
"~&Code object: ~S~%"
790 (sb-c::compiled-debug-info-name dinfo
)
793 (format stream
"~&~S~%" obj
))
794 (#.list-pointer-lowtag
795 (unless (gethash obj printed-conses
)
797 (let ((*print-circle
* t
)
800 (format stream
"~&~S~%" obj
))))
803 (let ((str (write-to-string obj
:level
5 :length
10
805 (unless (eql type instance-widetag
)
806 (format stream
"~S: " (type-of obj
)))
807 (format stream
"~A~%"
808 (subseq str
0 (min (length str
) 60))))))))))
812 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
814 (defvar *ignore-after
* nil
)
816 (defun valid-obj (space x
)
817 (or (not (eq space
:dynamic
))
818 ;; this test looks bogus if the allocator doesn't work linearly,
819 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
820 (< (get-lisp-obj-address x
) (get-lisp-obj-address *ignore-after
*))))
822 (defun maybe-cons (space x stuff
)
823 (if (valid-obj space x
)
827 (defun list-allocated-objects (space &key type larger smaller count
829 (declare (type spaces space
)
830 (type (or index null
) larger smaller type count
)
831 (type (or function null
) test
))
832 (unless *ignore-after
*
833 (setq *ignore-after
* (cons 1 2)))
834 (collect ((counted 0 1+))
836 (map-allocated-objects
837 (lambda (obj obj-type size
)
838 (when (and (or (not type
) (eql obj-type type
))
839 (or (not smaller
) (<= size smaller
))
840 (or (not larger
) (>= size larger
))
841 (or (not test
) (funcall test obj
)))
842 (setq res
(maybe-cons space obj res
))
843 (when (and count
(>= (counted) count
))
844 (return-from list-allocated-objects res
))))
848 ;;; Calls FUNCTION with all objects that have (possibly conservative)
849 ;;; references to them on current stack.
850 (defun map-stack-references (function)
853 #+stack-grows-downward-not-upward
*control-stack-end
*
854 #-stack-grows-downward-not-upward
*control-stack-start
*))
857 (loop until
#+stack-grows-downward-not-upward
(sap> sp end
)
858 #-stack-grows-downward-not-upward
(sap< sp end
)
859 do
(multiple-value-bind (obj ok
) (make-lisp-obj (sap-ref-word sp
0) nil
)
860 (when (and ok
(typep obj
'(not (or fixnum character
))))
861 (unless (member obj seen
:test
#'eq
)
862 (funcall function obj
)
865 #+stack-grows-downward-not-upward
(sap+ sp n-word-bytes
)
866 #-stack-grows-downward-not-upward
(sap+ sp
(- n-word-bytes
))))))
868 ;;; This interface allows one either to be agnostic of the referencing space,
869 ;;; or specify exactly one space, but not specify a list of spaces.
870 ;;; An upward-compatible change would be to assume a list, and call ENSURE-LIST.
871 (defun map-referencing-objects (fun space object
)
872 (declare (type (or (eql :all
) spaces
) space
))
873 (unless *ignore-after
*
874 (setq *ignore-after
* (cons 1 2)))
875 (flet ((ref-p (this widetag nwords
) ; return T if 'this' references object
878 (or (eq (car this
) object
) (eq (cdr this
) object
))))
880 ;; purely boxed objects
881 ((#.ratio-widetag
#.complex-widetag
#.value-cell-widetag
882 #.symbol-widetag
#.weak-pointer-widetag
883 #.simple-array-widetag
#.simple-vector-widetag
884 #.complex-array-widetag
#.complex-vector-widetag
885 #.complex-bit-vector-widetag
#.complex-vector-nil-widetag
886 #.complex-base-string-widetag
887 #+sb-unicode
#.complex-character-string-widetag
))
888 ;; mixed boxed/unboxed objects
889 (#.code-header-widetag
890 (dotimes (i (code-n-entries this
))
891 (let ((f (%code-entry-point this i
)))
892 (when (or (eq f object
)
893 (eq (%simple-fun-name f
) object
)
894 (eq (%simple-fun-arglist f
) object
)
895 (eq (%simple-fun-type f
) object
)
896 (eq (%simple-fun-info f
) object
))
897 (return-from ref-p t
))))
898 (setq nwords
(code-header-words this
)))
901 (or (eq (%instance-layout this
) object
)
902 (do-instance-tagged-slot (i this
)
903 (when (eq (%instance-ref this i
) object
)
905 (#.funcallable-instance-widetag
906 (let ((l (%funcallable-instance-layout this
)))
908 (return-from ref-p t
))
909 (let ((bitmap (layout-bitmap l
)))
910 (unless (eql bitmap -
1)
911 ;; tagged slots precede untagged slots,
912 ;; so integer-length is the count of tagged slots.
913 (setq nwords
(1+ (integer-length bitmap
)))))))
915 (when (eq (%closure-fun this
) object
)
916 (return-from ref-p t
)))
919 (when (eq (make-lisp-obj
921 (extern-alien "fdefn_callee_lispobj" (function unsigned unsigned
))
922 (logandc2 (get-lisp-obj-address this
) lowtag-mask
)))
924 (return-from ref-p t
))
925 ;; Without immobile-code the 'raw-addr' slot either holds the same thing
926 ;; as the 'fun' slot, or holds a trampoline address. We'll overlook the
927 ;; minor issue that due to concurrent writes, two representations of the
928 ;; allegedly same referent may diverge; thus the last slot is skipped
929 ;; even if it refers to a different simple-fun.
932 (return-from ref-p nil
)))
933 ;; gencgc has WITHOUT-GCING in map-allocated-objects over dynamic space,
934 ;; so we don't have to pin each object inside REF-P.
935 (#+cheneygc with-pinned-objects
#+cheneygc
(this)
937 (do ((sap (int-sap (logandc2 (get-lisp-obj-address this
) lowtag-mask
)))
938 (i (* (1- nwords
) n-word-bytes
) (- i n-word-bytes
)))
940 (when (eq (sap-ref-lispobj sap i
) object
)
942 (let ((fun (%coerce-callable-to-fun fun
)))
943 (dx-flet ((mapfun (obj widetag size
)
944 (when (and (ref-p obj widetag
(/ size n-word-bytes
))
945 (valid-obj space obj
))
947 (map-allocated-objects #'mapfun space
)))))
949 (defun list-referencing-objects (space object
)
951 (map-referencing-objects
952 (lambda (obj) (res obj
)) space object
)
957 (defun room-minimal-info ()
958 (multiple-value-bind (names name-width
959 used-bytes used-bytes-width
961 (loop for
(nil name function
) in
+all-spaces
+
962 for
(space-used-bytes space-overhead-bytes
)
963 = (multiple-value-list (funcall function
))
964 collect name into names
965 collect space-used-bytes into used-bytes
966 collect space-overhead-bytes into overhead-bytes
967 maximizing
(length name
) into name-maximum
968 maximizing space-used-bytes into used-bytes-maximum
969 finally
(return (values
971 used-bytes
(decimal-with-grouped-digits-width
974 (loop for name in names
975 for space-used-bytes in used-bytes
976 for space-overhead-bytes in overhead-bytes
977 do
(format t
"~V@<~A usage is:~> ~V:D bytes~@[ (~:D bytes ~
979 (+ name-width
10) name used-bytes-width space-used-bytes
980 space-overhead-bytes
)))
982 (format t
"Control and binding stack usage is for the current thread ~
984 (format t
"Garbage collection is currently ~:[enabled~;DISABLED~].~%"
987 (defun room-intermediate-info ()
989 (memory-usage :count-spaces
'(:dynamic
#+immobile-space
:immobile
)
994 (defun room-maximal-info ()
995 (let ((spaces '(:dynamic
#+immobile-space
:immobile
:static
)))
997 (memory-usage :count-spaces spaces
)
998 (dolist (space spaces
)
999 (instance-usage space
:top-n
10))))
1001 (defun room (&optional
(verbosity :default
))
1002 "Print to *STANDARD-OUTPUT* information about the state of internal
1003 storage and its management. The optional argument controls the
1004 verbosity of output. If it is T, ROOM prints out a maximal amount of
1005 information. If it is NIL, ROOM prints out a minimal amount of
1006 information. If it is :DEFAULT or it is not supplied, ROOM prints out
1007 an intermediate amount of information."
1011 (room-maximal-info))
1013 (room-minimal-info))
1015 (room-intermediate-info)))
1018 #+nil
; for debugging
1019 (defun dump-dynamic-space-code (&optional
(stream *standard-output
*)
1020 &aux
(n-code-bytes 0)
1021 (total-pages last-free-page
)
1023 (make-array total-pages
:element-type
'bit
)))
1024 (flet ((dump-page (page-num)
1025 (format stream
"~&Page ~D~%" page-num
)
1026 (let ((where (+ dynamic-space-start
(* page-num gencgc-card-bytes
)))
1029 (multiple-value-bind (obj type size
)
1030 (reconstitute-object (ash where
(- n-fixnum-tag-bits
)))
1031 (when (= type code-header-widetag
)
1032 (incf n-code-bytes size
))
1033 (when (if (and (consp obj
) (eq (car obj
) 0) (eq (cdr obj
) 0))
1035 (progn (write-char #\. stream
) nil
)
1036 (setq seen-filler t
))
1037 (progn (setq seen-filler nil
) t
))
1038 (let ((*print-pretty
* nil
))
1039 (format stream
"~& ~X ~4X ~S " where size obj
)))
1041 (loop for index from page-num to
(find-page-index (1- where
))
1042 do
(setf (sbit pages index
) 1)))
1043 (let ((next-page (find-page-index where
)))
1044 (cond ((= (logand where
(1- gencgc-card-bytes
)) 0)
1045 (format stream
"~&-- END OF PAGE --~%")
1047 ((eq next-page page-num
))
1049 (setq page-num next-page seen-filler nil
))))))))
1051 (loop while
(< i total-pages
)
1052 do
(let ((type (ldb (byte 2 0) (slot (deref page-table i
) 'flags
))))
1054 (setq i
(dump-page i
))
1056 (let* ((n-pages (count 1 pages
))
1057 (tot (* n-pages gencgc-card-bytes
))
1058 (waste (- tot n-code-bytes
)))
1059 (format t
"~&Used-bytes=~D Pages=~D Waste=~D (~F%)~%"
1060 n-code-bytes n-pages waste
1061 (* 100 (/ waste tot
))))))