contrib/sb-introspect/introspect.lisp

   1 ;;; introspection library
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 ;;; For the avoidance of doubt, the exported interface is the supported
  13 ;;; interface. Anything else is internal, though you're welcome to argue a
  14 ;;; case for exporting it.
  15
  16 ;;; If you steal the code from this file to cut and paste into your
  17 ;;; own project, there will be much wailing and gnashing of teeth.
  18 ;;; Your teeth.  If need be, we'll kick them for you.  This is a
  19 ;;; contrib, we're allowed to look in internals.  You're an
  20 ;;; application programmer, and are not.
  21
  22 ;;; TODO
  23 ;;; 1) structs don't have within-file location info.  problem for the
  24 ;;;   structure itself, accessors and the predicate
  25 ;;; 3) error handling.  Signal random errors, or handle and resignal 'our'
  26 ;;;   error, or return NIL?
  27 ;;; 4) FIXMEs
  28
  29 (defpackage :sb-introspect
  30   (:use "CL")
  31   (:export "ALLOCATION-INFORMATION"
  32            "FUNCTION-ARGLIST"
  33            "FUNCTION-LAMBDA-LIST"
  34            "DEFTYPE-LAMBDA-LIST"
  35            "VALID-FUNCTION-NAME-P"
  36            "FIND-DEFINITION-SOURCE"
  37            "FIND-DEFINITION-SOURCES-BY-NAME"
  38            "DEFINITION-SOURCE"
  39            "DEFINITION-SOURCE-PATHNAME"
  40            "DEFINITION-SOURCE-FORM-PATH"
  41            "DEFINITION-SOURCE-CHARACTER-OFFSET"
  42            "DEFINITION-SOURCE-FILE-WRITE-DATE"
  43            "DEFINITION-SOURCE-PLIST"
  44            "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
  45            "FIND-FUNCTION-CALLEES"
  46            "FIND-FUNCTION-CALLERS"
  47            "WHO-BINDS"
  48            "WHO-CALLS"
  49            "WHO-REFERENCES"
  50            "WHO-SETS"
  51            "WHO-MACROEXPANDS"))
  52
  53 (in-package :sb-introspect)
  54
  55 ;;;; Internal interface for SBCL debug info
  56
  57 ;;; Here are some tutorial-style type definitions to help understand
  58 ;;; the internal SBCL debugging data structures we're using. The
  59 ;;; commentary is based on CMUCL's debug internals manual.
  60 ;;;
  61 (deftype debug-info ()
  62   "Structure containing all the debug information related to a function.
  63 Function objects reference debug-infos which in turn reference
  64 debug-sources and so on."
  65   'sb-c::compiled-debug-info)
  66
  67 (deftype debug-source ()
  68   "Debug sources describe where to find source code.
  69 For example, the debug source for a function compiled from a file will
  70 include the pathname of the file and the position of the definition."
  71   'sb-c::debug-source)
  72
  73 (deftype debug-function ()
  74   "Debug function represent static compile-time information about a function."
  75   'sb-c::compiled-debug-fun)
  76
  77 (declaim (ftype (function (function) debug-info) function-debug-info))
  78 (defun function-debug-info (function)
  79   (let* ((function-object (sb-kernel::%fun-fun function))
  80          (function-header (sb-kernel:fun-code-header function-object)))
  81     (sb-kernel:%code-debug-info function-header)))
  82
  83 (declaim (ftype (function (function) debug-source) function-debug-source))
  84 (defun function-debug-source (function)
  85   (debug-info-source (function-debug-info function)))
  86
  87 (declaim (ftype (function (debug-info) debug-source) debug-info-source))
  88 (defun debug-info-source (debug-info)
  89   (sb-c::debug-info-source debug-info))
  90
  91 (declaim (ftype (function (debug-info) debug-function) debug-info-debug-function))
  92 (defun debug-info-debug-function (debug-info)
  93   (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
  94
  95 (defun valid-function-name-p (name)
  96   "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION "
  97   (and (sb-int:valid-function-name-p name) t))
  98
  99 ;;;; Finding definitions
 100
 101 (defstruct definition-source
 102   ;; Pathname of the source file that the definition was compiled from.
 103   ;; This is null if the definition was not compiled from a file.
 104   (pathname nil :type (or null pathname))
 105   ;; Source-path of the definition within the file.
 106   ;; This may be incomplete depending on the debug level at which the
 107   ;; source was compiled.
 108   (form-path '() :type list)
 109   ;; Character offset of the top-level-form containing the definition.
 110   ;; This corresponds to the first element of form-path.
 111   (character-offset nil :type (or null integer))
 112   ;; File-write-date of the source file when compiled.
 113   ;; Null if not compiled from a file.
 114   (file-write-date nil :type (or null integer))
 115   ;; plist from WITH-COMPILATION-UNIT
 116   (plist nil)
 117   ;; Any extra metadata that the caller might be interested in. For
 118   ;; example the specializers of the method whose definition-source this
 119   ;; is.
 120   (description nil :type list))
 121
 122 (defun find-definition-sources-by-name (name type)
 123   "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
 124 defined with name NAME. NAME may be a symbol or a extended function
 125 name. Type can currently be one of the following:
 126
 127    (Public)
 128    :CLASS
 129    :COMPILER-MACRO
 130    :CONDITION
 131    :CONSTANT
 132    :FUNCTION
 133    :GENERIC-FUNCTION
 134    :MACRO
 135    :METHOD
 136    :METHOD-COMBINATION
 137    :PACKAGE
 138    :SETF-EXPANDER
 139    :STRUCTURE
 140    :SYMBOL-MACRO
 141    :TYPE
 142    :VARIABLE
 143
 144    (Internal)
 145    :OPTIMIZER
 146    :SOURCE-TRANSFORM
 147    :TRANSFORM
 148    :VOP
 149
 150 If an unsupported TYPE is requested, the function will return NIL.
 151 "
 152   (flet ((listify (x)
 153            (if (listp x)
 154                x
 155                (list x)))
 156          (get-class (name)
 157            (and (symbolp name)
 158                 (find-class name nil)))
 159          (real-fdefinition (name)
 160            ;; for getting the real function object, even if the
 161            ;; function is being profiled
 162            (let ((profile-info (gethash name sb-profile::*profiled-fun-name->info*)))
 163              (if profile-info
 164                  (sb-profile::profile-info-encapsulated-fun profile-info)
 165                  (fdefinition name)))))
 166     (listify
 167      (case type
 168        ((:variable)
 169         (when (and (symbolp name)
 170                    (eq (sb-int:info :variable :kind name) :special))
 171           (translate-source-location (sb-int:info :source-location type name))))
 172        ((:constant)
 173         (when (and (symbolp name)
 174                    (eq (sb-int:info :variable :kind name) :constant))
 175           (translate-source-location (sb-int:info :source-location type name))))
 176        ((:symbol-macro)
 177         (when (and (symbolp name)
 178                    (eq (sb-int:info :variable :kind name) :macro))
 179           (translate-source-location (sb-int:info :source-location type name))))
 180        ((:macro)
 181         (when (and (symbolp name)
 182                    (macro-function name))
 183           (find-definition-source (macro-function name))))
 184        ((:compiler-macro)
 185         (when (compiler-macro-function name)
 186           (find-definition-source (compiler-macro-function name))))
 187        ((:function :generic-function)
 188         (when (and (fboundp name)
 189                    (or (not (symbolp name))
 190                        (not (macro-function name))))
 191           (let ((fun (real-fdefinition name)))
 192             (when (eq (not (typep fun 'generic-function))
 193                       (not (eq type :generic-function)))
 194               (find-definition-source fun)))))
 195        ((:type)
 196         ;; Source locations for types are saved separately when the expander
 197         ;; is a closure without a good source-location.
 198         (let ((loc (sb-int:info :type :source-location name)))
 199           (if loc
 200               (translate-source-location loc)
 201               (let ((expander-fun (sb-int:info :type :expander name)))
 202                 (when expander-fun
 203                   (find-definition-source expander-fun))))))
 204        ((:method)
 205         (when (fboundp name)
 206           (let ((fun (real-fdefinition name)))
 207            (when (typep fun 'generic-function)
 208              (loop for method in (sb-mop::generic-function-methods
 209                                   fun)
 210                 for source = (find-definition-source method)
 211                 when source collect source)))))
 212        ((:setf-expander)
 213         (when (and (consp name)
 214                    (eq (car name) 'setf))
 215           (setf name (cadr name)))
 216         (let ((expander (or (sb-int:info :setf :inverse name)
 217                             (sb-int:info :setf :expander name))))
 218           (when expander
 219             (sb-introspect:find-definition-source (if (symbolp expander)
 220                                                       (symbol-function expander)
 221                                                       expander)))))
 222        ((:structure)
 223         (let ((class (get-class name)))
 224           (if class
 225               (when (typep class 'sb-pcl::structure-class)
 226                 (find-definition-source class))
 227               (when (sb-int:info :typed-structure :info name)
 228                 (translate-source-location
 229                  (sb-int:info :source-location :typed-structure name))))))
 230        ((:condition :class)
 231         (let ((class (get-class name)))
 232           (when (and class
 233                      (not (typep class 'sb-pcl::structure-class)))
 234             (when (eq (not (typep class 'sb-pcl::condition-class))
 235                       (not (eq type :condition)))
 236               (find-definition-source class)))))
 237        ((:method-combination)
 238         (let ((combination-fun
 239                (find-method #'sb-mop:find-method-combination
 240                             nil
 241                             (list (find-class 'generic-function)
 242                                   (list 'eql name)
 243                                   t)
 244                             nil)))
 245           (when combination-fun
 246             (find-definition-source combination-fun))))
 247        ((:package)
 248         (when (symbolp name)
 249           (let ((package (find-package name)))
 250             (when package
 251               (find-definition-source package)))))
 252        ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
 253        ((:transform)
 254         (when (symbolp name)
 255           (let ((fun-info (sb-int:info :function :info name)))
 256             (when fun-info
 257               (loop for xform in (sb-c::fun-info-transforms fun-info)
 258                     for source = (find-definition-source
 259                                   (sb-c::transform-function xform))
 260                     for typespec = (sb-kernel:type-specifier
 261                                     (sb-c::transform-type xform))
 262                     for note = (sb-c::transform-note xform)
 263                     do (setf (definition-source-description source)
 264                              (if (consp typespec)
 265                                  (list (second typespec) note)
 266                                  (list note)))
 267                     collect source)))))
 268        ((:optimizer)
 269         (when (symbolp name)
 270           (let ((fun-info (sb-int:info :function :info name)))
 271             (when fun-info
 272               (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
 273                               (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
 274                               (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
 275                               (sb-c::fun-info-optimizer . sb-c:optimizer))))
 276                 (loop for (reader . name) in otypes
 277                       for fn = (funcall reader fun-info)
 278                       when fn collect
 279                       (let ((source (find-definition-source fn)))
 280                         (setf (definition-source-description source)
 281                               (list name))
 282                         source)))))))
 283        ((:vop)
 284         (when (symbolp name)
 285           (let ((fun-info (sb-int:info :function :info name)))
 286             (when fun-info
 287               (loop for vop in (sb-c::fun-info-templates fun-info)
 288                     for source = (find-definition-source
 289                                   (sb-c::vop-info-generator-function vop))
 290                     do (setf (definition-source-description source)
 291                              (list (sb-c::template-name vop)
 292                                    (sb-c::template-note vop)))
 293                     collect source)))))
 294        ((:source-transform)
 295         (when (symbolp name)
 296           (let ((transform-fun (sb-int:info :function :source-transform name)))
 297             (when transform-fun
 298               (sb-introspect:find-definition-source transform-fun)))))
 299        (t
 300         nil)))))
 301
 302 (defun find-definition-source (object)
 303   (typecase object
 304     ((or sb-pcl::condition-class sb-pcl::structure-class)
 305      (let ((classoid (sb-impl::find-classoid (class-name object))))
 306        (when classoid
 307          (let ((layout (sb-impl::classoid-layout classoid)))
 308            (when layout
 309              (translate-source-location
 310               (sb-kernel::layout-source-location layout)))))))
 311     (method-combination
 312      (car
 313       (find-definition-sources-by-name
 314        (sb-pcl::method-combination-type-name object) :method-combination)))
 315     (package
 316      (translate-source-location (sb-impl::package-source-location object)))
 317     (class
 318      (translate-source-location (sb-pcl::definition-source object)))
 319     ;; Use the PCL definition location information instead of the function
 320     ;; debug-info for methods and generic functions. Sometimes the
 321     ;; debug-info would point into PCL internals instead of the proper
 322     ;; location.
 323     (generic-function
 324      (let ((source (translate-source-location
 325                     (sb-pcl::definition-source object))))
 326        (when source
 327          (setf (definition-source-description source)
 328                (list (sb-mop:generic-function-lambda-list object))))
 329        source))
 330     (method
 331      (let ((source (translate-source-location
 332                     (sb-pcl::definition-source object))))
 333        (when source
 334          (setf (definition-source-description source)
 335                (append (method-qualifiers object)
 336                        (if (sb-mop:method-generic-function object)
 337                            (sb-pcl::unparse-specializers
 338                             (sb-mop:method-generic-function object)
 339                             (sb-mop:method-specializers object))
 340                            (sb-mop:method-specializers object)))))
 341        source))
 342     #+sb-eval
 343     (sb-eval:interpreted-function
 344      (let ((source (translate-source-location
 345                     (sb-eval:interpreted-function-source-location object))))
 346        source))
 347     (function
 348      (cond ((struct-accessor-p object)
 349             (find-definition-source
 350              (struct-accessor-structure-class object)))
 351            ((struct-predicate-p object)
 352             (find-definition-source
 353              (struct-predicate-structure-class object)))
 354            (t
 355             (find-function-definition-source object))))
 356     ((or condition standard-object structure-object)
 357      (find-definition-source (class-of object)))
 358     (t
 359      (error "Don't know how to retrieve source location for a ~S~%"
 360             (type-of object)))))
 361
 362 (defun find-function-definition-source (function)
 363   (let* ((debug-info (function-debug-info function))
 364          (debug-source (debug-info-source debug-info))
 365          (debug-fun (debug-info-debug-function debug-info))
 366          (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
 367     (make-definition-source
 368      :pathname
 369      ;; KLUDGE: at the moment, we don't record the correct toplevel
 370      ;; form number for forms processed by EVAL (including EVAL-WHEN
 371      ;; :COMPILE-TOPLEVEL).  Until that's fixed, don't return a
 372      ;; DEFINITION-SOURCE with a pathname.  (When that's fixed, take
 373      ;; out the (not (debug-source-form ...)) test.
 374      (if (and (sb-c::debug-source-namestring debug-source)
 375               (not (sb-c::debug-source-form debug-source)))
 376          (parse-namestring (sb-c::debug-source-namestring debug-source)))
 377      :character-offset
 378      (if tlf
 379          (elt (sb-c::debug-source-start-positions debug-source) tlf))
 380      ;; Unfortunately there is no proper source path available in the
 381      ;; debug-source. FIXME: We could use sb-di:code-locations to get
 382      ;; a full source path. -luke (12/Mar/2005)
 383      :form-path (if tlf (list tlf))
 384      :file-write-date (sb-c::debug-source-created debug-source)
 385      :plist (sb-c::debug-source-plist debug-source))))
 386
 387 (defun translate-source-location (location)
 388   (if location
 389       (make-definition-source
 390        :pathname (let ((n (sb-c:definition-source-location-namestring location)))
 391                    (when n
 392                      (parse-namestring n)))
 393        :form-path
 394        (let ((number (sb-c:definition-source-location-toplevel-form-number
 395                          location)))
 396          (when number
 397            (list number)))
 398        :plist (sb-c:definition-source-location-plist location))
 399       (make-definition-source)))
 400
 401 ;;; This is kludgey.  We expect these functions (the underlying functions,
 402 ;;; not the closures) to be in static space and so not move ever.
 403 ;;; FIXME It's also possibly wrong: not all structures use these vanilla
 404 ;;; accessors, e.g. when the :type option is used
 405 (defvar *struct-slotplace-reader*
 406   (sb-vm::%simple-fun-self #'definition-source-pathname))
 407 (defvar *struct-slotplace-writer*
 408   (sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
 409 (defvar *struct-predicate*
 410   (sb-vm::%simple-fun-self #'definition-source-p))
 411
 412 (defun struct-accessor-p (function)
 413   (let ((self (sb-vm::%simple-fun-self function)))
 414     ;; FIXME there are other kinds of struct accessor.  Fill out this list
 415     (member self (list *struct-slotplace-reader*
 416                        *struct-slotplace-writer*))))
 417
 418 (defun struct-predicate-p (function)
 419   (let ((self (sb-vm::%simple-fun-self function)))
 420     ;; FIXME there may be other structure predicate functions
 421     (member self (list *struct-predicate*))))
 422
 423 (defun function-arglist (function)
 424   "Deprecated alias for FUNCTION-LAMBDA-LIST."
 425   (function-lambda-list function))
 426
 427 (define-compiler-macro function-arglist (function)
 428   (sb-int:deprecation-warning 'function-arglist 'function-lambda-list)
 429   `(function-lambda-list ,function))
 430
 431 (defun function-lambda-list (function)
 432   "Describe the lambda list for the extended function designator FUNCTION.
 433 Works for special-operators, macros, simple functions, interpreted functions,
 434 and generic functions. Signals an error if FUNCTION is not a valid extended
 435 function designator."
 436   (cond ((valid-function-name-p function)
 437          (function-lambda-list (or (and (symbolp function)
 438                                         (macro-function function))
 439                                    (fdefinition function))))
 440         ((typep function 'generic-function)
 441          (sb-pcl::generic-function-pretty-arglist function))
 442         #+sb-eval
 443         ((typep function 'sb-eval:interpreted-function)
 444          (sb-eval:interpreted-function-lambda-list function))
 445         (t
 446          (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function)))))
 447
 448 (defun deftype-lambda-list (typespec-operator)
 449   "Returns the lambda list of TYPESPEC-OPERATOR as first return
 450 value, and a flag whether the arglist could be found as second
 451 value."
 452   (sb-int:info :type :lambda-list typespec-operator))
 453
 454 (defun struct-accessor-structure-class (function)
 455   (let ((self (sb-vm::%simple-fun-self function)))
 456     (cond
 457       ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
 458        (find-class
 459         (sb-kernel::classoid-name
 460          (sb-kernel::layout-classoid
 461           (sb-kernel:%closure-index-ref function 1)))))
 462       )))
 463
 464 (defun struct-predicate-structure-class (function)
 465   (let ((self (sb-vm::%simple-fun-self function)))
 466     (cond
 467       ((member self (list *struct-predicate*))
 468        (find-class
 469         (sb-kernel::classoid-name
 470          (sb-kernel::layout-classoid
 471           (sb-kernel:%closure-index-ref function 0)))))
 472       )))
 473
 474 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
 475
 476 ;;; This interface is trmendously experimental.
 477
 478 ;;; For the moment I'm taking the view that FDEFN is an internal
 479 ;;; object (one out of one CMUCL developer surveyed didn't know what
 480 ;;; they were for), so these routines deal in FUNCTIONs
 481
 482 ;;; Find callers and callees by looking at the constant pool of
 483 ;;; compiled code objects.  We assume every fdefn object in the
 484 ;;; constant pool corresponds to a call to that function.  A better
 485 ;;; strategy would be to use the disassembler to find actual
 486 ;;; call-sites.
 487
 488 (defun find-function-callees (function)
 489   "Return functions called by FUNCTION."
 490   (let ((callees '()))
 491     (map-code-constants
 492      (sb-kernel:fun-code-header function)
 493      (lambda (obj)
 494        (when (sb-kernel:fdefn-p obj)
 495          (push (sb-kernel:fdefn-fun obj)
 496                callees))))
 497     callees))
 498
 499
 500 (defun find-function-callers (function &optional (spaces '(:read-only :static
 501                                                            :dynamic)))
 502   "Return functions which call FUNCTION, by searching SPACES for code objects"
 503   (let ((referrers '()))
 504     (map-caller-code-components
 505      function
 506      spaces
 507      (lambda (code)
 508        (let ((entry (sb-kernel:%code-entry-points  code)))
 509          (cond ((not entry)
 510                 (push (princ-to-string code) referrers))
 511                (t
 512                 (loop for e = entry then (sb-kernel::%simple-fun-next e)
 513                       while e
 514                       do (pushnew e referrers)))))))
 515     referrers))
 516
 517 (declaim (inline map-code-constants))
 518 (defun map-code-constants (code fn)
 519   "Call FN for each constant in CODE's constant pool."
 520   (check-type code sb-kernel:code-component)
 521   (loop for i from sb-vm:code-constants-offset below
 522         (sb-kernel:get-header-data code)
 523         do (funcall fn (sb-kernel:code-header-ref code i))))
 524
 525 (declaim (inline map-allocated-code-components))
 526 (defun map-allocated-code-components (spaces fn)
 527   "Call FN for each allocated code component in one of SPACES.  FN
 528 receives the object and its size as arguments.  SPACES should be a
 529 list of the symbols :dynamic, :static, or :read-only."
 530   (dolist (space spaces)
 531     (sb-vm::map-allocated-objects
 532      (lambda (obj header size)
 533        (when (= sb-vm:code-header-widetag header)
 534          (funcall fn obj size)))
 535      space
 536      t)))
 537
 538 (declaim (inline map-caller-code-components))
 539 (defun map-caller-code-components (function spaces fn)
 540   "Call FN for each code component with a fdefn for FUNCTION in its
 541 constant pool."
 542   (let ((function (coerce function 'function)))
 543     (map-allocated-code-components
 544      spaces
 545      (lambda (obj size)
 546        (declare (ignore size))
 547        (map-code-constants
 548         obj
 549         (lambda (constant)
 550           (when (and (sb-kernel:fdefn-p constant)
 551                      (eq (sb-kernel:fdefn-fun constant)
 552                          function))
 553             (funcall fn obj))))))))
 554
 555 ;;; XREF facility
 556
 557 (defun get-simple-fun (functoid)
 558   (etypecase functoid
 559     (sb-kernel::fdefn
 560      (get-simple-fun (sb-vm::fdefn-fun functoid)))
 561     ((or null sb-impl::funcallable-instance)
 562      nil)
 563     (function
 564      (sb-kernel::%fun-fun functoid))))
 565
 566 (defun collect-xref (kind-index wanted-name)
 567   (let ((ret nil))
 568     (dolist (env sb-c::*info-environment* ret)
 569       ;; Loop through the infodb ...
 570       (sb-c::do-info (env :class class :type type :name info-name
 571                           :value value)
 572         ;; ... looking for function or macro definitions
 573         (when (and (eql class :function)
 574                    (or (eql type :macro-function)
 575                        (eql type :definition)))
 576           ;; Get a simple-fun for the definition, and an xref array
 577           ;; from the table if available.
 578           (let* ((simple-fun (get-simple-fun value))
 579                  (xrefs (when simple-fun
 580                           (sb-kernel:%simple-fun-xrefs simple-fun)))
 581                  (array (when xrefs
 582                           (aref xrefs kind-index))))
 583             ;; Loop through the name/path xref entries in the table
 584             (loop for i from 0 below (length array) by 2
 585                   for xref-name = (aref array i)
 586                   for xref-path = (aref array (1+ i))
 587                   do (when (eql xref-name wanted-name)
 588                        (let ((source-location
 589                               (find-function-definition-source simple-fun)))
 590                          ;; Use the more accurate source path from
 591                          ;; the xref entry.
 592                          (setf (definition-source-form-path source-location)
 593                                xref-path)
 594                          (push (cons info-name source-location)
 595                                ret))))))))))
 596
 597 (defun who-calls (function-name)
 598   "Use the xref facility to search for source locations where the
 599 global function named FUNCTION-NAME is called. Returns a list of
 600 function name, definition-source pairs."
 601   (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name))
 602
 603 (defun who-binds (symbol)
 604   "Use the xref facility to search for source locations where the
 605 special variable SYMBOL is rebound. Returns a list of function name,
 606 definition-source pairs."
 607   (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol))
 608
 609 (defun who-references (symbol)
 610   "Use the xref facility to search for source locations where the
 611 special variable or constant SYMBOL is read. Returns a list of function
 612 name, definition-source pairs."
 613   (collect-xref #.(position :references sb-c::*xref-kinds*) symbol))
 614
 615 (defun who-sets (symbol)
 616   "Use the xref facility to search for source locations where the
 617 special variable SYMBOL is written to. Returns a list of function name,
 618 definition-source pairs."
 619   (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol))
 620
 621 (defun who-macroexpands (macro-name)
 622   "Use the xref facility to search for source locations where the
 623 macro MACRO-NAME is expanded. Returns a list of function name,
 624 definition-source pairs."
 625   (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
 626
 627 ;;;; ALLOCATION INTROSPECTION
 628
 629 (defun allocation-information (object)
 630   #+sb-doc
 631   "Returns information about the allocation of OBJECT. Primary return value
 632 indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
 633 or :FOREIGN.
 634
 635 Possible secondary return value provides additional information about the
 636 allocation.
 637
 638 For :HEAP objects the secondary value is a plist:
 639
 640   :SPACE
 641     Inficates the heap segment the object is allocated in.
 642
 643   :GENERATION
 644     Is the current generation of the object: 0 for nursery, 6 for pseudo-static
 645     generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
 646
 647   :LARGE
 648     Indicates a \"large\" object subject to non-copying
 649     promotion. (GENCGC and :SPACE :DYNAMIC only.)
 650
 651   :PINNED
 652     Indicates that the page(s) on which the object resides are kept live due
 653     to conservative references. Note that object may reside on a pinned page
 654     even if :PINNED in NIL if the GC has not had the need to mark the the page
 655     as pinned. (GENCGC and :SPACE :DYNAMIC only.)
 656
 657 For :STACK objects secondary value is the thread on whose stack the object is
 658 allocated.
 659
 660 Expected use-cases include introspection to gain insight into allocation and
 661 GC behaviour and restricting memoization to heap-allocated arguments.
 662
 663 Experimental: interface subject to change."
 664   ;; FIXME: Would be nice to provide the size of the object as well, though
 665   ;; maybe that should be a separate function, and something like MAP-PARTS
 666   ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
 667   ;; as well if they want to.
 668   ;;
 669   ;; FIXME: For the memoization use-case possibly we should also provide a
 670   ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC
 671   ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for
 672   ;; checking if an object has been stack-allocated by a given thread for
 673   ;; testing purposes might not come amiss.
 674   (if (typep object '(or fixnum character))
 675       (values :immediate nil)
 676       (let ((plist
 677              (sb-sys:without-gcing
 678                ;; Disable GC so the object cannot move to another page while
 679                ;; we have the address.
 680                (let* ((addr (sb-kernel:get-lisp-obj-address object))
 681                       (space
 682                        (cond ((< sb-vm:read-only-space-start addr
 683                                  (* sb-vm:*read-only-space-free-pointer*
 684                                     sb-vm:n-word-bytes))
 685                               :read-only)
 686                              ((< sb-vm:static-space-start addr
 687                                  (* sb-vm:*static-space-free-pointer*
 688                                     sb-vm:n-word-bytes))
 689                               :static)
 690                              ((< (sb-kernel:current-dynamic-space-start) addr
 691                                  (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
 692                               :dynamic))))
 693                  (when space
 694                    #+gencgc
 695                    (if (eq :dynamic space)
 696                        (let ((index (sb-vm::find-page-index addr)))
 697                          (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index)))
 698                            (let ((flags (sb-alien:slot page 'sb-vm::flags)))
 699                              (list :space space
 700                                    :generation (sb-alien:slot page 'sb-vm::gen)
 701                                    :write-protected (logbitp 0 flags)
 702                                    :pinned (logbitp 5 flags)
 703                                    :large (logbitp 6 flags)))))
 704                        (list :space space))
 705                    #-gencgc
 706                    (list :space space))))))
 707         (cond (plist
 708                (values :heap plist))
 709               (t
 710                (let ((sap (sb-sys:int-sap (sb-kernel:get-lisp-obj-address object))))
 711                  ;; FIXME: Check other stacks as well.
 712                  #+sb-thread
 713                  (dolist (thread (sb-thread:list-all-threads))
 714                    (let ((c-start (sb-di::descriptor-sap
 715                                    (sb-thread::%symbol-value-in-thread
 716                                     'sb-vm:*control-stack-start*
 717                                     thread)))
 718                          (c-end (sb-di::descriptor-sap
 719                                  (sb-thread::%symbol-value-in-thread
 720                                   'sb-vm:*control-stack-end*
 721                                   thread))))
 722                      (when (and c-start c-end)
 723                        (when (and (sb-sys:sap<= c-start sap)
 724                                   (sb-sys:sap< sap c-end))
 725                          (return-from allocation-information
 726                            (values :stack thread))))))
 727                  #-sb-thread
 728                  (when (sb-vm:control-stack-pointer-valid-p sap nil)
 729                    (return-from allocation-information
 730                      (values :stack sb-thread::*current-thread*))))
 731                :foreign)))))
 732