1 ;;;; heap-grovelling memory usage stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (declaim (special sb!vm:*read-only-space-free-pointer*
15 sb!vm:*static-space-free-pointer*))
17 ;;;; type format database
19 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
21 ;; the name of this type
22 (name nil :type symbol)
23 ;; kind of type (how we determine length)
25 :type (member :lowtag :fixed :header :vector
26 :string :code :closure :instance))
27 ;; length if fixed-length, shift amount for element size if :VECTOR
28 (length nil :type (or fixnum null))))
30 (eval-when (:compile-toplevel :execute)
32 (defvar *meta-room-info* (make-array 256 :initial-element nil))
34 (dolist (obj *primitive-objects*)
35 (let ((widetag (primitive-object-widetag obj))
36 (lowtag (primitive-object-lowtag obj))
37 (name (primitive-object-name obj))
38 (variable (primitive-object-variable-length-p obj))
39 (size (primitive-object-size obj)))
43 (let ((info (make-room-info :name name
45 (lowtag (symbol-value lowtag)))
46 (declare (fixnum lowtag))
48 (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
51 (setf (svref *meta-room-info* (symbol-value widetag))
52 (make-room-info :name name
56 (dolist (code (list #!+sb-unicode complex-character-string-widetag
57 complex-base-string-widetag simple-array-widetag
58 complex-bit-vector-widetag complex-vector-widetag
59 complex-array-widetag complex-vector-nil-widetag))
60 (setf (svref *meta-room-info* code)
61 (make-room-info :name 'array-header
64 (setf (svref *meta-room-info* bignum-widetag)
65 (make-room-info :name 'bignum
68 (setf (svref *meta-room-info* closure-header-widetag)
69 (make-room-info :name 'closure
72 (dotimes (i (length *specialized-array-element-type-properties*))
73 (let* ((saetp (aref *specialized-array-element-type-properties* i))
74 (array-kind (if (characterp (saetp-initial-element-default saetp))
77 (element-shift (- (integer-length (saetp-n-bits saetp)) 4)))
78 (when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case.
79 (setf (svref *meta-room-info* (saetp-typecode saetp))
80 (make-room-info :name (saetp-primitive-type-name saetp)
82 :length element-shift)))))
84 (setf (svref *meta-room-info* simple-array-nil-widetag)
85 (make-room-info :name 'simple-array-nil
89 (setf (svref *meta-room-info* code-header-widetag)
90 (make-room-info :name 'code
93 (setf (svref *meta-room-info* instance-header-widetag)
94 (make-room-info :name 'instance
97 (setf (svref *meta-room-info* funcallable-instance-header-widetag)
98 (make-room-info :name 'funcallable-instance
103 (defparameter *room-info* '#.*meta-room-info*)
104 (deftype spaces () '(member :static :dynamic :read-only))
106 ;;;; MAP-ALLOCATED-OBJECTS
108 ;;; Since they're represented as counts of words, we should never
109 ;;; need bignums to represent these:
110 (declaim (type fixnum
111 *static-space-free-pointer*
112 *read-only-space-free-pointer*))
114 (defun space-bounds (space)
115 (declare (type spaces space))
118 (values (int-sap static-space-start)
119 (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))
121 (values (int-sap read-only-space-start)
122 (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))
124 (values (int-sap (current-dynamic-space-start))
125 (dynamic-space-free-pointer)))))
127 ;;; Return the total number of bytes used in SPACE.
128 (defun space-bytes (space)
129 (multiple-value-bind (start end) (space-bounds space)
130 (- (sap-int end) (sap-int start))))
132 ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
133 ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
134 ;;; platforms with 64-bit word size.
135 #!-sb-fluid (declaim (inline round-to-dualword))
136 (defun round-to-dualword (size)
137 (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))
139 ;;; Return the total size of a vector in bytes, including any pad.
140 #!-sb-fluid (declaim (inline vector-total-size))
141 (defun vector-total-size (obj info)
142 (let ((shift (room-info-length info))
143 (len (+ (length (the (simple-array * (*)) obj))
144 (ecase (room-info-kind info)
148 (+ (* vector-data-offset n-word-bytes)
150 (ash (+ len (1- (ash 1 (- shift))))
154 ;;; Access to the GENCGC page table for better precision in
155 ;;; MAP-ALLOCATED-OBJECTS
158 (define-alien-type (struct page)
161 ;; On platforms with small enough GC pages, this field
162 ;; will be a short. On platforms with larger ones, it'll
164 (bytes-used (unsigned
165 #.(if (typep sb!vm:gencgc-card-bytes
171 (declaim (inline find-page-index))
172 (define-alien-routine "find_page_index" long (index signed))
173 (define-alien-variable "page_table" (* (struct page))))
175 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
176 ;;; the object, the object's type code, and the object's total size in
177 ;;; bytes, including any header and padding. CAREFUL makes
178 ;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it
179 ;;; is intended for slightly more demanding uses of heap groveling
181 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
182 (defun map-allocated-objects (fun space &optional careful)
183 (declare (type function fun) (type spaces space))
184 (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
185 (flet ((make-obj (tagged-address)
187 (make-lisp-obj tagged-address nil)
188 (values (%make-lisp-obj tagged-address) t))))
189 ;; Inlining MAKE-OBJ reduces consing on platforms where dynamic
190 ;; space extends past fixnum range.
191 (declare (inline make-obj))
193 (multiple-value-bind (start end) (space-bounds space)
194 (declare (type system-area-pointer start end))
195 (declare (optimize (speed 3)))
196 (let ((current start)
198 (skip-tests-until-addr 0))
199 (labels ((maybe-finish-mapping ()
200 (unless (sap< current end)
201 (aver (sap= current end))
202 (return-from map-allocated-objects)))
203 ;; GENCGC doesn't allocate linearly, which means that the
204 ;; dynamic space can contain large blocks zeros that get
205 ;; accounted as conses in ROOM (and slow down other
206 ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
207 ;; check the GC page structure for the current address.
208 ;; If the page is free or the address is beyond the page-
209 ;; internal allocation offset (bytes-used) skip to the
210 ;; next page immediately.
213 (when (eq space :dynamic)
214 (loop with page-mask = #.(1- sb!vm:gencgc-card-bytes)
215 for addr of-type sb!vm:word = (sap-int current)
216 while (>= addr skip-tests-until-addr)
218 ;; For some reason binding PAGE with LET
219 ;; conses like mad (but gives no compiler notes...)
220 ;; Work around the problem with SYMBOL-MACROLET
221 ;; instead of trying to figure out the real
222 ;; issue. -- JES, 2005-05-17
224 ((page (deref page-table
225 (find-page-index addr))))
226 ;; Don't we have any nicer way to access C struct
228 (let ((alloc-flag (ldb (byte 3 2)
230 (bytes-used (slot page 'bytes-used)))
231 ;; If the page is not free and the current
232 ;; pointer is still below the allocation offset
234 (when (and (not (zerop alloc-flag))
235 (< (logand page-mask addr)
237 ;; Don't bother testing again until we
238 ;; get past that allocation offset
239 (setf skip-tests-until-addr
240 (+ (logandc2 addr page-mask) bytes-used))
241 ;; And then continue with the
243 (return-from maybe-skip-page))
244 ;; Move CURRENT to start of next page.
245 (setf current (int-sap (+ (logandc2 addr page-mask)
246 sb!vm:gencgc-card-bytes)))
247 (maybe-finish-mapping))))))
248 (maybe-map (obj obj-tag n-obj-bytes &optional (ok t))
249 (let ((next (typecase n-obj-bytes
250 (fixnum (sap+ current n-obj-bytes))
251 (integer (sap+ current n-obj-bytes)))))
252 ;; If this object would take us past END, it must
253 ;; be either bogus, or it has been allocated after
254 ;; the call to M-A-O.
255 (cond ((and ok next (sap<= next end))
256 (funcall fun obj obj-tag n-obj-bytes)
259 (setf current (sap+ current n-word-bytes)))))))
260 (declare (inline maybe-finish-mapping maybe-skip-page maybe-map))
262 (maybe-finish-mapping)
264 (let* ((header (sap-ref-word current 0))
265 (header-widetag (logand header #xFF))
266 (info (svref *room-info* header-widetag)))
269 (eq (room-info-kind info) :lowtag))
270 (multiple-value-bind (obj ok)
271 (make-obj (logior (sap-int current) list-pointer-lowtag))
274 (* cons-size n-word-bytes)
276 ((eq (room-info-kind info) :closure)
277 (let* ((obj (%make-lisp-obj (logior (sap-int current)
278 fun-pointer-lowtag)))
279 (size (round-to-dualword
280 (* (the fixnum (1+ (get-closure-length obj)))
282 (maybe-map obj header-widetag size)))
283 ((eq (room-info-kind info) :instance)
284 (let* ((obj (%make-lisp-obj
285 (logior (sap-int current) instance-pointer-lowtag)))
286 (size (round-to-dualword
287 (* (+ (%instance-length obj) 1) n-word-bytes))))
288 (aver (zerop (logand size lowtag-mask)))
289 (maybe-map obj header-widetag size)))
291 (multiple-value-bind (obj ok)
292 (make-obj (logior (sap-int current) other-pointer-lowtag))
294 (ecase (room-info-kind info)
296 (aver (or (eql (room-info-length info)
297 (1+ (get-header-data obj)))
299 (simple-array-nil-p obj)))
301 (* (room-info-length info) n-word-bytes)))
303 (vector-total-size obj info))
306 (* (1+ (get-header-data obj)) n-word-bytes)))
309 (* (get-header-data obj) n-word-bytes))
311 (* (the fixnum (%code-code-size obj))
315 (when size (aver (zerop (logand size lowtag-mask))))
316 (maybe-map obj header-widetag size))))
320 (null (frob))))))))))))))))
325 ;;; Return a list of 3-lists (bytes object type-name) for the objects
326 ;;; allocated in Space.
327 (defun type-breakdown (space)
328 (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
329 (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
330 (map-allocated-objects
331 (lambda (obj type size)
332 (declare (word size) (optimize (speed 3)) (ignore obj))
333 (incf (aref sizes type) size)
334 (incf (aref counts type)))
337 (let ((totals (make-hash-table :test 'eq)))
339 (let ((total-count (aref counts i)))
340 (unless (zerop total-count)
341 (let* ((total-size (aref sizes i))
342 (name (room-info-name (aref *room-info* i)))
343 (found (gethash name totals)))
345 (incf (first found) total-size)
346 (incf (second found) total-count))
348 (setf (gethash name totals)
349 (list total-size total-count name))))))))
351 (collect ((totals-list))
352 (maphash (lambda (k v)
356 (sort (totals-list) #'> :key #'first)))))
358 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
359 ;;; (space-name . totals-for-space), where totals-for-space is the list
360 ;;; returned by TYPE-BREAKDOWN.
361 (defun print-summary (spaces totals)
362 (let ((summary (make-hash-table :test 'eq)))
363 (dolist (space-total totals)
364 (dolist (total (cdr space-total))
365 (push (cons (car space-total) total)
366 (gethash (third total) summary))))
368 (collect ((summary-totals))
369 (maphash (lambda (k v)
372 (declare (unsigned-byte sum))
373 (dolist (space-total v)
374 (incf sum (first (cdr space-total))))
375 (summary-totals (cons sum v))))
378 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
379 (let ((summary-total-bytes 0)
380 (summary-total-objects 0))
381 (declare (unsigned-byte summary-total-bytes summary-total-objects))
382 (dolist (space-totals
383 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
384 (let ((total-objects 0)
387 (declare (unsigned-byte total-objects total-bytes))
389 (dolist (space-total space-totals)
390 (let ((total (cdr space-total)))
391 (setq name (third total))
392 (incf total-bytes (first total))
393 (incf total-objects (second total))
394 (spaces (cons (car space-total) (first total)))))
395 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
396 name total-bytes total-objects)
397 (dolist (space (spaces))
398 (format t ", ~W% ~(~A~)"
399 (round (* (cdr space) 100) total-bytes)
402 (incf summary-total-bytes total-bytes)
403 (incf summary-total-objects total-objects))))
404 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
405 summary-total-bytes summary-total-objects)))))
407 ;;; Report object usage for a single space.
408 (defun report-space-total (space-total cutoff)
409 (declare (list space-total) (type (or single-float null) cutoff))
410 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
411 (let* ((types (cdr space-total))
412 (total-bytes (reduce #'+ (mapcar #'first types)))
413 (total-objects (reduce #'+ (mapcar #'second types)))
414 (cutoff-point (if cutoff
415 (truncate (* (float total-bytes) cutoff))
418 (reported-objects 0))
419 (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
421 (loop for (bytes objects name) in types do
422 (when (<= bytes cutoff-point)
423 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
424 (- total-bytes reported-bytes)
425 (- total-objects reported-objects))
427 (incf reported-bytes bytes)
428 (incf reported-objects objects)
429 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
431 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
432 total-bytes total-objects (car space-total))))
434 ;;; Print information about the heap memory in use. PRINT-SPACES is a
435 ;;; list of the spaces to print detailed information for.
436 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
437 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
438 ;;; PRINT-SUMMARY is true, then summary information will be printed.
439 ;;; The defaults print only summary information for dynamic space. If
440 ;;; true, CUTOFF is a fraction of the usage in a report below which
441 ;;; types will be combined as OTHER.
442 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
443 (print-summary t) cutoff)
444 (declare (type (or single-float null) cutoff))
445 (let* ((spaces (if (eq count-spaces t)
446 '(:static :dynamic :read-only)
448 (totals (mapcar (lambda (space)
449 (cons space (type-breakdown space)))
452 (dolist (space-total totals)
453 (when (or (eq print-spaces t)
454 (member (car space-total) print-spaces))
455 (report-space-total space-total cutoff)))
457 (when print-summary (print-summary spaces totals)))
461 ;;; Print info about how much code and no-ops there are in SPACE.
462 (defun count-no-ops (space)
463 (declare (type spaces space))
467 (declare (fixnum code-words no-ops)
468 (type unsigned-byte total-bytes))
469 (map-allocated-objects
470 (lambda (obj type size)
471 (when (eql type code-header-widetag)
472 (let ((words (truly-the fixnum (%code-code-size obj)))
473 (sap (%primitive code-instructions obj))
475 (declare (fixnum size))
476 (incf total-bytes size)
477 (incf code-words words)
479 (when (zerop (sap-ref-word sap (* i n-word-bytes)))
484 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
485 total-bytes code-words no-ops
486 (round (* no-ops 100) code-words)))
490 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
491 (let ((descriptor-words 0)
492 (non-descriptor-headers 0)
493 (non-descriptor-bytes 0))
494 (declare (type unsigned-byte descriptor-words non-descriptor-headers
495 non-descriptor-bytes))
496 (dolist (space (or spaces '(:read-only :static :dynamic)))
497 (declare (inline map-allocated-objects))
498 (map-allocated-objects
499 (lambda (obj type size)
501 (#.code-header-widetag
502 (let ((inst-words (truly-the fixnum (%code-code-size obj)))
504 (declare (type fixnum size inst-words))
505 (incf non-descriptor-bytes (* inst-words n-word-bytes))
506 (incf descriptor-words
507 (- (truncate size n-word-bytes) inst-words))))
509 #.single-float-widetag
510 #.double-float-widetag
511 #.simple-base-string-widetag
512 #!+sb-unicode #.simple-character-string-widetag
513 #.simple-array-nil-widetag
514 #.simple-bit-vector-widetag
515 #.simple-array-unsigned-byte-2-widetag
516 #.simple-array-unsigned-byte-4-widetag
517 #.simple-array-unsigned-byte-8-widetag
518 #.simple-array-unsigned-byte-16-widetag
519 #.simple-array-unsigned-byte-32-widetag
520 #.simple-array-signed-byte-8-widetag
521 #.simple-array-signed-byte-16-widetag
522 #.simple-array-signed-byte-32-widetag
523 #.simple-array-single-float-widetag
524 #.simple-array-double-float-widetag
525 #.simple-array-complex-single-float-widetag
526 #.simple-array-complex-double-float-widetag)
527 (incf non-descriptor-headers)
528 (incf non-descriptor-bytes (- size n-word-bytes)))
529 ((#.list-pointer-lowtag
530 #.instance-pointer-lowtag
533 #.simple-array-widetag
534 #.simple-vector-widetag
535 #.complex-base-string-widetag
536 #.complex-vector-nil-widetag
537 #.complex-bit-vector-widetag
538 #.complex-vector-widetag
539 #.complex-array-widetag
540 #.closure-header-widetag
541 #.funcallable-instance-header-widetag
542 #.value-cell-header-widetag
543 #.symbol-header-widetag
545 #.weak-pointer-widetag
546 #.instance-header-widetag)
547 (incf descriptor-words (truncate (the fixnum size) n-word-bytes)))
549 (error "bogus widetag: ~W" type))))
551 (format t "~:D words allocated for descriptor objects.~%"
553 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
554 non-descriptor-bytes non-descriptor-headers)
557 ;;; Print a breakdown by instance type of all the instances allocated
558 ;;; in SPACE. If TOP-N is true, print only information for the
559 ;;; TOP-N types with largest usage.
560 (defun instance-usage (space &key (top-n 15))
561 (declare (type spaces space) (type (or fixnum null) top-n))
562 (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
563 (let ((totals (make-hash-table :test 'eq))
566 (declare (unsigned-byte total-objects total-bytes))
567 (map-allocated-objects
568 (lambda (obj type size)
569 (declare (optimize (speed 3)))
570 (when (eql type instance-header-widetag)
572 (let* ((classoid (layout-classoid (%instance-ref obj 0)))
573 (found (gethash classoid totals))
575 (declare (fixnum size))
576 (incf total-bytes size)
578 (incf (the fixnum (car found)))
579 (incf (the fixnum (cdr found)) size))
581 (setf (gethash classoid totals) (cons 1 size)))))))
584 (collect ((totals-list))
585 (maphash (lambda (classoid what)
586 (totals-list (cons (prin1-to-string
587 (classoid-proper-name classoid))
590 (let ((sorted (sort (totals-list) #'> :key #'cddr))
593 (declare (unsigned-byte printed-bytes printed-objects))
594 (dolist (what (if top-n
595 (subseq sorted 0 (min (length sorted) top-n))
597 (let ((bytes (cddr what))
598 (objects (cadr what)))
599 (incf printed-bytes bytes)
600 (incf printed-objects objects)
601 (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what)
604 (let ((residual-objects (- total-objects printed-objects))
605 (residual-bytes (- total-bytes printed-bytes)))
606 (unless (zerop residual-objects)
607 (format t " Other types: ~:D bytes, ~:D object~:P.~%"
608 residual-bytes residual-objects))))
610 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
611 space total-bytes total-objects)))
615 ;;;; PRINT-ALLOCATED-OBJECTS
617 (defun print-allocated-objects (space &key (percent 0) (pages 5)
618 type larger smaller count
619 (stream *standard-output*))
620 (declare (type (integer 0 99) percent) (type index pages)
621 (type stream stream) (type spaces space)
622 (type (or index null) type larger smaller count))
623 (multiple-value-bind (start-sap end-sap) (space-bounds space)
624 (let* ((space-start (sap-int start-sap))
625 (space-end (sap-int end-sap))
626 (space-size (- space-end space-start))
627 (pagesize (sb!sys:get-page-size))
628 (start (+ space-start (round (* space-size percent) 100)))
629 (printed-conses (make-hash-table :test 'eq))
633 (declare (type (unsigned-byte 32) last-page start)
634 (fixnum pages-so-far count-so-far pagesize))
635 (labels ((note-conses (x)
636 (unless (or (atom x) (gethash x printed-conses))
637 (setf (gethash x printed-conses) t)
638 (note-conses (car x))
639 (note-conses (cdr x)))))
640 (map-allocated-objects
641 (lambda (obj obj-type size)
642 (let ((addr (get-lisp-obj-address obj)))
643 (when (>= addr start)
645 (> count-so-far count)
646 (> pages-so-far pages))
647 (return-from print-allocated-objects (values)))
650 (let ((this-page (* (the (values (unsigned-byte 32) t)
651 (truncate addr pagesize))
653 (declare (type (unsigned-byte 32) this-page))
654 (when (/= this-page last-page)
655 (when (< pages-so-far pages)
656 ;; FIXME: What is this? (ERROR "Argh..")? or
657 ;; a warning? or code that can be removed
658 ;; once the system is stable? or what?
659 (format stream "~2&**** Page ~W, address ~X:~%"
661 (setq last-page this-page)
662 (incf pages-so-far))))
664 (when (and (or (not type) (eql obj-type type))
665 (or (not smaller) (<= size smaller))
666 (or (not larger) (>= size larger)))
669 (#.code-header-widetag
670 (let ((dinfo (%code-debug-info obj)))
671 (format stream "~&Code object: ~S~%"
673 (sb!c::compiled-debug-info-name dinfo)
675 (#.symbol-header-widetag
676 (format stream "~&~S~%" obj))
677 (#.list-pointer-lowtag
678 (unless (gethash obj printed-conses)
680 (let ((*print-circle* t)
683 (format stream "~&~S~%" obj))))
686 (let ((str (write-to-string obj :level 5 :length 10
688 (unless (eql type instance-header-widetag)
689 (format stream "~S: " (type-of obj)))
690 (format stream "~A~%"
691 (subseq str 0 (min (length str) 60))))))))))
695 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
697 (defvar *ignore-after* nil)
699 (defun valid-obj (space x)
700 (or (not (eq space :dynamic))
701 ;; this test looks bogus if the allocator doesn't work linearly,
702 ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
703 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
705 (defun maybe-cons (space x stuff)
706 (if (valid-obj space x)
710 (defun list-allocated-objects (space &key type larger smaller count
712 (declare (type spaces space)
713 (type (or index null) larger smaller type count)
714 (type (or function null) test)
715 (inline map-allocated-objects))
716 (unless *ignore-after*
717 (setq *ignore-after* (cons 1 2)))
718 (collect ((counted 0 1+))
720 (map-allocated-objects
721 (lambda (obj obj-type size)
722 (when (and (or (not type) (eql obj-type type))
723 (or (not smaller) (<= size smaller))
724 (or (not larger) (>= size larger))
725 (or (not test) (funcall test obj)))
726 (setq res (maybe-cons space obj res))
727 (when (and count (>= (counted) count))
728 (return-from list-allocated-objects res))))
732 ;;; Calls FUNCTION with all object that have (possibly conservative)
733 ;;; references to them on current stack.
734 (defun map-stack-references (function)
736 (sb!di::descriptor-sap
737 #!+stack-grows-downward-not-upward *control-stack-end*
738 #!-stack-grows-downward-not-upward *control-stack-start*))
741 (loop until #!+stack-grows-downward-not-upward (sap> sp end)
742 #!-stack-grows-downward-not-upward (sap< sp end)
743 do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
744 (when (and ok (typep obj '(not (or fixnum character))))
745 (unless (member obj seen :test #'eq)
746 (funcall function obj)
749 #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
750 #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
752 (defun map-referencing-objects (fun space object)
753 (declare (type spaces space) (inline map-allocated-objects))
754 (unless *ignore-after*
755 (setq *ignore-after* (cons 1 2)))
756 (flet ((maybe-call (fun obj)
757 (when (valid-obj space obj)
759 (map-allocated-objects
760 (lambda (obj obj-type size)
761 (declare (ignore obj-type size))
764 (when (or (eq (car obj) object)
765 (eq (cdr obj) object))
766 (maybe-call fun obj)))
768 (dotimes (i (%instance-length obj))
769 (when (eq (%instance-ref obj i) object)
773 (let ((length (get-header-data obj)))
774 (do ((i code-constants-offset (1+ i)))
776 (when (eq (code-header-ref obj i) object)
780 (dotimes (i (length obj))
781 (when (eq (svref obj i) object)
785 (when (or (eq (symbol-name obj) object)
786 (eq (symbol-package obj) object)
787 (eq (symbol-plist obj) object)
789 (eq (symbol-value obj) object)))
790 (maybe-call fun obj)))))
793 (defun list-referencing-objects (space object)
795 (map-referencing-objects
796 (lambda (obj) (res obj)) space object)