ff6152bcae180536b74ddc369271a609de576327
[sbcl.git] / 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
618 (declaim (inline map-caller-code-components))
619 (defun map-caller-code-components (function spaces fn)
620   "Call FN for each code component with a fdefn for FUNCTION in its
621 constant pool."
622   (let ((function (coerce function 'function)))
623     (map-allocated-code-components
624      spaces
625      (lambda (obj size)
626        (declare (ignore size))
627        (map-code-constants
628         obj
629         (lambda (constant)
630           (when (and (sb-kernel:fdefn-p constant)
631                      (eq (sb-kernel:fdefn-fun constant)
632                          function))
633             (funcall fn obj))))))))
634
635 ;;; XREF facility
636
637 (defun get-simple-fun (functoid)
638   (etypecase functoid
639     (sb-kernel::fdefn
640      (get-simple-fun (sb-vm::fdefn-fun functoid)))
641     ((or null sb-impl::funcallable-instance)
642      nil)
643     (function
644      (sb-kernel::%fun-fun functoid))))
645
646 (defun collect-xref (kind-index wanted-name)
647   (let ((ret nil))
648     (dolist (env sb-c::*info-environment* ret)
649       ;; Loop through the infodb ...
650       (sb-c::do-info (env :class class :type type :name info-name
651                           :value value)
652         ;; ... looking for function or macro definitions
653         (when (and (eql class :function)
654                    (or (eql type :macro-function)
655                        (eql type :definition)))
656           ;; Get a simple-fun for the definition, and an xref array
657           ;; from the table if available.
658           (let* ((simple-fun (get-simple-fun value))
659                  (xrefs (when simple-fun
660                           (sb-kernel:%simple-fun-xrefs simple-fun)))
661                  (array (when xrefs
662                           (aref xrefs kind-index))))
663             ;; Loop through the name/path xref entries in the table
664             (loop for i from 0 below (length array) by 2
665                   for xref-name = (aref array i)
666                   for xref-path = (aref array (1+ i))
667                   do (when (equal xref-name wanted-name)
668                        (let ((source-location
669                               (find-function-definition-source simple-fun)))
670                          ;; Use the more accurate source path from
671                          ;; the xref entry.
672                          (setf (definition-source-form-path source-location)
673                                xref-path)
674                          (push (cons info-name source-location)
675                                ret))))))))))
676
677 (defun who-calls (function-name)
678   "Use the xref facility to search for source locations where the
679 global function named FUNCTION-NAME is called. Returns a list of
680 function name, definition-source pairs."
681   (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name))
682
683 (defun who-binds (symbol)
684   "Use the xref facility to search for source locations where the
685 special variable SYMBOL is rebound. Returns a list of function name,
686 definition-source pairs."
687   (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol))
688
689 (defun who-references (symbol)
690   "Use the xref facility to search for source locations where the
691 special variable or constant SYMBOL is read. Returns a list of function
692 name, definition-source pairs."
693   (collect-xref #.(position :references sb-c::*xref-kinds*) symbol))
694
695 (defun who-sets (symbol)
696   "Use the xref facility to search for source locations where the
697 special variable SYMBOL is written to. Returns a list of function name,
698 definition-source pairs."
699   (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol))
700
701 (defun who-macroexpands (macro-name)
702   "Use the xref facility to search for source locations where the
703 macro MACRO-NAME is expanded. Returns a list of function name,
704 definition-source pairs."
705   (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
706
707 (defun who-specializes-directly (class-designator)
708   "Search for source locations of methods directly specializing on
709 CLASS-DESIGNATOR. Returns an alist of method name, definition-source
710 pairs.
711
712 A method matches the criterion either if it specializes on the same
713 class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
714 specializers), or if it eql-specializes on an instance of the
715 designated class.
716
717 Experimental.
718 "
719   (let ((class (canonicalize-class-designator class-designator)))
720     (unless class
721       (return-from who-specializes-directly nil))
722     (let ((result (collect-specializing-methods
723                    #'(lambda (specl)
724                        ;; Does SPECL specialize on CLASS directly?
725                        (typecase specl
726                          (sb-pcl::class-eq-specializer
727                           (eq (sb-pcl::specializer-object specl) class))
728                          (sb-pcl::eql-specializer
729                           (let ((obj (sb-mop:eql-specializer-object specl)))
730                             (eq (class-of obj) class)))
731                          ((not sb-pcl::standard-specializer)
732                           nil)
733                          (t
734                           (eq specl class)))))))
735       (map-into result #'(lambda (m)
736                            (cons `(method ,(method-generic-function-name m))
737                                  (find-definition-source m)))
738                 result))))
739
740 (defun who-specializes-generally (class-designator)
741   "Search for source locations of methods specializing on
742 CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
743 name, definition-source pairs.
744
745 A method matches the criterion either if it specializes on the
746 designated class itself or a subclass of it (this includes CLASS-EQ
747 specializers), or if it eql-specializes on an instance of the
748 designated class or a subclass of it.
749
750 Experimental.
751 "
752   (let ((class (canonicalize-class-designator class-designator)))
753     (unless class
754       (return-from who-specializes-generally nil))
755     (let ((result (collect-specializing-methods
756                    #'(lambda (specl)
757                        ;; Does SPECL specialize on CLASS or a subclass
758                        ;; of it?
759                        (typecase specl
760                          (sb-pcl::class-eq-specializer
761                           (subtypep (sb-pcl::specializer-object specl) class))
762                          (sb-pcl::eql-specializer
763                           (typep (sb-mop:eql-specializer-object specl) class))
764                          ((not sb-pcl::standard-specializer)
765                           nil)
766                          (t
767                           (subtypep specl class)))))))
768       (map-into result #'(lambda (m)
769                            (cons `(method ,(method-generic-function-name m))
770                                  (find-definition-source m)))
771                 result))))
772
773 (defun canonicalize-class-designator (class-designator)
774   (typecase class-designator
775     (symbol (find-class class-designator nil))
776     (class  class-designator)
777     (t nil)))
778
779 (defun method-generic-function-name (method)
780   (sb-mop:generic-function-name (sb-mop:method-generic-function method)))
781
782 (defun collect-specializing-methods (predicate)
783   (let ((result '()))
784     (sb-pcl::map-specializers
785      #'(lambda (specl)
786          (when (funcall predicate specl)
787            (let ((methods (sb-mop:specializer-direct-methods specl)))
788              (setf result (append methods result))))))
789     (delete-duplicates result)))
790
791
792 ;;;; ALLOCATION INTROSPECTION
793
794 (defun allocation-information (object)
795   #+sb-doc
796   "Returns information about the allocation of OBJECT. Primary return value
797 indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
798 or :FOREIGN.
799
800 Possible secondary return value provides additional information about the
801 allocation.
802
803 For :HEAP objects the secondary value is a plist:
804
805   :SPACE
806     Inficates the heap segment the object is allocated in.
807
808   :GENERATION
809     Is the current generation of the object: 0 for nursery, 6 for pseudo-static
810     generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
811
812   :LARGE
813     Indicates a \"large\" object subject to non-copying
814     promotion. (GENCGC and :SPACE :DYNAMIC only.)
815
816   :BOXED
817     Indicates that the object is allocated in a boxed region. Unboxed
818     allocation is used for eg. specialized arrays after they have survived one
819     collection. (GENCGC and :SPACE :DYNAMIC only.)
820
821   :PINNED
822     Indicates that the page(s) on which the object resides are kept live due
823     to conservative references. Note that object may reside on a pinned page
824     even if :PINNED in NIL if the GC has not had the need to mark the the page
825     as pinned. (GENCGC and :SPACE :DYNAMIC only.)
826
827   :WRITE-PROTECTED
828     Indicates that the page on which the object starts is write-protected,
829     which indicates for :BOXED objects that it hasn't been written to since
830     the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
831
832   :PAGE
833     The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
834     only.)
835
836 For :STACK objects secondary value is the thread on whose stack the object is
837 allocated.
838
839 Expected use-cases include introspection to gain insight into allocation and
840 GC behaviour and restricting memoization to heap-allocated arguments.
841
842 Experimental: interface subject to change."
843   ;; FIXME: Would be nice to provide the size of the object as well, though
844   ;; maybe that should be a separate function, and something like MAP-PARTS
845   ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
846   ;; as well if they want to.
847   ;;
848   ;; FIXME: For the memoization use-case possibly we should also provide a
849   ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC
850   ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for
851   ;; checking if an object has been stack-allocated by a given thread for
852   ;; testing purposes might not come amiss.
853   (if (typep object '(or fixnum character))
854       (values :immediate nil)
855       (let ((plist
856              (sb-sys:without-gcing
857                ;; Disable GC so the object cannot move to another page while
858                ;; we have the address.
859                (let* ((addr (sb-kernel:get-lisp-obj-address object))
860                       (space
861                        (cond ((< sb-vm:read-only-space-start addr
862                                  (ash sb-vm:*read-only-space-free-pointer*
863                                       sb-vm:n-fixnum-tag-bits))
864                               :read-only)
865                              ((< sb-vm:static-space-start addr
866                                  (ash sb-vm:*static-space-free-pointer*
867                                       sb-vm:n-fixnum-tag-bits))
868                               :static)
869                              ((< (sb-kernel:current-dynamic-space-start) addr
870                                  (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
871                               :dynamic))))
872                  (when space
873                    #+gencgc
874                    (if (eq :dynamic space)
875                        (let ((index (sb-vm::find-page-index addr)))
876                          (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index)))
877                            (let ((flags (sb-alien:slot page 'sb-vm::flags)))
878                              (list :space space
879                                    :generation (sb-alien:slot page 'sb-vm::gen)
880                                    :write-protected (logbitp 0 flags)
881                                    :boxed (logbitp 2 flags)
882                                    :pinned (logbitp 5 flags)
883                                    :large (logbitp 6 flags)
884                                    :page index))))
885                        (list :space space))
886                    #-gencgc
887                    (list :space space))))))
888         (cond (plist
889                (values :heap plist))
890               (t
891                (let ((sap (sb-sys:int-sap (sb-kernel:get-lisp-obj-address object))))
892                  ;; FIXME: Check other stacks as well.
893                  #+sb-thread
894                  (dolist (thread (sb-thread:list-all-threads))
895                    (let ((c-start (sb-di::descriptor-sap
896                                    (sb-thread::%symbol-value-in-thread
897                                     'sb-vm:*control-stack-start*
898                                     thread)))
899                          (c-end (sb-di::descriptor-sap
900                                  (sb-thread::%symbol-value-in-thread
901                                   'sb-vm:*control-stack-end*
902                                   thread))))
903                      (when (and c-start c-end)
904                        (when (and (sb-sys:sap<= c-start sap)
905                                   (sb-sys:sap< sap c-end))
906                          (return-from allocation-information
907                            (values :stack thread))))))
908                  #-sb-thread
909                  (when (sb-vm:control-stack-pointer-valid-p sap nil)
910                    (return-from allocation-information
911                      (values :stack sb-thread::*current-thread*))))
912                :foreign)))))
913
914 (defun map-root (function object &key simple (ext t))
915   "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
916 Returns OBJECT.
917
918 If SIMPLE is true (default is NIL), elides those pointers that are not
919 notionally part of certain built-in objects, but backpointers to a
920 conceptual parent: eg. elides the pointer from a SYMBOL to the
921 corresponding PACKAGE.
922
923 If EXT is true (default is T), includes some pointers that are not
924 actually contained in the object, but found in certain well-known
925 indirect containers: FDEFINITIONs, EQL specializers, classes, and
926 thread-local symbol values in other threads fall into this category.
927
928 NOTE: calling MAP-ROOT with a THREAD does not currently map over
929 conservative roots from the thread registers and interrupt contexts.
930
931 Experimental: interface subject to change."
932   (let ((fun (coerce function 'function))
933         (seen (sb-int:alloc-xset)))
934     (flet ((call (part)
935              (when (and (member (sb-kernel:lowtag-of part)
936                                 `(,sb-vm:instance-pointer-lowtag
937                                   ,sb-vm:list-pointer-lowtag
938                                   ,sb-vm:fun-pointer-lowtag
939                                   ,sb-vm:other-pointer-lowtag))
940                         (not (sb-int:xset-member-p part seen)))
941                (sb-int:add-to-xset part seen)
942                (funcall fun part))))
943       (when ext
944         (let ((table sb-pcl::*eql-specializer-table*))
945           (call (sb-int:with-locked-system-table (table)
946                   (gethash object table)))))
947       (etypecase object
948         ((or bignum float sb-sys:system-area-pointer fixnum))
949         (sb-ext:weak-pointer
950          (call (sb-ext:weak-pointer-value object)))
951         (cons
952          (call (car object))
953          (call (cdr object))
954          (when (and ext (ignore-errors (fboundp object)))
955            (call (fdefinition object))))
956         (ratio
957          (call (numerator object))
958          (call (denominator object)))
959         (complex
960          (call (realpart object))
961          (call (realpart object)))
962         (sb-vm::instance
963          (let* ((len (sb-kernel:%instance-length object))
964                 (nuntagged (if (typep object 'structure-object)
965                                (sb-kernel:layout-n-untagged-slots
966                                 (sb-kernel:%instance-layout object))
967                                0)))
968            (dotimes (i (- len nuntagged))
969              (call (sb-kernel:%instance-ref object i))))
970          #+sb-thread
971          (when (typep object 'sb-thread:thread)
972            (cond ((eq object sb-thread:*current-thread*)
973                   (dolist (value (sb-thread::%thread-local-references))
974                     (call value))
975                   (sb-vm::map-stack-references #'call))
976                  (t
977                   ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
978                   ;; the alternative would be stopping the world...
979                   #+sb-thread
980                   (let ((sem (sb-thread:make-semaphore))
981                         (refs nil))
982                     (handler-case
983                         (progn
984                           (sb-thread:interrupt-thread
985                            object
986                            (lambda ()
987                              (setf refs (sb-thread::%thread-local-references))
988                              (sb-vm::map-stack-references (lambda (x) (push x refs)))
989                              (sb-thread:signal-semaphore sem)))
990                           (sb-thread:wait-on-semaphore sem))
991                       (sb-thread:interrupt-thread-error ()))
992                     (mapc #'call refs))))))
993         (array
994          (if (simple-vector-p object)
995              (dotimes (i (length object))
996                (call (aref object i)))
997              (when (sb-kernel:array-header-p object)
998                (call (sb-kernel::%array-data-vector object))
999                (call (sb-kernel::%array-displaced-p object))
1000                (unless simple
1001                  (call (sb-kernel::%array-displaced-from object))))))
1002         (sb-kernel:code-component
1003          (call (sb-kernel:%code-entry-points object))
1004          (call (sb-kernel:%code-debug-info object))
1005          (loop for i from sb-vm:code-constants-offset
1006                below (sb-kernel:get-header-data object)
1007                do (call (sb-kernel:code-header-ref object i))))
1008         (sb-kernel:fdefn
1009          (call (sb-kernel:fdefn-name object))
1010          (call (sb-kernel:fdefn-fun object)))
1011         (sb-kernel:simple-fun
1012          (unless simple
1013            (call (sb-kernel:%simple-fun-next object)))
1014          (call (sb-kernel:fun-code-header object))
1015          (call (sb-kernel:%simple-fun-name object))
1016          (call (sb-kernel:%simple-fun-arglist object))
1017          (call (sb-kernel:%simple-fun-type object))
1018          (call (sb-kernel:%simple-fun-info object)))
1019         (sb-kernel:closure
1020          (call (sb-kernel:%closure-fun object))
1021          (sb-kernel:do-closure-values (x object)
1022            (call x)))
1023         (sb-kernel:funcallable-instance
1024          (call (sb-kernel:%funcallable-instance-function object))
1025          (loop for i from 1 below (- (1+ (sb-kernel:get-closure-length object))
1026                                      sb-vm::funcallable-instance-info-offset)
1027                do (call (sb-kernel:%funcallable-instance-info object i))))
1028         (symbol
1029          (when ext
1030            (dolist (thread (sb-thread:list-all-threads))
1031              (call (sb-thread:symbol-value-in-thread object thread nil))))
1032          (handler-case
1033              ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg.
1034              (call (sb-ext:symbol-global-value object))
1035            (unbound-variable ()))
1036          (when (and ext (ignore-errors (fboundp object)))
1037            (call (fdefinition object))
1038            (call (macro-function object))
1039            (let ((class (find-class object nil)))
1040              (when class (call class))))
1041          (call (symbol-plist object))
1042          (call (symbol-name object))
1043          (unless simple
1044            (call (symbol-package object))))
1045         (sb-kernel::random-class
1046          (case (sb-kernel:widetag-of object)
1047            (#.sb-vm::value-cell-header-widetag
1048             (call (sb-kernel::value-cell-ref object)))
1049            (t
1050             (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
1051                   (sb-kernel:widetag-of object) object)))))))
1052   object)