;;; introspection library

;;;; 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.

;;; For the avoidance of doubt, the exported interface is the supported
;;; interface. Anything else is internal, though you're welcome to argue a
;;; case for exporting it.

;;; If you steal the code from this file to cut and paste into your
;;; own project, there will be much wailing and gnashing of teeth.
;;; Your teeth.  If need be, we'll kick them for you.  This is a
;;; contrib, we're allowed to look in internals.  You're an
;;; application programmer and are not.

;;; TODO
;;; 3) error handling.  Signal random errors, or handle and resignal 'our'
;;;   error, or return NIL?
;;; 4) FIXMEs

(defpackage :sb-introspect
  (:use "CL" "SB-KERNEL" "SB-INT")
  (:import-from "SB-VM" "PRIMITIVE-OBJECT-SIZE")
  (:shadow "VALID-FUNCTION-NAME-P")
  (:export "ALLOCATION-INFORMATION"
           "FUNCTION-ARGLIST"
           "FUNCTION-LAMBDA-LIST"
           "FUNCTION-TYPE"
           "METHOD-COMBINATION-LAMBDA-LIST"
           "DEFTYPE-LAMBDA-LIST"
           "VALID-FUNCTION-NAME-P"
           "FIND-DEFINITION-SOURCE"
           "FIND-DEFINITION-SOURCES-BY-NAME"
           "DEFINITION-SOURCE"
           "DEFINITION-SOURCE-PATHNAME"
           "DEFINITION-SOURCE-FORM-PATH"
           "DEFINITION-SOURCE-FORM-NUMBER"
           "DEFINITION-SOURCE-CHARACTER-OFFSET"
           "DEFINITION-SOURCE-FILE-WRITE-DATE"
           "DEFINITION-SOURCE-PLIST"
           "FIND-FUNCTION-CALLEES"
           "FIND-FUNCTION-CALLERS"
           "MAP-ROOT"
           "WHO-BINDS"
           "WHO-CALLS"
           "WHO-REFERENCES"
           "WHO-SETS"
           "WHO-MACROEXPANDS"
           "WHO-SPECIALIZES-DIRECTLY"
           "WHO-SPECIALIZES-GENERALLY"))

(in-package :sb-introspect)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (system-package-p *package*) t))

;;;; Internal interface for SBCL debug info

;;; Here are some tutorial-style type definitions to help understand
;;; the internal SBCL debugging data structures we're using. The
;;; commentary is based on CMUCL's debug internals manual.
;;;
(deftype debug-info ()
  "Structure containing all the debug information related to a function.
Function objects reference debug-infos, which in turn reference
debug-sources and so on."
  'sb-c::compiled-debug-info)

(deftype debug-source ()
  "Debug sources describe where to find source code.
For example, the debug source for a function compiled from a file will
include the pathname of the file and the position of the definition."
  'sb-c::debug-source)

(declaim (ftype (sfunction (function) debug-info) function-debug-info))
(defun function-debug-info (function)
  (let* ((function-object (%fun-fun function))
         (function-header (fun-code-header function-object)))
    (%code-debug-info function-header)))

(declaim (ftype (sfunction (function) debug-source) function-debug-source))
(defun function-debug-source (function)
  (debug-info-source (function-debug-info function)))

(declaim (ftype (sfunction (debug-info) debug-source) debug-info-source))
(defun debug-info-source (debug-info)
  (sb-c::debug-info-source debug-info))

(defun valid-function-name-p (name)
  "See if NAME is a valid function name. In addition to the ANSI
definition of function name, which is symbols plus lists like (SETF
SYMBOL), SBCL allows (SB-EXT:CAS SYMBOL) and various internal
constructs."
  (and (sb-int:valid-function-name-p name) t))

;;;; Utilities for code

(declaim (inline map-code-constants))
(defun map-code-constants (code fn)
  "Call FN for each constant in CODE's constant pool."
  (check-type code code-component)
  (loop for i from sb-vm:code-constants-offset below (code-header-words code)
     do (funcall fn (code-header-ref code i))))

(declaim (inline map-allocated-code-components))
(defun map-allocated-code-components (spaces fn)
  "Call FN for each allocated code component in one of SPACES.  FN
receives the object and its size as arguments. SPACES should be a list
of the symbols :DYNAMIC, :STATIC, :READ-ONLY, or :IMMOBILE on
#+IMMOBILE-SPACE. The shorthand (:ALL) is also accepted."
  (apply #'sb-vm:map-allocated-objects
     (lambda (obj header size)
       (when (= sb-vm:code-header-widetag header)
         (funcall fn obj size)))
     spaces))

(declaim (inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
  "Call FN for each code component with a FDEFN for FUNCTION in its
constant pool."
  (let ((function (coerce function 'function)))
    (map-allocated-code-components
     spaces
     (lambda (obj size)
       (declare (ignore size))
       ;; There are no constants for linkage-space calls. Not only that,
       ;; but certain linkage entry refs get elided because it is not
       ;; required for liveness from a GC perspective.
       #+linkage-space
       (dolist (index (sb-c:unpack-code-fixup-locs (sb-vm::%code-fixups obj)))
         (let ((ep (sb-sys:sap-ref-word
                    (sb-alien:extern-alien "linkage_space" sb-sys:system-area-pointer)
                    (ash index sb-vm:word-shift))))
           (when (eq (sb-kernel:%make-lisp-obj (+ ep -16 sb-vm:fun-pointer-lowtag)) function)
             (funcall fn obj))))
       #-linkage-space
       (map-code-constants
        obj
        (lambda (constant)
          (when (and (fdefn-p constant)
                     (eq (fdefn-fun constant) function))
            (funcall fn obj))))))))

;;;; Finding definitions

(defmacro defstruct* (name-and-options &rest slot-descriptions)
  "Like DEFSTRUCT, but support :DOCUMENTATION among slot options.
The documentation is attached to the slot's STRUCTURE-ACCESSOR.
Example:

    (defstruct* my-struct
      (my-slot nil :documentation \"docstring\"))

In addition to the normal DEFSTRUCT processing, the above also does
the moral equivalent of

    (setf (documentation 'my-struct-my-slot 'function) \"docstring\")"
  (destructuring-bind (name &rest options)
      (sb-c::ensure-list name-and-options)
    (let* ((conc-name-option (find :conc-name options :key (lambda (x)
                                                             (if (consp x)
                                                                 (car x)
                                                                 x))))
           (conc-name (cond ((not conc-name-option)
                             (format nil "~A-" name))
                            ((or (atom conc-name-option)
                                 (null (cdr conc-name-option))
                                 (null (second conc-name-option)))
                             "")
                            (t
                             (string (second conc-name-option)))))
           (not-found (gensym))
           (set-doc-forms ())
           (new-sds
             (loop
               for sd in slot-descriptions
               collect (let ((documentation
                               (and (listp sd)
                                    (getf (cddr sd) :documentation not-found))))
                         (cond
                           ((or (not (listp sd))
                                (eq documentation not-found))
                            sd)
                           (t
                            (let ((accessor-name (intern
                                                  (format nil "~A~A" conc-name
                                                          (first sd)))))
                              (push `(setf (documentation ',accessor-name
                                                          'function)
                                           ,documentation)
                                    set-doc-forms))
                            (let ((sd (copy-seq sd)))
                              (remf (cddr sd) :documentation)
                              sd)))))))
      `(progn
         (defstruct ,name-and-options
           ,@new-sds)
         ,@set-doc-forms))))

;;; FIXME: Rename this
(defstruct* definition-source
  "This structure identifies a sexp in a compiled file.
Despite the name, the source location may not correspond to a
definition but to e.g. a function call (see WHO-CALLS)."
  (pathname
   nil :type (or null pathname)
   :documentation "Pathname of the source file.
This is NIL if the source location is not in a compiled file.")
  (form-path
   '() :type list
   :documentation "List of indices that identify the sexp in the
file given by DEFINITION-SOURCE-PATHNAME. The first element in the
list is the index of the top-level form that contains the sexp. If the
file was compiled at a high enough debug level, then the rest of the
elements recursively index into the list structure of the top-level
form.

Thus, the form path is somewhat stable regarding edits in the file,
but it gets invalidated by, for example, inserting a new top-level
form before the sexp in question.")
  (form-number
   nil :type (or null unsigned-byte)
   :documentation "Depth-first index of the sexp within the top-level
form identified by the first element of DEFINITION-SOURCE-FORM-PATH.
That is, this is the index of the sexp in the list of subexpressions
of the top-level form ordered according to depth-first traversal. 0
corresponds to the top-level form itself.

When combined with the index of the top-level form (given by the first
element of DEFINITION-SOURCE-FORM-PATH), the form number allows
reconstruction of the rest of the form path, which may be missing.
This requires parsing the source file. Currently, this job is
delegated to e.g. SLIME.")
  (character-offset
   nil :type (or null unsigned-byte)
   :documentation "Character offset of the top-level form containing
the sexp.")
  (file-write-date
   nil :type (or null unsigned-byte)
   :documentation "FILE-WRITE-DATE of DEFINITION-SOURCE-PATHNAME at
the time of compilation. NIL if not compiled from a file.")
  (plist
   nil
   :documentation "The `SOURCE-PLIST` from WITH-COMPILATION-UNIT in effect
when the file was compiled.")
  ;; Any extra metadata that the caller might be interested in. For
  ;; example, DEFINITION-SOURCE of a method contains the specializers
  ;; of the method to help disambiguate it.
  ;;
  ;; FIXME: This is currently unexported, but it is also necessary to
  ;; disambiguate methods. See e.g. WHO-SPECIALIZES-DIRECTLY.
  (description nil :type list))

(defun vops-translating-fun (name)
  (let ((fun-info (info :function :info name)))
    (when fun-info
      (sb-c::fun-info-templates fun-info))))

(defun find-vop-source (name)
  (let* ((vop (gethash name sb-c::*backend-parsed-vops*))
         (translating (vops-translating-fun name))
         (vops (if vop
                   (cons vop (remove vop translating))
                   translating)))
    (loop for vop in vops
          for vop-parse = (if (typep vop 'sb-c::vop-parse)
                              vop
                              (gethash (sb-c::vop-info-name vop)
                                       sb-c::*backend-parsed-vops*))
          for name = (and vop-parse
                          (sb-c::vop-parse-name vop-parse))
          for loc = (and vop-parse
                         (sb-c::vop-parse-source-location vop-parse))
          when loc
          collect (let ((source (translate-source-location loc)))
                    (setf (definition-source-description source)
                          (if (sb-c::vop-parse-note vop-parse)
                              (list name (sb-c::vop-parse-note vop-parse))
                              (list name)))
                    source))))

(defun find-definition-sources-by-name (name type)
  "Returns a list of DEFINITION-SOURCEs for definitions of NAME with
the given definition TYPE. A DEFINITION-SOURCE object is always
returned for definitions that exist, but the source location (e.g.
DEFINITION-SOURCE-PATHNAME) may be missing. TYPE can currently be one
of the following.

- Public definition types:

    :CLASS
    :COMPILER-MACRO
    :CONDITION
    :CONSTANT
    :FUNCTION
    :GENERIC-FUNCTION
    :MACRO
    :METHOD
    :METHOD-COMBINATION
    :PACKAGE
    :SETF-EXPANDER
    :STRUCTURE
    :SYMBOL-MACRO
    :TYPE
    :ALIEN-TYPE
    :ALIEN-CALLBACK
    :VARIABLE
    :DECLARATION

- Internal definition types:

    :OPTIMIZER
    :SOURCE-TRANSFORM
    :TRANSFORM
    :VOP
    :IR1-CONVERT

Definition types are disjoint. For example, :TYPE refers to DEFTYPEs
but not CLASSes or SB-ALIEN:DEFINE-ALIEN-TYPE, as those are of
definition type :CLASS and :ALIEN-TYPE, respectively. :FUNCTION does
not include :GENERIC-FUNCTION, :CLASS does not include :STRUCTURE,
etc. :VARIABLE refers to non-constant dynamic variables (e.g. those
defined with DEFVAR, DEFPARAMETER, SB-EXT:DEFGLOBAL or
SB-ALIEN:DEFINE-ALIEN-VARIABLE but not with DEFCONSTANT).

Valid NAMEs are generally SYMBOLs with the following exceptions:

- For :COMPILER-MACRO, :FUNCTION, :GENERIC-FUNCTION and :METHOD,
  anything that's VALID-FUNCTION-NAME-P is valid.

- For :PACKAGE, string designators are valid.

If an unsupported TYPE is requested or NAME is invalid, this function
returns NIL."
  (flet ((get-class (name)
           (and (symbolp name)
                (find-class name nil)))
         (real-fdefinition (name)
           (sb-ext:unencapsulated-function name)))
    (ensure-list
     (case type
       ((:variable)
        (when (and (symbolp name)
                   (member (info :variable :kind name)
                           '(:global :special :alien)))
          (translate-source-location (info :source-location type name))))
       ((:constant)
        (when (and (symbolp name)
                   (eq (info :variable :kind name) :constant))
          (translate-source-location (info :source-location type name))))
       ((:symbol-macro)
        (when (and (symbolp name)
                   (eq (info :variable :kind name) :macro))
          (translate-source-location (info :source-location type name))))
       ((:macro)
        (when (and (symbolp name)
                   (macro-function name))
          (find-definition-source (macro-function name))))
       ((:compiler-macro)
        (when (and (valid-function-name-p name)
                   (compiler-macro-function name))
          (find-definition-source (compiler-macro-function name))))
       (:ir1-convert
        (let ((converter (info :function :ir1-convert name)))
          (and converter
               (find-definition-source converter))))
       ((:function :generic-function)
        (when (valid-function-name-p name)
          (if (fboundp name)
              (when (and (or (consp name)
                             (and
                              (not (macro-function name))
                              (not (special-operator-p name)))))
                (let ((fun (real-fdefinition name)))
                  (when (eq (not (typep fun 'generic-function))
                            (not (eq type :generic-function)))
                    (find-definition-source fun))))
              (let ((dd (info :function :source-transform name)))
                (when (typep dd '(cons defstruct-description))
                  (find-definition-sources-by-name (dd-name (car dd))
                                                   :structure))))))
       ((:type)
        ;; Source locations for types are saved separately when the expander
        ;; is a closure without a good source-location.
        (let ((loc (info :type :source-location name)))
          (if loc
              (translate-source-location loc)
              (let ((expander-fun (info :type :expander name)))
                (when (functionp expander-fun)
                  (find-definition-source expander-fun))))))
       ((:method)
        (when (and (valid-function-name-p name) (fboundp name))
          (let ((fun (real-fdefinition name)))
            (when (typep fun 'generic-function)
              (loop for method in (sb-mop::generic-function-methods
                                   fun)
                    for source = (find-definition-source method)
                    when source collect source)))))
       ((:setf-expander)
        (when (and (consp name)
                   (eq (car name) 'setf))
          (setf name (cadr name)))
        (let ((expander (info :setf :expander name)))
          (cond ((typep expander '(cons symbol))
                 (translate-source-location (cddr expander)))
                (expander
                 (find-definition-source
                  (if (listp expander) (cdr expander) expander))))))
       ((:structure)
        (let ((class (get-class name)))
          (if class
              (when (typep class 'sb-pcl::structure-class)
                (find-definition-source class))
              (when (info :typed-structure :info name)
                (translate-source-location
                 (info :source-location :typed-structure name))))))
       ((:condition :class)
        (let ((class (get-class name)))
          (when (and class
                     (not (typep class 'sb-pcl::structure-class)))
            (when (eq (not (typep class 'sb-pcl::condition-class))
                      (not (eq type :condition)))
              (find-definition-source class)))))
       ((:method-combination)
        (let ((info (gethash name sb-pcl::**method-combinations**)))
          (when info
            (translate-source-location
             (sb-pcl::method-combination-info-source-location info)))))
       ((:package)
        (let ((package (ignore-errors (find-package name))))
          (when package
            (find-definition-source package))))
       ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
       ((:transform)
        (let ((fun-info (info :function :info name)))
          (when fun-info
            (loop for xform in (sb-c::fun-info-transforms fun-info)
                  for source = (find-definition-source
                                (sb-c::transform-function xform))
                  for typespec = (type-specifier
                                  (sb-c::transform-type xform))
                  for note = (sb-c::transform-note xform)
                  do (setf (definition-source-description source)
                           (if (consp typespec)
                               (if (eq (third typespec) '*)
                                   (list (second typespec) note)
                                   (list (second typespec) (third typespec) note))
                               (list note)))
                  collect source))))
       ((:optimizer)
        (let ((fun-info (and (symbolp name)
                             (info :function :info name))))
          (when fun-info
            (let ((otypes '((sb-c:fun-info-derive-type . sb-c:derive-type)
                            (sb-c:fun-info-ltn-annotate . sb-c:ltn-annotate)
                            (sb-c:fun-info-optimizer . sb-c:optimizer)
                            (sb-c:fun-info-ir2-convert . sb-c:ir2-convert)
                            (sb-c::fun-info-ir2-hook . sb-c::ir2-hook)
                            (sb-c::fun-info-stack-allocate-result . sb-c::stack-allocate-result)
                            (sb-c::fun-info-constraint-propagate . sb-c::constraint-propagate)
                            (sb-c::fun-info-constraint-propagate-if . sb-c::constraint-propagate-if)
                            (sb-c::fun-info-constraint-propagate-back . sb-c::constraint-propagate-back)
                            (sb-c::fun-info-constraint-propagate-result . sb-c::constraint-propagate-result)
                            (sb-c::fun-info-equality-constraint . sb-c::equality-constraint)
                            (sb-c::fun-info-folder . sb-c::folder)
                            (sb-c::fun-info-externally-checkable-type . sb-c::externally-checkable-type)
                            (sb-c::fun-info-constants . sb-c::constants)
                            (sb-c::fun-info-call-type-deriver . sb-c::call-type-deriver)
                            (sb-c::fun-info-rewrite-full-call . sb-c::rewrite-full-call)
                            (sb-c::fun-info-fold-p . sb-c::fold-p)
                            (sb-c::fun-info-flushable . sb-c::flushable))))
              (loop for (reader . name) in otypes
                    for fn = (funcall reader fun-info)
                    when (functionp fn)
                      collect (let ((source (find-definition-source fn)))
                                (setf (definition-source-description source)
                                      (list name))
                                source))))))
       (:vop
        (find-vop-source name))
       (:alien-type
        (let ((loc (info :source-location type name)))
          (and loc
               (translate-source-location loc))))
       (:alien-callback
        (let ((cb (gethash name sb-alien::*alien-callables*)))
          (when cb
            (let ((index (sb-alien::alien-callback-index cb)))
              (when (and index
                         (array-in-bounds-p sb-alien::*alien-callback-functions* index))
                (find-definition-source (aref sb-alien::*alien-callback-functions* index)))))))
       ((:source-transform)
        (let* ((transform-fun
                 (or (info :function :source-transform name)
                     (and (typep name '(cons (eql setf) (cons symbol null)))
                          (info :function :source-transform
                                (second name)))))
               ;; A cons for the :source-transform is essentially the same
               ;; info that was formerly in :structure-accessor.
               (accessor (and (consp transform-fun) (cdr transform-fun))))
          ;; Structure accessors have source transforms, but the
          ;; returned locations will neither show the actual place
          ;; where it's defined, nor is really interesting.
          (when (and transform-fun
                     (not accessor))
            (find-definition-source transform-fun))))
       (:declaration
        (let ((locations (info :source-location :declaration name)))
          (loop for (kind loc) on locations by #'cddr
                when loc
                  collect (let ((loc (translate-source-location loc)))
                            (setf (definition-source-description loc)
                                  ;; Copy list to ensure that user code
                                  ;; cannot mutate the original.
                                  (copy-list (ensure-list kind)))
                            loc))))
       (t
        nil)))))

(defun find-definition-source (object)
  "Return the DEFINITION-SOURCE corresponding to the definition of OBJECT
or NIL if there is no corresponding definition. OBJECT must be a
PACKAGE, FUNCTION, METHOD, METHOD-COMBINATION, SB-MOP:SLOT-DEFINITION,
STANDARD-OBJECT, STRUCTURE-OBJECT, CONDITION, CLASS, STRUCTURE-CLASS,
or a subclass of CONDITION. An error is signalled for other types.

A DEFINITION-SOURCE object is always returned for definitions that
exist, but the source location (e.g. DEFINITION-SOURCE-PATHNAME) may
be missing.

For definitions that do not define an object (e.g. DEFVAR), use
FIND-DEFINITION-SOURCES-BY-NAME."
  (typecase object
    ((or sb-pcl::condition-class sb-pcl::structure-class)
     (let ((classoid (sb-pcl::class-classoid object)))
       (when classoid
         (translate-source-location
          (sb-kernel::classoid-source-location classoid)))))
    (method-combination
     (car
      (find-definition-sources-by-name
       (sb-pcl::method-combination-type-name object) :method-combination)))
    (package
     (translate-source-location (sb-impl::package-source-location object)))
    ((or class sb-mop:slot-definition)
     (translate-source-location (sb-pcl::definition-source object)))
    ;; Use the PCL definition location information instead of the function
    ;; debug-info for methods and generic functions. Sometimes the
    ;; debug-info would point into PCL internals instead of the proper
    ;; location.
    (generic-function
     (let ((source (translate-source-location
                    (sb-pcl::definition-source object))))
       (when source
         (setf (definition-source-description source)
               (list (sb-mop:generic-function-lambda-list object))))
       source))
    (method
     (let ((source (translate-source-location
                    (sb-pcl::definition-source object))))
       (when source
         (setf (definition-source-description source)
               (append (method-qualifiers object)
                       (if (sb-mop:method-generic-function object)
                           (sb-pcl::unparse-specializers
                            (sb-mop:method-generic-function object)
                            (sb-mop:method-specializers object))
                           (sb-mop:method-specializers object)))))
       source))
    (interpreted-function
     #+sb-eval
     (let ((source (translate-source-location
                    (sb-eval:interpreted-function-source-location object))))
       source)
     #+sb-fasteval
     (translate-source-location (sb-interpreter:fun-source-location object)))
    (function
     (find-function-definition-source object))
    ((or condition standard-object structure-object)
     (find-definition-source (class-of object)))
    (t
     (error "Don't know how to retrieve source location for a ~S"
            (type-of object)))))

(defun find-function-definition-source (function)
  (let* ((debug-source (debug-info-source (function-debug-info function)))
         (debug-fun (sb-di::fun-debug-fun function))
         (tlf (sb-c::compiled-debug-fun-tlf-number
               (sb-di::compiled-debug-fun-compiler-debug-fun debug-fun))))
    (make-definition-source
     :pathname
     (when (stringp (sb-c::debug-source-namestring debug-source))
       (parse-namestring (sb-c::debug-source-namestring debug-source)))
     :character-offset
     (if tlf
         (elt (sb-c::debug-source-start-positions debug-source) tlf))
     :form-path (if tlf (list tlf))
     :form-number (handler-case (sb-di::code-location-form-number
                                 (sb-di::debug-fun-start-location debug-fun))
                    (sb-di::unknown-code-location (cond)
                      (declare (ignore cond))
                      (sb-c::compiled-debug-fun-blocks
                       (sb-di::compiled-debug-fun-compiler-debug-fun debug-fun))))
     :file-write-date (sb-c::debug-source-created debug-source)
     :plist (sb-c::debug-source-plist debug-source))))

(defun translate-source-location (location)
  (if location
      (make-definition-source
       :pathname (let ((n (sb-c:definition-source-location-namestring location)))
                   (when n
                     (parse-namestring n)))
       :form-path
       (let ((number (sb-c:definition-source-location-toplevel-form-number
                         location)))
         (when number
           (list number)))
       :form-number (sb-c:definition-source-location-form-number
                     location)
       :plist (sb-c:definition-source-location-plist location))
      (make-definition-source)))

(define-deprecated-function :late "1.0.24.5" function-arglist function-lambda-list
    (function)
  (function-lambda-list function))

(defun function-lambda-list (function)
  "Return the lambda list of FUNCTION.
FUNCTION must be a function object or a function name in the sense of
VALID-FUNCTION-NAME-P. Works for special operators, macros, simple
functions, interpreted functions, and generic functions.

The second return value indicates whether the lambda list could not be
determined (e.g. because the function was compiled with DEBUG 0)."
  (cond ((and (symbolp function) (special-operator-p function))
         (function-lambda-list (info :function :ir1-convert function)))
        ((valid-function-name-p function)
         (function-lambda-list (or (and (symbolp function)
                                        (macro-function function))
                                   (fdefinition function))))
        ((typep function 'generic-function)
         (sb-pcl::generic-function-pretty-arglist function))
        (t
         (let ((raw-result (%fun-lambda-list (sb-ext:unencapsulated-function function))))
           (if (eq raw-result :unknown)
               (values nil t)
               (values raw-result nil))))))

(defun deftype-lambda-list (type-specifier-name)
  "Returns the lambda list of TYPE-SPECIFIER-NAME as the first return
value, and a flag whether the arglist could be found as the second
value.

TYPE-SPECIFIER-NAME must be a symbol. This function can find the
lambda list of derived type specifiers (e.g. those defined with
DEFTYPE) and classes with compound type specifier syntaxes (e.g. the
class FLOAT). It returns NIL, NIL for other type specifiers (e.g. AND,
OR, NOT) and types (e.g. LIST)."
  (check-type type-specifier-name symbol)
  (let* ((f (and (info :type :kind type-specifier-name)
                 (info :type :expander type-specifier-name)))
         (f (if (listp f) (car f) f)))
    (if (functionp f)
        (let ((lambda-list (%fun-lambda-list f)))
          (if (eq lambda-list :unknown)
              (values nil nil)
              (values lambda-list t)))
        (values nil nil))))

(defun method-combination-lambda-list (method-combination)
  "Return the lambda list of the METHOD-COMBINATION designator.
METHOD-COMBINATION can be a method combination object,
or a method combination name."
  (let* ((name (etypecase method-combination
                 (symbol method-combination)
                 (method-combination
                  (sb-pcl::method-combination-type-name method-combination))))
         (info (or (gethash name sb-pcl::**method-combinations**)
                   (error "~S: no such method combination." name))))
    (sb-pcl::method-combination-info-lambda-list info)))

(defun function-type (function-designator)
  "Returns the ftype of FUNCTION-DESIGNATOR or NIL."
  (etypecase function-designator
    ((or symbol cons)
     ;; XXX: why require FBOUNDP? Would it be wrong to always report the proclaimed type?
     (when (and (legal-fun-name-p function-designator) ; guarding FBOUNDP against error
                (fboundp function-designator)
                (eq (info :function :kind function-designator) :function))
       (type-specifier (global-ftype function-designator))))
    (function
     (let ((name (%fun-name function-designator)))
       (if (and (legal-fun-name-p name)
                (fboundp name)
                ;; It seems inappropriate to report the global ftype if this
                ;; function is not the current binding of the global name,
                (eq (fdefinition name) function-designator))
           ;; Give declared type in globaldb priority over derived type
           ;; because it contains more accurate information e.g. for
           ;; struct-accessors.
           (function-type name)
           (sb-impl::%fun-ftype function-designator))))))

;;;; find callers/callees, liberated from Helmut Eller's code in SLIME

;;; This interface is tremendously experimental.

;;; For the moment I'm taking the view that FDEFN is an internal
;;; object (one out of one CMUCL developer surveyed didn't know what
;;; they were for), so these routines deal in FUNCTIONs

;;; Find callers and callees by looking at the constant pool of
;;; compiled code objects.  We assume every fdefn object in the
;;; constant pool corresponds to a call to that function.  A better
;;; strategy would be to use the disassembler to find actual
;;; call-sites.

;; FIXME[1]: this is quite clearly intended to do just about the same thing
;;           as CTU:FIND-NAMED-CALLEES yet the two are unnecessarily different.
;; FIXME[2]: for at least #+linkage-space we should disassemble FUNCTION
;;           because the stored linkage indices underestimate the answer.
;;           The gain from doing it right is that code constants overestimate
;;           especially if >1 simple-fun is present in the code.
(defun find-function-callees (function)
  "Return functions called by FUNCTION."
  (if (typep function 'generic-function)
      (loop for method in (sb-mop:generic-function-methods function)
            for method-fun = (sb-mop:method-function method)
            append (find-function-callees
                    (if (typep (%fun-name method-fun) '(cons (eql sb-pcl::call)))
                        (sb-kernel:%closure-index-ref  method-fun 0)
                        method-fun)))
      (let ((callees '()))
        #+linkage-space
        (dolist (index (sb-c:unpack-code-fixup-locs
                        (sb-vm::%code-fixups (fun-code-header (sb-kernel:%fun-fun function)))))
          (let ((name (sb-vm::linkage-addr->name index :index)))
            (when (fboundp name)
              (push (fdefinition name) callees))))
        #-linkage-space
        (map-code-constants
         (fun-code-header (sb-kernel:%fun-fun function))
         (lambda (obj)
           (when (fdefn-p obj)
             (let ((fun (fdefn-fun obj)))
               (when fun
                 (push fun callees))))))
        callees)))

(defun find-function-callers (function &optional (spaces '(:all)))
  "List functions that call FUNCTION by searching SPACES for code objects.
This can make previously garbage objects live.

SPACES should be a list of the symbols :DYNAMIC, :STATIC, :READ-ONLY,
or :IMMOBILE on #+IMMOBILE-SPACE. The shorthand (:ALL) is also
accepted."
  (let ((referrers '()))
    (map-caller-code-components
     function
     spaces
     (lambda (code)
       (dotimes (i (code-n-entries code))
         (pushnew (%code-entry-point code i) referrers))))
    referrers))

;;; XREF facility

#-(and system-tlabs (not mark-region-gc))
(progn
  (labels ((functoid-simple-fun (functoid)
             ;; looks like this is supposed to ignore INTERPRETED-FUNCTION ?
             (typecase functoid
               (simple-fun functoid)
               (closure
                (let ((fun (%closure-fun functoid)))
                  (if (and (eq (%fun-name fun) 'sb-impl::encapsulation))
                      (functoid-simple-fun
                       (sb-impl::encapsulation-info-definition
                        (sb-impl::encapsulation-info functoid)))
                      fun))))))
    (defun map-simple-funs (function)
      (let ((function (%coerce-callable-to-fun function)))
        (labels ((process (name value)
                   (awhen (functoid-simple-fun value)
                     (funcall function name it))))
          (call-with-each-globaldb-name
           (lambda (name)
             ;; Methods are processed with their generic function
             (unless (typep name '(cons (member sb-pcl::slow-method sb-pcl::fast-method)))
               (let ((f (or (and (symbolp name) (macro-function name))
                            (and (legal-fun-name-p name) (fboundp name)))))
                 (typecase f
                   (generic-function
                    (loop for method in (sb-mop:generic-function-methods f)
                          for fun = (sb-pcl::safe-method-fast-function method)
                          when fun do (process (sb-kernel:%fun-name fun) fun)))
                   (function
                    (process name f)))))
             #+sb-xref-for-internals
             (let ((info (info :function :info name)))
               (when info
                 (loop for transform in (sb-c::fun-info-transforms info)
                       for fun = (sb-c::transform-function transform)
                       ;; Defined using :defun-only and a later %deftransform.
                       unless (symbolp fun)
                       do (process transform fun))))))
          #+sb-xref-for-internals
          (sb-int:dohash ((name vop) sb-c::*backend-template-names*)
            (declare (ignore name))
            (let ((fun (sb-c::vop-info-generator-function vop)))
              (when fun
                (process vop fun))))))))
  (defun collect-xref (wanted-kind wanted-name)
    (let ((result '()))
      (map-simple-funs
       (lambda (name fun)
         (binding* ((xrefs (%simple-fun-xrefs fun) :exit-if-null))
           (sb-c:map-packed-xref-data
            (lambda (xref-kind xref-name xref-form-number)
              (when (and (eq xref-kind wanted-kind)
                         (equal xref-name wanted-name))
                (let ((source-location (find-function-definition-source fun)))
                  ;; Use the more accurate source path from the xref
                  ;; entry.
                  (setf (definition-source-form-number source-location)
                        xref-form-number)
                  (let ((name (typecase name
                                (sb-c::transform
                                 (let ((fun-name (%fun-name fun)))
                                   (append (if (consp fun-name)
                                               fun-name
                                               (list fun-name))
                                           (let* ((type (sb-c::transform-type name))
                                                  (type-spec (type-specifier type)))
                                             (and (sb-kernel:fun-type-p type)
                                                  (list (second type-spec)))))))
                                (sb-c::vop-info
                                 (list 'sb-c:define-vop
                                       (sb-c::vop-info-name name)))
                                (t
                                 name))))
                    (push (cons name source-location) result)))))
            xrefs))))
      result)))

#+(and system-tlabs (not mark-region-gc))
(progn
(sb-ext:defglobal *codeblob-cache* nil)
(flet ((gather-code (stamp) ; = the value of sb-vm::*code-alloc-count*
         ;; Remove unreachable functions.
         (sb-ext:gc :full t)
         (let ((arena (sb-vm:new-arena (* 2 1024 1024)))
               (result))
           ;; Can allocate inside an arena while holding without-gcing in sb-vm:map-code-objects
           ;; Anyway this approach is silly because Lisp should maintain at all times
           ;; a binary-searchable tree of all code which would solve all problems
           ;; related to finding a codeblob from a PC without relying on whatever
           ;; a particular GC implementation exposes in terms of linearly searchable
           ;; ranges of memory. immobile-space does maintain such a tree. Of course the tree
           ;; should also _weakly_ reference all code, and should be usable for xref
           ;; and other consumers beside the debugger. And it should come with a pony too.
           (unwind-protect
                (sb-vm:with-arena (arena)
                  ;; No filtering since we want this to pertain to all COLLECT-XREFS calls
                  (sb-vm:map-code-objects (lambda (code) (push code result))))
             ;; arenas are not suitable for returning memoized data
             (setq result (coerce result 'vector))
             (sb-vm:destroy-arena arena))
           (setf *codeblob-cache* (cons stamp (sb-ext:make-weak-pointer result)))
           result)))
(defun collect-xref (wanted-kind wanted-name)
  (let* ((current-stamp sb-vm::*code-alloc-count*)
         (all-code
          ;; this is not an attempt to be 100% correct in observing an up-to-date
          ;; snapshot at a point in time.  It's close enough though.
          ;; I can't imagine that users are clamoring for a perfect solution to
          ;; racing threads and XREFing jit-compiled code.
          (or (let ((cache *codeblob-cache*))
                (and (eql (car cache) current-stamp)
                     (sb-ext:weak-pointer-value (cdr cache))))
              (loop ; expect exactly 1 iteration
               (let ((vector (gather-code current-stamp))
                     (new-stamp sb-vm::*code-alloc-count*))
                 (if (eq new-stamp current-stamp) ; say it's done
                     (return vector)
                     (setq current-stamp new-stamp))))))
         (funs))
    (dovector (code all-code)
      (dotimes (i (code-n-entries code))
        (let ((fun (%code-entry-point code i)))
          (binding* ((xrefs (%simple-fun-xrefs fun) :exit-if-null))
            (sb-c:map-packed-xref-data
             (lambda (xref-kind xref-name xref-form-number)
               (when (and (eq xref-kind wanted-kind)
                          (equal xref-name wanted-name))
                 (push (cons fun xref-form-number) funs)))
             xrefs)))))
    (let (result)
      (loop for (fun . xref-form-number) in funs
            do
            (let ((source-location (find-function-definition-source fun)))
              ;; Use the more accurate source path from the xref
              ;; entry.
              (setf (definition-source-form-number source-location) xref-form-number)
              (let* ((name (sb-c::%fun-name fun))
                     (name (cond ((typep name '(cons (eql sb-c:deftransform)))
                                  (let* ((fun-name (second name))
                                         (info (sb-int:info :function :info fun-name))
                                         (transform (and info
                                                         (find fun (sb-c::fun-info-transforms info)
                                                               :key #'sb-c::transform-function))))
                                    (if transform
                                        (append name
                                                (let* ((type (sb-c::transform-type transform))
                                                       (type-spec (type-specifier type)))
                                                  (and (sb-kernel:fun-type-p type)
                                                       (list (second type-spec)))))
                                        name)))
                                 (t
                                  name))))
                (pushnew (cons name source-location) result :test #'equalp))))
      result)))))

(defun who-calls (function-name)
  "Find the source locations where the global function FUNCTION-NAME is
called, and return them as an alist of function or macro name,
DEFINITION-SOURCE pairs."
  (collect-xref :calls function-name))

(defun who-binds (symbol)
  "Find the source locations where the special variable SYMBOL is bound,
and return them as an alist of function or macro name,
DEFINITION-SOURCE pairs."
  (collect-xref :binds symbol))

(defun who-references (symbol)
  "Find the source locations where the special variable SYMBOL is read,
and return them as an alist of function or macro name,
DEFINITION-SOURCE pairs."
  (collect-xref :references symbol))

(defun who-sets (symbol)
  "Find the source locations where the special variable SYMBOL is set,
and return them as an alist of function or macro name,
DEFINITION-SOURCE pairs."
  (collect-xref :sets symbol))

(defun who-macroexpands (macro-name)
  "Find the source locations where the macro MACRO-NAME is expanded, and
return them as an alist of function or macro name, DEFINITION-SOURCE
pairs."
  (collect-xref :macroexpands macro-name))

(defun who-specializes-directly (class-designator)
  "Find the source locations of methods directly specializing on
CLASS-DESIGNATOR, and return them as an alist of generic function
name, DEFINITION-SOURCE pairs.

A method matches the criterion either if it specializes on the same
class as CLASS-DESIGNATOR designates, or if it eql-specializes on an
instance of the designated class.

Experimental."
  (let ((class (canonicalize-class-designator class-designator)))
    (unless class
      (return-from who-specializes-directly nil))
    (let ((result (collect-specializing-methods
                   #'(lambda (specl)
                       ;; Does SPECL specialize on CLASS directly?
                       (typecase specl
                         (sb-pcl::class-eq-specializer
                          (eq (sb-pcl::specializer-object specl) class))
                         (sb-pcl::eql-specializer
                          (let ((obj (sb-mop:eql-specializer-object specl)))
                            (eq (class-of obj) class)))
                         ((not sb-pcl::standard-specializer)
                          nil)
                         (t
                          (eq specl class)))))))
      (map-into result #'(lambda (m)
                           (cons `(method ,(method-generic-function-name m))
                                 (find-definition-source m)))
                result))))

(defun who-specializes-generally (class-designator)
  "Find the source locations of methods specializing on
CLASS-DESIGNATOR or a subclass of it, and return them as an alist of
generic function name, DEFINITION-SOURCE pairs.
DEFINITION-SOURCE-DESCRIPTION identifies the method.

A method matches the criterion either if it specializes on the
designated class itself or a subclass of it (this includes CLASS-EQ
specializers), or if it eql-specializes on an instance of the
designated class or a subclass of it.

Experimental."
  (let ((class (canonicalize-class-designator class-designator)))
    (unless class
      (return-from who-specializes-generally nil))
    (let ((result (collect-specializing-methods
                   #'(lambda (specl)
                       ;; Does SPECL specialize on CLASS or a subclass
                       ;; of it?
                       (typecase specl
                         (sb-pcl::class-eq-specializer
                          (subtypep (sb-pcl::specializer-object specl) class))
                         (sb-pcl::eql-specializer
                          (typep (sb-mop:eql-specializer-object specl) class))
                         ((not sb-pcl::standard-specializer)
                          nil)
                         (t
                          (subtypep specl class)))))))
      (map-into result #'(lambda (m)
                           (cons `(method ,(method-generic-function-name m))
                                 (find-definition-source m)))
                result))))

(defun canonicalize-class-designator (class-designator)
  (typecase class-designator
    (symbol (find-class class-designator nil))
    (class  class-designator)
    (t nil)))

(defun method-generic-function-name (method)
  (sb-mop:generic-function-name (sb-mop:method-generic-function method)))

(defun collect-specializing-methods (predicate)
  (let ((result '()))
    (sb-pcl::map-specializers
     #'(lambda (specl)
         (when (funcall predicate specl)
           (let ((methods (sb-mop:specializer-direct-methods specl)))
             (setf result (append methods result))))))
    (delete-duplicates result)))


;;;; ALLOCATION INTROSPECTION

(eval-when (:compile-toplevel :execute)
  (defmacro pinnedp (addr)
    `(eql (sb-alien:alien-funcall
           (sb-alien:extern-alien "sb_introspect_pinnedp"
                                  (function sb-alien:int sb-alien:unsigned))
           ,addr)
          1)))

(defun allocation-information (object)
  "Returns information about the allocation of OBJECT. The primary return
value indicates the general type of allocation: :IMMEDIATE, :HEAP,
:STACK, or :FOREIGN.

Non-NIL secondary return values provide additional information about
the allocation.

For :HEAP objects the secondary value is a plist:

  :SPACE
    Indicates the heap segment the object is allocated in.

  :GENERATION
    The current generation of the object: 0 for nursery, 6 for pseudo-static
    generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)

  :LARGE
    Indicates a \"large\" object subject to non-copying
    promotion. (GENCGC and :SPACE :DYNAMIC only.)

  :BOXED
    Indicates that the object is allocated in a boxed region. Unboxed
    allocation is used for e.g. specialized arrays after they have survived one
    collection. (GENCGC and :SPACE :DYNAMIC only.)

  :PINNED
    Indicates that the page(s) on which the object resides are kept live due
    to conservative references. Note that object may reside on a pinned page
    even if :PINNED is NIL if the GC has not had the need to mark the page
    as pinned. (GENCGC and :SPACE :DYNAMIC only.)

  :WRITE-PROTECTED
    Indicates that the page on which the object starts is write-protected,
    which indicates for :BOXED objects that it hasn't been written to since
    the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)

  :PAGE
    The index of the page the object resides on. (GENCGC and :SPACE :DYNAMIC
    only.)

For :STACK objects, the secondary value is the thread on whose stack
the object is allocated.

Expected use-cases include introspection to gain insight into allocation and
GC behaviour and restricting memoization to heap-allocated arguments.

Experimental: interface subject to change."
  ;; FIXME: Would be nice to provide the size of the object as well, though
  ;; maybe that should be a separate function, and something like MAP-PARTS
  ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
  ;; as well if they want to.
  ;;
  (if (not (sb-vm:is-lisp-pointer (get-lisp-obj-address object)))
      (values :immediate nil)
      (let ((plist
             (sb-sys:with-pinned-objects (object)
               (let ((space (sb-ext:heap-allocated-p object)))
                 (when space
                   #+generational
                   (if (eq :dynamic space)
                       (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index)))
                         ;; No wonder #+big-endian failed introspection tests-
                         ;; bits are packed in the opposite order. And thankfully,
                         ;; this fix seems not to depend on whether the numbering
                         ;; scheme is MSB 0 or LSB 0, afaict.
                         (let* ((wp (page-protected-p object))
                                (index (sb-vm:find-page-index
                                        (get-lisp-obj-address object)))
                                (type (sb-alien:slot page 'sb-vm::flags)))
                           (list :space space
                                 :generation (sb-alien:slot page 'sb-vm::gen)
                                 :write-protected wp
                                 :boxed (> (logand type #xf) 1)
                                 :pinned (pinnedp (get-lisp-obj-address object))
                                 :large (logbitp 4 type)
                                 :page index)))
                       (list :space space))
                   #-generational
                   (list :space space))))))
        (cond (plist
               (values :heap plist))
              (t
               #+sb-thread
               (let ((thread (sb-ext:stack-allocated-p object t)))
                 (when thread
                   (return-from allocation-information
                     (values :stack thread))))
               #-sb-thread
               (when (sb-vm:control-stack-pointer-valid-p
                      (sb-sys:int-sap (get-lisp-obj-address object)) nil)
                 (return-from allocation-information
                   (values :stack sb-thread::*current-thread*)))
               :foreign)))))

(defun map-root (function object &key simple (ext t))
  "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
Returns OBJECT.

If SIMPLE is true (default is NIL), elides those pointers that are not
notionally part of certain built-in objects but backpointers to a
conceptual parent: e.g. elides the pointer from a SYMBOL to the
corresponding PACKAGE.

If EXT is true (default is T), includes some pointers that are not
actually contained in the object but found in certain well-known
indirect containers: FDEFINITIONs, EQL specializers, classes, and
thread-local symbol values in other threads fall into this category.

NOTE: calling MAP-ROOT with a THREAD does not currently map over
conservative roots from the thread registers and interrupt contexts.

Experimental: interface subject to change."
  (when (typep object '(or bignum float sb-sys:system-area-pointer
                           fixnum character))
    (return-from map-root object))
  (let ((fun (coerce function 'function))
        (seen (alloc-xset)))
    (flet ((call (part)
             (when (and (sb-vm:is-lisp-pointer (get-lisp-obj-address part))
                        (not (xset-member-p part seen)))
                 (add-to-xset part seen)
                 (funcall fun part))))
      (declare (dynamic-extent #'call))
      (when ext
        (multiple-value-bind (value foundp)
            (let ((table sb-pcl::*eql-specializer-table*))
              (with-system-mutex ((hash-table-lock table))
                (gethash object table)))
          (when foundp (call value))))
      (sb-vm:do-referenced-object (object call)
        (cons
         :extend
         (when (and ext (ignore-errors (fboundp object)))
           (call (fdefinition object))))
        (instance
         :extend
         #+sb-thread
         (when (typep object 'sb-thread:thread)
           (cond ((eq object sb-thread:*current-thread*)
                  (dolist (value (sb-thread::%thread-local-references))
                    (call value))
                  (sb-vm::map-stack-references #'call))
                 (t
                  ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
                  ;; the alternative would be stopping the world...
                  (let ((sem (sb-thread:make-semaphore))
                        (refs nil))
                    (handler-case
                        (progn
                          (sb-thread:interrupt-thread
                           object
                           (lambda ()
                             (setf refs (sb-thread::%thread-local-references))
                             (sb-vm::map-stack-references (lambda (x) (push x refs)))
                             (sb-thread:signal-semaphore sem)))
                          (sb-thread:wait-on-semaphore sem))
                      (sb-thread:interrupt-thread-error ()))
                    ;; This is whacky - the other thread signals our condition var,
                    ;; *then* we call the funarg on objects that may no longer
                    ;; satisfy VALID-TAGGED-POINTER-P.
                    ;; And incidentally, we miss any references from TLS indices
                    ;; that map onto the 'struct thread', which is just as well
                    ;; since they're either fixnums or dynamic-extent objects.
                    (mapc #'call refs))))))
        ((satisfies array-header-p)
         :override
         ;; The default implementation always scans %array-displaced-from
         (call (%array-data object))
         (call (%array-displaced-p object))
         (unless simple
           (call (%array-displaced-from object))))
        (code-component
         :extend
         (loop for i below (code-n-entries object)
               do (call (%code-entry-point object i))))
        (function ; excluding CLOSURE and FUNCALLABLE-INSTANCE
         :override
         (unless simple
           (call (fun-code-header object)))
         (call (%simple-fun-name object))
         (call (%simple-fun-arglist object))
         (call (%simple-fun-source object))
         (call (%simple-fun-info object)))
        (symbol
         ;; We use :override here because (apparently) the intent is
         ;; to avoid calling FUNCTION on the SYMBOL-PACKAGE
         ;; when SIMPLE is NIL (the default). And we skip SYMBOL-EXTRA for
         ;; the same reason that we don't call FUNCTION on SYMBOL-INFO
         ;; (logically it's "system" data, not for user consumption).
         ;; Frankly this entire function is a confusing mishmash that is not
         ;; accurate for computing a true graph of objects starting from a
         ;; certain point, given all the special cases that it implements.
         :override
         (when ext
           (dolist (thread (sb-thread:list-all-threads))
             (call (sb-thread:symbol-value-in-thread object thread nil))))
         (call (sb-sys:%primitive sb-c:fast-symbol-global-value object))
         ;; These first two are probably unnecessary.
         ;; The functoid values, if present, are in SYMBOL-INFO
         ;; which is traversed whether or not EXT was true.
         ;; But should we traverse SYMBOL-INFO?
         ;; I don't know what is expected of this interface.
         (when (and ext (ignore-errors (fboundp object)))
           (call (fdefinition object))
           (call (macro-function object))
           (let ((class (find-class object nil)))
             (when class (call class))))
         (call (symbol-plist object)) ; perhaps SB-KERNEL:SYMBOL-INFO instead?
         (call (symbol-name object))
         (unless simple
           (call (symbol-package object))))
        (t
         :extend
         (case (widetag-of object)
           (#.sb-vm:value-cell-widetag
            (call (value-cell-ref object)))
           (t
            (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
                  (widetag-of object) object)))))))
  object)

(defun object-size (object)
  (+ (primitive-object-size object)
     (typecase object
       (sb-mop:funcallable-standard-object
        (primitive-object-size (sb-pcl::fsc-instance-slots object)))
       (standard-object
        (primitive-object-size (sb-pcl::std-instance-slots object)))
       (t 0))))

;;; Print a distribution of object sizes in SPACE.
;;; There are two bins for cons-sized objects: conses and anything else,
;;; the latter including SAPs, value cells, 0-length simple-vectors,
;;; and a bunch of other things.
(defun object-size-histogram (&optional
                              (space :dynamic)
                              (size-bins ; objects whose size in words is <= this
                               `#(2 4 6 8 10 16 20 24 32 64 128 256 512 1024
                                  2048 4096 8192 16384 32768 131072 524288
                                  ,(ash 1 20) ,(ash 1 21) ,(ash 1 23))))
  (declare (simple-vector size-bins))
  (let* ((n-bins (+ (length size-bins) 2))
         (counts (make-array n-bins :initial-element 0))
         (size-totals (make-array n-bins :initial-element 0)))
    (sb-vm:map-allocated-objects
     (lambda (obj type size)
       (declare (ignore type))
       (cond ((consp obj)
              (incf (aref counts 0)))
             (t
              (let* ((words (ash size (- sb-vm:word-shift)))
                     (bin
                      (let ((i (position words size-bins :test #'<=)))
                        (if i (1+ i) (1- n-bins)))))
                (incf (aref counts bin))
                (incf (aref size-totals bin) words)))))
     space)
    (format t "     Freq     Tot Words~% =========    =========~%")
    (dotimes (i n-bins)
      (format t " ~9d  ~11d  ~a~%"
              (aref counts i)
              (if (eql i 0) ; cons bin
                  (* 2 (aref counts i))
                  (aref size-totals i))
              (cond ((zerop i) "cons")
                    ((eql i (1- n-bins))
                     (format nil " > ~D" (aref size-bins (- n-bins 3))))
                    (t
                     (let ((this-bin-size (aref size-bins (1- i)))
                           (prev-bin-size (when (>= i 2) (aref size-bins (- i 2)))))
                       (format nil "~:[<=~;=~] ~D"
                               (or (not prev-bin-size)
                                   (= this-bin-size (+ prev-bin-size 2)))
                               this-bin-size))))))))

(defun largest-objects (&key (threshold #+generational sb-vm:gencgc-page-bytes
                                        #-generational sb-c:+backend-page-bytes+)
                             (sort :size))
  (declare (type (member :address :size) sort))
  (flet ((show-obj (obj)
           #-generational
           (format t "~10x ~7x ~s~%"
                     (get-lisp-obj-address obj)
                     (primitive-object-size obj)
                     (type-of obj))
           #+generational
           (let* ((gen (generation-of obj))
                  (page (sb-vm::find-page-index (sb-kernel:get-lisp-obj-address obj)))
                  (flags (if (>= page 0)
                             (sb-alien:slot (sb-alien:deref sb-vm:page-table page)
                                            'sb-vm::flags))))
             (format t "~10x ~7x ~a ~:[        ~;~:*~8b~] ~s~%"
                     (get-lisp-obj-address obj)
                     (primitive-object-size obj)
                     (if gen gen #\?)
                     flags
                     (type-of obj)))))
    (case sort
     (:address
      (sb-vm:map-allocated-objects
       (lambda (obj widetag size)
         (declare (ignore widetag))
         (when (>= size threshold)
           (show-obj obj)))
       :all))
     (:size
      (let (list)
         (sb-vm:map-allocated-objects
          (lambda (obj widetag size)
            (declare (ignore widetag))
            (when (>= size threshold)
              (push obj list)))
          :all)
         (mapc #'show-obj
               (stable-sort list #'> :key #'primitive-object-size))
         nil)))))
