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