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