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