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