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