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