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