;;;; heap-grovelling memory usage stuff

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

(declaim (special sb!vm:*read-only-space-free-pointer*
                  sb!vm:*static-space-free-pointer*))

;;;; type format database

(eval-when (:compile-toplevel :load-toplevel :execute)
  (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
    ;; the name of this type
    (name nil :type symbol)
    ;; kind of type (how to reconstitute an object)
    (kind (missing-arg)
          :type (member :other :closure :instance :list
                        :code :vector-nil :weak-pointer))))

(defun room-info-type-name (info)
  (if (specialized-array-element-type-properties-p info)
      (saetp-primitive-type-name info)
      (room-info-name info)))

(eval-when (:compile-toplevel :execute)

(defvar *meta-room-info* (make-array 256 :initial-element nil))

(dolist (obj *primitive-objects*)
  (let ((widetag (primitive-object-widetag obj))
        (lowtag (primitive-object-lowtag obj))
        (name (primitive-object-name obj)))
    (when (and (eq lowtag 'other-pointer-lowtag)
               (not (member widetag '(t nil)))
               (not (eq name 'weak-pointer)))
      (setf (svref *meta-room-info* (symbol-value widetag))
            (make-room-info :name name
                            :kind :other)))))

(dolist (code (list #!+sb-unicode complex-character-string-widetag
                    complex-base-string-widetag simple-array-widetag
                    complex-bit-vector-widetag complex-vector-widetag
                    complex-array-widetag complex-vector-nil-widetag))
  (setf (svref *meta-room-info* code)
        (make-room-info :name 'array-header
                        :kind :other)))

(setf (svref *meta-room-info* bignum-widetag)
      (make-room-info :name 'bignum
                      :kind :other))

(setf (svref *meta-room-info* closure-header-widetag)
      (make-room-info :name 'closure
                      :kind :closure))

(dotimes (i (length *specialized-array-element-type-properties*))
  (let ((saetp (aref *specialized-array-element-type-properties* i)))
    (when (saetp-specifier saetp) ;; SIMPLE-ARRAY-NIL is a special case.
      (setf (svref *meta-room-info* (saetp-typecode saetp)) saetp))))

(setf (svref *meta-room-info* simple-array-nil-widetag)
      (make-room-info :name 'simple-array-nil
                      :kind :vector-nil))

(setf (svref *meta-room-info* code-header-widetag)
      (make-room-info :name 'code
                      :kind :code))

(setf (svref *meta-room-info* instance-header-widetag)
      (make-room-info :name 'instance
                      :kind :instance))

(setf (svref *meta-room-info* funcallable-instance-header-widetag)
      (make-room-info :name 'funcallable-instance
                      :kind :closure))

(setf (svref *meta-room-info* weak-pointer-widetag)
      (make-room-info :name 'weak-pointer
                      :kind :weak-pointer))

(let ((cons-info (make-room-info :name 'cons
                                 :kind :list)))
  ;; A cons consists of two words, both of which may be either a
  ;; pointer or immediate data.  According to the runtime this means
  ;; either a fixnum, a character, an unbound-marker, a single-float
  ;; on a 64-bit system, or a pointer.
  (dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits)))
    (setf (svref *meta-room-info* (ash i n-fixnum-tag-bits)) cons-info))

  (dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits)))
    (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
                                          instance-pointer-lowtag))
          cons-info)
    (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
                                          list-pointer-lowtag))
          cons-info)
    (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
                                          fun-pointer-lowtag))
          cons-info)
    (setf (svref *meta-room-info* (logior (ash i n-lowtag-bits)
                                          other-pointer-lowtag))
          cons-info))

  (setf (svref *meta-room-info* character-widetag) cons-info)

  (setf (svref *meta-room-info* unbound-marker-widetag) cons-info)

  ;; Single-floats are immediate data on 64-bit systems.
  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
  (setf (svref *meta-room-info* single-float-widetag) cons-info))

) ; EVAL-WHEN

(defparameter *room-info*
  ;; SAETP instances don't dump properly from XC (or possibly
  ;; normally), and we'd rather share structure with the master copy
  ;; if we can anyway, so...
  (make-array 256
              :initial-contents
              #.`(list
                  ,@(map 'list
                         (lambda (info)
                           (if (specialized-array-element-type-properties-p info)
                               `(aref *specialized-array-element-type-properties*
                                      ,(position info *specialized-array-element-type-properties*))
                               info))
                         *meta-room-info*))))
(deftype spaces () '(member :static :dynamic :read-only))

;;;; MAP-ALLOCATED-OBJECTS

;;; Since they're represented as counts of words, we should never
;;; need bignums to represent these:
(declaim (type fixnum
               *static-space-free-pointer*
               *read-only-space-free-pointer*))

(defun space-bounds (space)
  (declare (type spaces space))
  (ecase space
    (:static
     (values (int-sap static-space-start)
             (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))
    (:read-only
     (values (int-sap read-only-space-start)
             (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))
    (:dynamic
     (values (int-sap (current-dynamic-space-start))
             (dynamic-space-free-pointer)))))

;;; Return the total number of bytes used in SPACE.
(defun space-bytes (space)
  (multiple-value-bind (start end) (space-bounds space)
    (- (sap-int end) (sap-int start))))

;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
;;; platforms with 64-bit word size.
#!-sb-fluid (declaim (inline round-to-dualword))
(defun round-to-dualword (size)
  (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))

;;; Return the vector OBJ, its WIDETAG, and the number of octets
;;; required for its storage (including padding and alignment).
(defun reconstitute-vector (obj saetp)
  (declare (type (simple-array * (*)) obj)
           (type specialized-array-element-type-properties saetp))
  (let* ((length (+ (length obj)
                    (saetp-n-pad-elements saetp)))
         (n-bits (saetp-n-bits saetp))
         (alignment-pad (floor 7 n-bits))
         (n-data-octets (if (>= n-bits 8)
                            (* length (ash n-bits -3))
                            (ash (* (+ length alignment-pad)
                                    n-bits)
                                 -3))))
    (values obj
            (saetp-typecode saetp)
            (round-to-dualword (+ (* vector-data-offset n-word-bytes)
                                  n-data-octets)))))

;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
;;; of a lisp object, return the object, its "type code" (either
;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
;;; required for its storage (including padding and alignment).  Note
;;; that this function is designed to NOT CONS, even if called
;;; out-of-line.
(defun reconstitute-object (address)
  (let* ((object-sap (int-sap (get-lisp-obj-address address)))
         (header (sap-ref-word object-sap 0))
         (widetag (logand header widetag-mask))
         (header-value (ash header (- n-widetag-bits)))
         (info (svref *room-info* widetag)))
    (symbol-macrolet
        ((boxed-size (round-to-dualword (ash (1+ header-value) word-shift))))
      (macrolet
          ((tagged-object (tag)
             `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address)))))
        (cond
          ;; Pick off arrays, as they're the only plausible cause for
          ;; a non-nil, non-ROOM-INFO object as INFO.
          ((specialized-array-element-type-properties-p info)
           (reconstitute-vector (tagged-object other-pointer-lowtag) info))

          ((null info)
           (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
                  widetag))

          ((eq (room-info-kind info) :list)
           (values (tagged-object list-pointer-lowtag)
                   list-pointer-lowtag
                   (* 2 n-word-bytes)))

          ((eq (room-info-kind info) :closure)
           (values (tagged-object fun-pointer-lowtag)
                   widetag
                   boxed-size))

          ((eq (room-info-kind info) :instance)
           (values (tagged-object instance-pointer-lowtag)
                   widetag
                   boxed-size))

          ((eq (room-info-kind info) :other)
           (values (tagged-object other-pointer-lowtag)
                   widetag
                   boxed-size))

          ((eq (room-info-kind info) :vector-nil)
           (values (tagged-object other-pointer-lowtag)
                   simple-array-nil-widetag
                   (* 2 n-word-bytes)))

          ((eq (room-info-kind info) :weak-pointer)
           (values (tagged-object other-pointer-lowtag)
                   weak-pointer-widetag
                   (round-to-dualword
                    (* weak-pointer-size
                       n-word-bytes))))

          ((eq (room-info-kind info) :code)
           (values (tagged-object other-pointer-lowtag)
                   code-header-widetag
                   (round-to-dualword
                    (* (+ header-value
                          (the fixnum
                            (sap-ref-lispobj object-sap
                                             (* code-code-size-slot
                                                n-word-bytes))))
                       n-word-bytes))))

          (t
           (error "Unrecognized room-info-kind ~S in reconstitute-object"
                  (room-info-kind info))))))))

;;; Iterate over all the objects in the contiguous block of memory
;;; with the low address at START and the high address just before
;;; END, calling FUN with the object, the object's type code, and the
;;; object's total size in bytes, including any header and padding.
;;; START and END are untagged, aligned memory addresses interpreted
;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
(defun map-objects-in-range (fun start end)
  (declare (type function fun))
  ;; If START is (unsigned) greater than END, then we have somehow
  ;; blown past our endpoint.
  (aver (<= (get-lisp-obj-address start)
            (get-lisp-obj-address end)))
  (unless (= start end)
    (multiple-value-bind
          (obj typecode size)
        (reconstitute-object start)
      (aver (zerop (logand n-lowtag-bits size)))
      (let ((next-start
             ;; This special little dance is to add a number of octets
             ;; (and it had best be a number evenly divisible by our
             ;; allocation granularity) to an unboxed, aligned address
             ;; masquerading as a fixnum.  Without consing.
             (%make-lisp-obj
              (mask-field (byte #.n-word-bits 0)
                          (+ (get-lisp-obj-address start)
                             size)))))
        (funcall fun obj typecode size)
        (map-objects-in-range fun next-start end)))))

;;; Access to the GENCGC page table for better precision in
;;; MAP-ALLOCATED-OBJECTS
#!+gencgc
(progn
  (define-alien-type (struct page)
      (struct page
              (start signed)
              ;; On platforms with small enough GC pages, this field
              ;; will be a short. On platforms with larger ones, it'll
              ;; be an int.
              (bytes-used (unsigned
                           #.(if (typep sb!vm:gencgc-card-bytes
                                        '(unsigned-byte 16))
                                 16
                                 32)))
              (flags (unsigned 8))
              (gen (signed 8))))
  (declaim (inline find-page-index))
  (define-alien-routine "find_page_index" long (index signed))
  (define-alien-variable "last_free_page" sb!kernel::page-index-t)
  (define-alien-variable "heap_base" (* t))
  (define-alien-variable "page_table" (* (struct page))))

;;; Iterate over all the objects allocated in SPACE, calling FUN with
;;; the object, the object's type code, and the object's total size in
;;; bytes, including any header and padding. CAREFUL makes
;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it
;;; is intended for slightly more demanding uses of heap groveling
;;; then ROOM.
#!-sb-fluid (declaim (maybe-inline map-allocated-objects))
(defun map-allocated-objects (fun space)
  (declare (type function fun)
           (type spaces space))
  (without-gcing
    (ecase space
      (:static
       ;; Static space starts with NIL, which requires special
       ;; handling, as the header and alignment are slightly off.
       (multiple-value-bind (start end) (space-bounds space)
         (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
         (map-objects-in-range fun
                               (%make-lisp-obj (+ (* 8 n-word-bytes)
                                                  (sap-int start)))
                               (%make-lisp-obj (sap-int end)))))

      ((:read-only #!-gencgc :dynamic)
       ;; Read-only space (and dynamic space on cheneygc) is a block
       ;; of contiguous allocations.
       (multiple-value-bind (start end) (space-bounds space)
         (map-objects-in-range fun
                               (%make-lisp-obj (sap-int start))
                               (%make-lisp-obj (sap-int end)))))

      #!+gencgc
      (:dynamic
       ;; Dynamic space on gencgc requires walking the GC page tables
       ;; in order to determine what regions contain objects.

       ;; We explicitly presume that any pages in an allocation region
       ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
       ;; (indicating a full page) or an otherwise-valid BYTES-USED.
       ;; We also presume that the pages of an open allocation region
       ;; after the first page, and any pages that are unallocated,
       ;; have a BYTES-USED of zero.  GENCGC seems to guarantee this.

       ;; Our procedure is to scan forward through the page table,
       ;; maintaining an "end pointer" until we reach a page where
       ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
       ;; LAST-FREE-PAGE.  We then MAP-OBJECTS-IN-RANGE if the range
       ;; is not empty, and proceed to the next page (unless we've hit
       ;; LAST-FREE-PAGE).  We happily take advantage of the fact that
       ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
       ;; coincident pointers for the range.

       ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
       ;; closing allocation regions and opening new ones.  This may
       ;; prove to be an issue with concurrent systems, or with
       ;; spectacularly poor timing for closing an allocation region
       ;; in a single-threaded system.

       (loop
          with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
          ;; This magic dance gets us an unboxed aligned pointer as a
          ;; FIXNUM.
          with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
          with end = start

          ;; This is our page range.
          for page-index from 0 below last-free-page
          for next-page-addr from (+ start page-size) by page-size
          for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)

          when (< page-bytes-used gencgc-card-bytes)
          do (progn
               (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
               (map-objects-in-range fun start end)
               (setf start next-page-addr)
               (setf end next-page-addr))
          else do (incf end page-size)

          finally (map-objects-in-range fun start end))))))

;;;; MEMORY-USAGE

;;; Return a list of 3-lists (bytes object type-name) for the objects
;;; allocated in Space.
(defun type-breakdown (space)
  (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
        (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
    (map-allocated-objects
     (lambda (obj type size)
       (declare (word size) (optimize (speed 3)) (ignore obj))
       (incf (aref sizes type) size)
       (incf (aref counts type)))
     space)

    (let ((totals (make-hash-table :test 'eq)))
      (dotimes (i 256)
        (let ((total-count (aref counts i)))
          (unless (zerop total-count)
            (let* ((total-size (aref sizes i))
                   (name (room-info-type-name (aref *room-info* i)))
                   (found (gethash name totals)))
              (cond (found
                     (incf (first found) total-size)
                     (incf (second found) total-count))
                    (t
                     (setf (gethash name totals)
                           (list total-size total-count name))))))))

      (collect ((totals-list))
        (maphash (lambda (k v)
                   (declare (ignore k))
                   (totals-list v))
                 totals)
        (sort (totals-list) #'> :key #'first)))))

;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
;;; (space-name . totals-for-space), where totals-for-space is the list
;;; returned by TYPE-BREAKDOWN.
(defun print-summary (spaces totals)
  (let ((summary (make-hash-table :test 'eq)))
    (dolist (space-total totals)
      (dolist (total (cdr space-total))
        (push (cons (car space-total) total)
              (gethash (third total) summary))))

    (collect ((summary-totals))
      (maphash (lambda (k v)
                 (declare (ignore k))
                 (let ((sum 0))
                   (declare (unsigned-byte sum))
                   (dolist (space-total v)
                     (incf sum (first (cdr space-total))))
                   (summary-totals (cons sum v))))
               summary)

      (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
      (let ((summary-total-bytes 0)
            (summary-total-objects 0))
        (declare (unsigned-byte summary-total-bytes summary-total-objects))
        (dolist (space-totals
                 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
          (let ((total-objects 0)
                (total-bytes 0)
                name)
            (declare (unsigned-byte total-objects total-bytes))
            (collect ((spaces))
              (dolist (space-total space-totals)
                (let ((total (cdr space-total)))
                  (setq name (third total))
                  (incf total-bytes (first total))
                  (incf total-objects (second total))
                  (spaces (cons (car space-total) (first total)))))
              (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
                      name total-bytes total-objects)
              (dolist (space (spaces))
                (format t ", ~W% ~(~A~)"
                        (round (* (cdr space) 100) total-bytes)
                        (car space)))
              (format t ".~%")
              (incf summary-total-bytes total-bytes)
              (incf summary-total-objects total-objects))))
        (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
                summary-total-bytes summary-total-objects)))))

;;; Report object usage for a single space.
(defun report-space-total (space-total cutoff)
  (declare (list space-total) (type (or single-float null) cutoff))
  (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
  (let* ((types (cdr space-total))
         (total-bytes (reduce #'+ (mapcar #'first types)))
         (total-objects (reduce #'+ (mapcar #'second types)))
         (cutoff-point (if cutoff
                           (truncate (* (float total-bytes) cutoff))
                           0))
         (reported-bytes 0)
         (reported-objects 0))
    (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
                            reported-bytes))
    (loop for (bytes objects name) in types do
      (when (<= bytes cutoff-point)
        (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
                (- total-bytes reported-bytes)
                (- total-objects reported-objects))
        (return))
      (incf reported-bytes bytes)
      (incf reported-objects objects)
      (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
              bytes objects name))
    (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
            total-bytes total-objects (car space-total))))

;;; Print information about the heap memory in use. PRINT-SPACES is a
;;; list of the spaces to print detailed information for.
;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
;;; PRINT-SUMMARY is true, then summary information will be printed.
;;; The defaults print only summary information for dynamic space. If
;;; true, CUTOFF is a fraction of the usage in a report below which
;;; types will be combined as OTHER.
(defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
                          (print-summary t) cutoff)
  (declare (type (or single-float null) cutoff))
  (let* ((spaces (if (eq count-spaces t)
                     '(:static :dynamic :read-only)
                     count-spaces))
         (totals (mapcar (lambda (space)
                           (cons space (type-breakdown space)))
                         spaces)))

    (dolist (space-total totals)
      (when (or (eq print-spaces t)
                (member (car space-total) print-spaces))
        (report-space-total space-total cutoff)))

    (when print-summary (print-summary spaces totals)))

  (values))

;;; Print info about how much code and no-ops there are in SPACE.
(defun count-no-ops (space)
  (declare (type spaces space))
  (let ((code-words 0)
        (no-ops 0)
        (total-bytes 0))
    (declare (fixnum code-words no-ops)
             (type unsigned-byte total-bytes))
    (map-allocated-objects
     (lambda (obj type size)
       (when (eql type code-header-widetag)
         (let ((words (truly-the fixnum (%code-code-size obj)))
               (sap (%primitive code-instructions obj))
               (size size))
           (declare (fixnum size))
           (incf total-bytes size)
           (incf code-words words)
           (dotimes (i words)
             (when (zerop (sap-ref-word sap (* i n-word-bytes)))
               (incf no-ops))))))
     space)

    (format t
            "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
            total-bytes code-words no-ops
            (round (* no-ops 100) code-words)))

  (values))

(defun descriptor-vs-non-descriptor-storage (&rest spaces)
  (let ((descriptor-words 0)
        (non-descriptor-headers 0)
        (non-descriptor-bytes 0))
    (declare (type unsigned-byte descriptor-words non-descriptor-headers
                   non-descriptor-bytes))
    (dolist (space (or spaces '(:read-only :static :dynamic)))
      (declare (inline map-allocated-objects))
      (map-allocated-objects
       (lambda (obj type size)
         (case type
           (#.code-header-widetag
            (let ((inst-words (truly-the fixnum (%code-code-size obj)))
                  (size size))
              (declare (type fixnum size inst-words))
              (incf non-descriptor-bytes (* inst-words n-word-bytes))
              (incf descriptor-words
                    (- (truncate size n-word-bytes) inst-words))))
           ((#.bignum-widetag
             #.single-float-widetag
             #.double-float-widetag
             #.simple-base-string-widetag
             #!+sb-unicode #.simple-character-string-widetag
             #.simple-array-nil-widetag
             #.simple-bit-vector-widetag
             #.simple-array-unsigned-byte-2-widetag
             #.simple-array-unsigned-byte-4-widetag
             #.simple-array-unsigned-byte-8-widetag
             #.simple-array-unsigned-byte-16-widetag
             #.simple-array-unsigned-byte-32-widetag
             #.simple-array-signed-byte-8-widetag
             #.simple-array-signed-byte-16-widetag
             #.simple-array-signed-byte-32-widetag
             #.simple-array-single-float-widetag
             #.simple-array-double-float-widetag
             #.simple-array-complex-single-float-widetag
             #.simple-array-complex-double-float-widetag)
            (incf non-descriptor-headers)
            (incf non-descriptor-bytes (- size n-word-bytes)))
           ((#.list-pointer-lowtag
             #.instance-pointer-lowtag
             #.ratio-widetag
             #.complex-widetag
             #.simple-array-widetag
             #.simple-vector-widetag
             #.complex-base-string-widetag
             #.complex-vector-nil-widetag
             #.complex-bit-vector-widetag
             #.complex-vector-widetag
             #.complex-array-widetag
             #.closure-header-widetag
             #.funcallable-instance-header-widetag
             #.value-cell-header-widetag
             #.symbol-header-widetag
             #.sap-widetag
             #.weak-pointer-widetag
             #.instance-header-widetag)
            (incf descriptor-words (truncate (the fixnum size) n-word-bytes)))
           (t
            (error "bogus widetag: ~W" type))))
       space))
    (format t "~:D words allocated for descriptor objects.~%"
            descriptor-words)
    (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
            non-descriptor-bytes non-descriptor-headers)
    (values)))

;;; Print a breakdown by instance type of all the instances allocated
;;; in SPACE. If TOP-N is true, print only information for the
;;; TOP-N types with largest usage.
(defun instance-usage (space &key (top-n 15))
  (declare (type spaces space) (type (or fixnum null) top-n))
  (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
  (let ((totals (make-hash-table :test 'eq))
        (total-objects 0)
        (total-bytes 0))
    (declare (unsigned-byte total-objects total-bytes))
    (map-allocated-objects
     (lambda (obj type size)
       (declare (optimize (speed 3)))
       (when (eql type instance-header-widetag)
         (incf total-objects)
         (let* ((classoid (layout-classoid (%instance-ref obj 0)))
                (found (gethash classoid totals))
                (size size))
           (declare (fixnum size))
           (incf total-bytes size)
           (cond (found
                  (incf (the fixnum (car found)))
                  (incf (the fixnum (cdr found)) size))
                 (t
                  (setf (gethash classoid totals) (cons 1 size)))))))
     space)

    (collect ((totals-list))
      (maphash (lambda (classoid what)
                 (totals-list (cons (prin1-to-string
                                     (classoid-proper-name classoid))
                                    what)))
               totals)
      (let ((sorted (sort (totals-list) #'> :key #'cddr))
            (printed-bytes 0)
            (printed-objects 0))
        (declare (unsigned-byte printed-bytes printed-objects))
        (dolist (what (if top-n
                          (subseq sorted 0 (min (length sorted) top-n))
                          sorted))
          (let ((bytes (cddr what))
                (objects (cadr what)))
            (incf printed-bytes bytes)
            (incf printed-objects objects)
            (format t "  ~A: ~:D bytes, ~:D object~:P.~%" (car what)
                    bytes objects)))

        (let ((residual-objects (- total-objects printed-objects))
              (residual-bytes (- total-bytes printed-bytes)))
          (unless (zerop residual-objects)
            (format t "  Other types: ~:D bytes, ~:D object~:P.~%"
                    residual-bytes residual-objects))))

      (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
              space total-bytes total-objects)))

  (values))

;;;; PRINT-ALLOCATED-OBJECTS

(defun print-allocated-objects (space &key (percent 0) (pages 5)
                                      type larger smaller count
                                      (stream *standard-output*))
  (declare (type (integer 0 99) percent) (type index pages)
           (type stream stream) (type spaces space)
           (type (or index null) type larger smaller count))
  (multiple-value-bind (start-sap end-sap) (space-bounds space)
    (let* ((space-start (sap-int start-sap))
           (space-end (sap-int end-sap))
           (space-size (- space-end space-start))
           (pagesize (sb!sys:get-page-size))
           (start (+ space-start (round (* space-size percent) 100)))
           (printed-conses (make-hash-table :test 'eq))
           (pages-so-far 0)
           (count-so-far 0)
           (last-page 0))
      (declare (type (unsigned-byte 32) last-page start)
               (fixnum pages-so-far count-so-far pagesize))
      (labels ((note-conses (x)
                 (unless (or (atom x) (gethash x printed-conses))
                   (setf (gethash x printed-conses) t)
                   (note-conses (car x))
                   (note-conses (cdr x)))))
        (map-allocated-objects
         (lambda (obj obj-type size)
           (let ((addr (get-lisp-obj-address obj)))
             (when (>= addr start)
               (when (if count
                         (> count-so-far count)
                         (> pages-so-far pages))
                 (return-from print-allocated-objects (values)))

               (unless count
                 (let ((this-page (* (the (values (unsigned-byte 32) t)
                                       (truncate addr pagesize))
                                     pagesize)))
                   (declare (type (unsigned-byte 32) this-page))
                   (when (/= this-page last-page)
                     (when (< pages-so-far pages)
                       ;; FIXME: What is this? (ERROR "Argh..")? or
                       ;; a warning? or code that can be removed
                       ;; once the system is stable? or what?
                       (format stream "~2&**** Page ~W, address ~X:~%"
                               pages-so-far addr))
                     (setq last-page this-page)
                     (incf pages-so-far))))

               (when (and (or (not type) (eql obj-type type))
                          (or (not smaller) (<= size smaller))
                          (or (not larger) (>= size larger)))
                 (incf count-so-far)
                 (case type
                   (#.code-header-widetag
                    (let ((dinfo (%code-debug-info obj)))
                      (format stream "~&Code object: ~S~%"
                              (if dinfo
                                  (sb!c::compiled-debug-info-name dinfo)
                                  "No debug info."))))
                   (#.symbol-header-widetag
                    (format stream "~&~S~%" obj))
                   (#.list-pointer-lowtag
                    (unless (gethash obj printed-conses)
                      (note-conses obj)
                      (let ((*print-circle* t)
                            (*print-level* 5)
                            (*print-length* 10))
                        (format stream "~&~S~%" obj))))
                   (t
                    (fresh-line stream)
                    (let ((str (write-to-string obj :level 5 :length 10
                                                :pretty nil)))
                      (unless (eql type instance-header-widetag)
                        (format stream "~S: " (type-of obj)))
                      (format stream "~A~%"
                              (subseq str 0 (min (length str) 60))))))))))
         space))))
  (values))

;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS

(defvar *ignore-after* nil)

(defun valid-obj (space x)
  (or (not (eq space :dynamic))
      ;; this test looks bogus if the allocator doesn't work linearly,
      ;; which I suspect is the case for GENCGC.  -- CSR, 2004-06-29
      (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))

(defun maybe-cons (space x stuff)
  (if (valid-obj space x)
      (cons x stuff)
      stuff))

(defun list-allocated-objects (space &key type larger smaller count
                                     test)
  (declare (type spaces space)
           (type (or index null) larger smaller type count)
           (type (or function null) test)
           (inline map-allocated-objects))
  (unless *ignore-after*
    (setq *ignore-after* (cons 1 2)))
  (collect ((counted 0 1+))
    (let ((res ()))
      (map-allocated-objects
       (lambda (obj obj-type size)
         (when (and (or (not type) (eql obj-type type))
                    (or (not smaller) (<= size smaller))
                    (or (not larger) (>= size larger))
                    (or (not test) (funcall test obj)))
           (setq res (maybe-cons space obj res))
           (when (and count (>= (counted) count))
             (return-from list-allocated-objects res))))
       space)
      res)))

;;; Calls FUNCTION with all object that have (possibly conservative)
;;; references to them on current stack.
(defun map-stack-references (function)
  (let ((end
         (sb!di::descriptor-sap
          #!+stack-grows-downward-not-upward *control-stack-end*
          #!-stack-grows-downward-not-upward *control-stack-start*))
        (sp (current-sp))
        (seen nil))
    (loop until #!+stack-grows-downward-not-upward (sap> sp end)
                #!-stack-grows-downward-not-upward (sap< sp end)
          do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
               (when (and ok (typep obj '(not (or fixnum character))))
                 (unless (member obj seen :test #'eq)
                   (funcall function obj)
                   (push obj seen))))
             (setf sp
                   #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
                   #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))

(defun map-referencing-objects (fun space object)
  (declare (type spaces space) (inline map-allocated-objects))
  (unless *ignore-after*
    (setq *ignore-after* (cons 1 2)))
  (flet ((maybe-call (fun obj)
           (when (valid-obj space obj)
             (funcall fun obj))))
    (map-allocated-objects
     (lambda (obj obj-type size)
       (declare (ignore obj-type size))
       (typecase obj
         (cons
          (when (or (eq (car obj) object)
                    (eq (cdr obj) object))
            (maybe-call fun obj)))
         (instance
          (dotimes (i (%instance-length obj))
            (when (eq (%instance-ref obj i) object)
              (maybe-call fun obj)
              (return))))
         (code-component
          (let ((length (get-header-data obj)))
            (do ((i code-constants-offset (1+ i)))
                ((= i length))
              (when (eq (code-header-ref obj i) object)
                (maybe-call fun obj)
                (return)))))
         (simple-vector
          (dotimes (i (length obj))
            (when (eq (svref obj i) object)
              (maybe-call fun obj)
              (return))))
         (symbol
          (when (or (eq (symbol-name obj) object)
                    (eq (symbol-package obj) object)
                    (eq (symbol-plist obj) object)
                    (and (boundp obj)
                         (eq (symbol-value obj) object)))
            (maybe-call fun obj)))))
     space)))

(defun list-referencing-objects (space object)
  (collect ((res))
    (map-referencing-objects
     (lambda (obj) (res obj)) space object)
    (res)))
