1 ;;;; heap-grovelling memory usage stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; type format database
16 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
17 (def!struct
(room-info (:make-load-form-fun just-dump-it-normally
))
18 ;; the name of this type
19 (name nil
:type symbol
)
20 ;; kind of type (how we determine length)
22 :type
(member :lowtag
:fixed
:header
:vector
23 :string
:code
:closure
:instance
))
24 ;; length if fixed-length, shift amount for element size if :VECTOR
25 (length nil
:type
(or fixnum null
))))
27 (eval-when (:compile-toplevel
:execute
)
29 (defvar *meta-room-info
* (make-array 256 :initial-element nil
))
31 (dolist (obj *primitive-objects
*)
32 (let ((widetag (primitive-object-widetag obj
))
33 (lowtag (primitive-object-lowtag obj
))
34 (name (primitive-object-name obj
))
35 (variable (primitive-object-variable-length-p obj
))
36 (size (primitive-object-size obj
)))
39 (;; KLUDGE described in dan_b message "Another one for the
40 ;; collection [bug 108]" (sbcl-devel 2004-01-22)
42 ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T)) causes
43 ;; debugger invoked on a SB-INT:BUG in thread 5911:
44 ;; failed AVER: "(SAP= CURRENT END)"
45 ;; [WHN: Similar things happened on one but not the other of my
46 ;; machines when I just run ROOM a lot in a loop.]
48 ;; This appears to be due to my [DB] abuse of the primitive
49 ;; object macros to define a thread object that shares a lowtag
50 ;; with fixnums and has no widetag: it looks like the code that
51 ;; generates *META-ROOM-INFO* infers from this that even fixnums
52 ;; are thread-sized - probably undesirable.
54 ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the
55 ;; nature of a workaround than a really good fix. I'm not sure
56 ;; what a really good fix is: I /think/ it's probably to remove
57 ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach
58 ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros
59 ;; for assembly source in the runtime/genesis/*.h files.
62 (let ((info (make-room-info :name name
64 (lowtag (symbol-value lowtag
)))
65 (declare (fixnum lowtag
))
67 (setf (svref *meta-room-info
* (logior lowtag
(ash i
3))) info
))))
70 (setf (svref *meta-room-info
* (symbol-value widetag
))
71 (make-room-info :name name
75 (dolist (code (list #!+sb-unicode complex-character-string-widetag
76 complex-base-string-widetag simple-array-widetag
77 complex-bit-vector-widetag complex-vector-widetag
78 complex-array-widetag complex-vector-nil-widetag
))
79 (setf (svref *meta-room-info
* code
)
80 (make-room-info :name
'array-header
83 (setf (svref *meta-room-info
* bignum-widetag
)
84 (make-room-info :name
'bignum
87 (setf (svref *meta-room-info
* closure-header-widetag
)
88 (make-room-info :name
'closure
91 ;; FIXME: This looks rather brittle. Can we get more of these numbers
92 ;; from somewhere sensible?
93 (dolist (stuff '((simple-bit-vector-widetag . -
3)
94 (simple-vector-widetag .
#.sb
!vm
:word-shift
)
95 (simple-array-unsigned-byte-2-widetag . -
2)
96 (simple-array-unsigned-byte-4-widetag . -
1)
97 (simple-array-unsigned-byte-7-widetag .
0)
98 (simple-array-unsigned-byte-8-widetag .
0)
99 (simple-array-unsigned-byte-15-widetag .
1)
100 (simple-array-unsigned-byte-16-widetag .
1)
101 (simple-array-unsigned-byte-31-widetag .
2)
102 (simple-array-unsigned-byte-32-widetag .
2)
103 (simple-array-unsigned-byte-60-widetag .
3)
104 (simple-array-unsigned-byte-63-widetag .
3)
105 (simple-array-unsigned-byte-64-widetag .
3)
106 (simple-array-signed-byte-8-widetag .
0)
107 (simple-array-signed-byte-16-widetag .
1)
108 (simple-array-unsigned-byte-29-widetag .
2)
109 (simple-array-signed-byte-30-widetag .
2)
110 (simple-array-signed-byte-32-widetag .
2)
111 (simple-array-signed-byte-61-widetag .
3)
112 (simple-array-signed-byte-64-widetag .
3)
113 (simple-array-single-float-widetag .
2)
114 (simple-array-double-float-widetag .
3)
115 (simple-array-complex-single-float-widetag .
3)
116 (simple-array-complex-double-float-widetag .
4)))
117 (let* ((name (car stuff
))
119 (sname (string name
)))
121 (setf (svref *meta-room-info
* (symbol-value name
))
122 (make-room-info :name
(intern (subseq sname
124 (mismatch sname
"-WIDETAG"
129 (setf (svref *meta-room-info
* simple-base-string-widetag
)
130 (make-room-info :name
'simple-base-string
135 (setf (svref *meta-room-info
* simple-character-string-widetag
)
136 (make-room-info :name
'simple-character-string
140 (setf (svref *meta-room-info
* simple-array-nil-widetag
)
141 (make-room-info :name
'simple-array-nil
145 (setf (svref *meta-room-info
* code-header-widetag
)
146 (make-room-info :name
'code
149 (setf (svref *meta-room-info
* instance-header-widetag
)
150 (make-room-info :name
'instance
155 (defparameter *room-info
* '#.
*meta-room-info
*)
156 (deftype spaces
() '(member :static
:dynamic
:read-only
))
158 ;;;; MAP-ALLOCATED-OBJECTS
160 ;;; Since they're represented as counts of words, we should never
161 ;;; need bignums to represent these:
162 (declaim (type fixnum
163 *static-space-free-pointer
*
164 *read-only-space-free-pointer
*))
166 (defun space-bounds (space)
167 (declare (type spaces space
))
170 (values (int-sap static-space-start
)
171 (int-sap (* *static-space-free-pointer
* n-word-bytes
))))
173 (values (int-sap read-only-space-start
)
174 (int-sap (* *read-only-space-free-pointer
* n-word-bytes
))))
176 (values (int-sap (current-dynamic-space-start))
177 (dynamic-space-free-pointer)))))
179 ;;; Return the total number of bytes used in SPACE.
180 (defun space-bytes (space)
181 (multiple-value-bind (start end
) (space-bounds space
)
182 (- (sap-int end
) (sap-int start
))))
184 ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
185 ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
186 ;;; platforms with 64-bit word size.
187 #!-sb-fluid
(declaim (inline round-to-dualword
))
188 (defun round-to-dualword (size)
189 (logand (the word
(+ size lowtag-mask
)) (lognot lowtag-mask
)))
191 ;;; Return the total size of a vector in bytes, including any pad.
192 #!-sb-fluid
(declaim (inline vector-total-size
))
193 (defun vector-total-size (obj info
)
194 (let ((shift (room-info-length info
))
195 (len (+ (length (the (simple-array * (*)) obj
))
196 (ecase (room-info-kind info
)
200 (+ (* vector-data-offset n-word-bytes
)
202 (ash (+ len
(1- (ash 1 (- shift
))))
206 ;;; Access to the GENCGC page table for better precision in
207 ;;; MAP-ALLOCATED-OBJECTS
210 (define-alien-type (struct page
)
213 ;; On platforms with small enough GC pages, this field
214 ;; will be a short. On platforms with larger ones, it'll
216 (bytes-used (unsigned
217 #.
(if (typep sb
!vm
:gencgc-page-size
223 (declaim (inline find-page-index
))
224 (define-alien-routine "find_page_index" long
(index long
))
225 (define-alien-variable "page_table" (* (struct page
))))
227 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
228 ;;; the object, the object's type code, and the object's total size in
229 ;;; bytes, including any header and padding.
230 #!-sb-fluid
(declaim (maybe-inline map-allocated-objects
))
231 (defun map-allocated-objects (fun space
)
232 (declare (type function fun
) (type spaces space
))
234 (multiple-value-bind (start end
) (space-bounds space
)
235 (declare (type system-area-pointer start end
))
236 (declare (optimize (speed 3)))
237 (let ((current start
)
238 #!+gencgc
(skip-tests-until-addr 0))
239 (labels ((maybe-finish-mapping ()
240 (unless (sap< current end
)
241 (aver (sap= current end
))
242 (return-from map-allocated-objects
)))
243 ;; GENCGC doesn't allocate linearly, which means that the
244 ;; dynamic space can contain large blocks zeros that get
245 ;; accounted as conses in ROOM (and slow down other
246 ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
247 ;; check the GC page structure for the current address.
248 ;; If the page is free or the address is beyond the page-
249 ;; internal allocation offset (bytes-used) skip to the
250 ;; next page immediately.
253 (when (eq space
:dynamic
)
254 (loop with page-mask
= #.
(1- sb
!vm
:gencgc-page-size
)
255 for addr of-type sb
!vm
:word
= (sap-int current
)
256 while
(>= addr skip-tests-until-addr
)
258 ;; For some reason binding PAGE with LET
259 ;; conses like mad (but gives no compiler notes...)
260 ;; Work around the problem with SYMBOL-MACROLET
261 ;; instead of trying to figure out the real
262 ;; issue. -- JES, 2005-05-17
264 ((page (deref page-table
265 (find-page-index addr
))))
266 ;; Don't we have any nicer way to access C struct
268 (let ((alloc-flag (ldb (byte 3 2)
270 (bytes-used (slot page
'bytes-used
)))
271 ;; If the page is not free and the current
272 ;; pointer is still below the allocation offset
274 (when (and (not (zerop alloc-flag
))
275 (<= (logand page-mask addr
)
277 ;; Don't bother testing again until we
278 ;; get past that allocation offset
279 (setf skip-tests-until-addr
280 (+ (logandc2 addr page-mask
) bytes-used
))
281 ;; And then continue with the scheduled
283 (return-from maybe-skip-page
))
284 ;; Move CURRENT to start of next page
285 (setf current
(int-sap (+ (logandc2 addr page-mask
)
286 sb
!vm
:gencgc-page-size
)))
287 (maybe-finish-mapping)))))))
288 (declare (inline maybe-finish-mapping maybe-skip-page
))
290 (maybe-finish-mapping)
292 (let* ((header (sap-ref-word current
0))
293 (header-widetag (logand header
#xFF
))
294 (info (svref *room-info
* header-widetag
)))
297 (eq (room-info-kind info
) :lowtag
))
298 (let ((size (* cons-size n-word-bytes
)))
300 (%make-lisp-obj
(logior (sap-int current
)
301 list-pointer-lowtag
))
304 (setq current
(sap+ current size
))))
305 ((eql header-widetag closure-header-widetag
)
306 (let* ((obj (%make-lisp-obj
(logior (sap-int current
)
307 fun-pointer-lowtag
)))
308 (size (round-to-dualword
309 (* (the fixnum
(1+ (get-closure-length obj
)))
311 (funcall fun obj header-widetag size
)
312 (setq current
(sap+ current size
))))
313 ((eq (room-info-kind info
) :instance
)
314 (let* ((obj (%make-lisp-obj
315 (logior (sap-int current
) instance-pointer-lowtag
)))
316 (size (round-to-dualword
317 (* (+ (%instance-length obj
) 1) n-word-bytes
))))
318 (declare (fixnum size
))
319 (funcall fun obj header-widetag size
)
320 (aver (zerop (logand size lowtag-mask
)))
321 (setq current
(sap+ current size
))))
323 (let* ((obj (%make-lisp-obj
324 (logior (sap-int current
) other-pointer-lowtag
)))
325 (size (ecase (room-info-kind info
)
327 (aver (or (eql (room-info-length info
)
328 (1+ (get-header-data obj
)))
330 (simple-array-nil-p obj
)))
332 (* (room-info-length info
) n-word-bytes
)))
334 (vector-total-size obj info
))
337 (* (1+ (get-header-data obj
)) n-word-bytes
)))
340 (* (get-header-data obj
) n-word-bytes
))
342 (* (the fixnum
(%code-code-size obj
))
344 (funcall fun obj header-widetag size
)
347 (aver (zerop (logand size lowtag-mask
)))
348 (setq current
(sap+ current size
)))))
351 (word (frob))))))))))))))
356 ;;; Return a list of 3-lists (bytes object type-name) for the objects
357 ;;; allocated in Space.
358 (defun type-breakdown (space)
359 (let ((sizes (make-array 256 :initial-element
0 :element-type
'(unsigned-byte #.sb
!vm
:n-word-bits
)))
360 (counts (make-array 256 :initial-element
0 :element-type
'(unsigned-byte #.sb
!vm
:n-word-bits
))))
361 (map-allocated-objects
362 (lambda (obj type size
)
363 (declare (word size
) (optimize (speed 3)) (ignore obj
))
364 (incf (aref sizes type
) size
)
365 (incf (aref counts type
)))
368 (let ((totals (make-hash-table :test
'eq
)))
370 (let ((total-count (aref counts i
)))
371 (unless (zerop total-count
)
372 (let* ((total-size (aref sizes i
))
373 (name (room-info-name (aref *room-info
* i
)))
374 (found (gethash name totals
)))
376 (incf (first found
) total-size
)
377 (incf (second found
) total-count
))
379 (setf (gethash name totals
)
380 (list total-size total-count name
))))))))
382 (collect ((totals-list))
383 (maphash (lambda (k v
)
387 (sort (totals-list) #'> :key
#'first
)))))
389 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
390 ;;; (space-name . totals-for-space), where totals-for-space is the list
391 ;;; returned by TYPE-BREAKDOWN.
392 (defun print-summary (spaces totals
)
393 (let ((summary (make-hash-table :test
'eq
)))
394 (dolist (space-total totals
)
395 (dolist (total (cdr space-total
))
396 (push (cons (car space-total
) total
)
397 (gethash (third total
) summary
))))
399 (collect ((summary-totals))
400 (maphash (lambda (k v
)
403 (declare (unsigned-byte sum
))
404 (dolist (space-total v
)
405 (incf sum
(first (cdr space-total
))))
406 (summary-totals (cons sum v
))))
409 (format t
"~2&Summary of spaces: ~(~{~A ~}~)~%" spaces
)
410 (let ((summary-total-bytes 0)
411 (summary-total-objects 0))
412 (declare (unsigned-byte summary-total-bytes summary-total-objects
))
413 (dolist (space-totals
414 (mapcar #'cdr
(sort (summary-totals) #'> :key
#'car
)))
415 (let ((total-objects 0)
418 (declare (unsigned-byte total-objects total-bytes
))
420 (dolist (space-total space-totals
)
421 (let ((total (cdr space-total
)))
422 (setq name
(third total
))
423 (incf total-bytes
(first total
))
424 (incf total-objects
(second total
))
425 (spaces (cons (car space-total
) (first total
)))))
426 (format t
"~%~A:~% ~:D bytes, ~:D object~:P"
427 name total-bytes total-objects
)
428 (dolist (space (spaces))
429 (format t
", ~W% ~(~A~)"
430 (round (* (cdr space
) 100) total-bytes
)
433 (incf summary-total-bytes total-bytes
)
434 (incf summary-total-objects total-objects
))))
435 (format t
"~%Summary total:~% ~:D bytes, ~:D objects.~%"
436 summary-total-bytes summary-total-objects
)))))
438 ;;; Report object usage for a single space.
439 (defun report-space-total (space-total cutoff
)
440 (declare (list space-total
) (type (or single-float null
) cutoff
))
441 (format t
"~2&Breakdown for ~(~A~) space:~%" (car space-total
))
442 (let* ((types (cdr space-total
))
443 (total-bytes (reduce #'+ (mapcar #'first types
)))
444 (total-objects (reduce #'+ (mapcar #'second types
)))
445 (cutoff-point (if cutoff
446 (truncate (* (float total-bytes
) cutoff
))
449 (reported-objects 0))
450 (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
452 (loop for
(bytes objects name
) in types do
453 (when (<= bytes cutoff-point
)
454 (format t
" ~10:D bytes for ~9:D other object~2:*~P.~%"
455 (- total-bytes reported-bytes
)
456 (- total-objects reported-objects
))
458 (incf reported-bytes bytes
)
459 (incf reported-objects objects
)
460 (format t
" ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
462 (format t
" ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
463 total-bytes total-objects
(car space-total
))))
465 ;;; Print information about the heap memory in use. PRINT-SPACES is a
466 ;;; list of the spaces to print detailed information for.
467 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
468 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
469 ;;; PRINT-SUMMARY is true, then summary information will be printed.
470 ;;; The defaults print only summary information for dynamic space. If
471 ;;; true, CUTOFF is a fraction of the usage in a report below which
472 ;;; types will be combined as OTHER.
473 (defun memory-usage (&key print-spaces
(count-spaces '(:dynamic
))
474 (print-summary t
) cutoff
)
475 (declare (type (or single-float null
) cutoff
))
476 (let* ((spaces (if (eq count-spaces t
)
477 '(:static
:dynamic
:read-only
)
479 (totals (mapcar (lambda (space)
480 (cons space
(type-breakdown space
)))
483 (dolist (space-total totals
)
484 (when (or (eq print-spaces t
)
485 (member (car space-total
) print-spaces
))
486 (report-space-total space-total cutoff
)))
488 (when print-summary
(print-summary spaces totals
)))
492 ;;; Print info about how much code and no-ops there are in SPACE.
493 (defun count-no-ops (space)
494 (declare (type spaces space
))
498 (declare (fixnum code-words no-ops
)
499 (type unsigned-byte total-bytes
))
500 (map-allocated-objects
501 (lambda (obj type size
)
502 (when (eql type code-header-widetag
)
503 (let ((words (truly-the fixnum
(%code-code-size obj
)))
504 (sap (truly-the system-area-pointer
505 (%primitive code-instructions obj
)))
507 (declare (fixnum size
))
508 (incf total-bytes size
)
509 (incf code-words words
)
511 (when (zerop (sap-ref-word sap
(* i n-word-bytes
)))
516 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
517 total-bytes code-words no-ops
518 (round (* no-ops
100) code-words
)))
522 (defun descriptor-vs-non-descriptor-storage (&rest spaces
)
523 (let ((descriptor-words 0)
524 (non-descriptor-headers 0)
525 (non-descriptor-bytes 0))
526 (declare (type unsigned-byte descriptor-words non-descriptor-headers
527 non-descriptor-bytes
))
528 (dolist (space (or spaces
'(:read-only
:static
:dynamic
)))
529 (declare (inline map-allocated-objects
))
530 (map-allocated-objects
531 (lambda (obj type size
)
533 (#.code-header-widetag
534 (let ((inst-words (truly-the fixnum
(%code-code-size obj
)))
536 (declare (type fixnum size inst-words
))
537 (incf non-descriptor-bytes
(* inst-words n-word-bytes
))
538 (incf descriptor-words
539 (- (truncate size n-word-bytes
) inst-words
))))
541 #.single-float-widetag
542 #.double-float-widetag
543 #.simple-base-string-widetag
544 #!+sb-unicode
#.simple-character-string-widetag
545 #.simple-array-nil-widetag
546 #.simple-bit-vector-widetag
547 #.simple-array-unsigned-byte-2-widetag
548 #.simple-array-unsigned-byte-4-widetag
549 #.simple-array-unsigned-byte-8-widetag
550 #.simple-array-unsigned-byte-16-widetag
551 #.simple-array-unsigned-byte-32-widetag
552 #.simple-array-signed-byte-8-widetag
553 #.simple-array-signed-byte-16-widetag
554 ;; #.simple-array-signed-byte-30-widetag
555 #.simple-array-signed-byte-32-widetag
556 #.simple-array-single-float-widetag
557 #.simple-array-double-float-widetag
558 #.simple-array-complex-single-float-widetag
559 #.simple-array-complex-double-float-widetag
)
560 (incf non-descriptor-headers
)
561 (incf non-descriptor-bytes
(- size n-word-bytes
)))
562 ((#.list-pointer-lowtag
563 #.instance-pointer-lowtag
566 #.simple-array-widetag
567 #.simple-vector-widetag
568 #.complex-base-string-widetag
569 #.complex-vector-nil-widetag
570 #.complex-bit-vector-widetag
571 #.complex-vector-widetag
572 #.complex-array-widetag
573 #.closure-header-widetag
574 #.funcallable-instance-header-widetag
575 #.value-cell-header-widetag
576 #.symbol-header-widetag
578 #.weak-pointer-widetag
579 #.instance-header-widetag
)
580 (incf descriptor-words
(truncate (the fixnum size
) n-word-bytes
)))
582 (error "bogus widetag: ~W" type
))))
584 (format t
"~:D words allocated for descriptor objects.~%"
586 (format t
"~:D bytes data/~:D words header for non-descriptor objects.~%"
587 non-descriptor-bytes non-descriptor-headers
)
590 ;;; Print a breakdown by instance type of all the instances allocated
591 ;;; in SPACE. If TOP-N is true, print only information for the
592 ;;; TOP-N types with largest usage.
593 (defun instance-usage (space &key
(top-n 15))
594 (declare (type spaces space
) (type (or fixnum null
) top-n
))
595 (format t
"~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space
)
596 (let ((totals (make-hash-table :test
'eq
))
599 (declare (unsigned-byte total-objects total-bytes
))
600 (map-allocated-objects
601 (lambda (obj type size
)
602 (declare (optimize (speed 3)))
603 (when (eql type instance-header-widetag
)
605 (let* ((classoid (layout-classoid (%instance-ref obj
0)))
606 (found (gethash classoid totals
))
608 (declare (fixnum size
))
609 (incf total-bytes size
)
611 (incf (the fixnum
(car found
)))
612 (incf (the fixnum
(cdr found
)) size
))
614 (setf (gethash classoid totals
) (cons 1 size
)))))))
617 (collect ((totals-list))
618 (maphash (lambda (classoid what
)
619 (totals-list (cons (prin1-to-string
620 (classoid-proper-name classoid
))
623 (let ((sorted (sort (totals-list) #'> :key
#'cddr
))
626 (declare (unsigned-byte printed-bytes printed-objects
))
627 (dolist (what (if top-n
628 (subseq sorted
0 (min (length sorted
) top-n
))
630 (let ((bytes (cddr what
))
631 (objects (cadr what
)))
632 (incf printed-bytes bytes
)
633 (incf printed-objects objects
)
634 (format t
" ~A: ~:D bytes, ~:D object~:P.~%" (car what
)
637 (let ((residual-objects (- total-objects printed-objects
))
638 (residual-bytes (- total-bytes printed-bytes
)))
639 (unless (zerop residual-objects
)
640 (format t
" Other types: ~:D bytes, ~:D object~:P.~%"
641 residual-bytes residual-objects
))))
643 (format t
" ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
644 space total-bytes total-objects
)))
648 ;;;; PRINT-ALLOCATED-OBJECTS
650 (defun print-allocated-objects (space &key
(percent 0) (pages 5)
651 type larger smaller count
652 (stream *standard-output
*))
653 (declare (type (integer 0 99) percent
) (type index pages
)
654 (type stream stream
) (type spaces space
)
655 (type (or index null
) type larger smaller count
))
656 (multiple-value-bind (start-sap end-sap
) (space-bounds space
)
657 (let* ((space-start (sap-int start-sap
))
658 (space-end (sap-int end-sap
))
659 (space-size (- space-end space-start
))
660 (pagesize (sb!sys
:get-page-size
))
661 (start (+ space-start
(round (* space-size percent
) 100)))
662 (printed-conses (make-hash-table :test
'eq
))
666 (declare (type (unsigned-byte 32) last-page start
)
667 (fixnum pages-so-far count-so-far pagesize
))
668 (labels ((note-conses (x)
669 (unless (or (atom x
) (gethash x printed-conses
))
670 (setf (gethash x printed-conses
) t
)
671 (note-conses (car x
))
672 (note-conses (cdr x
)))))
673 (map-allocated-objects
674 (lambda (obj obj-type size
)
675 (let ((addr (get-lisp-obj-address obj
)))
676 (when (>= addr start
)
678 (> count-so-far count
)
679 (> pages-so-far pages
))
680 (return-from print-allocated-objects
(values)))
683 (let ((this-page (* (the (values (unsigned-byte 32) t
)
684 (truncate addr pagesize
))
686 (declare (type (unsigned-byte 32) this-page
))
687 (when (/= this-page last-page
)
688 (when (< pages-so-far pages
)
689 ;; FIXME: What is this? (ERROR "Argh..")? or
690 ;; a warning? or code that can be removed
691 ;; once the system is stable? or what?
692 (format stream
"~2&**** Page ~W, address ~X:~%"
694 (setq last-page this-page
)
695 (incf pages-so-far
))))
697 (when (and (or (not type
) (eql obj-type type
))
698 (or (not smaller
) (<= size smaller
))
699 (or (not larger
) (>= size larger
)))
702 (#.code-header-widetag
703 (let ((dinfo (%code-debug-info obj
)))
704 (format stream
"~&Code object: ~S~%"
706 (sb!c
::compiled-debug-info-name dinfo
)
708 (#.symbol-header-widetag
709 (format stream
"~&~S~%" obj
))
710 (#.list-pointer-lowtag
711 (unless (gethash obj printed-conses
)
713 (let ((*print-circle
* t
)
716 (format stream
"~&~S~%" obj
))))
719 (let ((str (write-to-string obj
:level
5 :length
10
721 (unless (eql type instance-header-widetag
)
722 (format stream
"~S: " (type-of obj
)))
723 (format stream
"~A~%"
724 (subseq str
0 (min (length str
) 60))))))))))
728 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
730 (defvar *ignore-after
* nil
)
732 (defun valid-obj (space x
)
733 (or (not (eq space
:dynamic
))
734 ;; this test looks bogus if the allocator doesn't work linearly,
735 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
736 (< (get-lisp-obj-address x
) (get-lisp-obj-address *ignore-after
*))))
738 (defun maybe-cons (space x stuff
)
739 (if (valid-obj space x
)
743 (defun list-allocated-objects (space &key type larger smaller count
745 (declare (type spaces space
)
746 (type (or index null
) larger smaller type count
)
747 (type (or function null
) test
)
748 (inline map-allocated-objects
))
749 (unless *ignore-after
*
750 (setq *ignore-after
* (cons 1 2)))
751 (collect ((counted 0 1+))
753 (map-allocated-objects
754 (lambda (obj obj-type size
)
755 (when (and (or (not type
) (eql obj-type type
))
756 (or (not smaller
) (<= size smaller
))
757 (or (not larger
) (>= size larger
))
758 (or (not test
) (funcall test obj
)))
759 (setq res
(maybe-cons space obj res
))
760 (when (and count
(>= (counted) count
))
761 (return-from list-allocated-objects res
))))
765 (defun map-referencing-objects (fun space object
)
766 (declare (type spaces space
) (inline map-allocated-objects
))
767 (unless *ignore-after
*
768 (setq *ignore-after
* (cons 1 2)))
769 (flet ((maybe-call (fun obj
)
770 (when (valid-obj space obj
)
772 (map-allocated-objects
773 (lambda (obj obj-type size
)
774 (declare (ignore obj-type size
))
777 (when (or (eq (car obj
) object
)
778 (eq (cdr obj
) object
))
779 (maybe-call fun obj
)))
781 (dotimes (i (%instance-length obj
))
782 (when (eq (%instance-ref obj i
) object
)
786 (let ((length (get-header-data obj
)))
787 (do ((i code-constants-offset
(1+ i
)))
789 (when (eq (code-header-ref obj i
) object
)
793 (dotimes (i (length obj
))
794 (when (eq (svref obj i
) object
)
798 (when (or (eq (symbol-name obj
) object
)
799 (eq (symbol-package obj
) object
)
800 (eq (symbol-plist obj
) object
)
802 (eq (symbol-value obj
) object
)))
803 (maybe-call fun obj
)))))
806 (defun list-referencing-objects (space object
)
808 (map-referencing-objects
809 (lambda (obj) (res obj
)) space object
)