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