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