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