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 \f
  15 ;;;; type format database
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
  19     ;; the name of this type
  20     (name nil :type symbol)
  21     ;; kind of type (how to reconstitute an object)
  22     (kind (missing-arg)
  23           :type (member :other :small-other :closure :instance :list
  24                         :code :vector-nil :weak-pointer))))
  25
  26 (defun room-info-type-name (info)
  27   (if (specialized-array-element-type-properties-p info)
  28       (saetp-primitive-type-name info)
  29       (room-info-name info)))
  30
  31 (eval-when (:compile-toplevel :execute)
  32
  33 (defvar *meta-room-info* (make-array 256 :initial-element nil))
  34
  35 (dolist (obj *primitive-objects*)
  36   (let ((widetag (primitive-object-widetag obj))
  37         (lowtag (primitive-object-lowtag obj))
  38         (name (primitive-object-name obj)))
  39     (when (and (eq lowtag 'other-pointer-lowtag)
  40                (not (member widetag '(t nil)))
  41                (not (eq name 'weak-pointer)))
  42       (setf (svref *meta-room-info* (symbol-value widetag))
  43             (make-room-info :name name
  44                             :kind (if (eq name 'symbol)
  45                                       :small-other
  46                                       :other))))))
  47
  48 (dolist (code (list #!+sb-unicode complex-character-string-widetag
  49                     complex-base-string-widetag simple-array-widetag
  50                     complex-bit-vector-widetag complex-vector-widetag
  51                     complex-array-widetag complex-vector-nil-widetag))
  52   (setf (svref *meta-room-info* code)
  53         (make-room-info :name 'array-header
  54                         :kind :other)))
  55
  56 (setf (svref *meta-room-info* bignum-widetag)
  57       (make-room-info :name 'bignum
  58                       :kind :other))
  59
  60 (setf (svref *meta-room-info* closure-header-widetag)
  61       (make-room-info :name 'closure
  62                       :kind :closure))
  63
  64 (dotimes (i (length *specialized-array-element-type-properties*))
  65   (let ((saetp (aref *specialized-array-element-type-properties* i)))
  66     (when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case.
  67       (setf (svref *meta-room-info* (saetp-typecode saetp)) saetp))))
  68
  69 (setf (svref *meta-room-info* simple-array-nil-widetag)
  70       (make-room-info :name 'simple-array-nil
  71                       :kind :vector-nil))
  72
  73 (setf (svref *meta-room-info* code-header-widetag)
  74       (make-room-info :name 'code
  75                       :kind :code))
  76
  77 (setf (svref *meta-room-info* instance-header-widetag)
  78       (make-room-info :name 'instance
  79                       :kind :instance))
  80
  81 (setf (svref *meta-room-info* funcallable-instance-header-widetag)
  82       (make-room-info :name 'funcallable-instance
  83                       :kind :closure))
  84
  85 (setf (svref *meta-room-info* weak-pointer-widetag)
  86       (make-room-info :name 'weak-pointer
  87                       :kind :weak-pointer))
  88
  89 (let ((cons-info (make-room-info :name 'cons
  90                                  :kind :list)))
  91   ;; A cons consists of two words, both of which may be either a
  92   ;; pointer or immediate data.  According to the runtime this means
  93   ;; either a fixnum, a character, an unbound-marker, a single-float
  94   ;; on a 64-bit system, or a pointer.
  95   (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits)))
  96     (setf (svref *meta-room-info* (ash i n-fixnum-tag-bits)) cons-info))
  97
  98   (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits)))
  99     (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
 100                                           instance-pointer-lowtag))
 101           cons-info)
 102     (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
 103                                           list-pointer-lowtag))
 104           cons-info)
 105     (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
 106                                           fun-pointer-lowtag))
 107           cons-info)
 108     (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
 109                                           other-pointer-lowtag))
 110           cons-info))
 111
 112   (setf (svref *meta-room-info* character-widetag) cons-info)
 113
 114   (setf (svref *meta-room-info* unbound-marker-widetag) cons-info)
 115
 116   ;; Single-floats are immediate data on 64-bit systems.
 117   #!+64-bit
 118   (setf (svref *meta-room-info* single-float-widetag) cons-info))
 119
 120 ) ; EVAL-WHEN
 121
 122 (defparameter *room-info*
 123   ;; SAETP instances don't dump properly from XC (or possibly
 124   ;; normally), and we'd rather share structure with the master copy
 125   ;; if we can anyway, so...
 126   (make-array 256
 127               :initial-contents
 128               #.`(list
 129                   ,@(map 'list
 130                          (lambda (info)
 131                            (if (specialized-array-element-type-properties-p info)
 132                                `(aref *specialized-array-element-type-properties*
 133                                       ,(position info *specialized-array-element-type-properties*))
 134                                info))
 135                          *meta-room-info*))))
 136 (deftype spaces () '(member :static :dynamic :read-only))
 137 \f
 138 ;;;; MAP-ALLOCATED-OBJECTS
 139
 140 ;;; Since they're represented as counts of words, we should never
 141 ;;; need bignums to represent these:
 142 (declaim (type fixnum
 143                *static-space-free-pointer*
 144                *read-only-space-free-pointer*))
 145
 146 #!-sb-fluid
 147 (declaim (inline current-dynamic-space-start))
 148 #!+gencgc
 149 (defun current-dynamic-space-start () sb!vm:dynamic-space-start)
 150 #!-gencgc
 151 (defun current-dynamic-space-start ()
 152   (extern-alien "current_dynamic_space" unsigned-long))
 153
 154 (defun space-bounds (space)
 155   (declare (type spaces space))
 156   (ecase space
 157     (:static
 158      (values (int-sap static-space-start)
 159              (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))
 160     (:read-only
 161      (values (int-sap read-only-space-start)
 162              (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))
 163     (:dynamic
 164      (values (int-sap (current-dynamic-space-start))
 165              (dynamic-space-free-pointer)))))
 166
 167 ;;; Return the total number of bytes used in SPACE.
 168 (defun space-bytes (space)
 169   (multiple-value-bind (start end) (space-bounds space)
 170     (- (sap-int end) (sap-int start))))
 171
 172 ;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
 173 ;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
 174 ;;; platforms with 64-bit word size.
 175 #!-sb-fluid (declaim (inline round-to-dualword))
 176 (defun round-to-dualword (size)
 177   (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))
 178
 179 ;;; Return the vector OBJ, its WIDETAG, and the number of octets
 180 ;;; required for its storage (including padding and alignment).
 181 (defun reconstitute-vector (obj saetp)
 182   (declare (type (simple-array * (*)) obj)
 183            (type specialized-array-element-type-properties saetp))
 184   (let* ((length (+ (length obj)
 185                     (saetp-n-pad-elements saetp)))
 186          (n-bits (saetp-n-bits saetp))
 187          (alignment-pad (floor 7 n-bits))
 188          (n-data-octets (if (>= n-bits 8)
 189                             (* length (ash n-bits -3))
 190                             (ash (* (+ length alignment-pad)
 191                                     n-bits)
 192                                  -3))))
 193     (values obj
 194             (saetp-typecode saetp)
 195             (round-to-dualword (+ (* vector-data-offset n-word-bytes)
 196                                   n-data-octets)))))
 197
 198 ;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
 199 ;;; of a lisp object, return the object, its "type code" (either
 200 ;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
 201 ;;; required for its storage (including padding and alignment).  Note
 202 ;;; that this function is designed to NOT CONS, even if called
 203 ;;; out-of-line.
 204 (defun reconstitute-object (address)
 205   (let* ((object-sap (int-sap (get-lisp-obj-address address)))
 206          (header (sap-ref-word object-sap 0))
 207          (widetag (logand header widetag-mask))
 208          (header-value (ash header (- n-widetag-bits)))
 209          (info (svref *room-info* widetag)))
 210     (macrolet
 211         ((boxed-size (header-value)
 212            `(round-to-dualword (ash (1+ ,header-value) word-shift)))
 213          (tagged-object (tag)
 214            `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address)))))
 215       (cond
 216           ;; Pick off arrays, as they're the only plausible cause for
 217           ;; a non-nil, non-ROOM-INFO object as INFO.
 218         ((specialized-array-element-type-properties-p info)
 219          (reconstitute-vector (tagged-object other-pointer-lowtag) info))
 220
 221         ((null info)
 222          (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
 223                 widetag))
 224
 225         (t
 226          (case (room-info-kind info)
 227           (:list
 228            (values (tagged-object list-pointer-lowtag)
 229                    list-pointer-lowtag
 230                    (* 2 n-word-bytes)))
 231
 232           (:closure
 233            (values (tagged-object fun-pointer-lowtag)
 234                    widetag
 235                    (boxed-size header-value)))
 236
 237           (:instance
 238            (values (tagged-object instance-pointer-lowtag)
 239                    widetag
 240                    (boxed-size header-value)))
 241
 242           (:other
 243            (values (tagged-object other-pointer-lowtag)
 244                    widetag
 245                    (boxed-size header-value)))
 246
 247           (:small-other
 248            (values (tagged-object other-pointer-lowtag)
 249                    widetag
 250                    (boxed-size (logand header-value #xff))))
 251
 252           (:vector-nil
 253            (values (tagged-object other-pointer-lowtag)
 254                    simple-array-nil-widetag
 255                    (* 2 n-word-bytes)))
 256
 257           (:weak-pointer
 258            (values (tagged-object other-pointer-lowtag)
 259                    weak-pointer-widetag
 260                    (round-to-dualword
 261                     (* weak-pointer-size
 262                        n-word-bytes))))
 263
 264           (:code
 265            (values (tagged-object other-pointer-lowtag)
 266                    code-header-widetag
 267                    (round-to-dualword
 268                     (+ (* header-value n-word-bytes)
 269                        (the fixnum
 270                             (sap-ref-lispobj object-sap
 271                                              (* code-code-size-slot
 272                                                 n-word-bytes)))))))
 273
 274           (t
 275            (error "Unrecognized room-info-kind ~S in reconstitute-object"
 276                   (room-info-kind info)))))))))
 277
 278 ;;; Iterate over all the objects in the contiguous block of memory
 279 ;;; with the low address at START and the high address just before
 280 ;;; END, calling FUN with the object, the object's type code, and the
 281 ;;; object's total size in bytes, including any header and padding.
 282 ;;; START and END are untagged, aligned memory addresses interpreted
 283 ;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
 284 (defun map-objects-in-range (fun start end)
 285   (declare (type function fun))
 286   ;; If START is (unsigned) greater than END, then we have somehow
 287   ;; blown past our endpoint.
 288   (aver (<= (get-lisp-obj-address start)
 289             (get-lisp-obj-address end)))
 290   (unless (= start end)
 291     (multiple-value-bind
 292           (obj typecode size)
 293         (reconstitute-object start)
 294       (aver (zerop (logand n-lowtag-bits size)))
 295       (let ((next-start
 296              ;; This special little dance is to add a number of octets
 297              ;; (and it had best be a number evenly divisible by our
 298              ;; allocation granularity) to an unboxed, aligned address
 299              ;; masquerading as a fixnum.  Without consing.
 300              (%make-lisp-obj
 301               (mask-field (byte #.n-word-bits 0)
 302                           (+ (get-lisp-obj-address start)
 303                              size)))))
 304         (funcall fun obj typecode size)
 305         (map-objects-in-range fun next-start end)))))
 306
 307 ;;; Access to the GENCGC page table for better precision in
 308 ;;; MAP-ALLOCATED-OBJECTS
 309 #!+gencgc
 310 (progn
 311   (define-alien-type (struct page)
 312       (struct page
 313               (start signed)
 314               ;; On platforms with small enough GC pages, this field
 315               ;; will be a short. On platforms with larger ones, it'll
 316               ;; be an int.
 317               (bytes-used (unsigned
 318                            #.(if (typep sb!vm:gencgc-card-bytes
 319                                         '(unsigned-byte 16))
 320                                  16
 321                                  32)))
 322               (flags (unsigned 8))
 323               (has-dontmove-dwords (unsigned 8))
 324               (gen (signed 8))))
 325   (declaim (inline find-page-index))
 326   (define-alien-routine "find_page_index" long (index signed))
 327   (define-alien-variable "last_free_page" sb!kernel::page-index-t)
 328   (define-alien-variable "heap_base" (* t))
 329   (define-alien-variable "page_table" (* (struct page))))
 330
 331 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 332 ;;; the object, the object's type code, and the object's total size in
 333 ;;; bytes, including any header and padding.
 334 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
 335 (defun map-allocated-objects (fun space)
 336   (declare (type function fun)
 337            (type spaces space))
 338   (without-gcing
 339     (ecase space
 340       (:static
 341        ;; Static space starts with NIL, which requires special
 342        ;; handling, as the header and alignment are slightly off.
 343        (multiple-value-bind (start end) (space-bounds space)
 344          (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
 345          (map-objects-in-range fun
 346                                (%make-lisp-obj (+ (* 8 n-word-bytes)
 347                                                   (sap-int start)))
 348                                (%make-lisp-obj (sap-int end)))))
 349
 350       ((:read-only #!-gencgc :dynamic)
 351        ;; Read-only space (and dynamic space on cheneygc) is a block
 352        ;; of contiguous allocations.
 353        (multiple-value-bind (start end) (space-bounds space)
 354          (map-objects-in-range fun
 355                                (%make-lisp-obj (sap-int start))
 356                                (%make-lisp-obj (sap-int end)))))
 357
 358       #!+gencgc
 359       (:dynamic
 360        ;; Dynamic space on gencgc requires walking the GC page tables
 361        ;; in order to determine what regions contain objects.
 362
 363        ;; We explicitly presume that any pages in an allocation region
 364        ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
 365        ;; (indicating a full page) or an otherwise-valid BYTES-USED.
 366        ;; We also presume that the pages of an open allocation region
 367        ;; after the first page, and any pages that are unallocated,
 368        ;; have a BYTES-USED of zero.  GENCGC seems to guarantee this.
 369
 370        ;; Our procedure is to scan forward through the page table,
 371        ;; maintaining an "end pointer" until we reach a page where
 372        ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
 373        ;; LAST-FREE-PAGE.  We then MAP-OBJECTS-IN-RANGE if the range
 374        ;; is not empty, and proceed to the next page (unless we've hit
 375        ;; LAST-FREE-PAGE).  We happily take advantage of the fact that
 376        ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
 377        ;; coincident pointers for the range.
 378
 379        ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
 380        ;; closing allocation regions and opening new ones.  This may
 381        ;; prove to be an issue with concurrent systems, or with
 382        ;; spectacularly poor timing for closing an allocation region
 383        ;; in a single-threaded system.
 384
 385        (loop
 386           with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
 387           ;; This magic dance gets us an unboxed aligned pointer as a
 388           ;; FIXNUM.
 389           with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
 390           with end = start
 391
 392           ;; This is our page range.
 393           for page-index from 0 below last-free-page
 394           for next-page-addr from (+ start page-size) by page-size
 395           for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)
 396
 397           when (< page-bytes-used gencgc-card-bytes)
 398           do (progn
 399                (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
 400                (map-objects-in-range fun start end)
 401                (setf start next-page-addr)
 402                (setf end next-page-addr))
 403           else do (incf end page-size)
 404
 405           finally (map-objects-in-range fun start end))))))
 406 \f
 407 ;;;; MEMORY-USAGE
 408
 409 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 410 ;;; allocated in Space.
 411 (defun type-breakdown (space)
 412   (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
 413         (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
 414     (map-allocated-objects
 415      (lambda (obj type size)
 416        (declare (word size) (optimize (speed 3)) (ignore obj))
 417        (incf (aref sizes type) size)
 418        (incf (aref counts type)))
 419      space)
 420
 421     (let ((totals (make-hash-table :test 'eq)))
 422       (dotimes (i 256)
 423         (let ((total-count (aref counts i)))
 424           (unless (zerop total-count)
 425             (let* ((total-size (aref sizes i))
 426                    (name (room-info-type-name (aref *room-info* i)))
 427                    (found (gethash name totals)))
 428               (cond (found
 429                      (incf (first found) total-size)
 430                      (incf (second found) total-count))
 431                     (t
 432                      (setf (gethash name totals)
 433                            (list total-size total-count name))))))))
 434
 435       (collect ((totals-list))
 436         (maphash (lambda (k v)
 437                    (declare (ignore k))
 438                    (totals-list v))
 439                  totals)
 440         (sort (totals-list) #'> :key #'first)))))
 441
 442 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
 443 ;;; (space-name . totals-for-space), where totals-for-space is the list
 444 ;;; returned by TYPE-BREAKDOWN.
 445 (defun print-summary (spaces totals)
 446   (let ((summary (make-hash-table :test 'eq)))
 447     (dolist (space-total totals)
 448       (dolist (total (cdr space-total))
 449         (push (cons (car space-total) total)
 450               (gethash (third total) summary))))
 451
 452     (collect ((summary-totals))
 453       (maphash (lambda (k v)
 454                  (declare (ignore k))
 455                  (let ((sum 0))
 456                    (declare (unsigned-byte sum))
 457                    (dolist (space-total v)
 458                      (incf sum (first (cdr space-total))))
 459                    (summary-totals (cons sum v))))
 460                summary)
 461
 462       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
 463       (let ((summary-total-bytes 0)
 464             (summary-total-objects 0))
 465         (declare (unsigned-byte summary-total-bytes summary-total-objects))
 466         (dolist (space-totals
 467                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
 468           (let ((total-objects 0)
 469                 (total-bytes 0)
 470                 name)
 471             (declare (unsigned-byte total-objects total-bytes))
 472             (collect ((spaces))
 473               (dolist (space-total space-totals)
 474                 (let ((total (cdr space-total)))
 475                   (setq name (third total))
 476                   (incf total-bytes (first total))
 477                   (incf total-objects (second total))
 478                   (spaces (cons (car space-total) (first total)))))
 479               (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
 480                       name total-bytes total-objects)
 481               (dolist (space (spaces))
 482                 (format t ", ~W% ~(~A~)"
 483                         (round (* (cdr space) 100) total-bytes)
 484                         (car space)))
 485               (format t ".~%")
 486               (incf summary-total-bytes total-bytes)
 487               (incf summary-total-objects total-objects))))
 488         (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
 489                 summary-total-bytes summary-total-objects)))))
 490
 491 ;;; Report object usage for a single space.
 492 (defun report-space-total (space-total cutoff)
 493   (declare (list space-total) (type (or single-float null) cutoff))
 494   (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
 495   (let* ((types (cdr space-total))
 496          (total-bytes (reduce #'+ (mapcar #'first types)))
 497          (total-objects (reduce #'+ (mapcar #'second types)))
 498          (cutoff-point (if cutoff
 499                            (truncate (* (float total-bytes) cutoff))
 500                            0))
 501          (reported-bytes 0)
 502          (reported-objects 0))
 503     (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
 504                             reported-bytes))
 505     (loop for (bytes objects name) in types do
 506       (when (<= bytes cutoff-point)
 507         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
 508                 (- total-bytes reported-bytes)
 509                 (- total-objects reported-objects))
 510         (return))
 511       (incf reported-bytes bytes)
 512       (incf reported-objects objects)
 513       (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
 514               bytes objects name))
 515     (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
 516             total-bytes total-objects (car space-total))))
 517
 518 ;;; Print information about the heap memory in use. PRINT-SPACES is a
 519 ;;; list of the spaces to print detailed information for.
 520 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
 521 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
 522 ;;; PRINT-SUMMARY is true, then summary information will be printed.
 523 ;;; The defaults print only summary information for dynamic space. If
 524 ;;; true, CUTOFF is a fraction of the usage in a report below which
 525 ;;; types will be combined as OTHER.
 526 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
 527                           (print-summary t) cutoff)
 528   (declare (type (or single-float null) cutoff))
 529   (let* ((spaces (if (eq count-spaces t)
 530                      '(:static :dynamic :read-only)
 531                      count-spaces))
 532          (totals (mapcar (lambda (space)
 533                            (cons space (type-breakdown space)))
 534                          spaces)))
 535
 536     (dolist (space-total totals)
 537       (when (or (eq print-spaces t)
 538                 (member (car space-total) print-spaces))
 539         (report-space-total space-total cutoff)))
 540
 541     (when print-summary (print-summary spaces totals)))
 542
 543   (values))
 544 \f
 545 ;;; Print a breakdown by instance type of all the instances allocated
 546 ;;; in SPACE. If TOP-N is true, print only information for the
 547 ;;; TOP-N types with largest usage.
 548 (defun instance-usage (space &key (top-n 15))
 549   (declare (type spaces space) (type (or fixnum null) top-n))
 550   (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
 551   (let ((totals (make-hash-table :test 'eq))
 552         (total-objects 0)
 553         (total-bytes 0))
 554     (declare (unsigned-byte total-objects total-bytes))
 555     (map-allocated-objects
 556      (lambda (obj type size)
 557        (declare (optimize (speed 3)))
 558        (when (eql type instance-header-widetag)
 559          (incf total-objects)
 560          (let* ((classoid (layout-classoid (%instance-layout obj)))
 561                 (found (gethash classoid totals))
 562                 (size size))
 563            (declare (fixnum size))
 564            (incf total-bytes size)
 565            (cond (found
 566                   (incf (the fixnum (car found)))
 567                   (incf (the fixnum (cdr found)) size))
 568                  (t
 569                   (setf (gethash classoid totals) (cons 1 size)))))))
 570      space)
 571
 572     (collect ((totals-list))
 573       (maphash (lambda (classoid what)
 574                  (totals-list (cons (prin1-to-string
 575                                      (classoid-proper-name classoid))
 576                                     what)))
 577                totals)
 578       (let ((sorted (sort (totals-list) #'> :key #'cddr))
 579             (printed-bytes 0)
 580             (printed-objects 0))
 581         (declare (unsigned-byte printed-bytes printed-objects))
 582         (dolist (what (if top-n
 583                           (subseq sorted 0 (min (length sorted) top-n))
 584                           sorted))
 585           (let ((bytes (cddr what))
 586                 (objects (cadr what)))
 587             (incf printed-bytes bytes)
 588             (incf printed-objects objects)
 589             (format t "  ~A: ~:D bytes, ~:D object~:P.~%" (car what)
 590                     bytes objects)))
 591
 592         (let ((residual-objects (- total-objects printed-objects))
 593               (residual-bytes (- total-bytes printed-bytes)))
 594           (unless (zerop residual-objects)
 595             (format t "  Other types: ~:D bytes, ~:D object~:P.~%"
 596                     residual-bytes residual-objects))))
 597
 598       (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
 599               space total-bytes total-objects)))
 600
 601   (values))
 602 \f
 603 ;;;; PRINT-ALLOCATED-OBJECTS
 604
 605 (defun print-allocated-objects (space &key (percent 0) (pages 5)
 606                                       type larger smaller count
 607                                       (stream *standard-output*))
 608   (declare (type (integer 0 99) percent) (type index pages)
 609            (type stream stream) (type spaces space)
 610            (type (or index null) type larger smaller count))
 611   (multiple-value-bind (start-sap end-sap) (space-bounds space)
 612     (let* ((space-start (sap-int start-sap))
 613            (space-end (sap-int end-sap))
 614            (space-size (- space-end space-start))
 615            (pagesize (get-page-size))
 616            (start (+ space-start (round (* space-size percent) 100)))
 617            (printed-conses (make-hash-table :test 'eq))
 618            (pages-so-far 0)
 619            (count-so-far 0)
 620            (last-page 0))
 621       (declare (type (unsigned-byte 32) last-page start)
 622                (fixnum pages-so-far count-so-far pagesize))
 623       (labels ((note-conses (x)
 624                  (unless (or (atom x) (gethash x printed-conses))
 625                    (setf (gethash x printed-conses) t)
 626                    (note-conses (car x))
 627                    (note-conses (cdr x)))))
 628         (map-allocated-objects
 629          (lambda (obj obj-type size)
 630            (let ((addr (get-lisp-obj-address obj)))
 631              (when (>= addr start)
 632                (when (if count
 633                          (> count-so-far count)
 634                          (> pages-so-far pages))
 635                  (return-from print-allocated-objects (values)))
 636
 637                (unless count
 638                  (let ((this-page (* (the (values (unsigned-byte 32) t)
 639                                        (truncate addr pagesize))
 640                                      pagesize)))
 641                    (declare (type (unsigned-byte 32) this-page))
 642                    (when (/= this-page last-page)
 643                      (when (< pages-so-far pages)
 644                        ;; FIXME: What is this? (ERROR "Argh..")? or
 645                        ;; a warning? or code that can be removed
 646                        ;; once the system is stable? or what?
 647                        (format stream "~2&**** Page ~W, address ~X:~%"
 648                                pages-so-far addr))
 649                      (setq last-page this-page)
 650                      (incf pages-so-far))))
 651
 652                (when (and (or (not type) (eql obj-type type))
 653                           (or (not smaller) (<= size smaller))
 654                           (or (not larger) (>= size larger)))
 655                  (incf count-so-far)
 656                  (case type
 657                    (#.code-header-widetag
 658                     (let ((dinfo (%code-debug-info obj)))
 659                       (format stream "~&Code object: ~S~%"
 660                               (if dinfo
 661                                   (sb!c::compiled-debug-info-name dinfo)
 662                                   "No debug info."))))
 663                    (#.symbol-header-widetag
 664                     (format stream "~&~S~%" obj))
 665                    (#.list-pointer-lowtag
 666                     (unless (gethash obj printed-conses)
 667                       (note-conses obj)
 668                       (let ((*print-circle* t)
 669                             (*print-level* 5)
 670                             (*print-length* 10))
 671                         (format stream "~&~S~%" obj))))
 672                    (t
 673                     (fresh-line stream)
 674                     (let ((str (write-to-string obj :level 5 :length 10
 675                                                 :pretty nil)))
 676                       (unless (eql type instance-header-widetag)
 677                         (format stream "~S: " (type-of obj)))
 678                       (format stream "~A~%"
 679                               (subseq str 0 (min (length str) 60))))))))))
 680          space))))
 681   (values))
 682 \f
 683 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
 684
 685 (defvar *ignore-after* nil)
 686
 687 (defun valid-obj (space x)
 688   (or (not (eq space :dynamic))
 689       ;; this test looks bogus if the allocator doesn't work linearly,
 690       ;; which I suspect is the case for GENCGC.  -- CSR, 2004-06-29
 691       (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
 692
 693 (defun maybe-cons (space x stuff)
 694   (if (valid-obj space x)
 695       (cons x stuff)
 696       stuff))
 697
 698 (defun list-allocated-objects (space &key type larger smaller count
 699                                      test)
 700   (declare (type spaces space)
 701            (type (or index null) larger smaller type count)
 702            (type (or function null) test)
 703            (inline map-allocated-objects))
 704   (unless *ignore-after*
 705     (setq *ignore-after* (cons 1 2)))
 706   (collect ((counted 0 1+))
 707     (let ((res ()))
 708       (map-allocated-objects
 709        (lambda (obj obj-type size)
 710          (when (and (or (not type) (eql obj-type type))
 711                     (or (not smaller) (<= size smaller))
 712                     (or (not larger) (>= size larger))
 713                     (or (not test) (funcall test obj)))
 714            (setq res (maybe-cons space obj res))
 715            (when (and count (>= (counted) count))
 716              (return-from list-allocated-objects res))))
 717        space)
 718       res)))
 719
 720 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
 721 ;;; change our notion of what we think they are.
 722 ;;;
 723 ;;; Defining this here (as opposed to in 'debug-int' where it belongs)
 724 ;;; is the path of least resistance to avoiding an inlining failure warning.
 725 #!-sb-fluid (declaim (inline sb!di::descriptor-sap))
 726 (defun sb!di::descriptor-sap (x)
 727   (int-sap (get-lisp-obj-address x)))
 728
 729 ;;; Calls FUNCTION with all object that have (possibly conservative)
 730 ;;; references to them on current stack.
 731 (defun map-stack-references (function)
 732   (let ((end
 733          (sb!di::descriptor-sap
 734           #!+stack-grows-downward-not-upward *control-stack-end*
 735           #!-stack-grows-downward-not-upward *control-stack-start*))
 736         (sp (current-sp))
 737         (seen nil))
 738     (loop until #!+stack-grows-downward-not-upward (sap> sp end)
 739                 #!-stack-grows-downward-not-upward (sap< sp end)
 740           do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
 741                (when (and ok (typep obj '(not (or fixnum character))))
 742                  (unless (member obj seen :test #'eq)
 743                    (funcall function obj)
 744                    (push obj seen))))
 745              (setf sp
 746                    #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
 747                    #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
 748
 749 (defun map-referencing-objects (fun space object)
 750   (declare (type spaces space) (inline map-allocated-objects))
 751   (unless *ignore-after*
 752     (setq *ignore-after* (cons 1 2)))
 753   (flet ((maybe-call (fun obj)
 754            (when (valid-obj space obj)
 755              (funcall fun obj))))
 756     (map-allocated-objects
 757      (lambda (obj obj-type size)
 758        (declare (ignore obj-type size))
 759        (typecase obj
 760          (cons
 761           (when (or (eq (car obj) object)
 762                     (eq (cdr obj) object))
 763             (maybe-call fun obj)))
 764          (instance
 765           (when (or (eq (%instance-layout obj) object)
 766                     (do-instance-tagged-slot (i obj)
 767                       (when (eq (%instance-ref obj i) object)
 768                         (return t))))
 769             (maybe-call fun obj)))
 770          (code-component
 771           (let ((length (get-header-data obj)))
 772             (do ((i code-constants-offset (1+ i)))
 773                 ((= i length))
 774               (when (eq (code-header-ref obj i) object)
 775                 (maybe-call fun obj)
 776                 (return)))))
 777          (simple-vector
 778           (dotimes (i (length obj))
 779             (when (eq (svref obj i) object)
 780               (maybe-call fun obj)
 781               (return))))
 782          (symbol
 783           (when (or (eq (symbol-name obj) object)
 784                     (eq (symbol-package obj) object)
 785                     (eq (symbol-info obj) object)
 786                     (and (boundp obj)
 787                          (eq (symbol-value obj) object)))
 788             (maybe-call fun obj)))))
 789      space)))
 790
 791 (defun list-referencing-objects (space object)
 792   (collect ((res))
 793     (map-referencing-objects
 794      (lambda (obj) (res obj)) space object)
 795     (res)))