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