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            "FUNCTION-TYPE"
  35            "DEFTYPE-LAMBDA-LIST"
  36            "VALID-FUNCTION-NAME-P"
  37            "FIND-DEFINITION-SOURCE"
  38            "FIND-DEFINITION-SOURCES-BY-NAME"
  39            "DEFINITION-SOURCE"
  40            "DEFINITION-SOURCE-PATHNAME"
  41            "DEFINITION-SOURCE-FORM-PATH"
  42            "DEFINITION-SOURCE-CHARACTER-OFFSET"
  43            "DEFINITION-SOURCE-FILE-WRITE-DATE"
  44            "DEFINITION-SOURCE-PLIST"
  45            "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
  46            "FIND-FUNCTION-CALLEES"
  47            "FIND-FUNCTION-CALLERS"
  48            "MAP-ROOT"
  49            "WHO-BINDS"
  50            "WHO-CALLS"
  51            "WHO-REFERENCES"
  52            "WHO-SETS"
  53            "WHO-MACROEXPANDS"
  54            "WHO-SPECIALIZES-DIRECTLY"
  55            "WHO-SPECIALIZES-GENERALLY"))
  56
  57 (in-package :sb-introspect)
  58
  59 ;;;; Internal interface for SBCL debug info
  60
  61 ;;; Here are some tutorial-style type definitions to help understand
  62 ;;; the internal SBCL debugging data structures we're using. The
  63 ;;; commentary is based on CMUCL's debug internals manual.
  64 ;;;
  65 (deftype debug-info ()
  66   "Structure containing all the debug information related to a function.
  67 Function objects reference debug-infos which in turn reference
  68 debug-sources and so on."
  69   'sb-c::compiled-debug-info)
  70
  71 (deftype debug-source ()
  72   "Debug sources describe where to find source code.
  73 For example, the debug source for a function compiled from a file will
  74 include the pathname of the file and the position of the definition."
  75   'sb-c::debug-source)
  76
  77 (deftype debug-function ()
  78   "Debug function represent static compile-time information about a function."
  79   'sb-c::compiled-debug-fun)
  80
  81 (declaim (ftype (function (function) debug-info) function-debug-info))
  82 (defun function-debug-info (function)
  83   (let* ((function-object (sb-kernel::%fun-fun function))
  84          (function-header (sb-kernel:fun-code-header function-object)))
  85     (sb-kernel:%code-debug-info function-header)))
  86
  87 (declaim (ftype (function (function) debug-source) function-debug-source))
  88 (defun function-debug-source (function)
  89   (debug-info-source (function-debug-info function)))
  90
  91 (declaim (ftype (function (debug-info) debug-source) debug-info-source))
  92 (defun debug-info-source (debug-info)
  93   (sb-c::debug-info-source debug-info))
  94
  95 (declaim (ftype (function (debug-info) debug-function) debug-info-debug-function))
  96 (defun debug-info-debug-function (debug-info)
  97   (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
  98
  99 (defun valid-function-name-p (name)
 100   "True if NAME denotes a valid function name, ie. one that can be passed to
 101 FBOUNDP."
 102   (and (sb-int:valid-function-name-p name) t))
 103
 104 ;;;; Finding definitions
 105
 106 (defstruct definition-source
 107   ;; Pathname of the source file that the definition was compiled from.
 108   ;; This is null if the definition was not compiled from a file.
 109   (pathname nil :type (or null pathname))
 110   ;; Source-path of the definition within the file.
 111   ;; This may be incomplete depending on the debug level at which the
 112   ;; source was compiled.
 113   (form-path '() :type list)
 114   ;; Character offset of the top-level-form containing the definition.
 115   ;; This corresponds to the first element of form-path.
 116   (character-offset nil :type (or null integer))
 117   ;; File-write-date of the source file when compiled.
 118   ;; Null if not compiled from a file.
 119   (file-write-date nil :type (or null integer))
 120   ;; plist from WITH-COMPILATION-UNIT
 121   (plist nil)
 122   ;; Any extra metadata that the caller might be interested in. For
 123   ;; example the specializers of the method whose definition-source this
 124   ;; is.
 125   (description nil :type list))
 126
 127 (defun find-definition-sources-by-name (name type)
 128   "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
 129 defined with name NAME. NAME may be a symbol or a extended function
 130 name. Type can currently be one of the following:
 131
 132    (Public)
 133    :CLASS
 134    :COMPILER-MACRO
 135    :CONDITION
 136    :CONSTANT
 137    :FUNCTION
 138    :GENERIC-FUNCTION
 139    :MACRO
 140    :METHOD
 141    :METHOD-COMBINATION
 142    :PACKAGE
 143    :SETF-EXPANDER
 144    :STRUCTURE
 145    :SYMBOL-MACRO
 146    :TYPE
 147    :VARIABLE
 148
 149    (Internal)
 150    :OPTIMIZER
 151    :SOURCE-TRANSFORM
 152    :TRANSFORM
 153    :VOP
 154
 155 If an unsupported TYPE is requested, the function will return NIL.
 156 "
 157   (flet ((listify (x)
 158            (if (listp x)
 159                x
 160                (list x)))
 161          (get-class (name)
 162            (and (symbolp name)
 163                 (find-class name nil)))
 164          (real-fdefinition (name)
 165            ;; for getting the real function object, even if the
 166            ;; function is being profiled
 167            (let ((profile-info (gethash name sb-profile::*profiled-fun-name->info*)))
 168              (if profile-info
 169                  (sb-profile::profile-info-encapsulated-fun profile-info)
 170                  (fdefinition name)))))
 171     (listify
 172      (case type
 173        ((:variable)
 174         (when (and (symbolp name)
 175                    (eq (sb-int:info :variable :kind name) :special))
 176           (translate-source-location (sb-int:info :source-location type name))))
 177        ((:constant)
 178         (when (and (symbolp name)
 179                    (eq (sb-int:info :variable :kind name) :constant))
 180           (translate-source-location (sb-int:info :source-location type name))))
 181        ((:symbol-macro)
 182         (when (and (symbolp name)
 183                    (eq (sb-int:info :variable :kind name) :macro))
 184           (translate-source-location (sb-int:info :source-location type name))))
 185        ((:macro)
 186         (when (and (symbolp name)
 187                    (macro-function name))
 188           (find-definition-source (macro-function name))))
 189        ((:compiler-macro)
 190         (when (compiler-macro-function name)
 191           (find-definition-source (compiler-macro-function name))))
 192        ((:function :generic-function)
 193         (when (and (fboundp name)
 194                    (or (not (symbolp name))
 195                        (not (macro-function name))))
 196           (let ((fun (real-fdefinition name)))
 197             (when (eq (not (typep fun 'generic-function))
 198                       (not (eq type :generic-function)))
 199               (find-definition-source fun)))))
 200        ((:type)
 201         ;; Source locations for types are saved separately when the expander
 202         ;; is a closure without a good source-location.
 203         (let ((loc (sb-int:info :type :source-location name)))
 204           (if loc
 205               (translate-source-location loc)
 206               (let ((expander-fun (sb-int:info :type :expander name)))
 207                 (when expander-fun
 208                   (find-definition-source expander-fun))))))
 209        ((:method)
 210         (when (fboundp name)
 211           (let ((fun (real-fdefinition name)))
 212            (when (typep fun 'generic-function)
 213              (loop for method in (sb-mop::generic-function-methods
 214                                   fun)
 215                 for source = (find-definition-source method)
 216                 when source collect source)))))
 217        ((:setf-expander)
 218         (when (and (consp name)
 219                    (eq (car name) 'setf))
 220           (setf name (cadr name)))
 221         (let ((expander (or (sb-int:info :setf :inverse name)
 222                             (sb-int:info :setf :expander name))))
 223           (when expander
 224             (sb-introspect:find-definition-source (if (symbolp expander)
 225                                                       (symbol-function expander)
 226                                                       expander)))))
 227        ((:structure)
 228         (let ((class (get-class name)))
 229           (if class
 230               (when (typep class 'sb-pcl::structure-class)
 231                 (find-definition-source class))
 232               (when (sb-int:info :typed-structure :info name)
 233                 (translate-source-location
 234                  (sb-int:info :source-location :typed-structure name))))))
 235        ((:condition :class)
 236         (let ((class (get-class name)))
 237           (when (and class
 238                      (not (typep class 'sb-pcl::structure-class)))
 239             (when (eq (not (typep class 'sb-pcl::condition-class))
 240                       (not (eq type :condition)))
 241               (find-definition-source class)))))
 242        ((:method-combination)
 243         (let ((combination-fun
 244                (find-method #'sb-mop:find-method-combination
 245                             nil
 246                             (list (find-class 'generic-function)
 247                                   (list 'eql name)
 248                                   t)
 249                             nil)))
 250           (when combination-fun
 251             (find-definition-source combination-fun))))
 252        ((:package)
 253         (when (symbolp name)
 254           (let ((package (find-package name)))
 255             (when package
 256               (find-definition-source package)))))
 257        ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
 258        ((:transform)
 259         (when (symbolp name)
 260           (let ((fun-info (sb-int:info :function :info name)))
 261             (when fun-info
 262               (loop for xform in (sb-c::fun-info-transforms fun-info)
 263                     for source = (find-definition-source
 264                                   (sb-c::transform-function xform))
 265                     for typespec = (sb-kernel:type-specifier
 266                                     (sb-c::transform-type xform))
 267                     for note = (sb-c::transform-note xform)
 268                     do (setf (definition-source-description source)
 269                              (if (consp typespec)
 270                                  (list (second typespec) note)
 271                                  (list note)))
 272                     collect source)))))
 273        ((:optimizer)
 274         (when (symbolp name)
 275           (let ((fun-info (sb-int:info :function :info name)))
 276             (when fun-info
 277               (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
 278                               (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
 279                               (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
 280                               (sb-c::fun-info-optimizer . sb-c:optimizer))))
 281                 (loop for (reader . name) in otypes
 282                       for fn = (funcall reader fun-info)
 283                       when fn collect
 284                       (let ((source (find-definition-source fn)))
 285                         (setf (definition-source-description source)
 286                               (list name))
 287                         source)))))))
 288        ((:vop)
 289         (when (symbolp name)
 290           (let ((fun-info (sb-int:info :function :info name)))
 291             (when fun-info
 292               (loop for vop in (sb-c::fun-info-templates fun-info)
 293                     for source = (find-definition-source
 294                                   (sb-c::vop-info-generator-function vop))
 295                     do (setf (definition-source-description source)
 296                              (list (sb-c::template-name vop)
 297                                    (sb-c::template-note vop)))
 298                     collect source)))))
 299        ((:source-transform)
 300         (when (symbolp name)
 301           (let ((transform-fun (sb-int:info :function :source-transform name)))
 302             (when transform-fun
 303               (sb-introspect:find-definition-source transform-fun)))))
 304        (t
 305         nil)))))
 306
 307 (defun find-definition-source (object)
 308   (typecase object
 309     ((or sb-pcl::condition-class sb-pcl::structure-class)
 310      (let ((classoid (sb-impl::find-classoid (class-name object))))
 311        (when classoid
 312          (let ((layout (sb-impl::classoid-layout classoid)))
 313            (when layout
 314              (translate-source-location
 315               (sb-kernel::layout-source-location layout)))))))
 316     (method-combination
 317      (car
 318       (find-definition-sources-by-name
 319        (sb-pcl::method-combination-type-name object) :method-combination)))
 320     (package
 321      (translate-source-location (sb-impl::package-source-location object)))
 322     (class
 323      (translate-source-location (sb-pcl::definition-source object)))
 324     ;; Use the PCL definition location information instead of the function
 325     ;; debug-info for methods and generic functions. Sometimes the
 326     ;; debug-info would point into PCL internals instead of the proper
 327     ;; location.
 328     (generic-function
 329      (let ((source (translate-source-location
 330                     (sb-pcl::definition-source object))))
 331        (when source
 332          (setf (definition-source-description source)
 333                (list (sb-mop:generic-function-lambda-list object))))
 334        source))
 335     (method
 336      (let ((source (translate-source-location
 337                     (sb-pcl::definition-source object))))
 338        (when source
 339          (setf (definition-source-description source)
 340                (append (method-qualifiers object)
 341                        (if (sb-mop:method-generic-function object)
 342                            (sb-pcl::unparse-specializers
 343                             (sb-mop:method-generic-function object)
 344                             (sb-mop:method-specializers object))
 345                            (sb-mop:method-specializers object)))))
 346        source))
 347     #+sb-eval
 348     (sb-eval:interpreted-function
 349      (let ((source (translate-source-location
 350                     (sb-eval:interpreted-function-source-location object))))
 351        source))
 352     (function
 353      (cond ((struct-accessor-p object)
 354             (find-definition-source
 355              (struct-accessor-structure-class object)))
 356            ((struct-predicate-p object)
 357             (find-definition-source
 358              (struct-predicate-structure-class object)))
 359            (t
 360             (find-function-definition-source object))))
 361     ((or condition standard-object structure-object)
 362      (find-definition-source (class-of object)))
 363     (t
 364      (error "Don't know how to retrieve source location for a ~S"
 365             (type-of object)))))
 366
 367 (defun find-function-definition-source (function)
 368   (let* ((debug-info (function-debug-info function))
 369          (debug-source (debug-info-source debug-info))
 370          (debug-fun (debug-info-debug-function debug-info))
 371          (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
 372     (make-definition-source
 373      :pathname
 374      ;; KLUDGE: at the moment, we don't record the correct toplevel
 375      ;; form number for forms processed by EVAL (including EVAL-WHEN
 376      ;; :COMPILE-TOPLEVEL).  Until that's fixed, don't return a
 377      ;; DEFINITION-SOURCE with a pathname.  (When that's fixed, take
 378      ;; out the (not (debug-source-form ...)) test.
 379      (if (and (sb-c::debug-source-namestring debug-source)
 380               (not (sb-c::debug-source-form debug-source)))
 381          (parse-namestring (sb-c::debug-source-namestring debug-source)))
 382      :character-offset
 383      (if tlf
 384          (elt (sb-c::debug-source-start-positions debug-source) tlf))
 385      ;; Unfortunately there is no proper source path available in the
 386      ;; debug-source. FIXME: We could use sb-di:code-locations to get
 387      ;; a full source path. -luke (12/Mar/2005)
 388      :form-path (if tlf (list tlf))
 389      :file-write-date (sb-c::debug-source-created debug-source)
 390      :plist (sb-c::debug-source-plist debug-source))))
 391
 392 (defun translate-source-location (location)
 393   (if location
 394       (make-definition-source
 395        :pathname (let ((n (sb-c:definition-source-location-namestring location)))
 396                    (when n
 397                      (parse-namestring n)))
 398        :form-path
 399        (let ((number (sb-c:definition-source-location-toplevel-form-number
 400                          location)))
 401          (when number
 402            (list number)))
 403        :plist (sb-c:definition-source-location-plist location))
 404       (make-definition-source)))
 405
 406 ;;; This is kludgey.  We expect these functions (the underlying functions,
 407 ;;; not the closures) to be in static space and so not move ever.
 408 ;;; FIXME It's also possibly wrong: not all structures use these vanilla
 409 ;;; accessors, e.g. when the :type option is used
 410 (defvar *struct-slotplace-reader*
 411   (sb-vm::%simple-fun-self #'definition-source-pathname))
 412 (defvar *struct-slotplace-writer*
 413   (sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
 414 (defvar *struct-predicate*
 415   (sb-vm::%simple-fun-self #'definition-source-p))
 416
 417 (defun struct-accessor-p (function)
 418   (let ((self (sb-vm::%simple-fun-self function)))
 419     ;; FIXME there are other kinds of struct accessor.  Fill out this list
 420     (member self (list *struct-slotplace-reader*
 421                        *struct-slotplace-writer*))))
 422
 423 (defun struct-predicate-p (function)
 424   (let ((self (sb-vm::%simple-fun-self function)))
 425     ;; FIXME there may be other structure predicate functions
 426     (member self (list *struct-predicate*))))
 427
 428 (sb-int:define-deprecated-function :late "1.0.24.5" function-arglist function-lambda-list
 429     (function)
 430   (function-lambda-list function))
 431
 432 (defun function-lambda-list (function)
 433   "Describe the lambda list for the extended function designator FUNCTION.
 434 Works for special-operators, macros, simple functions, interpreted functions,
 435 and generic functions. Signals an error if FUNCTION is not a valid extended
 436 function designator."
 437   (cond ((valid-function-name-p function)
 438          (function-lambda-list (or (and (symbolp function)
 439                                         (macro-function function))
 440                                    (fdefinition function))))
 441         ((typep function 'generic-function)
 442          (sb-pcl::generic-function-pretty-arglist function))
 443         #+sb-eval
 444         ((typep function 'sb-eval:interpreted-function)
 445          (sb-eval:interpreted-function-lambda-list function))
 446         (t
 447          (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function)))))
 448
 449 (defun deftype-lambda-list (typespec-operator)
 450   "Returns the lambda list of TYPESPEC-OPERATOR as first return
 451 value, and a flag whether the arglist could be found as second
 452 value."
 453   (check-type typespec-operator symbol)
 454   (case (sb-int:info :type :kind typespec-operator)
 455     (:defined
 456      (sb-int:info :type :lambda-list typespec-operator))
 457     (:primitive
 458      (let ((translator-fun (sb-int:info :type :translator typespec-operator)))
 459        (if translator-fun
 460            (values (sb-kernel:%fun-lambda-list translator-fun) t)
 461            ;; Some builtin types (e.g. STRING) do not have a
 462            ;; translator, but they were actually defined via DEFTYPE
 463            ;; in src/code/deftypes-for-target.lisp.
 464            (sb-int:info :type :lambda-list typespec-operator))))
 465     (t (values nil nil))))
 466
 467 (defun function-type (function-designator)
 468   "Returns the ftype of FUNCTION-DESIGNATOR, or NIL."
 469   (flet ((ftype-of (function-designator)
 470            (sb-kernel:type-specifier
 471             (sb-int:info :function :type function-designator))))
 472     (etypecase function-designator
 473       (symbol
 474        (when (and (fboundp function-designator)
 475                   (not (macro-function function-designator))
 476                   (not (special-operator-p function-designator)))
 477          (ftype-of function-designator)))
 478       (cons
 479        (when (and (sb-int:legal-fun-name-p function-designator)
 480                   (fboundp function-designator))
 481          (ftype-of function-designator)))
 482       (generic-function
 483        (function-type (sb-pcl:generic-function-name function-designator)))
 484       (function
 485        ;; Give declared type in globaldb priority over derived type
 486        ;; because it contains more accurate information e.g. for
 487        ;; struct-accessors.
 488        (let ((type (function-type (sb-kernel:%fun-name
 489                                    (sb-impl::%fun-fun function-designator)))))
 490          (if type
 491              type
 492              (sb-impl::%fun-type function-designator)))))))
 493
 494 (defun struct-accessor-structure-class (function)
 495   (let ((self (sb-vm::%simple-fun-self function)))
 496     (cond
 497       ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
 498        (find-class
 499         (sb-kernel::classoid-name
 500          (sb-kernel::layout-classoid
 501           (sb-kernel:%closure-index-ref function 1)))))
 502       )))
 503
 504 (defun struct-predicate-structure-class (function)
 505   (let ((self (sb-vm::%simple-fun-self function)))
 506     (cond
 507       ((member self (list *struct-predicate*))
 508        (find-class
 509         (sb-kernel::classoid-name
 510          (sb-kernel::layout-classoid
 511           (sb-kernel:%closure-index-ref function 0)))))
 512       )))
 513
 514 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
 515
 516 ;;; This interface is trmendously experimental.
 517
 518 ;;; For the moment I'm taking the view that FDEFN is an internal
 519 ;;; object (one out of one CMUCL developer surveyed didn't know what
 520 ;;; they were for), so these routines deal in FUNCTIONs
 521
 522 ;;; Find callers and callees by looking at the constant pool of
 523 ;;; compiled code objects.  We assume every fdefn object in the
 524 ;;; constant pool corresponds to a call to that function.  A better
 525 ;;; strategy would be to use the disassembler to find actual
 526 ;;; call-sites.
 527
 528 (defun find-function-callees (function)
 529   "Return functions called by FUNCTION."
 530   (let ((callees '()))
 531     (map-code-constants
 532      (sb-kernel:fun-code-header function)
 533      (lambda (obj)
 534        (when (sb-kernel:fdefn-p obj)
 535          (push (sb-kernel:fdefn-fun obj)
 536                callees))))
 537     callees))
 538
 539
 540 (defun find-function-callers (function &optional (spaces '(:read-only :static
 541                                                            :dynamic)))
 542   "Return functions which call FUNCTION, by searching SPACES for code objects"
 543   (let ((referrers '()))
 544     (map-caller-code-components
 545      function
 546      spaces
 547      (lambda (code)
 548        (let ((entry (sb-kernel:%code-entry-points  code)))
 549          (cond ((not entry)
 550                 (push (princ-to-string code) referrers))
 551                (t
 552                 (loop for e = entry then (sb-kernel::%simple-fun-next e)
 553                       while e
 554                       do (pushnew e referrers)))))))
 555     referrers))
 556
 557 (declaim (inline map-code-constants))
 558 (defun map-code-constants (code fn)
 559   "Call FN for each constant in CODE's constant pool."
 560   (check-type code sb-kernel:code-component)
 561   (loop for i from sb-vm:code-constants-offset below
 562         (sb-kernel:get-header-data code)
 563         do (funcall fn (sb-kernel:code-header-ref code i))))
 564
 565 (declaim (inline map-allocated-code-components))
 566 (defun map-allocated-code-components (spaces fn)
 567   "Call FN for each allocated code component in one of SPACES.  FN
 568 receives the object and its size as arguments.  SPACES should be a
 569 list of the symbols :dynamic, :static, or :read-only."
 570   (dolist (space spaces)
 571     (sb-vm::map-allocated-objects
 572      (lambda (obj header size)
 573        (when (= sb-vm:code-header-widetag header)
 574          (funcall fn obj size)))
 575      space
 576      t)))
 577
 578 (declaim (inline map-caller-code-components))
 579 (defun map-caller-code-components (function spaces fn)
 580   "Call FN for each code component with a fdefn for FUNCTION in its
 581 constant pool."
 582   (let ((function (coerce function 'function)))
 583     (map-allocated-code-components
 584      spaces
 585      (lambda (obj size)
 586        (declare (ignore size))
 587        (map-code-constants
 588         obj
 589         (lambda (constant)
 590           (when (and (sb-kernel:fdefn-p constant)
 591                      (eq (sb-kernel:fdefn-fun constant)
 592                          function))
 593             (funcall fn obj))))))))
 594
 595 ;;; XREF facility
 596
 597 (defun get-simple-fun (functoid)
 598   (etypecase functoid
 599     (sb-kernel::fdefn
 600      (get-simple-fun (sb-vm::fdefn-fun functoid)))
 601     ((or null sb-impl::funcallable-instance)
 602      nil)
 603     (function
 604      (sb-kernel::%fun-fun functoid))))
 605
 606 (defun collect-xref (kind-index wanted-name)
 607   (let ((ret nil))
 608     (dolist (env sb-c::*info-environment* ret)
 609       ;; Loop through the infodb ...
 610       (sb-c::do-info (env :class class :type type :name info-name
 611                           :value value)
 612         ;; ... looking for function or macro definitions
 613         (when (and (eql class :function)
 614                    (or (eql type :macro-function)
 615                        (eql type :definition)))
 616           ;; Get a simple-fun for the definition, and an xref array
 617           ;; from the table if available.
 618           (let* ((simple-fun (get-simple-fun value))
 619                  (xrefs (when simple-fun
 620                           (sb-kernel:%simple-fun-xrefs simple-fun)))
 621                  (array (when xrefs
 622                           (aref xrefs kind-index))))
 623             ;; Loop through the name/path xref entries in the table
 624             (loop for i from 0 below (length array) by 2
 625                   for xref-name = (aref array i)
 626                   for xref-path = (aref array (1+ i))
 627                   do (when (eql xref-name wanted-name)
 628                        (let ((source-location
 629                               (find-function-definition-source simple-fun)))
 630                          ;; Use the more accurate source path from
 631                          ;; the xref entry.
 632                          (setf (definition-source-form-path source-location)
 633                                xref-path)
 634                          (push (cons info-name source-location)
 635                                ret))))))))))
 636
 637 (defun who-calls (function-name)
 638   "Use the xref facility to search for source locations where the
 639 global function named FUNCTION-NAME is called. Returns a list of
 640 function name, definition-source pairs."
 641   (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name))
 642
 643 (defun who-binds (symbol)
 644   "Use the xref facility to search for source locations where the
 645 special variable SYMBOL is rebound. Returns a list of function name,
 646 definition-source pairs."
 647   (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol))
 648
 649 (defun who-references (symbol)
 650   "Use the xref facility to search for source locations where the
 651 special variable or constant SYMBOL is read. Returns a list of function
 652 name, definition-source pairs."
 653   (collect-xref #.(position :references sb-c::*xref-kinds*) symbol))
 654
 655 (defun who-sets (symbol)
 656   "Use the xref facility to search for source locations where the
 657 special variable SYMBOL is written to. Returns a list of function name,
 658 definition-source pairs."
 659   (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol))
 660
 661 (defun who-macroexpands (macro-name)
 662   "Use the xref facility to search for source locations where the
 663 macro MACRO-NAME is expanded. Returns a list of function name,
 664 definition-source pairs."
 665   (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
 666
 667 (defun who-specializes-directly (class-designator)
 668   "Search for source locations of methods directly specializing on
 669 CLASS-DESIGNATOR. Returns an alist of method name, definition-source
 670 pairs.
 671
 672 A method matches the criterion either if it specializes on the same
 673 class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
 674 specializers), or if it eql-specializes on an instance of the
 675 designated class.
 676
 677 Experimental.
 678 "
 679   (let ((class (canonicalize-class-designator class-designator)))
 680     (unless class
 681       (return-from who-specializes-directly nil))
 682     (let ((result (collect-specializing-methods
 683                    #'(lambda (specl)
 684                        ;; Does SPECL specialize on CLASS directly?
 685                        (typecase specl
 686                          (sb-pcl::class-eq-specializer
 687                           (eq (sb-pcl::specializer-object specl) class))
 688                          (sb-pcl::eql-specializer
 689                           (let ((obj (sb-mop:eql-specializer-object specl)))
 690                             (eq (class-of obj) class)))
 691                          ((not sb-pcl::standard-specializer)
 692                           nil)
 693                          (t
 694                           (eq specl class)))))))
 695       (map-into result #'(lambda (m)
 696                            (cons `(method ,(method-generic-function-name m))
 697                                  (find-definition-source m)))
 698                 result))))
 699
 700 (defun who-specializes-generally (class-designator)
 701   "Search for source locations of methods specializing on
 702 CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
 703 name, definition-source pairs.
 704
 705 A method matches the criterion either if it specializes on the
 706 designated class itself or a subclass of it (this includes CLASS-EQ
 707 specializers), or if it eql-specializes on an instance of the
 708 designated class or a subclass of it.
 709
 710 Experimental.
 711 "
 712   (let ((class (canonicalize-class-designator class-designator)))
 713     (unless class
 714       (return-from who-specializes-generally nil))
 715     (let ((result (collect-specializing-methods
 716                    #'(lambda (specl)
 717                        ;; Does SPECL specialize on CLASS or a subclass
 718                        ;; of it?
 719                        (typecase specl
 720                          (sb-pcl::class-eq-specializer
 721                           (subtypep (sb-pcl::specializer-object specl) class))
 722                          (sb-pcl::eql-specializer
 723                           (typep (sb-mop:eql-specializer-object specl) class))
 724                          ((not sb-pcl::standard-specializer)
 725                           nil)
 726                          (t
 727                           (subtypep specl class)))))))
 728       (map-into result #'(lambda (m)
 729                            (cons `(method ,(method-generic-function-name m))
 730                                  (find-definition-source m)))
 731                 result))))
 732
 733 (defun canonicalize-class-designator (class-designator)
 734   (typecase class-designator
 735     (symbol (find-class class-designator nil))
 736     (class  class-designator)
 737     (t nil)))
 738
 739 (defun method-generic-function-name (method)
 740   (sb-mop:generic-function-name (sb-mop:method-generic-function method)))
 741
 742 (defun collect-specializing-methods (predicate)
 743   (let ((result '()))
 744     (sb-pcl::map-specializers
 745      #'(lambda (specl)
 746          (when (funcall predicate specl)
 747            (let ((methods (sb-mop:specializer-direct-methods specl)))
 748              (setf result (append methods result))))))
 749     (delete-duplicates result)))
 750
 751
 752 ;;;; ALLOCATION INTROSPECTION
 753
 754 (defun allocation-information (object)
 755   #+sb-doc
 756   "Returns information about the allocation of OBJECT. Primary return value
 757 indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
 758 or :FOREIGN.
 759
 760 Possible secondary return value provides additional information about the
 761 allocation.
 762
 763 For :HEAP objects the secondary value is a plist:
 764
 765   :SPACE
 766     Inficates the heap segment the object is allocated in.
 767
 768   :GENERATION
 769     Is the current generation of the object: 0 for nursery, 6 for pseudo-static
 770     generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
 771
 772   :LARGE
 773     Indicates a \"large\" object subject to non-copying
 774     promotion. (GENCGC and :SPACE :DYNAMIC only.)
 775
 776   :BOXED
 777     Indicates that the object is allocated in a boxed region. Unboxed
 778     allocation is used for eg. specialized arrays after they have survived one
 779     collection. (GENCGC and :SPACE :DYNAMIC only.)
 780
 781   :PINNED
 782     Indicates that the page(s) on which the object resides are kept live due
 783     to conservative references. Note that object may reside on a pinned page
 784     even if :PINNED in NIL if the GC has not had the need to mark the the page
 785     as pinned. (GENCGC and :SPACE :DYNAMIC only.)
 786
 787   :WRITE-PROTECTED
 788     Indicates that the page on which the object starts is write-protected,
 789     which indicates for :BOXED objects that it hasn't been written to since
 790     the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
 791
 792   :PAGE
 793     The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
 794     only.)
 795
 796 For :STACK objects secondary value is the thread on whose stack the object is
 797 allocated.
 798
 799 Expected use-cases include introspection to gain insight into allocation and
 800 GC behaviour and restricting memoization to heap-allocated arguments.
 801
 802 Experimental: interface subject to change."
 803   ;; FIXME: Would be nice to provide the size of the object as well, though
 804   ;; maybe that should be a separate function, and something like MAP-PARTS
 805   ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
 806   ;; as well if they want to.
 807   ;;
 808   ;; FIXME: For the memoization use-case possibly we should also provide a
 809   ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC
 810   ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for
 811   ;; checking if an object has been stack-allocated by a given thread for
 812   ;; testing purposes might not come amiss.
 813   (if (typep object '(or fixnum character))
 814       (values :immediate nil)
 815       (let ((plist
 816              (sb-sys:without-gcing
 817                ;; Disable GC so the object cannot move to another page while
 818                ;; we have the address.
 819                (let* ((addr (sb-kernel:get-lisp-obj-address object))
 820                       (space
 821                        (cond ((< sb-vm:read-only-space-start addr
 822                                  (* sb-vm:*read-only-space-free-pointer*
 823                                     sb-vm:n-word-bytes))
 824                               :read-only)
 825                              ((< sb-vm:static-space-start addr
 826                                  (* sb-vm:*static-space-free-pointer*
 827                                     sb-vm:n-word-bytes))
 828                               :static)
 829                              ((< (sb-kernel:current-dynamic-space-start) addr
 830                                  (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
 831                               :dynamic))))
 832                  (when space
 833                    #+gencgc
 834                    (if (eq :dynamic space)
 835                        (let ((index (sb-vm::find-page-index addr)))
 836                          (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index)))
 837                            (let ((flags (sb-alien:slot page 'sb-vm::flags)))
 838                              (list :space space
 839                                    :generation (sb-alien:slot page 'sb-vm::gen)
 840                                    :write-protected (logbitp 0 flags)
 841                                    :boxed (logbitp 2 flags)
 842                                    :pinned (logbitp 5 flags)
 843                                    :large (logbitp 6 flags)
 844                                    :page index))))
 845                        (list :space space))
 846                    #-gencgc
 847                    (list :space space))))))
 848         (cond (plist
 849                (values :heap plist))
 850               (t
 851                (let ((sap (sb-sys:int-sap (sb-kernel:get-lisp-obj-address object))))
 852                  ;; FIXME: Check other stacks as well.
 853                  #+sb-thread
 854                  (dolist (thread (sb-thread:list-all-threads))
 855                    (let ((c-start (sb-di::descriptor-sap
 856                                    (sb-thread::%symbol-value-in-thread
 857                                     'sb-vm:*control-stack-start*
 858                                     thread)))
 859                          (c-end (sb-di::descriptor-sap
 860                                  (sb-thread::%symbol-value-in-thread
 861                                   'sb-vm:*control-stack-end*
 862                                   thread))))
 863                      (when (and c-start c-end)
 864                        (when (and (sb-sys:sap<= c-start sap)
 865                                   (sb-sys:sap< sap c-end))
 866                          (return-from allocation-information
 867                            (values :stack thread))))))
 868                  #-sb-thread
 869                  (when (sb-vm:control-stack-pointer-valid-p sap nil)
 870                    (return-from allocation-information
 871                      (values :stack sb-thread::*current-thread*))))
 872                :foreign)))))
 873
 874 (defun map-root (function object &key simple (ext t))
 875   "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
 876 Returns OBJECT.
 877
 878 If SIMPLE is true (default is NIL), elides those pointers that are not
 879 notionally part of certain built-in objects, but backpointers to a
 880 conceptual parent: eg. elides the pointer from a SYMBOL to the
 881 corresponding PACKAGE.
 882
 883 If EXT is true (default is T), includes some pointers that are not
 884 actually contained in the object, but found in certain well-known
 885 indirect containers: FDEFINITIONs, EQL specializers, classes, and
 886 thread-local symbol values in other threads fall into this category.
 887
 888 NOTE: calling MAP-ROOT with a THREAD does not currently map over
 889 conservative roots from the thread registers and interrupt contexts.
 890
 891 Experimental: interface subject to change."
 892   (let ((fun (coerce function 'function))
 893         (seen (sb-int:alloc-xset)))
 894     (flet ((call (part)
 895              (when (and (member (sb-kernel:lowtag-of part)
 896                                 `(,sb-vm:instance-pointer-lowtag
 897                                   ,sb-vm:list-pointer-lowtag
 898                                   ,sb-vm:fun-pointer-lowtag
 899                                   ,sb-vm:other-pointer-lowtag))
 900                         (not (sb-int:xset-member-p part seen)))
 901                (sb-int:add-to-xset part seen)
 902                (funcall fun part))))
 903       (when ext
 904         (let ((table sb-pcl::*eql-specializer-table*))
 905           (call (sb-ext:with-locked-hash-table (table)
 906                   (gethash object table)))))
 907       (etypecase object
 908         ((or bignum float sb-sys:system-area-pointer fixnum))
 909         (sb-ext:weak-pointer
 910          (call (sb-ext:weak-pointer-value object)))
 911         (cons
 912          (call (car object))
 913          (call (cdr object))
 914          (when (and ext (ignore-errors (fboundp object)))
 915            (call (fdefinition object))))
 916         (ratio
 917          (call (numerator object))
 918          (call (denominator object)))
 919         (complex
 920          (call (realpart object))
 921          (call (realpart object)))
 922         (sb-vm::instance
 923          (let* ((len (sb-kernel:%instance-length object))
 924                 (nuntagged (if (typep object 'structure-object)
 925                                (sb-kernel:layout-n-untagged-slots
 926                                 (sb-kernel:%instance-layout object))
 927                                0)))
 928            (dotimes (i (- len nuntagged))
 929              (call (sb-kernel:%instance-ref object i))))
 930          #+sb-thread
 931          (when (typep object 'sb-thread:thread)
 932            (cond ((eq object sb-thread:*current-thread*)
 933                   (dolist (value (sb-thread::%thread-local-references))
 934                     (call value))
 935                   (sb-vm::map-stack-references #'call))
 936                  (t
 937                   ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
 938                   ;; the alternative would be stopping the world...
 939                   #+sb-thread
 940                   (let ((sem (sb-thread:make-semaphore))
 941                         (refs nil))
 942                     (handler-case
 943                         (progn
 944                           (sb-thread:interrupt-thread
 945                            object
 946                            (lambda ()
 947                              (setf refs (sb-thread::%thread-local-references))
 948                              (sb-vm::map-stack-references (lambda (x) (push x refs)))
 949                              (sb-thread:signal-semaphore sem)))
 950                           (sb-thread:wait-on-semaphore sem))
 951                       (sb-thread:interrupt-thread-error ()))
 952                     (mapc #'call refs))))))
 953         (array
 954          (if (simple-vector-p object)
 955              (dotimes (i (length object))
 956                (call (aref object i)))
 957              (when (sb-kernel:array-header-p object)
 958                (call (sb-kernel::%array-data-vector object))
 959                (call (sb-kernel::%array-displaced-p object))
 960                (unless simple
 961                  (call (sb-kernel::%array-displaced-from object))))))
 962         (sb-kernel:code-component
 963          (call (sb-kernel:%code-entry-points object))
 964          (call (sb-kernel:%code-debug-info object))
 965          (loop for i from sb-vm:code-constants-offset
 966                below (sb-kernel:get-header-data object)
 967                do (call (sb-kernel:code-header-ref object i))))
 968         (sb-kernel:fdefn
 969          (call (sb-kernel:fdefn-name object))
 970          (call (sb-kernel:fdefn-fun object)))
 971         (sb-kernel:simple-fun
 972          (unless simple
 973            (call (sb-kernel:%simple-fun-next object)))
 974          (call (sb-kernel:fun-code-header object))
 975          (call (sb-kernel:%simple-fun-name object))
 976          (call (sb-kernel:%simple-fun-arglist object))
 977          (call (sb-kernel:%simple-fun-type object))
 978          (call (sb-kernel:%simple-fun-info object)))
 979         (sb-kernel:closure
 980          (call (sb-kernel:%closure-fun object))
 981          (sb-kernel:do-closure-values (x object)
 982            (call x)))
 983         (sb-kernel:funcallable-instance
 984          (call (sb-kernel:%funcallable-instance-function object))
 985          (loop for i from 1 below (- (1+ (sb-kernel:get-closure-length object))
 986                                      sb-vm::funcallable-instance-info-offset)
 987                do (call (sb-kernel:%funcallable-instance-info object i))))
 988         (symbol
 989          (when ext
 990            (dolist (thread (sb-thread:list-all-threads))
 991              (call (sb-thread:symbol-value-in-thread object thread nil))))
 992          (handler-case
 993              ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg.
 994              (call (sb-ext:symbol-global-value object))
 995            (unbound-variable ()))
 996          (when (and ext (ignore-errors (fboundp object)))
 997            (call (fdefinition object))
 998            (call (macro-function object))
 999            (let ((class (find-class object nil)))
1000              (when class (call class))))
1001          (call (symbol-plist object))
1002          (call (symbol-name object))
1003          (unless simple
1004            (call (symbol-package object))))
1005         (sb-kernel::random-class
1006          (case (sb-kernel:widetag-of object)
1007            (#.sb-vm::value-cell-header-widetag
1008             (call (sb-kernel::value-cell-ref object)))
1009            #+(and sb-lutex sb-thread)
1010            (#.sb-vm::lutex-widetag)
1011            (t
1012             (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
1013                   (sb-kernel:widetag-of object) object)))))))
1014   object)