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