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            (values (tagged-object other-pointer-lowtag)
 262                    code-header-widetag
 263                    (round-to-dualword
 264                     (+ (* (logand header-value short-header-max-words)
 265                           n-word-bytes)
 266                        (the fixnum
 267                             (sap-ref-lispobj object-sap
 268                                              (* code-code-size-slot
 269                                                 n-word-bytes)))))))
 270
 271           (t
 272            (error "Unrecognized room-info-kind ~S in reconstitute-object"
 273                   (room-info-kind info)))))))))
 274
 275 ;;; Iterate over all the objects in the contiguous block of memory
 276 ;;; with the low address at START and the high address just before
 277 ;;; END, calling FUN with the object, the object's type code, and the
 278 ;;; object's total size in bytes, including any header and padding.
 279 ;;; START and END are untagged, aligned memory addresses interpreted
 280 ;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
 281 (defun map-objects-in-range (fun start end)
 282   (declare (type function fun))
 283   ;; If START is (unsigned) greater than END, then we have somehow
 284   ;; blown past our endpoint.
 285   (aver (<= (get-lisp-obj-address start)
 286             (get-lisp-obj-address end)))
 287   (unless (= start end)
 288     (multiple-value-bind
 289           (obj typecode size)
 290         (reconstitute-object start)
 291       (aver (zerop (logand n-lowtag-bits size)))
 292       (let ((next-start
 293              ;; This special little dance is to add a number of octets
 294              ;; (and it had best be a number evenly divisible by our
 295              ;; allocation granularity) to an unboxed, aligned address
 296              ;; masquerading as a fixnum.  Without consing.
 297              (%make-lisp-obj
 298               (mask-field (byte #.n-word-bits 0)
 299                           (+ (get-lisp-obj-address start)
 300                              size)))))
 301         (funcall fun obj typecode size)
 302         (map-objects-in-range fun next-start end)))))
 303
 304 ;;; Access to the GENCGC page table for better precision in
 305 ;;; MAP-ALLOCATED-OBJECTS
 306 #!+gencgc
 307 (progn
 308   (define-alien-type (struct page)
 309       (struct page
 310               (start signed)
 311               ;; On platforms with small enough GC pages, this field
 312               ;; will be a short. On platforms with larger ones, it'll
 313               ;; be an int.
 314               (bytes-used (unsigned
 315                            #.(if (typep gencgc-card-bytes '(unsigned-byte 16))
 316                                  16
 317                                  32)))
 318               (flags (unsigned 8))
 319               (has-dontmove-dwords (unsigned 8))
 320               (gen (signed 8))))
 321   #!+immobile-space
 322   (progn
 323     (define-alien-type (struct immobile-page)
 324         ;; ... and yet another place for Lisp to become out-of-sync with C.
 325         (struct immobile-page
 326                 (flags (unsigned 8))
 327                 (obj-spacing (unsigned 8))
 328                 (obj-size (unsigned 8))
 329                 (generations (unsigned 8))
 330                 (free-index (unsigned 32))
 331                 (page-link (unsigned 16))
 332                 (prior-free-index (unsigned 16))))
 333     (define-alien-variable "fixedobj_pages" (* (struct immobile-page))))
 334   (declaim (inline find-page-index))
 335   (define-alien-routine "find_page_index" long (index signed))
 336   (define-alien-variable "last_free_page" sb!kernel::page-index-t)
 337   (define-alien-variable "heap_base" (* t))
 338   (define-alien-variable "page_table" (* (struct page))))
 339
 340 (declaim (inline code-header-words))
 341 (defun code-header-words (code)
 342   (logand (get-header-data code) short-header-max-words))
 343
 344 ;;; Iterate over all the objects allocated in each of the SPACES, calling FUN
 345 ;;; with the object, the object's type code, and the object's total size in
 346 ;;; bytes, including any header and padding. As a special case, if exactly one
 347 ;;; space named :ALL is requested, then map over the known spaces.
 348 (defun map-allocated-objects (fun &rest spaces)
 349   (declare (type function fun))
 350   (when (and (= (length spaces) 1) (eq (first spaces) :all))
 351     (return-from map-allocated-objects
 352      (map-allocated-objects fun
 353                             :read-only :static
 354                             #!+immobile-space :immobile
 355                             :dynamic)))
 356   ;; You can't specify :ALL and also a list of spaces. Check that up front.
 357   (do-rest-arg ((space) spaces) (the spaces space))
 358   (flet ((do-1-space (space)
 359     (ecase space
 360       (:static
 361        ;; Static space starts with NIL, which requires special
 362        ;; handling, as the header and alignment are slightly off.
 363        (multiple-value-bind (start end) (space-bounds space)
 364          (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
 365          (map-objects-in-range fun
 366                                (%make-lisp-obj (+ (* 8 n-word-bytes)
 367                                                   (sap-int start)))
 368                                (%make-lisp-obj (sap-int end)))))
 369
 370       ((:read-only #!-gencgc :dynamic)
 371        ;; Read-only space (and dynamic space on cheneygc) is a block
 372        ;; of contiguous allocations.
 373        (multiple-value-bind (start end) (space-bounds space)
 374          (map-objects-in-range fun
 375                                (%make-lisp-obj (sap-int start))
 376                                (%make-lisp-obj (sap-int end)))))
 377
 378       #!+immobile-space
 379       (:immobile
 380        ;; Filter out filler objects. These either look like cons cells
 381        ;; in fixedobj subspace, or code without enough header words
 382        ;; in varyobj subspace. (cf 'immobile_filler_p' in gc-internal.h)
 383        (dx-flet ((filter (obj type size)
 384                    (unless (or (and (code-component-p obj)
 385                                     (eql (code-header-words obj) 2))
 386                                (consp obj))
 387                      (funcall fun obj type size))))
 388          (let ((start immobile-space-start)
 389                (end *immobile-fixedobj-free-pointer*))
 390            (dotimes (pass 2)
 391              (map-objects-in-range #'filter
 392                                    (ash start (- n-fixnum-tag-bits))
 393                                    end)
 394              (setq start (+ immobile-space-start immobile-fixedobj-subspace-size)
 395                    end *immobile-space-free-pointer*)))))
 396
 397       #!+gencgc
 398       (:dynamic
 399        ;; Dynamic space on gencgc requires walking the GC page tables
 400        ;; in order to determine what regions contain objects.
 401
 402        ;; We explicitly presume that any pages in an allocation region
 403        ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
 404        ;; (indicating a full page) or an otherwise-valid BYTES-USED.
 405        ;; We also presume that the pages of an open allocation region
 406        ;; after the first page, and any pages that are unallocated,
 407        ;; have a BYTES-USED of zero.  GENCGC seems to guarantee this.
 408
 409        ;; Our procedure is to scan forward through the page table,
 410        ;; maintaining an "end pointer" until we reach a page where
 411        ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
 412        ;; LAST-FREE-PAGE.  We then MAP-OBJECTS-IN-RANGE if the range
 413        ;; is not empty, and proceed to the next page (unless we've hit
 414        ;; LAST-FREE-PAGE).  We happily take advantage of the fact that
 415        ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
 416        ;; coincident pointers for the range.
 417
 418        ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
 419        ;; closing allocation regions and opening new ones.  This may
 420        ;; prove to be an issue with concurrent systems, or with
 421        ;; spectacularly poor timing for closing an allocation region
 422        ;; in a single-threaded system.
 423
 424        (loop
 425           with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
 426           ;; This magic dance gets us an unboxed aligned pointer as a
 427           ;; FIXNUM.
 428           with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
 429           with end = start
 430
 431           ;; This is our page range. The type constraint is far too generous,
 432           ;; but it does its job of producing efficient code.
 433           for page-index
 434           of-type (integer -1 (#.(/ (ash 1 n-machine-word-bits) gencgc-card-bytes)))
 435           from 0 below last-free-page
 436           for next-page-addr from (+ start page-size) by page-size
 437           for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)
 438
 439           when (< page-bytes-used gencgc-card-bytes)
 440           do (progn
 441                (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
 442                (map-objects-in-range fun start end)
 443                (setf start next-page-addr)
 444                (setf end next-page-addr))
 445           else do (incf end page-size)
 446
 447           finally (map-objects-in-range fun start end))))))
 448   (do-rest-arg ((space) spaces)
 449     (if (eq space :dynamic)
 450         (without-gcing (do-1-space space))
 451         (do-1-space space)))))
 452 \f
 453 ;;;; MEMORY-USAGE
 454
 455 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 456 ;;; allocated in Space.
 457 (defun type-breakdown (space)
 458   (declare (muffle-conditions t))
 459   (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.n-word-bits)))
 460         (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.n-word-bits))))
 461     (map-allocated-objects
 462      (lambda (obj type size)
 463        (declare (word size) (optimize (speed 3)) (ignore obj))
 464        (incf (aref sizes type) size)
 465        (incf (aref counts type)))
 466      space)
 467
 468     (let ((totals (make-hash-table :test 'eq)))
 469       (dotimes (i 256)
 470         (let ((total-count (aref counts i)))
 471           (unless (zerop total-count)
 472             (let* ((total-size (aref sizes i))
 473                    (name (room-info-type-name (aref *room-info* i)))
 474                    (found (gethash name totals)))
 475               (cond (found
 476                      (incf (first found) total-size)
 477                      (incf (second found) total-count))
 478                     (t
 479                      (setf (gethash name totals)
 480                            (list total-size total-count name))))))))
 481
 482       (collect ((totals-list))
 483         (maphash (lambda (k v)
 484                    (declare (ignore k))
 485                    (totals-list v))
 486                  totals)
 487         (sort (totals-list) #'> :key #'first)))))
 488
 489 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
 490 ;;; (space-name . totals-for-space), where totals-for-space is the list
 491 ;;; returned by TYPE-BREAKDOWN.
 492 (defun print-summary (spaces totals)
 493   (let ((summary (make-hash-table :test 'eq)))
 494     (dolist (space-total totals)
 495       (dolist (total (cdr space-total))
 496         (push (cons (car space-total) total)
 497               (gethash (third total) summary))))
 498
 499     (collect ((summary-totals))
 500       (maphash (lambda (k v)
 501                  (declare (ignore k))
 502                  (let ((sum 0))
 503                    (declare (unsigned-byte sum))
 504                    (dolist (space-total v)
 505                      (incf sum (first (cdr space-total))))
 506                    (summary-totals (cons sum v))))
 507                summary)
 508
 509       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
 510       (let ((summary-total-bytes 0)
 511             (summary-total-objects 0))
 512         (declare (unsigned-byte summary-total-bytes summary-total-objects))
 513         (dolist (space-totals
 514                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
 515           (let ((total-objects 0)
 516                 (total-bytes 0)
 517                 name)
 518             (declare (unsigned-byte total-objects total-bytes))
 519             (collect ((spaces))
 520               (dolist (space-total space-totals)
 521                 (let ((total (cdr space-total)))
 522                   (setq name (third total))
 523                   (incf total-bytes (first total))
 524                   (incf total-objects (second total))
 525                   (spaces (cons (car space-total) (first total)))))
 526               (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
 527                       name total-bytes total-objects)
 528               (dolist (space (spaces))
 529                 (format t ", ~W% ~(~A~)"
 530                         (round (* (cdr space) 100) total-bytes)
 531                         (car space)))
 532               (format t ".~%")
 533               (incf summary-total-bytes total-bytes)
 534               (incf summary-total-objects total-objects))))
 535         (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
 536                 summary-total-bytes summary-total-objects)))))
 537
 538 ;;; Report object usage for a single space.
 539 (defun report-space-total (space-total cutoff)
 540   (declare (list space-total) (type (or single-float null) cutoff))
 541   (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
 542   (let* ((types (cdr space-total))
 543          (total-bytes (reduce #'+ (mapcar #'first types)))
 544          (total-objects (reduce #'+ (mapcar #'second types)))
 545          (cutoff-point (if cutoff
 546                            (truncate (* (float total-bytes) cutoff))
 547                            0))
 548          (reported-bytes 0)
 549          (reported-objects 0))
 550     (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
 551                             reported-bytes))
 552     (loop for (bytes objects name) in types do
 553       (when (<= bytes cutoff-point)
 554         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
 555                 (- total-bytes reported-bytes)
 556                 (- total-objects reported-objects))
 557         (return))
 558       (incf reported-bytes bytes)
 559       (incf reported-objects objects)
 560       (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
 561               bytes objects name))
 562     (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
 563             total-bytes total-objects (car space-total))))
 564
 565 ;;; Print information about the heap memory in use. PRINT-SPACES is a
 566 ;;; list of the spaces to print detailed information for.
 567 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
 568 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
 569 ;;; PRINT-SUMMARY is true, then summary information will be printed.
 570 ;;; The defaults print only summary information for dynamic space. If
 571 ;;; true, CUTOFF is a fraction of the usage in a report below which
 572 ;;; types will be combined as OTHER.
 573 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
 574                           (print-summary t) cutoff)
 575   (declare (type (or single-float null) cutoff))
 576   (let* ((spaces (if (eq count-spaces t)
 577                      '(:static :dynamic :read-only)
 578                      count-spaces))
 579          (totals (mapcar (lambda (space)
 580                            (cons space (type-breakdown space)))
 581                          spaces)))
 582
 583     (dolist (space-total totals)
 584       (when (or (eq print-spaces t)
 585                 (member (car space-total) print-spaces))
 586         (report-space-total space-total cutoff)))
 587
 588     (when print-summary (print-summary spaces totals)))
 589
 590   (values))
 591 \f
 592 ;;; Print a breakdown by instance type of all the instances allocated
 593 ;;; in SPACE. If TOP-N is true, print only information for the
 594 ;;; TOP-N types with largest usage.
 595 (defun instance-usage (space &key (top-n 15))
 596   (declare (type spaces space) (type (or fixnum null) top-n))
 597   (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
 598   (let ((totals (make-hash-table :test 'eq))
 599         (total-objects 0)
 600         (total-bytes 0))
 601     (declare (unsigned-byte total-objects total-bytes))
 602     (map-allocated-objects
 603      (lambda (obj type size)
 604        (declare (optimize (speed 3)))
 605        (when (eql type instance-header-widetag)
 606          (incf total-objects)
 607          (let* ((classoid (layout-classoid (%instance-layout obj)))
 608                 (found (gethash classoid totals))
 609                 (size size))
 610            (declare (fixnum size))
 611            (incf total-bytes size)
 612            (cond (found
 613                   (incf (the fixnum (car found)))
 614                   (incf (the fixnum (cdr found)) size))
 615                  (t
 616                   (setf (gethash classoid totals) (cons 1 size)))))))
 617      space)
 618
 619     (collect ((totals-list))
 620       (maphash (lambda (classoid what)
 621                  (totals-list (cons (prin1-to-string
 622                                      (classoid-proper-name classoid))
 623                                     what)))
 624                totals)
 625       (let ((sorted (sort (totals-list) #'> :key #'cddr))
 626             (printed-bytes 0)
 627             (printed-objects 0))
 628         (declare (unsigned-byte printed-bytes printed-objects))
 629         (dolist (what (if top-n
 630                           (subseq sorted 0 (min (length sorted) top-n))
 631                           sorted))
 632           (let ((bytes (cddr what))
 633                 (objects (cadr what)))
 634             (incf printed-bytes bytes)
 635             (incf printed-objects objects)
 636             (format t "  ~A: ~:D bytes, ~:D object~:P.~%" (car what)
 637                     bytes objects)))
 638
 639         (let ((residual-objects (- total-objects printed-objects))
 640               (residual-bytes (- total-bytes printed-bytes)))
 641           (unless (zerop residual-objects)
 642             (format t "  Other types: ~:D bytes, ~:D object~:P.~%"
 643                     residual-bytes residual-objects))))
 644
 645       (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
 646               space total-bytes total-objects)))
 647
 648   (values))
 649 \f
 650 ;;;; PRINT-ALLOCATED-OBJECTS
 651
 652 (defun print-allocated-objects (space &key (percent 0) (pages 5)
 653                                       type larger smaller count
 654                                       (stream *standard-output*))
 655   (declare (type (integer 0 99) percent) (type index pages)
 656            (type stream stream) (type spaces space)
 657            (type (or index null) type larger smaller count))
 658   (multiple-value-bind (start-sap end-sap) (space-bounds space)
 659     (let* ((space-start (sap-int start-sap))
 660            (space-end (sap-int end-sap))
 661            (space-size (- space-end space-start))
 662            (pagesize (get-page-size))
 663            (start (+ space-start (round (* space-size percent) 100)))
 664            (printed-conses (make-hash-table :test 'eq))
 665            (pages-so-far 0)
 666            (count-so-far 0)
 667            (last-page 0))
 668       (declare (type (unsigned-byte 32) last-page start)
 669                (fixnum pages-so-far count-so-far pagesize))
 670       (labels ((note-conses (x)
 671                  (unless (or (atom x) (gethash x printed-conses))
 672                    (setf (gethash x printed-conses) t)
 673                    (note-conses (car x))
 674                    (note-conses (cdr x)))))
 675         (map-allocated-objects
 676          (lambda (obj obj-type size)
 677            (let ((addr (get-lisp-obj-address obj)))
 678              (when (>= addr start)
 679                (when (if count
 680                          (> count-so-far count)
 681                          (> pages-so-far pages))
 682                  (return-from print-allocated-objects (values)))
 683
 684                (unless count
 685                  (let ((this-page (* (the (values (unsigned-byte 32) t)
 686                                        (truncate addr pagesize))
 687                                      pagesize)))
 688                    (declare (type (unsigned-byte 32) this-page))
 689                    (when (/= this-page last-page)
 690                      (when (< pages-so-far pages)
 691                        ;; FIXME: What is this? (ERROR "Argh..")? or
 692                        ;; a warning? or code that can be removed
 693                        ;; once the system is stable? or what?
 694                        (format stream "~2&**** Page ~W, address ~X:~%"
 695                                pages-so-far addr))
 696                      (setq last-page this-page)
 697                      (incf pages-so-far))))
 698
 699                (when (and (or (not type) (eql obj-type type))
 700                           (or (not smaller) (<= size smaller))
 701                           (or (not larger) (>= size larger)))
 702                  (incf count-so-far)
 703                  (case type
 704                    (#.code-header-widetag
 705                     (let ((dinfo (%code-debug-info obj)))
 706                       (format stream "~&Code object: ~S~%"
 707                               (if dinfo
 708                                   (sb!c::compiled-debug-info-name dinfo)
 709                                   "No debug info."))))
 710                    (#.symbol-header-widetag
 711                     (format stream "~&~S~%" obj))
 712                    (#.list-pointer-lowtag
 713                     (unless (gethash obj printed-conses)
 714                       (note-conses obj)
 715                       (let ((*print-circle* t)
 716                             (*print-level* 5)
 717                             (*print-length* 10))
 718                         (format stream "~&~S~%" obj))))
 719                    (t
 720                     (fresh-line stream)
 721                     (let ((str (write-to-string obj :level 5 :length 10
 722                                                 :pretty nil)))
 723                       (unless (eql type instance-header-widetag)
 724                         (format stream "~S: " (type-of obj)))
 725                       (format stream "~A~%"
 726                               (subseq str 0 (min (length str) 60))))))))))
 727          space))))
 728   (values))
 729 \f
 730 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
 731
 732 (defvar *ignore-after* nil)
 733
 734 (defun valid-obj (space x)
 735   (or (not (eq space :dynamic))
 736       ;; this test looks bogus if the allocator doesn't work linearly,
 737       ;; which I suspect is the case for GENCGC.  -- CSR, 2004-06-29
 738       (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
 739
 740 (defun maybe-cons (space x stuff)
 741   (if (valid-obj space x)
 742       (cons x stuff)
 743       stuff))
 744
 745 (defun list-allocated-objects (space &key type larger smaller count
 746                                      test)
 747   (declare (type spaces space)
 748            (type (or index null) larger smaller type count)
 749            (type (or function null) test))
 750   (unless *ignore-after*
 751     (setq *ignore-after* (cons 1 2)))
 752   (collect ((counted 0 1+))
 753     (let ((res ()))
 754       (map-allocated-objects
 755        (lambda (obj obj-type size)
 756          (when (and (or (not type) (eql obj-type type))
 757                     (or (not smaller) (<= size smaller))
 758                     (or (not larger) (>= size larger))
 759                     (or (not test) (funcall test obj)))
 760            (setq res (maybe-cons space obj res))
 761            (when (and count (>= (counted) count))
 762              (return-from list-allocated-objects res))))
 763        space)
 764       res)))
 765
 766 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
 767 ;;; change our notion of what we think they are.
 768 ;;;
 769 ;;; Defining this here (as opposed to in 'debug-int' where it belongs)
 770 ;;; is the path of least resistance to avoiding an inlining failure warning.
 771 #!-sb-fluid (declaim (inline sb!di::descriptor-sap))
 772 (defun sb!di::descriptor-sap (x)
 773   (int-sap (get-lisp-obj-address x)))
 774
 775 ;;; Calls FUNCTION with all objects that have (possibly conservative)
 776 ;;; references to them on current stack.
 777 (defun map-stack-references (function)
 778   (let ((end
 779          (sb!di::descriptor-sap
 780           #!+stack-grows-downward-not-upward *control-stack-end*
 781           #!-stack-grows-downward-not-upward *control-stack-start*))
 782         (sp (current-sp))
 783         (seen nil))
 784     (loop until #!+stack-grows-downward-not-upward (sap> sp end)
 785                 #!-stack-grows-downward-not-upward (sap< sp end)
 786           do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
 787                (when (and ok (typep obj '(not (or fixnum character))))
 788                  (unless (member obj seen :test #'eq)
 789                    (funcall function obj)
 790                    (push obj seen))))
 791              (setf sp
 792                    #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
 793                    #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
 794
 795 ;;; This interface allows one either to be agnostic of the referencing space,
 796 ;;; or specify exactly one space, but not specify a list of spaces.
 797 ;;; An upward-compatible change would be to assume a list, and call ENSURE-LIST.
 798 (defun map-referencing-objects (fun space object)
 799   (declare (type (or (eql :all) spaces) space))
 800   (unless *ignore-after*
 801     (setq *ignore-after* (cons 1 2)))
 802   (flet ((maybe-call (fun obj)
 803            (when (valid-obj space obj)
 804              (funcall fun obj))))
 805     (map-allocated-objects
 806      (lambda (obj obj-type size)
 807        (declare (ignore obj-type size))
 808        (typecase obj
 809          (cons
 810           (when (or (eq (car obj) object)
 811                     (eq (cdr obj) object))
 812             (maybe-call fun obj)))
 813          (instance
 814           (when (or (eq (%instance-layout obj) object)
 815                     (do-instance-tagged-slot (i obj)
 816                       (when (eq (%instance-ref obj i) object)
 817                         (return t))))
 818             (maybe-call fun obj)))
 819          (code-component
 820           (let ((length (code-header-words obj)))
 821             (do ((i code-constants-offset (1+ i)))
 822                 ((= i length))
 823               (when (eq (code-header-ref obj i) object)
 824                 (maybe-call fun obj)
 825                 (return)))))
 826          (simple-vector
 827           (dotimes (i (length obj))
 828             (when (eq (svref obj i) object)
 829               (maybe-call fun obj)
 830               (return))))
 831          (symbol
 832           (when (or (eq (symbol-name obj) object)
 833                     (eq (symbol-package obj) object)
 834                     (eq (symbol-info obj) object)
 835                     (and (boundp obj)
 836                          (eq (symbol-value obj) object)))
 837             (maybe-call fun obj)))))
 838      space)))
 839
 840 (defun list-referencing-objects (space object)
 841   (collect ((res))
 842     (map-referencing-objects
 843      (lambda (obj) (res obj)) space object)
 844     (res)))