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