Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/code/room.lisp

Text File | 1992-05-30 | 26.9 KB | 837 lines

;;; -*- Mode: Lisp; Package: VM -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: room.lisp,v 1.16 92/02/26 12:13:16 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; Heap grovelling memory usage stuff.
;;;
(in-package "VM")
(use-package "SYSTEM")
(export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
               structure-usage find-holes print-allocated-objects
               code-breakdown uninterned-symbol-count))
(in-package "LISP")
(import '(
      dynamic-0-space-start dynamic-1-space-start read-only-space-start
      static-space-start current-dynamic-space-start
      *static-space-free-pointer* *read-only-space-free-pointer*)
    "VM")
(in-package "VM")


;;;; Type format database.

(defstruct room-info
  ;;
  ;; The name of this type.
  (name nil :type symbol)
  ;;
  ;; Kind of type (how we determine length).
  (kind (required-argument)
    :type (member :lowtag :fixed :header :vector
              :string :code :closure :structure))
  ;;
  ;; Length if fixed-length, shift amount for element size if :vector.
  (length nil :type (or fixnum null)))

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


(dolist (obj *primitive-objects*)
  (let ((header (primitive-object-header obj))
    (lowtag (primitive-object-lowtag obj))
    (name (primitive-object-name obj))
    (variable (primitive-object-variable-length obj))
    (size (primitive-object-size obj)))
    (cond
     ((not lowtag))
     ((not header)
      (let ((info (make-room-info :name name  :kind :lowtag))
        (lowtag (symbol-value lowtag)))
    (declare (fixnum lowtag))
    (dotimes (i 32)
      (setf (svref *room-info* (logior lowtag (ash i 3))) info))))
     (variable)
     (t
      (setf (svref *room-info* (symbol-value header))
        (make-room-info :name name  :kind :fixed  :length size))))))

(dolist (code (list complex-string-type simple-array-type
            complex-bit-vector-type complex-vector-type
            complex-array-type))
  (setf (svref *room-info* code)
    (make-room-info :name 'array-header  :kind :header)))

(setf (svref *room-info* bignum-type)
      (make-room-info :name 'bignum  :kind :header))

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

(dolist (stuff '((simple-bit-vector-type . -3)
         (simple-vector-type . 2)
         (simple-array-unsigned-byte-2-type . -2)
         (simple-array-unsigned-byte-4-type . -1)
         (simple-array-unsigned-byte-8-type . 0)
         (simple-array-unsigned-byte-16-type . 1)
         (simple-array-unsigned-byte-32-type . 2)
         (simple-array-single-float-type . 2)
         (simple-array-double-float-type . 3)))
  (let ((name (car stuff))
    (size (cdr stuff)))
    (setf (svref *room-info* (symbol-value name))
      (make-room-info :name name  :kind :vector  :length size))))

(setf (svref *room-info* simple-string-type)
      (make-room-info :name 'simple-string-type :kind :string :length 0))

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

(setf (svref *room-info* structure-header-type)
      (make-room-info :name 'structure :kind :structure))

(deftype spaces () '(member :static :dynamic :read-only))


;;;; MAP-ALLOCATED-OBJECTS:

(proclaim '(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 (* *static-space-free-pointer* word-bytes))))
    (:read-only
     (values (int-sap (read-only-space-start))
         (int-sap (* *read-only-space-free-pointer* word-bytes))))
    (:dynamic
     (values (int-sap (current-dynamic-space-start))
         (dynamic-space-free-pointer)))))

;;; SPACE-BYTES  --  Internal
;;;
;;;    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-TO-DUALWORD  --  Internal
;;;
;;;    Round Size (in bytes) up to the next dualword (eight byte) boundry.
;;;
(proclaim '(inline round-to-dualword))
(defun round-to-dualword (size)
  (declare (fixnum size))
  (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))


;;; VECTOR-TOTAL-SIZE  --  Internal
;;;
;;;    Return the total size of a vector in bytes, including any pad.
;;;
(proclaim '(inline vector-total-size))
(defun vector-total-size (obj info)
  (let ((shift (room-info-length info))
    (len (+ (length (the (simple-array * (*)) obj))
        (ecase (room-info-kind info)
          (:vector 0)
          (:string 1)))))
    (declare (type (integer -3 3) shift))
    (round-to-dualword
     (+ (* vector-data-offset word-bytes)
    (the fixnum
         (if (minusp shift)
         (ash (the fixnum
               (+ len (the fixnum
                       (1- (the fixnum (ash 1 (- shift)))))))
              shift)
         (ash len shift)))))))


;;; MAP-ALLOCATED-OBJECTS  --  Interface
;;;
;;;    Iterate over all the objects allocated in Space, calling Fun with the
;;; object, the object's type code, and the objects total size in bytes,
;;; including any header and padding.
;;;
(proclaim '(maybe-inline map-allocated-objects))
(defun map-allocated-objects (fun space)
  (declare (type function fun) (type spaces space))
  (without-gcing
    (multiple-value-bind (start end)
             (space-bounds space)
      (declare (type system-area-pointer start end))
      (declare (optimize (speed 3) (safety 0)))
      (let ((current start)
        #+nil
        (prev nil))
    (loop
      (let* ((header (sap-ref-32 current 0))
         (header-type (logand header #xFF))
         (info (svref *room-info* header-type)))
        (cond
         ((or (not info)
          (eq (room-info-kind info) :lowtag))
          (let ((size (* cons-size word-bytes)))
        (funcall fun
             (make-lisp-obj (logior (sap-int current)
                        list-pointer-type))
             list-pointer-type
             size)
        (setq current (sap+ current size))))
         ((eql header-type closure-header-type)
          (let* ((obj (make-lisp-obj (logior (sap-int current)
                         function-pointer-type)))
             (size (round-to-dualword
                (* (the fixnum (1+ (get-closure-length obj)))
                   word-bytes))))
        (funcall fun obj header-type size)
        (setq current (sap+ current size))))
         ((eq (room-info-kind info) :structure)
          (let* ((obj (make-lisp-obj
               (logior (sap-int current) structure-pointer-type)))
             (size (round-to-dualword
                (* (+ (c::structure-length obj) 1) word-bytes))))
        (declare (fixnum size))
        (funcall fun obj header-type size)
        (assert (zerop (logand size lowtag-mask)))
        #+nil
        (when (> size 200000) (break "Implausible size, prev ~S" prev))
        #+nil
        (setq prev current)
        (setq current (sap+ current size))))
         (t
          (let* ((obj (make-lisp-obj
               (logior (sap-int current) other-pointer-type)))
             (size (ecase (room-info-kind info)
                 (:fixed
                  (assert (or (eql (room-info-length info)
                           (1+ (get-header-data obj)))
                      (floatp obj)))
                  (round-to-dualword
                   (* (room-info-length info) word-bytes)))
                 ((:vector :string)
                  (vector-total-size obj info))
                 (:header
                  (round-to-dualword
                   (* (1+ (get-header-data obj)) word-bytes)))
                 (:code
                  (+ (the fixnum
                      (* (get-header-data obj) word-bytes))
                 (round-to-dualword
                  (* (the fixnum
                      (%primitive code-code-size obj))
                     word-bytes)))))))
        (declare (fixnum size))
        (funcall fun obj header-type size)
        (assert (zerop (logand size lowtag-mask)))
        #+nil
        (when (> size 200000)
          (break "Implausible size, prev ~S" prev))
        #+nil
        (setq prev current)
        (setq current (sap+ current size))))))
      (unless (sap< current end)
        (assert (sap= current end))
        (return)))

    #+nil
    prev))))


;;;; MEMORY-USAGE:

;;; TYPE-BREAKDOWN  --  Interface
;;;
;;;    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 'fixnum))
    (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
    (map-allocated-objects
     #'(lambda (obj type size)
     (declare (fixnum size) (optimize (speed 3) (safety 0)) (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-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)))))


;;; PRINT-SUMMARY  --  Internal
;;;
;;;    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 (fixnum 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 (fixnum 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 (fixnum 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 ", ~D% ~(~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-SPACE-TOTAL  --  Internal
;;;
;;;    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 (fixnum 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))))


;;; MEMORY-USAGE  --  Public
;;;
(defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
              (print-summary t) cutoff)
  "Print out 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 (:Static, :Dyanmic
  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."
  (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))


;;; COUNT-NO-OPS  --  Public
;;;
(defun count-no-ops (space)
  "Print info about how much code and no-ops there are in 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)
      (declare (fixnum size) (optimize (safety 0)))
     (when (eql type code-header-type)
       (incf total-bytes size)
       (let ((words (truly-the fixnum (%primitive code-code-size obj)))
         (sap (truly-the system-area-pointer
                 (%primitive code-instructions obj))))
         (incf code-words words)
         (dotimes (i words)
           (when (zerop (sap-ref-32 sap (* i vm: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))


;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE  --  Public
;;;
(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)
       (declare (fixnum size) (optimize (safety 0)))
       (case type
         (#.code-header-type
          (let ((inst-words
             (truly-the fixnum (%primitive code-code-size obj))))
        (declare (type fixnum inst-words))
        (incf non-descriptor-bytes (* inst-words word-bytes))
        (incf descriptor-words
              (- (truncate size word-bytes) inst-words))))
         ((#.bignum-type
           #.single-float-type
           #.double-float-type
           #.simple-string-type
           #.simple-bit-vector-type
           #.simple-array-unsigned-byte-2-type
           #.simple-array-unsigned-byte-4-type
           #.simple-array-unsigned-byte-8-type
           #.simple-array-unsigned-byte-16-type
           #.simple-array-unsigned-byte-32-type
           #.simple-array-single-float-type
           #.simple-array-double-float-type)
          (incf non-descriptor-headers)
          (incf non-descriptor-bytes (- size word-bytes)))
         ((#.list-pointer-type
           #.structure-pointer-type
           #.ratio-type
           #.complex-type
           #.simple-array-type
           #.simple-vector-type
           #.complex-string-type
           #.complex-bit-vector-type
           #.complex-vector-type
           #.complex-array-type
           #.closure-header-type
           #.funcallable-instance-header-type
           #.value-cell-header-type
           #.symbol-header-type
           #.sap-type
           #.weak-pointer-type
           #.structure-header-type)
          (incf descriptor-words (truncate size word-bytes)))
         (t
          (error "Bogus type: ~D" 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)))


;;; STRUCTURE-USAGE  --  Public
;;;
(defun structure-usage (space &key (top-n 15))
  (declare (type spaces space) (type (or fixnum null) top-n))
  "Print a breakdown by structure type of all the structures allocated in
  Space.  If TOP-N is true, print only information for the the TOP-N types with
  largest usage."
  (format t "~2&~@[Top ~D ~]~(~A~) structure types:~%" top-n space)
  (let ((totals (make-hash-table :test #'eq))
    (total-objects 0)
    (total-bytes 0))
    (declare (fixnum total-objects total-bytes))
    (map-allocated-objects
     #'(lambda (obj type size)
     (declare (fixnum size) (optimize (speed 3) (safety 0)))
     (when (eql type structure-header-type)
       (incf total-objects)
       (incf total-bytes size)
       (let* ((name (structure-ref obj 0))
          (found (gethash name totals)))
         (cond (found
            (incf (the fixnum (car found)))
            (incf (the fixnum (cdr found)) size))
           (t
            (setf (gethash name totals) (cons 1 size)))))))
     space)

    (collect ((totals-list))
      (maphash #'(lambda (name what)
           (totals-list (cons name what)))
           totals)
      (let ((sorted (sort (totals-list) #'> :key #'cddr))
        (printed-bytes 0)
        (printed-objects 0))
    (declare (fixnum 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 "  ~S: ~: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~) structure total: ~:D bytes, ~:D object~:P.~%"
          space total-bytes total-objects)))

  (values))


;;; FIND-HOLES -- Public
;;;
(defun find-holes (&rest spaces)
  (dolist (space (or spaces '(:read-only :static :dynamic)))
    (format t "In ~A space:~%" space)
    (let ((start-addr nil)
      (total-bytes 0))
      (declare (type (or null (unsigned-byte 32)) start-addr)
           (type (unsigned-byte 32) total-bytes))
      (map-allocated-objects
       #'(lambda (object typecode bytes)
       (declare (ignore typecode)
            (type (unsigned-byte 32) bytes))
       (if (and (consp object)
            (eql (car object) 0)
            (eql (cdr object) 0))
           (if start-addr
           (incf total-bytes bytes)
           (setf start-addr (di::get-lisp-obj-address object)
             total-bytes bytes))
           (when start-addr
         (format t "~D bytes at #x~X~%" total-bytes start-addr)
         (setf start-addr nil))))
       space)
      (when start-addr
    (format t "~D bytes at #x~X~%" total-bytes start-addr))))
  (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 c::index pages)
       (type stream stream) (type spaces space)
       (type (or c::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 (system:get-page-size))
       (start (+ space-start (round (* space-size percent) 100)))
       (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))
      (map-allocated-objects
       #'(lambda (obj obj-type size)
       (declare (optimize (safety 0)))
       (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 (unsigned-byte 32)
                      (truncate addr pagesize))
                     pagesize)))
           (declare (type (unsigned-byte 32) this-page))
           (when (/= this-page last-page)
             (when (< pages-so-far pages)
               (format stream "~2&**** Page ~D, 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-type
            (let ((dinfo (code-debug-info obj)))
              (format stream "~&Code object: ~S~%"
                  (if dinfo
                  (c::compiled-debug-info-name dinfo)
                  "No debug info."))))
           (#.symbol-header-type
            (format stream "~&~S~%" obj))
           (#.list-pointer-type
            (write-char #\. stream))
           (t
            (fresh-line stream)
            (let ((str (write-to-string obj :level 5 :length 10
                        :pretty nil)))
              (unless (eql type structure-header-type)
            (format stream "~S: " (type-of obj)))
              (format stream "~A~%"
                  (subseq str 0 (min (length str) 60))))))))))
       space)))
  (values))

;;;; Misc:

(defun uninterned-symbol-count (space)
  (declare (type spaces space))
  (let ((total 0)
    (uninterned 0))
    (map-allocated-objects
     #'(lambda (obj type size)
     (declare (ignore type size))
     (when (symbolp obj)
       (incf total)
       (unless (symbol-package obj)
         (incf uninterned))))
     space)
    (values uninterned (float (/ uninterned total)))))


(defun code-breakdown (space &key (how :package))
  (declare (type spaces space) (type (member :file :package) how))
  (let ((info (make-hash-table :test (if (eq how :package) #'equal #'eq))))
    (map-allocated-objects
     #'(lambda (obj type size)
     (when (eql type code-header-type)
       (let* ((dinfo (code-debug-info obj))
          (name (if dinfo
                (ecase how
                  (:package (c::compiled-debug-info-package dinfo))
                  (:file
                   (let ((source
                      (first (c::compiled-debug-info-source
                          dinfo))))
                 (if (eq (c::debug-source-from source)
                     :file)
                     (c::debug-source-name source)
                     "FROM LISP"))))
                "UNKNOWN"))
          (found (or (gethash name info)
                 (setf (gethash name info) (cons 0 0)))))
         (incf (car found))
         (incf (cdr found) size))))
     space)

    (collect ((res))
      (maphash #'(lambda (k v)
           (res (list v k)))
           info)
      (loop for ((count . size) name) in (sort (res) #'> :key #'cdar) do
    (format t "~40@A: ~:D bytes, ~:D object~:P.~%"
        (subseq name (max (- (length name) 40) 0))
        size count))))
  (values))


;;;; Histogram interface.  Uses Scott's Hist package.
#+nil
(defun memory-histogram (space &key (low 4) (high 20)
                   (bucket-size 1)
                   (function
                #'(lambda (obj type size)
                    (declare (ignore obj type) (fixnum size))
                    (integer-length (1- size))))
                   (type nil))
  (let ((function (if (eval:interpreted-function-p function)
              (compile nil function)
              function)))
    (hist:hist (low high bucket-size)
      (map-allocated-objects
       #'(lambda (obj this-type size)
       (when (or (not type) (eql this-type type))
         (hist:hist-record (funcall function obj type size))))
       space)))
  (values))

;;; Return the number of fbound constants in a code object.
;;;
(defun code-object-calls (obj)
  (loop for i from code-constants-offset below (get-header-data obj)
    count (find-code-object (code-header-ref obj i))))

;;; Return the number of calls in Obj to functions with <= N calls.  Calls is
;;; an eq hashtable translating code objects to the number of references.
;;;
(defun code-object-leaf-calls (obj n calls)
  (loop for i from code-constants-offset below (get-header-data obj)
    count (let ((code (find-code-object (code-header-ref obj i))))
        (and code (<= (gethash code calls 0) n)))))

#+nil
(defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
                   (function #'identity))
  "Given a hashtable, print a histogram of the contents.  Function should give
  the value to plot when applied to the hashtable values."
  (let ((function (if (eval:interpreted-function-p function)
              (compile nil function)
              function)))
    (hist:hist (low high bucket-size)
      (loop for count being each hash-value in table do
    (hist:hist-record (funcall function count))))))

(defun report-top-n (table &key (top-n 20) (function #'identity))
  "Report the Top-N entries in the hashtable Table, when sorted by Function
  applied to the hash value.  If Top-N is NIL, report all entries."
  (let ((function (if (eval:interpreted-function-p function)
              (compile nil function)
              function)))
    (collect ((totals-list)
          (total-val 0 +))
      (maphash #'(lambda (name what)
           (let ((val (funcall function what)))
             (totals-list (cons name val))
             (total-val val)))
           table)
      (let ((sorted (sort (totals-list) #'> :key #'cdr))
        (printed 0))
    (declare (fixnum printed))
    (dolist (what (if top-n
              (subseq sorted 0 (min (length sorted) top-n))
              sorted))
      (let ((val (cdr what)))
        (incf printed val)
        (format t "~8:D: ~S~%" val (car what))))

    (let ((residual (- (total-val) printed)))
      (unless (zerop residual)
        (format t "~8:D: Other~%" residual))))

      (format t "~8:D: Total~%" (total-val))))
  (values))


;;; Given any Lisp object, return the associated code object, or NIL.
;;;
(defun find-code-object (const)
  (flet ((frob (def)
       (function-code-header
        (ecase (get-type def)
          ((#.closure-header-type
        #.funcallable-instance-header-type)
           (%closure-function def))
          (#.function-header-type
           def)))))
    (typecase const
      (function (frob const))
      (symbol
       (if (fboundp const)
       (frob (symbol-function const))
       nil))
      (t nil))))


(defun find-caller-counts (space)
  "Return a hashtable mapping each function in for which a call appears in
  Space to the number of times such a call appears."
  (let ((counts (make-hash-table :test #'eq)))
    (map-allocated-objects
     #'(lambda (obj type size)
     (declare (ignore size))
     (when (eql type code-header-type)
       (loop for i from code-constants-offset below (get-header-data obj)
         do (let ((code (find-code-object (code-header-ref obj i))))
          (when code
            (incf (gethash code counts 0)))))))
       space)
    counts))

(defun find-high-callers (space &key (above 10) table (threshold 2))
  "Return a hashtable translating code objects to function constant counts for
  all code objects in Space with more than Above function constants."
  (let ((counts (make-hash-table :test #'eq)))
    (map-allocated-objects
     #'(lambda (obj type size)
     (declare (ignore size))
     (when (eql type code-header-type)
       (let ((count (if table
                (code-object-leaf-calls obj threshold table)
                (code-object-calls obj))))
         (when (> count above)
           (setf (gethash obj counts) count)))))
     space)
    counts))