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