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