0.7.5.15:
[sbcl.git] / src / code / room.lisp
1 ;;;; heap-grovelling memory usage stuff
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; type format database
15
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)
21     (kind (missing-arg)
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))))
26
27 (eval-when (:compile-toplevel :execute)
28
29 (defvar *meta-room-info* (make-array 256 :initial-element nil))
30
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-var-length obj))
36         (size (primitive-object-size obj)))
37     (cond
38      ((not lowtag))
39      ((not widetag)
40       (let ((info (make-room-info :name name
41                                   :kind :lowtag))
42             (lowtag (symbol-value lowtag)))
43         (declare (fixnum lowtag))
44         (dotimes (i 32)
45           (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
46      (variable)
47      (t
48       (setf (svref *meta-room-info* (symbol-value widetag))
49             (make-room-info :name name
50                             :kind :fixed
51                             :length size))))))
52
53 (dolist (code (list complex-string-widetag simple-array-widetag
54                     complex-bit-vector-widetag complex-vector-widetag
55                     complex-array-widetag))
56   (setf (svref *meta-room-info* code)
57         (make-room-info :name 'array-header
58                         :kind :header)))
59
60 (setf (svref *meta-room-info* bignum-widetag)
61       (make-room-info :name 'bignum
62                       :kind :header))
63
64 (setf (svref *meta-room-info* closure-header-widetag)
65       (make-room-info :name 'closure
66                       :kind :closure))
67
68 (dolist (stuff '((simple-bit-vector-widetag . -3)
69                  (simple-vector-widetag . 2)
70                  (simple-array-unsigned-byte-2-widetag . -2)
71                  (simple-array-unsigned-byte-4-widetag . -1)
72                  (simple-array-unsigned-byte-8-widetag . 0)
73                  (simple-array-unsigned-byte-16-widetag . 1)
74                  (simple-array-unsigned-byte-32-widetag . 2)
75                  (simple-array-signed-byte-8-widetag . 0)
76                  (simple-array-signed-byte-16-widetag . 1)
77                  (simple-array-signed-byte-30-widetag . 2)
78                  (simple-array-signed-byte-32-widetag . 2)
79                  (simple-array-single-float-widetag . 2)
80                  (simple-array-double-float-widetag . 3)
81                  (simple-array-complex-single-float-widetag . 3)
82                  (simple-array-complex-double-float-widetag . 4)))
83   (let ((name (car stuff))
84         (size (cdr stuff)))
85     (setf (svref *meta-room-info* (symbol-value name))
86           (make-room-info :name name
87                           :kind :vector
88                           :length size))))
89
90 (setf (svref *meta-room-info* simple-string-widetag)
91       (make-room-info :name 'simple-string-widetag
92                       :kind :string
93                       :length 0))
94
95 (setf (svref *meta-room-info* code-header-widetag)
96       (make-room-info :name 'code
97                       :kind :code))
98
99 (setf (svref *meta-room-info* instance-header-widetag)
100       (make-room-info :name 'instance
101                       :kind :instance))
102
103 ); eval-when (compile eval)
104
105 (defparameter *room-info* '#.*meta-room-info*)
106 (deftype spaces () '(member :static :dynamic :read-only))
107 \f
108 ;;;; MAP-ALLOCATED-OBJECTS
109
110 ;;; Since they're represented as counts of words, we should never
111 ;;; need bignums to represent these:
112 (declaim (type fixnum
113                *static-space-free-pointer*
114                *read-only-space-free-pointer*))
115
116 (defun space-bounds (space)
117   (declare (type spaces space))
118   (ecase space
119     (:static
120      (values (int-sap static-space-start)
121              (int-sap (* *static-space-free-pointer* n-word-bytes))))
122     (:read-only
123      (values (int-sap read-only-space-start)
124              (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
125     (:dynamic
126      (values (int-sap dynamic-space-start)
127              (dynamic-space-free-pointer)))))
128
129 ;;; Return the total number of bytes used in SPACE.
130 (defun space-bytes (space)
131   (multiple-value-bind (start end) (space-bounds space)
132     (- (sap-int end) (sap-int start))))
133
134 ;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
135 #!-sb-fluid (declaim (inline round-to-dualword))
136 (defun round-to-dualword (size)
137   (declare (fixnum size))
138   (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
139
140 ;;; Return the total size of a vector in bytes, including any pad.
141 #!-sb-fluid (declaim (inline vector-total-size))
142 (defun vector-total-size (obj info)
143   (let ((shift (room-info-length info))
144         (len (+ (length (the (simple-array * (*)) obj))
145                 (ecase (room-info-kind info)
146                   (:vector 0)
147                   (:string 1)))))
148     (declare (type (integer -3 3) shift))
149     (round-to-dualword
150      (+ (* vector-data-offset n-word-bytes)
151         (the fixnum
152              (if (minusp shift)
153                  (ash (the fixnum
154                            (+ len (the fixnum
155                                        (1- (the fixnum (ash 1 (- shift)))))))
156                       shift)
157                  (ash len shift)))))))
158
159 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
160 ;;; the object, the object's type code, and the objects total size in
161 ;;; bytes, including any header and padding.
162 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
163 (defun map-allocated-objects (fun space)
164   (declare (type function fun) (type spaces space))
165   (without-gcing
166     (multiple-value-bind (start end) (space-bounds space)
167       (declare (type system-area-pointer start end))
168       (declare (optimize (speed 3) (safety 0)))
169       (let ((current start)
170             #+nil
171             (prev nil))
172         (loop
173           (let* ((header (sap-ref-32 current 0))
174                  (header-widetag (logand header #xFF))
175                  (info (svref *room-info* header-widetag)))
176             (cond
177              ((or (not info)
178                   (eq (room-info-kind info) :lowtag))
179               (let ((size (* cons-size n-word-bytes)))
180                 (funcall fun
181                          (make-lisp-obj (logior (sap-int current)
182                                                 list-pointer-lowtag))
183                          list-pointer-lowtag
184                          size)
185                 (setq current (sap+ current size))))
186              ((eql header-widetag closure-header-widetag)
187               (let* ((obj (make-lisp-obj (logior (sap-int current)
188                                                  fun-pointer-lowtag)))
189                      (size (round-to-dualword
190                             (* (the fixnum (1+ (get-closure-length obj)))
191                                n-word-bytes))))
192                 (funcall fun obj header-widetag size)
193                 (setq current (sap+ current size))))
194              ((eq (room-info-kind info) :instance)
195               (let* ((obj (make-lisp-obj
196                            (logior (sap-int current) instance-pointer-lowtag)))
197                      (size (round-to-dualword
198                             (* (+ (%instance-length obj) 1) n-word-bytes))))
199                 (declare (fixnum size))
200                 (funcall fun obj header-widetag size)
201                 (aver (zerop (logand size lowtag-mask)))
202                 #+nil
203                 (when (> size 200000) (break "implausible size, prev ~S" prev))
204                 #+nil
205                 (setq prev current)
206                 (setq current (sap+ current size))))
207              (t
208               (let* ((obj (make-lisp-obj
209                            (logior (sap-int current) other-pointer-lowtag)))
210                      (size (ecase (room-info-kind info)
211                              (:fixed
212                               (aver (or (eql (room-info-length info)
213                                                (1+ (get-header-data obj)))
214                                           (floatp obj)))
215                               (round-to-dualword
216                                (* (room-info-length info) n-word-bytes)))
217                              ((:vector :string)
218                               (vector-total-size obj info))
219                              (:header
220                               (round-to-dualword
221                                (* (1+ (get-header-data obj)) n-word-bytes)))
222                              (:code
223                               (+ (the fixnum
224                                       (* (get-header-data obj) n-word-bytes))
225                                  (round-to-dualword
226                                   (* (the fixnum (%code-code-size obj))
227                                      n-word-bytes)))))))
228                 (declare (fixnum size))
229                 (funcall fun obj header-widetag size)
230                 (aver (zerop (logand size lowtag-mask)))
231                 #+nil
232                 (when (> size 200000)
233                   (break "Implausible size, prev ~S" prev))
234                 #+nil
235                 (setq prev current)
236                 (setq current (sap+ current size))))))
237           (unless (sap< current end)
238             (aver (sap= current end))
239             (return)))
240
241         #+nil
242         prev))))
243 \f
244 ;;;; MEMORY-USAGE
245
246 ;;; Return a list of 3-lists (bytes object type-name) for the objects
247 ;;; allocated in Space.
248 (defun type-breakdown (space)
249   (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
250         (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
251     (map-allocated-objects
252      (lambda (obj type size)
253        (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
254        (incf (aref sizes type) size)
255        (incf (aref counts type)))
256      space)
257
258     (let ((totals (make-hash-table :test 'eq)))
259       (dotimes (i 256)
260         (let ((total-count (aref counts i)))
261           (unless (zerop total-count)
262             (let* ((total-size (aref sizes i))
263                    (name (room-info-name (aref *room-info* i)))
264                    (found (gethash name totals)))
265               (cond (found
266                      (incf (first found) total-size)
267                      (incf (second found) total-count))
268                     (t
269                      (setf (gethash name totals)
270                            (list total-size total-count name))))))))
271
272       (collect ((totals-list))
273         (maphash (lambda (k v)
274                    (declare (ignore k))
275                    (totals-list v))
276                  totals)
277         (sort (totals-list) #'> :key #'first)))))
278
279 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
280 ;;; (space-name . totals-for-space), where totals-for-space is the list
281 ;;; returned by TYPE-BREAKDOWN.
282 (defun print-summary (spaces totals)
283   (let ((summary (make-hash-table :test 'eq)))
284     (dolist (space-total totals)
285       (dolist (total (cdr space-total))
286         (push (cons (car space-total) total)
287               (gethash (third total) summary))))
288
289     (collect ((summary-totals))
290       (maphash (lambda (k v)
291                  (declare (ignore k))
292                  (let ((sum 0))
293                    (declare (fixnum sum))
294                    (dolist (space-total v)
295                      (incf sum (first (cdr space-total))))
296                    (summary-totals (cons sum v))))
297                summary)
298
299       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
300       (let ((summary-total-bytes 0)
301             (summary-total-objects 0))
302         (declare (fixnum summary-total-bytes summary-total-objects))
303         (dolist (space-totals
304                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
305           (let ((total-objects 0)
306                 (total-bytes 0)
307                 name)
308             (declare (fixnum total-objects total-bytes))
309             (collect ((spaces))
310               (dolist (space-total space-totals)
311                 (let ((total (cdr space-total)))
312                   (setq name (third total))
313                   (incf total-bytes (first total))
314                   (incf total-objects (second total))
315                   (spaces (cons (car space-total) (first total)))))
316               (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
317                       name total-bytes total-objects)
318               (dolist (space (spaces))
319                 (format t ", ~W% ~(~A~)"
320                         (round (* (cdr space) 100) total-bytes)
321                         (car space)))
322               (format t ".~%")
323               (incf summary-total-bytes total-bytes)
324               (incf summary-total-objects total-objects))))
325         (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
326                 summary-total-bytes summary-total-objects)))))
327
328 ;;; Report object usage for a single space.
329 (defun report-space-total (space-total cutoff)
330   (declare (list space-total) (type (or single-float null) cutoff))
331   (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
332   (let* ((types (cdr space-total))
333          (total-bytes (reduce #'+ (mapcar #'first types)))
334          (total-objects (reduce #'+ (mapcar #'second types)))
335          (cutoff-point (if cutoff
336                            (truncate (* (float total-bytes) cutoff))
337                            0))
338          (reported-bytes 0)
339          (reported-objects 0))
340     (declare (fixnum total-objects total-bytes cutoff-point reported-objects
341                      reported-bytes))
342     (loop for (bytes objects name) in types do
343       (when (<= bytes cutoff-point)
344         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
345                 (- total-bytes reported-bytes)
346                 (- total-objects reported-objects))
347         (return))
348       (incf reported-bytes bytes)
349       (incf reported-objects objects)
350       (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
351               bytes objects name))
352     (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
353             total-bytes total-objects (car space-total))))
354
355 ;;; Print information about the heap memory in use. PRINT-SPACES is a
356 ;;; list of the spaces to print detailed information for.
357 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
358 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
359 ;;; PRINT-SUMMARY is true, then summary information will be printed.
360 ;;; The defaults print only summary information for dynamic space. If
361 ;;; true, CUTOFF is a fraction of the usage in a report below which
362 ;;; types will be combined as OTHER.
363 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
364                           (print-summary t) cutoff)
365   (declare (type (or single-float null) cutoff))
366   (let* ((spaces (if (eq count-spaces t)
367                      '(:static :dynamic :read-only)
368                      count-spaces))
369          (totals (mapcar (lambda (space)
370                            (cons space (type-breakdown space)))
371                          spaces)))
372
373     (dolist (space-total totals)
374       (when (or (eq print-spaces t)
375                 (member (car space-total) print-spaces))
376         (report-space-total space-total cutoff)))
377
378     (when print-summary (print-summary spaces totals)))
379
380   (values))
381 \f
382 ;;; Print info about how much code and no-ops there are in SPACE.
383 (defun count-no-ops (space)
384   (declare (type spaces space))
385   (let ((code-words 0)
386         (no-ops 0)
387         (total-bytes 0))
388     (declare (fixnum code-words no-ops)
389              (type unsigned-byte total-bytes))
390     (map-allocated-objects
391      (lambda (obj type size)
392        (declare (fixnum size) (optimize (safety 0)))
393        (when (eql type code-header-widetag)
394          (incf total-bytes size)
395          (let ((words (truly-the fixnum (%code-code-size obj)))
396                (sap (truly-the system-area-pointer
397                                (%primitive code-instructions obj))))
398            (incf code-words words)
399            (dotimes (i words)
400              (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
401                (incf no-ops))))))
402      space)
403
404     (format t
405             "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
406             total-bytes code-words no-ops
407             (round (* no-ops 100) code-words)))
408
409   (values))
410 \f
411 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
412   (let ((descriptor-words 0)
413         (non-descriptor-headers 0)
414         (non-descriptor-bytes 0))
415     (declare (type unsigned-byte descriptor-words non-descriptor-headers
416                    non-descriptor-bytes))
417     (dolist (space (or spaces '(:read-only :static :dynamic)))
418       (declare (inline map-allocated-objects))
419       (map-allocated-objects
420        (lambda (obj type size)
421          (declare (fixnum size) (optimize (safety 0)))
422          (case type
423            (#.code-header-widetag
424             (let ((inst-words (truly-the fixnum (%code-code-size obj))))
425               (declare (type fixnum inst-words))
426               (incf non-descriptor-bytes (* inst-words n-word-bytes))
427               (incf descriptor-words
428                     (- (truncate size n-word-bytes) inst-words))))
429            ((#.bignum-widetag
430              #.single-float-widetag
431              #.double-float-widetag
432              #.simple-string-widetag
433              #.simple-bit-vector-widetag
434              #.simple-array-unsigned-byte-2-widetag
435              #.simple-array-unsigned-byte-4-widetag
436              #.simple-array-unsigned-byte-8-widetag
437              #.simple-array-unsigned-byte-16-widetag
438              #.simple-array-unsigned-byte-32-widetag
439              #.simple-array-signed-byte-8-widetag
440              #.simple-array-signed-byte-16-widetag
441              #.simple-array-signed-byte-30-widetag
442              #.simple-array-signed-byte-32-widetag
443              #.simple-array-single-float-widetag
444              #.simple-array-double-float-widetag
445              #.simple-array-complex-single-float-widetag
446              #.simple-array-complex-double-float-widetag)
447             (incf non-descriptor-headers)
448             (incf non-descriptor-bytes (- size n-word-bytes)))
449            ((#.list-pointer-lowtag
450              #.instance-pointer-lowtag
451              #.ratio-widetag
452              #.complex-widetag
453              #.simple-array-widetag
454              #.simple-vector-widetag
455              #.complex-string-widetag
456              #.complex-bit-vector-widetag
457              #.complex-vector-widetag
458              #.complex-array-widetag
459              #.closure-header-widetag
460              #.funcallable-instance-header-widetag
461              #.value-cell-header-widetag
462              #.symbol-header-widetag
463              #.sap-widetag
464              #.weak-pointer-widetag
465              #.instance-header-widetag)
466             (incf descriptor-words (truncate size n-word-bytes)))
467            (t
468             (error "bogus widetag: ~W" type))))
469        space))
470     (format t "~:D words allocated for descriptor objects.~%"
471             descriptor-words)
472     (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
473             non-descriptor-bytes non-descriptor-headers)
474     (values)))
475 \f
476 ;;; Print a breakdown by instance type of all the instances allocated
477 ;;; in SPACE. If TOP-N is true, print only information for the the
478 ;;; TOP-N types with largest usage.
479 (defun instance-usage (space &key (top-n 15))
480   (declare (type spaces space) (type (or fixnum null) top-n))
481   (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
482   (let ((totals (make-hash-table :test 'eq))
483         (total-objects 0)
484         (total-bytes 0))
485     (declare (fixnum total-objects total-bytes))
486     (map-allocated-objects
487      (lambda (obj type size)
488        (declare (fixnum size) (optimize (speed 3) (safety 0)))
489        (when (eql type instance-header-widetag)
490          (incf total-objects)
491          (incf total-bytes size)
492          (let* ((class (layout-class (%instance-ref obj 0)))
493                 (found (gethash class totals)))
494            (cond (found
495                   (incf (the fixnum (car found)))
496                   (incf (the fixnum (cdr found)) size))
497                  (t
498                   (setf (gethash class totals) (cons 1 size)))))))
499      space)
500
501     (collect ((totals-list))
502       (maphash (lambda (class what)
503                  (totals-list (cons (prin1-to-string
504                                      (class-proper-name class))
505                                     what)))
506                totals)
507       (let ((sorted (sort (totals-list) #'> :key #'cddr))
508             (printed-bytes 0)
509             (printed-objects 0))
510         (declare (fixnum printed-bytes printed-objects))
511         (dolist (what (if top-n
512                           (subseq sorted 0 (min (length sorted) top-n))
513                           sorted))
514           (let ((bytes (cddr what))
515                 (objects (cadr what)))
516             (incf printed-bytes bytes)
517             (incf printed-objects objects)
518             (format t "  ~A: ~:D bytes, ~:D object~:P.~%" (car what)
519                     bytes objects)))
520
521         (let ((residual-objects (- total-objects printed-objects))
522               (residual-bytes (- total-bytes printed-bytes)))
523           (unless (zerop residual-objects)
524             (format t "  Other types: ~:D bytes, ~:D object~:P.~%"
525                     residual-bytes residual-objects))))
526
527       (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
528               space total-bytes total-objects)))
529
530   (values))
531 \f
532 (defun find-holes (&rest spaces)
533   (dolist (space (or spaces '(:read-only :static :dynamic)))
534     (format t "In ~A space:~%" space)
535     (let ((start-addr nil)
536           (total-bytes 0))
537       (declare (type (or null (unsigned-byte 32)) start-addr)
538                (type (unsigned-byte 32) total-bytes))
539       (map-allocated-objects
540        (lambda (object typecode bytes)
541          (declare (ignore typecode)
542                   (type (unsigned-byte 32) bytes))
543          (if (and (consp object)
544                   (eql (car object) 0)
545                   (eql (cdr object) 0))
546              (if start-addr
547                  (incf total-bytes bytes)
548                  (setf start-addr (sb!di::get-lisp-obj-address object)
549                        total-bytes bytes))
550              (when start-addr
551                (format t "~:D bytes at #X~X~%" total-bytes start-addr)
552                (setf start-addr nil))))
553        space)
554       (when start-addr
555         (format t "~:D bytes at #X~X~%" total-bytes start-addr))))
556   (values))
557 \f
558 ;;;; PRINT-ALLOCATED-OBJECTS
559
560 (defun print-allocated-objects (space &key (percent 0) (pages 5)
561                                       type larger smaller count
562                                       (stream *standard-output*))
563   (declare (type (integer 0 99) percent) (type index pages)
564            (type stream stream) (type spaces space)
565            (type (or index null) type larger smaller count))
566   (multiple-value-bind (start-sap end-sap) (space-bounds space)
567     (let* ((space-start (sap-int start-sap))
568            (space-end (sap-int end-sap))
569            (space-size (- space-end space-start))
570            (pagesize (sb!sys:get-page-size))
571            (start (+ space-start (round (* space-size percent) 100)))
572            (printed-conses (make-hash-table :test 'eq))
573            (pages-so-far 0)
574            (count-so-far 0)
575            (last-page 0))
576       (declare (type (unsigned-byte 32) last-page start)
577                (fixnum pages-so-far count-so-far pagesize))
578       (labels ((note-conses (x)
579                  (unless (or (atom x) (gethash x printed-conses))
580                    (setf (gethash x printed-conses) t)
581                    (note-conses (car x))
582                    (note-conses (cdr x)))))
583         (map-allocated-objects
584          (lambda (obj obj-type size)
585            (declare (optimize (safety 0)))
586            (let ((addr (get-lisp-obj-address obj)))
587              (when (>= addr start)
588                (when (if count
589                          (> count-so-far count)
590                          (> pages-so-far pages))
591                  (return-from print-allocated-objects (values)))
592
593                (unless count
594                  (let ((this-page (* (the (values (unsigned-byte 32) t)
595                                        (truncate addr pagesize))
596                                      pagesize)))
597                    (declare (type (unsigned-byte 32) this-page))
598                    (when (/= this-page last-page)
599                      (when (< pages-so-far pages)
600                        ;; FIXME: What is this? (ERROR "Argh..")? or
601                        ;; a warning? or code that can be removed
602                        ;; once the system is stable? or what?
603                        (format stream "~2&**** Page ~W, address ~X:~%"
604                                pages-so-far addr))
605                      (setq last-page this-page)
606                      (incf pages-so-far))))
607
608                (when (and (or (not type) (eql obj-type type))
609                           (or (not smaller) (<= size smaller))
610                           (or (not larger) (>= size larger)))
611                  (incf count-so-far)
612                  (case type
613                    (#.code-header-widetag
614                     (let ((dinfo (%code-debug-info obj)))
615                       (format stream "~&Code object: ~S~%"
616                               (if dinfo
617                                   (sb!c::compiled-debug-info-name dinfo)
618                                   "No debug info."))))
619                    (#.symbol-header-widetag
620                     (format stream "~&~S~%" obj))
621                    (#.list-pointer-lowtag
622                     (unless (gethash obj printed-conses)
623                       (note-conses obj)
624                       (let ((*print-circle* t)
625                             (*print-level* 5)
626                             (*print-length* 10))
627                         (format stream "~&~S~%" obj))))
628                    (t
629                     (fresh-line stream)
630                     (let ((str (write-to-string obj :level 5 :length 10
631                                                 :pretty nil)))
632                       (unless (eql type instance-header-widetag)
633                         (format stream "~S: " (type-of obj)))
634                       (format stream "~A~%"
635                               (subseq str 0 (min (length str) 60))))))))))
636          space))))
637   (values))
638 \f
639 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
640
641 (defvar *ignore-after* nil)
642
643 (defun maybe-cons (space x stuff)
644   (if (or (not (eq space :dynamic))
645           (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
646       (cons x stuff)
647       stuff))
648
649 (defun list-allocated-objects (space &key type larger smaller count
650                                      test)
651   (declare (type spaces space)
652            (type (or index null) larger smaller type count)
653            (type (or function null) test)
654            (inline map-allocated-objects))
655   (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
656   (collect ((counted 0 1+))
657     (let ((res ()))
658       (map-allocated-objects
659        (lambda (obj obj-type size)
660          (declare (optimize (safety 0)))
661          (when (and (or (not type) (eql obj-type type))
662                     (or (not smaller) (<= size smaller))
663                     (or (not larger) (>= size larger))
664                     (or (not test) (funcall test obj)))
665            (setq res (maybe-cons space obj res))
666            (when (and count (>= (counted) count))
667              (return-from list-allocated-objects res))))
668        space)
669       res)))
670
671 (defun list-referencing-objects (space object)
672   (declare (type spaces space) (inline map-allocated-objects))
673   (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
674   (let ((res ()))
675     (flet ((res (x)
676              (setq res (maybe-cons space x res))))
677       (map-allocated-objects
678        (lambda (obj obj-type size)
679          (declare (optimize (safety 0)) (ignore obj-type size))
680          (typecase obj
681            (cons
682             (when (or (eq (car obj) object) (eq (cdr obj) object))
683               (res obj)))
684            (instance
685             (dotimes (i (%instance-length obj))
686               (when (eq (%instance-ref obj i) object)
687                 (res obj)
688                 (return))))
689            (simple-vector
690             (dotimes (i (length obj))
691               (when (eq (svref obj i) object)
692                 (res obj)
693                 (return))))
694            (symbol
695             (when (or (eq (symbol-name obj) object)
696                       (eq (symbol-package obj) object)
697                       (eq (symbol-plist obj) object)
698                       (eq (symbol-value obj) object))
699               (res obj)))))
700        space))
701     res))