src/code/room.lisp

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