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)
 875   "Call FUNCTION with all non-immediate objects pointed to by OBJECT. Returns
 876 OBJECT.
 877
 878 If SIMPLE is true, elides those pointers that are not notionally part of
 879 certain built-in objects, but backpointers to a conceptual parent: eg. elides
 880 the pointer from a SYMBOL to the corresponding PACKAGE.
 881
 882 If EXT is true, includes some pointers that are not actually contained in the
 883 object, but in well-known indirect containers. For example, symbols in SBCL do
 884 not directly point to their SYMBOL-FUNCTION or class by the same name, but
 885 when :EXT T is used MAP-ROOT will also walk the function and class (if any)
 886 associated with the symbol.
 887
 888 NOTE: calling MAP-ROOT with a THREAD does not currently map over conservative
 889 roots from the thread stack & interrupt contexts, nor over thread-local symbol
 890 bindings.
 891
 892 Experimental: interface subject to change."
 893   (let ((fun (coerce function 'function)))
 894     (flet ((call (part)
 895              (when (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                (funcall fun part))))
 901       (etypecase object
 902         ((or bignum float sb-sys:system-area-pointer fixnum))
 903         (sb-ext:weak-pointer
 904          (call (sb-ext:weak-pointer-value object)))
 905         (cons
 906          (call (car object))
 907          (call (cdr object))
 908          (when (and ext (ignore-errors (fboundp object)))
 909            (call (fdefinition object))))
 910         (ratio
 911          (call (numerator object))
 912          (call (denominator object)))
 913         (complex
 914          (call (realpart object))
 915          (call (realpart object)))
 916         (sb-vm::instance
 917          (let* ((len (sb-kernel:%instance-length object))
 918                 (nuntagged (if (typep object 'structure-object)
 919                                (sb-kernel:layout-n-untagged-slots
 920                                 (sb-kernel:%instance-layout object))
 921                                0)))
 922            (dotimes (i (- len nuntagged))
 923              (call (sb-kernel:%instance-ref object i)))))
 924         (array
 925          (if (simple-vector-p object)
 926              (dotimes (i (length object))
 927                (call (aref object i)))
 928              (when (sb-kernel:array-header-p object)
 929                (call (sb-kernel::%array-data-vector object))
 930                (call (sb-kernel::%array-displaced-p object))
 931                (unless simple
 932                  (call (sb-kernel::%array-displaced-from object))))))
 933         (sb-kernel:code-component
 934          (call (sb-kernel:%code-entry-points object))
 935          (call (sb-kernel:%code-debug-info object))
 936          (loop for i from sb-vm:code-constants-offset
 937                below (sb-kernel:get-header-data object)
 938                do (call (sb-kernel:code-header-ref object i))))
 939         (sb-kernel:fdefn
 940          (call (sb-kernel:fdefn-name object))
 941          (call (sb-kernel:fdefn-fun object)))
 942         (sb-kernel:simple-fun
 943          (unless simple
 944            (call (sb-kernel:%simple-fun-next object)))
 945          (call (sb-kernel:fun-code-header object))
 946          (call (sb-kernel:%simple-fun-name object))
 947          (call (sb-kernel:%simple-fun-arglist object))
 948          (call (sb-kernel:%simple-fun-type object))
 949          (call (sb-kernel:%simple-fun-info object)))
 950         (sb-kernel:closure
 951          (call (sb-kernel:%closure-fun object))
 952          (sb-kernel:do-closure-values (x object)
 953            (call x)))
 954         (sb-kernel:funcallable-instance
 955          (call (sb-kernel:%funcallable-instance-function object))
 956          (loop for i from 1 below (- (1+ (sb-kernel:get-closure-length object))
 957                                      sb-vm::funcallable-instance-info-offset)
 958                do (call (sb-kernel:%funcallable-instance-info object i))))
 959         (symbol
 960          (when (boundp object)
 961            (let ((local (symbol-value object)))
 962              (handler-case
 963                  ;; Possibly bound only in the current thread -- and we don't
 964                  ;; have GLOBAL-BOUNDP.
 965                  (let ((global (sb-ext:symbol-global-value object)))
 966                    (unless (eq local global)
 967                      (call global)))
 968                (unbound-variable ()
 969                  nil))))
 970          (when (and ext (ignore-errors (fboundp object)))
 971            (call (fdefinition object))
 972            (let ((class (find-class object nil)))
 973              (when class (call class))))
 974          (call (symbol-plist object))
 975          (call (symbol-name object))
 976          (unless simple
 977            (call (symbol-package object))))
 978         (sb-kernel::random-class
 979          (case (sb-kernel:widetag-of object)
 980            (#.sb-vm::value-cell-header-widetag
 981             (call (sb-kernel::value-cell-ref object)))
 982            #+(and sb-lutex sb-thread)
 983            (#.sb-vm::lutex-widetag)
 984            (t
 985             (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
 986                   (sb-kernel:widetag-of object) object)))))))
 987   object)