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