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