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