1.0.11.34: better SUBSEQ on lists
[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      (;; KLUDGE described in dan_b message "Another one for the
40       ;; collection [bug 108]" (sbcl-devel 2004-01-22)
41       ;;
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.]
47       ;;
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.
53       ;;
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.
60       (eql name 'thread))
61      ((not widetag)
62       (let ((info (make-room-info :name name
63                                   :kind :lowtag))
64             (lowtag (symbol-value lowtag)))
65         (declare (fixnum lowtag))
66         (dotimes (i 32)
67           (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
68      (variable)
69      (t
70       (setf (svref *meta-room-info* (symbol-value widetag))
71             (make-room-info :name name
72                             :kind :fixed
73                             :length size))))))
74
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
81                         :kind :header)))
82
83 (setf (svref *meta-room-info* bignum-widetag)
84       (make-room-info :name 'bignum
85                       :kind :header))
86
87 (setf (svref *meta-room-info* closure-header-widetag)
88       (make-room-info :name 'closure
89                       :kind :closure))
90
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))
118          (size (cdr stuff))
119          (sname (string name)))
120     (when (boundp name)
121       (setf (svref *meta-room-info* (symbol-value name))
122             (make-room-info :name (intern (subseq sname
123                                                   0
124                                                   (mismatch sname "-WIDETAG"
125                                                             :from-end t)))
126                             :kind :vector
127                             :length size)))))
128
129 (setf (svref *meta-room-info* simple-base-string-widetag)
130       (make-room-info :name 'simple-base-string
131                       :kind :string
132                       :length 0))
133
134 #!+sb-unicode
135 (setf (svref *meta-room-info* simple-character-string-widetag)
136       (make-room-info :name 'simple-character-string
137                       :kind :string
138                       :length 2))
139
140 (setf (svref *meta-room-info* simple-array-nil-widetag)
141       (make-room-info :name 'simple-array-nil
142                       :kind :fixed
143                       :length 2))
144
145 (setf (svref *meta-room-info* code-header-widetag)
146       (make-room-info :name 'code
147                       :kind :code))
148
149 (setf (svref *meta-room-info* instance-header-widetag)
150       (make-room-info :name 'instance
151                       :kind :instance))
152
153 ) ; EVAL-WHEN
154
155 (defparameter *room-info* '#.*meta-room-info*)
156 (deftype spaces () '(member :static :dynamic :read-only))
157 \f
158 ;;;; MAP-ALLOCATED-OBJECTS
159
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*))
165
166 (defun space-bounds (space)
167   (declare (type spaces space))
168   (ecase space
169     (:static
170      (values (int-sap static-space-start)
171              (int-sap (* *static-space-free-pointer* n-word-bytes))))
172     (:read-only
173      (values (int-sap read-only-space-start)
174              (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
175     (:dynamic
176      (values (int-sap (current-dynamic-space-start))
177              (dynamic-space-free-pointer)))))
178
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))))
183
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   (declare (fixnum size))
190   (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
191
192 ;;; Return the total size of a vector in bytes, including any pad.
193 #!-sb-fluid (declaim (inline vector-total-size))
194 (defun vector-total-size (obj info)
195   (let ((shift (room-info-length info))
196         (len (+ (length (the (simple-array * (*)) obj))
197                 (ecase (room-info-kind info)
198                   (:vector 0)
199                   (:string 1)))))
200     (round-to-dualword
201      (+ (* vector-data-offset n-word-bytes)
202         (if (minusp shift)
203             (ash (+ len (1- (ash 1 (- shift))))
204                  shift)
205             (ash len shift))))))
206
207 ;;; Access to the GENCGC page table for better precision in
208 ;;; MAP-ALLOCATED-OBJECTS
209 #!+gencgc
210 (progn
211   (define-alien-type (struct page)
212       (struct page
213               (start long)
214               ;; On platforms with small enough GC pages, this field
215               ;; will be a short. On platforms with larger ones, it'll
216               ;; be an int.
217               (bytes-used (unsigned
218                            #.(if (typep sb!vm:gencgc-page-size
219                                         '(unsigned-byte 16))
220                                  16
221                                  32)))
222               (flags (unsigned 8))
223               (gen (signed 8))))
224   (declaim (inline find-page-index))
225   (define-alien-routine "find_page_index" long (index long))
226   (define-alien-variable "page_table" (* (struct page))))
227
228 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
229 ;;; the object, the object's type code, and the object's total size in
230 ;;; bytes, including any header and padding.
231 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
232 (defun map-allocated-objects (fun space)
233   (declare (type function fun) (type spaces space))
234   (without-gcing
235    (multiple-value-bind (start end) (space-bounds space)
236      (declare (type system-area-pointer start end))
237      (declare (optimize (speed 3)))
238      (let ((current start)
239            #!+gencgc (skip-tests-until-addr 0))
240        (labels ((maybe-finish-mapping ()
241                   (unless (sap< current end)
242                     (aver (sap= current end))
243                     (return-from map-allocated-objects)))
244                 ;; GENCGC doesn't allocate linearly, which means that the
245                 ;; dynamic space can contain large blocks zeros that get
246                 ;; accounted as conses in ROOM (and slow down other
247                 ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
248                 ;; check the GC page structure for the current address.
249                 ;; If the page is free or the address is beyond the page-
250                 ;; internal allocation offset (bytes-used) skip to the
251                 ;; next page immediately.
252                 (maybe-skip-page ()
253                   #!+gencgc
254                   (when (eq space :dynamic)
255                     (loop with page-mask = #.(1- sb!vm:gencgc-page-size)
256                           for addr of-type sb!vm:word = (sap-int current)
257                           while (>= addr skip-tests-until-addr)
258                           do
259                           ;; For some reason binding PAGE with LET
260                           ;; conses like mad (but gives no compiler notes...)
261                           ;; Work around the problem with SYMBOL-MACROLET
262                           ;; instead of trying to figure out the real
263                           ;; issue. -- JES, 2005-05-17
264                           (symbol-macrolet
265                               ((page (deref page-table
266                                             (find-page-index addr))))
267                             ;; Don't we have any nicer way to access C struct
268                             ;; bitfields?
269                             (let ((alloc-flag (ldb (byte 3 2)
270                                                    (slot page 'flags)))
271                                   (bytes-used (slot page 'bytes-used)))
272                               ;; If the page is not free and the current
273                               ;; pointer is still below the allocation offset
274                               ;; of the page
275                               (when (and (not (zerop alloc-flag))
276                                          (<= (logand page-mask addr)
277                                              bytes-used))
278                                 ;; Don't bother testing again until we
279                                 ;; get past that allocation offset
280                                 (setf skip-tests-until-addr
281                                       (+ (logandc2 addr page-mask) bytes-used))
282                                 ;; And then continue with the scheduled
283                                 ;; mapping
284                                 (return-from maybe-skip-page))
285                               ;; Move CURRENT to start of next page
286                               (setf current (int-sap (+ (logandc2 addr page-mask)
287                                                         sb!vm:gencgc-page-size)))
288                               (maybe-finish-mapping)))))))
289          (declare (inline maybe-finish-mapping maybe-skip-page))
290          (loop
291              (maybe-finish-mapping)
292              (maybe-skip-page)
293            (let* ((header (sap-ref-word current 0))
294                   (header-widetag (logand header #xFF))
295                   (info (svref *room-info* header-widetag)))
296              (cond
297                ((or (not info)
298                     (eq (room-info-kind info) :lowtag))
299                 (let ((size (* cons-size n-word-bytes)))
300                   (funcall fun
301                            (%make-lisp-obj (logior (sap-int current)
302                                                   list-pointer-lowtag))
303                            list-pointer-lowtag
304                            size)
305                   (setq current (sap+ current size))))
306                ((eql header-widetag closure-header-widetag)
307                 (let* ((obj (%make-lisp-obj (logior (sap-int current)
308                                                    fun-pointer-lowtag)))
309                        (size (round-to-dualword
310                               (* (the fixnum (1+ (get-closure-length obj)))
311                                  n-word-bytes))))
312                   (funcall fun obj header-widetag size)
313                   (setq current (sap+ current size))))
314                ((eq (room-info-kind info) :instance)
315                 (let* ((obj (%make-lisp-obj
316                              (logior (sap-int current) instance-pointer-lowtag)))
317                        (size (round-to-dualword
318                               (* (+ (%instance-length obj) 1) n-word-bytes))))
319                   (declare (fixnum size))
320                   (funcall fun obj header-widetag size)
321                   (aver (zerop (logand size lowtag-mask)))
322                   (setq current (sap+ current size))))
323                (t
324                 (let* ((obj (%make-lisp-obj
325                              (logior (sap-int current) other-pointer-lowtag)))
326                        (size (ecase (room-info-kind info)
327                                (:fixed
328                                 (aver (or (eql (room-info-length info)
329                                                (1+ (get-header-data obj)))
330                                           (floatp obj)
331                                           (simple-array-nil-p obj)))
332                                 (round-to-dualword
333                                  (* (room-info-length info) n-word-bytes)))
334                                ((:vector :string)
335                                 (vector-total-size obj info))
336                                (:header
337                                 (round-to-dualword
338                                  (* (1+ (get-header-data obj)) n-word-bytes)))
339                                (:code
340                                 (+ (the fixnum
341                                      (* (get-header-data obj) n-word-bytes))
342                                    (round-to-dualword
343                                     (* (the fixnum (%code-code-size obj))
344                                        n-word-bytes)))))))
345                   (declare (fixnum size))
346                   (funcall fun obj header-widetag size)
347                   (aver (zerop (logand size lowtag-mask)))
348                   (setq current (sap+ current size))))))))))))
349
350 \f
351 ;;;; MEMORY-USAGE
352
353 ;;; Return a list of 3-lists (bytes object type-name) for the objects
354 ;;; allocated in Space.
355 (defun type-breakdown (space)
356   (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
357         (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
358     (map-allocated-objects
359      (lambda (obj type size)
360        (declare (fixnum size) (optimize (speed 3)) (ignore obj))
361        (incf (aref sizes type) size)
362        (incf (aref counts type)))
363      space)
364
365     (let ((totals (make-hash-table :test 'eq)))
366       (dotimes (i 256)
367         (let ((total-count (aref counts i)))
368           (unless (zerop total-count)
369             (let* ((total-size (aref sizes i))
370                    (name (room-info-name (aref *room-info* i)))
371                    (found (gethash name totals)))
372               (cond (found
373                      (incf (first found) total-size)
374                      (incf (second found) total-count))
375                     (t
376                      (setf (gethash name totals)
377                            (list total-size total-count name))))))))
378
379       (collect ((totals-list))
380         (maphash (lambda (k v)
381                    (declare (ignore k))
382                    (totals-list v))
383                  totals)
384         (sort (totals-list) #'> :key #'first)))))
385
386 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
387 ;;; (space-name . totals-for-space), where totals-for-space is the list
388 ;;; returned by TYPE-BREAKDOWN.
389 (defun print-summary (spaces totals)
390   (let ((summary (make-hash-table :test 'eq)))
391     (dolist (space-total totals)
392       (dolist (total (cdr space-total))
393         (push (cons (car space-total) total)
394               (gethash (third total) summary))))
395
396     (collect ((summary-totals))
397       (maphash (lambda (k v)
398                  (declare (ignore k))
399                  (let ((sum 0))
400                    (declare (unsigned-byte sum))
401                    (dolist (space-total v)
402                      (incf sum (first (cdr space-total))))
403                    (summary-totals (cons sum v))))
404                summary)
405
406       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
407       (let ((summary-total-bytes 0)
408             (summary-total-objects 0))
409         (declare (unsigned-byte summary-total-bytes summary-total-objects))
410         (dolist (space-totals
411                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
412           (let ((total-objects 0)
413                 (total-bytes 0)
414                 name)
415             (declare (unsigned-byte total-objects total-bytes))
416             (collect ((spaces))
417               (dolist (space-total space-totals)
418                 (let ((total (cdr space-total)))
419                   (setq name (third total))
420                   (incf total-bytes (first total))
421                   (incf total-objects (second total))
422                   (spaces (cons (car space-total) (first total)))))
423               (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
424                       name total-bytes total-objects)
425               (dolist (space (spaces))
426                 (format t ", ~W% ~(~A~)"
427                         (round (* (cdr space) 100) total-bytes)
428                         (car space)))
429               (format t ".~%")
430               (incf summary-total-bytes total-bytes)
431               (incf summary-total-objects total-objects))))
432         (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
433                 summary-total-bytes summary-total-objects)))))
434
435 ;;; Report object usage for a single space.
436 (defun report-space-total (space-total cutoff)
437   (declare (list space-total) (type (or single-float null) cutoff))
438   (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
439   (let* ((types (cdr space-total))
440          (total-bytes (reduce #'+ (mapcar #'first types)))
441          (total-objects (reduce #'+ (mapcar #'second types)))
442          (cutoff-point (if cutoff
443                            (truncate (* (float total-bytes) cutoff))
444                            0))
445          (reported-bytes 0)
446          (reported-objects 0))
447     (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
448                             reported-bytes))
449     (loop for (bytes objects name) in types do
450       (when (<= bytes cutoff-point)
451         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
452                 (- total-bytes reported-bytes)
453                 (- total-objects reported-objects))
454         (return))
455       (incf reported-bytes bytes)
456       (incf reported-objects objects)
457       (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
458               bytes objects name))
459     (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
460             total-bytes total-objects (car space-total))))
461
462 ;;; Print information about the heap memory in use. PRINT-SPACES is a
463 ;;; list of the spaces to print detailed information for.
464 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
465 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
466 ;;; PRINT-SUMMARY is true, then summary information will be printed.
467 ;;; The defaults print only summary information for dynamic space. If
468 ;;; true, CUTOFF is a fraction of the usage in a report below which
469 ;;; types will be combined as OTHER.
470 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
471                           (print-summary t) cutoff)
472   (declare (type (or single-float null) cutoff))
473   (let* ((spaces (if (eq count-spaces t)
474                      '(:static :dynamic :read-only)
475                      count-spaces))
476          (totals (mapcar (lambda (space)
477                            (cons space (type-breakdown space)))
478                          spaces)))
479
480     (dolist (space-total totals)
481       (when (or (eq print-spaces t)
482                 (member (car space-total) print-spaces))
483         (report-space-total space-total cutoff)))
484
485     (when print-summary (print-summary spaces totals)))
486
487   (values))
488 \f
489 ;;; Print info about how much code and no-ops there are in SPACE.
490 (defun count-no-ops (space)
491   (declare (type spaces space))
492   (let ((code-words 0)
493         (no-ops 0)
494         (total-bytes 0))
495     (declare (fixnum code-words no-ops)
496              (type unsigned-byte total-bytes))
497     (map-allocated-objects
498      (lambda (obj type size)
499        (declare (fixnum size))
500        (when (eql type code-header-widetag)
501          (incf total-bytes size)
502          (let ((words (truly-the fixnum (%code-code-size obj)))
503                (sap (truly-the system-area-pointer
504                                (%primitive code-instructions obj))))
505            (incf code-words words)
506            (dotimes (i words)
507              (when (zerop (sap-ref-word sap (* i n-word-bytes)))
508                (incf no-ops))))))
509      space)
510
511     (format t
512             "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
513             total-bytes code-words no-ops
514             (round (* no-ops 100) code-words)))
515
516   (values))
517 \f
518 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
519   (let ((descriptor-words 0)
520         (non-descriptor-headers 0)
521         (non-descriptor-bytes 0))
522     (declare (type unsigned-byte descriptor-words non-descriptor-headers
523                    non-descriptor-bytes))
524     (dolist (space (or spaces '(:read-only :static :dynamic)))
525       (declare (inline map-allocated-objects))
526       (map-allocated-objects
527        (lambda (obj type size)
528          (declare (fixnum size))
529          (case type
530            (#.code-header-widetag
531             (let ((inst-words (truly-the fixnum (%code-code-size obj))))
532               (declare (type fixnum inst-words))
533               (incf non-descriptor-bytes (* inst-words n-word-bytes))
534               (incf descriptor-words
535                     (- (truncate size n-word-bytes) inst-words))))
536            ((#.bignum-widetag
537              #.single-float-widetag
538              #.double-float-widetag
539              #.simple-base-string-widetag
540              #!+sb-unicode #.simple-character-string-widetag
541              #.simple-array-nil-widetag
542              #.simple-bit-vector-widetag
543              #.simple-array-unsigned-byte-2-widetag
544              #.simple-array-unsigned-byte-4-widetag
545              #.simple-array-unsigned-byte-8-widetag
546              #.simple-array-unsigned-byte-16-widetag
547              #.simple-array-unsigned-byte-32-widetag
548              #.simple-array-signed-byte-8-widetag
549              #.simple-array-signed-byte-16-widetag
550              ; #.simple-array-signed-byte-30-widetag
551              #.simple-array-signed-byte-32-widetag
552              #.simple-array-single-float-widetag
553              #.simple-array-double-float-widetag
554              #.simple-array-complex-single-float-widetag
555              #.simple-array-complex-double-float-widetag)
556             (incf non-descriptor-headers)
557             (incf non-descriptor-bytes (- size n-word-bytes)))
558            ((#.list-pointer-lowtag
559              #.instance-pointer-lowtag
560              #.ratio-widetag
561              #.complex-widetag
562              #.simple-array-widetag
563              #.simple-vector-widetag
564              #.complex-base-string-widetag
565              #.complex-vector-nil-widetag
566              #.complex-bit-vector-widetag
567              #.complex-vector-widetag
568              #.complex-array-widetag
569              #.closure-header-widetag
570              #.funcallable-instance-header-widetag
571              #.value-cell-header-widetag
572              #.symbol-header-widetag
573              #.sap-widetag
574              #.weak-pointer-widetag
575              #.instance-header-widetag)
576             (incf descriptor-words (truncate size n-word-bytes)))
577            (t
578             (error "bogus widetag: ~W" type))))
579        space))
580     (format t "~:D words allocated for descriptor objects.~%"
581             descriptor-words)
582     (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
583             non-descriptor-bytes non-descriptor-headers)
584     (values)))
585 \f
586 ;;; Print a breakdown by instance type of all the instances allocated
587 ;;; in SPACE. If TOP-N is true, print only information for the
588 ;;; TOP-N types with largest usage.
589 (defun instance-usage (space &key (top-n 15))
590   (declare (type spaces space) (type (or fixnum null) top-n))
591   (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
592   (let ((totals (make-hash-table :test 'eq))
593         (total-objects 0)
594         (total-bytes 0))
595     (declare (unsigned-byte total-objects total-bytes))
596     (map-allocated-objects
597      (lambda (obj type size)
598        (declare (fixnum size) (optimize (speed 3)))
599        (when (eql type instance-header-widetag)
600          (incf total-objects)
601          (incf total-bytes size)
602          (let* ((classoid (layout-classoid (%instance-ref obj 0)))
603                 (found (gethash classoid totals)))
604            (cond (found
605                   (incf (the fixnum (car found)))
606                   (incf (the fixnum (cdr found)) size))
607                  (t
608                   (setf (gethash classoid totals) (cons 1 size)))))))
609      space)
610
611     (collect ((totals-list))
612       (maphash (lambda (classoid what)
613                  (totals-list (cons (prin1-to-string
614                                      (classoid-proper-name classoid))
615                                     what)))
616                totals)
617       (let ((sorted (sort (totals-list) #'> :key #'cddr))
618             (printed-bytes 0)
619             (printed-objects 0))
620         (declare (unsigned-byte printed-bytes printed-objects))
621         (dolist (what (if top-n
622                           (subseq sorted 0 (min (length sorted) top-n))
623                           sorted))
624           (let ((bytes (cddr what))
625                 (objects (cadr what)))
626             (incf printed-bytes bytes)
627             (incf printed-objects objects)
628             (format t "  ~A: ~:D bytes, ~:D object~:P.~%" (car what)
629                     bytes objects)))
630
631         (let ((residual-objects (- total-objects printed-objects))
632               (residual-bytes (- total-bytes printed-bytes)))
633           (unless (zerop residual-objects)
634             (format t "  Other types: ~:D bytes, ~:D object~:P.~%"
635                     residual-bytes residual-objects))))
636
637       (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
638               space total-bytes total-objects)))
639
640   (values))
641 \f
642 ;;;; PRINT-ALLOCATED-OBJECTS
643
644 (defun print-allocated-objects (space &key (percent 0) (pages 5)
645                                       type larger smaller count
646                                       (stream *standard-output*))
647   (declare (type (integer 0 99) percent) (type index pages)
648            (type stream stream) (type spaces space)
649            (type (or index null) type larger smaller count))
650   (multiple-value-bind (start-sap end-sap) (space-bounds space)
651     (let* ((space-start (sap-int start-sap))
652            (space-end (sap-int end-sap))
653            (space-size (- space-end space-start))
654            (pagesize (sb!sys:get-page-size))
655            (start (+ space-start (round (* space-size percent) 100)))
656            (printed-conses (make-hash-table :test 'eq))
657            (pages-so-far 0)
658            (count-so-far 0)
659            (last-page 0))
660       (declare (type (unsigned-byte 32) last-page start)
661                (fixnum pages-so-far count-so-far pagesize))
662       (labels ((note-conses (x)
663                  (unless (or (atom x) (gethash x printed-conses))
664                    (setf (gethash x printed-conses) t)
665                    (note-conses (car x))
666                    (note-conses (cdr x)))))
667         (map-allocated-objects
668          (lambda (obj obj-type size)
669            (let ((addr (get-lisp-obj-address obj)))
670              (when (>= addr start)
671                (when (if count
672                          (> count-so-far count)
673                          (> pages-so-far pages))
674                  (return-from print-allocated-objects (values)))
675
676                (unless count
677                  (let ((this-page (* (the (values (unsigned-byte 32) t)
678                                        (truncate addr pagesize))
679                                      pagesize)))
680                    (declare (type (unsigned-byte 32) this-page))
681                    (when (/= this-page last-page)
682                      (when (< pages-so-far pages)
683                        ;; FIXME: What is this? (ERROR "Argh..")? or
684                        ;; a warning? or code that can be removed
685                        ;; once the system is stable? or what?
686                        (format stream "~2&**** Page ~W, address ~X:~%"
687                                pages-so-far addr))
688                      (setq last-page this-page)
689                      (incf pages-so-far))))
690
691                (when (and (or (not type) (eql obj-type type))
692                           (or (not smaller) (<= size smaller))
693                           (or (not larger) (>= size larger)))
694                  (incf count-so-far)
695                  (case type
696                    (#.code-header-widetag
697                     (let ((dinfo (%code-debug-info obj)))
698                       (format stream "~&Code object: ~S~%"
699                               (if dinfo
700                                   (sb!c::compiled-debug-info-name dinfo)
701                                   "No debug info."))))
702                    (#.symbol-header-widetag
703                     (format stream "~&~S~%" obj))
704                    (#.list-pointer-lowtag
705                     (unless (gethash obj printed-conses)
706                       (note-conses obj)
707                       (let ((*print-circle* t)
708                             (*print-level* 5)
709                             (*print-length* 10))
710                         (format stream "~&~S~%" obj))))
711                    (t
712                     (fresh-line stream)
713                     (let ((str (write-to-string obj :level 5 :length 10
714                                                 :pretty nil)))
715                       (unless (eql type instance-header-widetag)
716                         (format stream "~S: " (type-of obj)))
717                       (format stream "~A~%"
718                               (subseq str 0 (min (length str) 60))))))))))
719          space))))
720   (values))
721 \f
722 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
723
724 (defvar *ignore-after* nil)
725
726 (defun valid-obj (space x)
727   (or (not (eq space :dynamic))
728       ;; this test looks bogus if the allocator doesn't work linearly,
729       ;; which I suspect is the case for GENCGC.  -- CSR, 2004-06-29
730       (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
731
732 (defun maybe-cons (space x stuff)
733   (if (valid-obj space x)
734       (cons x stuff)
735       stuff))
736
737 (defun list-allocated-objects (space &key type larger smaller count
738                                      test)
739   (declare (type spaces space)
740            (type (or index null) larger smaller type count)
741            (type (or function null) test)
742            (inline map-allocated-objects))
743   (unless *ignore-after*
744     (setq *ignore-after* (cons 1 2)))
745   (collect ((counted 0 1+))
746     (let ((res ()))
747       (map-allocated-objects
748        (lambda (obj obj-type size)
749          (when (and (or (not type) (eql obj-type type))
750                     (or (not smaller) (<= size smaller))
751                     (or (not larger) (>= size larger))
752                     (or (not test) (funcall test obj)))
753            (setq res (maybe-cons space obj res))
754            (when (and count (>= (counted) count))
755              (return-from list-allocated-objects res))))
756        space)
757       res)))
758
759 (defun map-referencing-objects (fun space object)
760   (declare (type spaces space) (inline map-allocated-objects))
761   (unless *ignore-after*
762     (setq *ignore-after* (cons 1 2)))
763   (flet ((maybe-call (fun obj)
764            (when (valid-obj space obj)
765              (funcall fun obj))))
766     (map-allocated-objects
767      (lambda (obj obj-type size)
768        (declare (ignore obj-type size))
769        (typecase obj
770          (cons
771           (when (or (eq (car obj) object)
772                     (eq (cdr obj) object))
773             (maybe-call fun obj)))
774          (instance
775           (dotimes (i (%instance-length obj))
776             (when (eq (%instance-ref obj i) object)
777               (maybe-call fun obj)
778               (return))))
779          (code-component
780           (let ((length (get-header-data obj)))
781             (do ((i code-constants-offset (1+ i)))
782                 ((= i length))
783               (when (eq (code-header-ref obj i) object)
784                 (maybe-call fun obj)
785                 (return)))))
786          (simple-vector
787           (dotimes (i (length obj))
788             (when (eq (svref obj i) object)
789               (maybe-call fun obj)
790               (return))))
791          (symbol
792           (when (or (eq (symbol-name obj) object)
793                     (eq (symbol-package obj) object)
794                     (eq (symbol-plist obj) object)
795                     (and (boundp obj)
796                          (eq (symbol-value obj) object)))
797             (maybe-call fun obj)))))
798      space)))
799
800 (defun list-referencing-objects (space object)
801   (collect ((res))
802     (map-referencing-objects
803      (lambda (obj) (res obj)) space object)
804     (res)))