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