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