1 ;;; introspection library
3 ;;;; This software is part of the SBCL system. See the README file for
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.
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.
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.
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?
29 (defpackage :sb-introspect
31 (:export "ALLOCATION-INFORMATION"
33 "FUNCTION-LAMBDA-LIST"
36 "VALID-FUNCTION-NAME-P"
37 "FIND-DEFINITION-SOURCE"
38 "FIND-DEFINITION-SOURCES-BY-NAME"
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"
54 "WHO-SPECIALIZES-DIRECTLY"
55 "WHO-SPECIALIZES-GENERALLY"))
57 (in-package :sb-introspect)
59 ;;;; Internal interface for SBCL debug info
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.
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)
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."
77 (deftype debug-function ()
78 "Debug function represent static compile-time information about a function."
79 'sb-c::compiled-debug-fun)
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)))
87 (declaim (ftype (function (function) debug-source) function-debug-source))
88 (defun function-debug-source (function)
89 (debug-info-source (function-debug-info function)))
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))
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))
99 (defun valid-function-name-p (name)
100 "True if NAME denotes a valid function name, ie. one that can be passed to
102 (and (sb-int:valid-function-name-p name) t))
104 ;;;; Finding definitions
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
122 ;; Any extra metadata that the caller might be interested in. For
123 ;; example the specializers of the method whose definition-source this
125 (description nil :type list))
127 (defun vop-sources-from-fun-templates (name)
128 (let ((fun-info (sb-int:info :function :info name)))
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)))
138 (defun find-vop-source (name)
139 (let* ((templates (vop-sources-from-fun-templates name))
140 (vop (gethash name sb-c::*backend-template-names*))
142 (find-definition-source
143 (sb-c::vop-info-generator-function vop)))))
145 (setf (definition-source-description source)
148 (cons source templates)
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:
179 If an unsupported TYPE is requested, the function will return NIL.
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*)))
193 (sb-profile::profile-info-encapsulated-fun profile-info)
194 (fdefinition name)))))
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))))
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))))
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))))
210 (when (and (symbolp name)
211 (macro-function name))
212 (find-definition-source (macro-function name))))
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)))))
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)))
230 (translate-source-location loc)
231 (let ((expander-fun (sb-int:info :type :expander name)))
233 (find-definition-source expander-fun))))))
236 (let ((fun (real-fdefinition name)))
237 (when (typep fun 'generic-function)
238 (loop for method in (sb-mop::generic-function-methods
240 for source = (find-definition-source method)
241 when source collect source)))))
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))))
249 (find-definition-source (if (symbolp expander)
250 (symbol-function expander)
253 (let ((class (get-class name)))
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))))))
261 (let ((class (get-class name)))
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
271 (list (find-class 'generic-function)
275 (when combination-fun
276 (find-definition-source combination-fun))))
279 (let ((package (find-package name)))
281 (find-definition-source package)))))
282 ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
285 (let ((fun-info (sb-int:info :function :info name)))
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)
295 (list (second typespec) note)
299 (let ((fun-info (and (symbolp name)
300 (sb-int:info :function :info name))))
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)
311 (let ((source (find-definition-source fn)))
312 (setf (definition-source-description source)
317 (find-vop-source name)))
320 (let ((transform-fun (sb-int:info :function :source-transform name)))
322 (find-definition-source transform-fun)))))
326 (defun find-definition-source (object)
328 ((or sb-pcl::condition-class sb-pcl::structure-class)
329 (let ((classoid (sb-impl::find-classoid (class-name object))))
331 (let ((layout (sb-impl::classoid-layout classoid)))
333 (translate-source-location
334 (sb-kernel::layout-source-location layout)))))))
337 (find-definition-sources-by-name
338 (sb-pcl::method-combination-type-name object) :method-combination)))
340 (translate-source-location (sb-impl::package-source-location object)))
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
348 (let ((source (translate-source-location
349 (sb-pcl::definition-source object))))
351 (setf (definition-source-description source)
352 (list (sb-mop:generic-function-lambda-list object))))
355 (let ((source (translate-source-location
356 (sb-pcl::definition-source object))))
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)))))
367 (sb-eval:interpreted-function
368 (let ((source (translate-source-location
369 (sb-eval:interpreted-function-source-location object))))
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)))
382 (find-function-definition-source object))))
383 ((or condition standard-object structure-object)
384 (find-definition-source (class-of object)))
386 (error "Don't know how to retrieve source location for a ~S"
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
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)))
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))))
413 (defun translate-source-location (location)
415 (make-definition-source
416 :pathname (let ((n (sb-c:definition-source-location-namestring location)))
418 (parse-namestring n)))
420 (let ((number (sb-c:definition-source-location-toplevel-form-number
424 :plist (sb-c:definition-source-location-plist location))
425 (make-definition-source)))
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))
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*))))
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*))))
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*))))
456 (sb-int:define-deprecated-function :late "1.0.24.5" function-arglist function-lambda-list
458 (function-lambda-list function))
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))
472 ((typep function 'sb-eval:interpreted-function)
473 (sb-eval:interpreted-function-lambda-list function))
475 (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function)))))
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
481 (check-type typespec-operator symbol)
482 (case (sb-int:info :type :kind typespec-operator)
484 (sb-int:info :type :lambda-list typespec-operator))
486 (let ((translator-fun (sb-int:info :type :translator typespec-operator)))
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))))
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
502 (when (and (fboundp function-designator)
503 (not (macro-function function-designator))
504 (not (special-operator-p function-designator)))
505 (ftype-of function-designator)))
507 (when (and (sb-int:legal-fun-name-p function-designator)
508 (fboundp function-designator))
509 (ftype-of function-designator)))
511 (function-type (sb-pcl:generic-function-name function-designator)))
513 ;; Give declared type in globaldb priority over derived type
514 ;; because it contains more accurate information e.g. for
516 (let ((type (function-type (sb-kernel:%fun-name
517 (sb-impl::%fun-fun function-designator)))))
520 (sb-impl::%fun-type function-designator)))))))
522 ;;; FIXME: These three are pretty terrible. Can we place have some proper metadata
525 (defun struct-accessor-structure-class (function)
526 (let ((self (sb-vm::%simple-fun-self function)))
528 ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
530 (sb-kernel::classoid-name
531 (sb-kernel::layout-classoid
532 (sb-kernel:%closure-index-ref function 1)))))
535 (defun struct-copier-structure-class (function)
536 (let ((self (sb-vm::%simple-fun-self function)))
538 ((member self (list *struct-copier*))
540 (sb-kernel::classoid-name
541 (sb-kernel::layout-classoid
542 (sb-kernel:%closure-index-ref function 0)))))
545 (defun struct-predicate-structure-class (function)
546 (let ((self (sb-vm::%simple-fun-self function)))
548 ((member self (list *struct-predicate*))
550 (sb-kernel::classoid-name
551 (sb-kernel::layout-classoid
552 (sb-kernel:%closure-index-ref function 0)))))
555 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
557 ;;; This interface is trmendously experimental.
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
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
569 (defun find-function-callees (function)
570 "Return functions called by FUNCTION."
573 (sb-kernel:fun-code-header function)
575 (when (sb-kernel:fdefn-p obj)
576 (push (sb-kernel:fdefn-fun obj)
581 (defun find-function-callers (function &optional (spaces '(:read-only :static
583 "Return functions which call FUNCTION, by searching SPACES for code objects"
584 (let ((referrers '()))
585 (map-caller-code-components
589 (let ((entry (sb-kernel:%code-entry-points code)))
591 (push (princ-to-string code) referrers))
593 (loop for e = entry then (sb-kernel::%simple-fun-next e)
595 do (pushnew e referrers)))))))
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))))
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)))
619 (declaim (inline map-caller-code-components))
620 (defun map-caller-code-components (function spaces fn)
621 "Call FN for each code component with a fdefn for FUNCTION in its
623 (let ((function (coerce function 'function)))
624 (map-allocated-code-components
627 (declare (ignore size))
631 (when (and (sb-kernel:fdefn-p constant)
632 (eq (sb-kernel:fdefn-fun constant)
634 (funcall fn obj))))))))
638 (defun get-simple-fun (functoid)
641 (get-simple-fun (sb-vm::fdefn-fun functoid)))
642 ((or null sb-impl::funcallable-instance)
645 (sb-kernel::%fun-fun functoid))))
647 (defun collect-xref (kind-index wanted-name)
649 (dolist (env sb-c::*info-environment* ret)
650 ;; Loop through the infodb ...
651 (sb-c::do-info (env :class class :type type :name info-name
653 ;; ... looking for function or macro definitions
654 (when (and (eql class :function)
655 (or (eql type :macro-function)
656 (eql type :definition)))
657 ;; Get a simple-fun for the definition, and an xref array
658 ;; from the table if available.
659 (let* ((simple-fun (get-simple-fun value))
660 (xrefs (when simple-fun
661 (sb-kernel:%simple-fun-xrefs simple-fun)))
663 (aref xrefs kind-index))))
664 ;; Loop through the name/path xref entries in the table
665 (loop for i from 0 below (length array) by 2
666 for xref-name = (aref array i)
667 for xref-path = (aref array (1+ i))
668 do (when (equal xref-name wanted-name)
669 (let ((source-location
670 (find-function-definition-source simple-fun)))
671 ;; Use the more accurate source path from
673 (setf (definition-source-form-path source-location)
675 (push (cons info-name source-location)
678 (defun who-calls (function-name)
679 "Use the xref facility to search for source locations where the
680 global function named FUNCTION-NAME is called. Returns a list of
681 function name, definition-source pairs."
682 (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name))
684 (defun who-binds (symbol)
685 "Use the xref facility to search for source locations where the
686 special variable SYMBOL is rebound. Returns a list of function name,
687 definition-source pairs."
688 (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol))
690 (defun who-references (symbol)
691 "Use the xref facility to search for source locations where the
692 special variable or constant SYMBOL is read. Returns a list of function
693 name, definition-source pairs."
694 (collect-xref #.(position :references sb-c::*xref-kinds*) symbol))
696 (defun who-sets (symbol)
697 "Use the xref facility to search for source locations where the
698 special variable SYMBOL is written to. Returns a list of function name,
699 definition-source pairs."
700 (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol))
702 (defun who-macroexpands (macro-name)
703 "Use the xref facility to search for source locations where the
704 macro MACRO-NAME is expanded. Returns a list of function name,
705 definition-source pairs."
706 (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
708 (defun who-specializes-directly (class-designator)
709 "Search for source locations of methods directly specializing on
710 CLASS-DESIGNATOR. Returns an alist of method name, definition-source
713 A method matches the criterion either if it specializes on the same
714 class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
715 specializers), or if it eql-specializes on an instance of the
720 (let ((class (canonicalize-class-designator class-designator)))
722 (return-from who-specializes-directly nil))
723 (let ((result (collect-specializing-methods
725 ;; Does SPECL specialize on CLASS directly?
727 (sb-pcl::class-eq-specializer
728 (eq (sb-pcl::specializer-object specl) class))
729 (sb-pcl::eql-specializer
730 (let ((obj (sb-mop:eql-specializer-object specl)))
731 (eq (class-of obj) class)))
732 ((not sb-pcl::standard-specializer)
735 (eq specl class)))))))
736 (map-into result #'(lambda (m)
737 (cons `(method ,(method-generic-function-name m))
738 (find-definition-source m)))
741 (defun who-specializes-generally (class-designator)
742 "Search for source locations of methods specializing on
743 CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
744 name, definition-source pairs.
746 A method matches the criterion either if it specializes on the
747 designated class itself or a subclass of it (this includes CLASS-EQ
748 specializers), or if it eql-specializes on an instance of the
749 designated class or a subclass of it.
753 (let ((class (canonicalize-class-designator class-designator)))
755 (return-from who-specializes-generally nil))
756 (let ((result (collect-specializing-methods
758 ;; Does SPECL specialize on CLASS or a subclass
761 (sb-pcl::class-eq-specializer
762 (subtypep (sb-pcl::specializer-object specl) class))
763 (sb-pcl::eql-specializer
764 (typep (sb-mop:eql-specializer-object specl) class))
765 ((not sb-pcl::standard-specializer)
768 (subtypep specl class)))))))
769 (map-into result #'(lambda (m)
770 (cons `(method ,(method-generic-function-name m))
771 (find-definition-source m)))
774 (defun canonicalize-class-designator (class-designator)
775 (typecase class-designator
776 (symbol (find-class class-designator nil))
777 (class class-designator)
780 (defun method-generic-function-name (method)
781 (sb-mop:generic-function-name (sb-mop:method-generic-function method)))
783 (defun collect-specializing-methods (predicate)
785 (sb-pcl::map-specializers
787 (when (funcall predicate specl)
788 (let ((methods (sb-mop:specializer-direct-methods specl)))
789 (setf result (append methods result))))))
790 (delete-duplicates result)))
793 ;;;; ALLOCATION INTROSPECTION
795 (defun allocation-information (object)
797 "Returns information about the allocation of OBJECT. Primary return value
798 indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
801 Possible secondary return value provides additional information about the
804 For :HEAP objects the secondary value is a plist:
807 Inficates the heap segment the object is allocated in.
810 Is the current generation of the object: 0 for nursery, 6 for pseudo-static
811 generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
814 Indicates a \"large\" object subject to non-copying
815 promotion. (GENCGC and :SPACE :DYNAMIC only.)
818 Indicates that the object is allocated in a boxed region. Unboxed
819 allocation is used for eg. specialized arrays after they have survived one
820 collection. (GENCGC and :SPACE :DYNAMIC only.)
823 Indicates that the page(s) on which the object resides are kept live due
824 to conservative references. Note that object may reside on a pinned page
825 even if :PINNED in NIL if the GC has not had the need to mark the the page
826 as pinned. (GENCGC and :SPACE :DYNAMIC only.)
829 Indicates that the page on which the object starts is write-protected,
830 which indicates for :BOXED objects that it hasn't been written to since
831 the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
834 The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
837 For :STACK objects secondary value is the thread on whose stack the object is
840 Expected use-cases include introspection to gain insight into allocation and
841 GC behaviour and restricting memoization to heap-allocated arguments.
843 Experimental: interface subject to change."
844 ;; FIXME: Would be nice to provide the size of the object as well, though
845 ;; maybe that should be a separate function, and something like MAP-PARTS
846 ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
847 ;; as well if they want to.
849 ;; FIXME: For the memoization use-case possibly we should also provide a
850 ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC
851 ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for
852 ;; checking if an object has been stack-allocated by a given thread for
853 ;; testing purposes might not come amiss.
854 (if (typep object '(or fixnum character))
855 (values :immediate nil)
857 (sb-sys:without-gcing
858 ;; Disable GC so the object cannot move to another page while
859 ;; we have the address.
860 (let* ((addr (sb-kernel:get-lisp-obj-address object))
862 (cond ((< sb-vm:read-only-space-start addr
863 (ash sb-vm:*read-only-space-free-pointer*
864 sb-vm:n-fixnum-tag-bits))
866 ((< sb-vm:static-space-start addr
867 (ash sb-vm:*static-space-free-pointer*
868 sb-vm:n-fixnum-tag-bits))
870 ((< (sb-kernel:current-dynamic-space-start) addr
871 (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
875 (if (eq :dynamic space)
876 (let ((index (sb-vm::find-page-index addr)))
877 (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index)))
878 (let ((flags (sb-alien:slot page 'sb-vm::flags)))
880 :generation (sb-alien:slot page 'sb-vm::gen)
881 :write-protected (logbitp 0 flags)
882 :boxed (logbitp 2 flags)
883 :pinned (logbitp 5 flags)
884 :large (logbitp 6 flags)
888 (list :space space))))))
890 (values :heap plist))
892 (let ((sap (sb-sys:int-sap (sb-kernel:get-lisp-obj-address object))))
893 ;; FIXME: Check other stacks as well.
895 (dolist (thread (sb-thread:list-all-threads))
896 (let ((c-start (sb-di::descriptor-sap
897 (sb-thread::%symbol-value-in-thread
898 'sb-vm:*control-stack-start*
900 (c-end (sb-di::descriptor-sap
901 (sb-thread::%symbol-value-in-thread
902 'sb-vm:*control-stack-end*
904 (when (and c-start c-end)
905 (when (and (sb-sys:sap<= c-start sap)
906 (sb-sys:sap< sap c-end))
907 (return-from allocation-information
908 (values :stack thread))))))
910 (when (sb-vm:control-stack-pointer-valid-p sap nil)
911 (return-from allocation-information
912 (values :stack sb-thread::*current-thread*))))
915 (defun map-root (function object &key simple (ext t))
916 "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
919 If SIMPLE is true (default is NIL), elides those pointers that are not
920 notionally part of certain built-in objects, but backpointers to a
921 conceptual parent: eg. elides the pointer from a SYMBOL to the
922 corresponding PACKAGE.
924 If EXT is true (default is T), includes some pointers that are not
925 actually contained in the object, but found in certain well-known
926 indirect containers: FDEFINITIONs, EQL specializers, classes, and
927 thread-local symbol values in other threads fall into this category.
929 NOTE: calling MAP-ROOT with a THREAD does not currently map over
930 conservative roots from the thread registers and interrupt contexts.
932 Experimental: interface subject to change."
933 (let ((fun (coerce function 'function))
934 (seen (sb-int:alloc-xset)))
936 (when (and (member (sb-kernel:lowtag-of part)
937 `(,sb-vm:instance-pointer-lowtag
938 ,sb-vm:list-pointer-lowtag
939 ,sb-vm:fun-pointer-lowtag
940 ,sb-vm:other-pointer-lowtag))
941 (not (sb-int:xset-member-p part seen)))
942 (sb-int:add-to-xset part seen)
943 (funcall fun part))))
945 (let ((table sb-pcl::*eql-specializer-table*))
946 (call (sb-int:with-locked-system-table (table)
947 (gethash object table)))))
949 ((or bignum float sb-sys:system-area-pointer fixnum))
951 (call (sb-ext:weak-pointer-value object)))
955 (when (and ext (ignore-errors (fboundp object)))
956 (call (fdefinition object))))
958 (call (numerator object))
959 (call (denominator object)))
961 (call (realpart object))
962 (call (realpart object)))
964 (let* ((len (sb-kernel:%instance-length object))
965 (nuntagged (if (typep object 'structure-object)
966 (sb-kernel:layout-n-untagged-slots
967 (sb-kernel:%instance-layout object))
969 (dotimes (i (- len nuntagged))
970 (call (sb-kernel:%instance-ref object i))))
972 (when (typep object 'sb-thread:thread)
973 (cond ((eq object sb-thread:*current-thread*)
974 (dolist (value (sb-thread::%thread-local-references))
976 (sb-vm::map-stack-references #'call))
978 ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
979 ;; the alternative would be stopping the world...
981 (let ((sem (sb-thread:make-semaphore))
985 (sb-thread:interrupt-thread
988 (setf refs (sb-thread::%thread-local-references))
989 (sb-vm::map-stack-references (lambda (x) (push x refs)))
990 (sb-thread:signal-semaphore sem)))
991 (sb-thread:wait-on-semaphore sem))
992 (sb-thread:interrupt-thread-error ()))
993 (mapc #'call refs))))))
995 (if (simple-vector-p object)
996 (dotimes (i (length object))
997 (call (aref object i)))
998 (when (sb-kernel:array-header-p object)
999 (call (sb-kernel::%array-data-vector object))
1000 (call (sb-kernel::%array-displaced-p object))
1002 (call (sb-kernel::%array-displaced-from object))))))
1003 (sb-kernel:code-component
1004 (call (sb-kernel:%code-entry-points object))
1005 (call (sb-kernel:%code-debug-info object))
1006 (loop for i from sb-vm:code-constants-offset
1007 below (sb-kernel:get-header-data object)
1008 do (call (sb-kernel:code-header-ref object i))))
1010 (call (sb-kernel:fdefn-name object))
1011 (call (sb-kernel:fdefn-fun object)))
1012 (sb-kernel:simple-fun
1014 (call (sb-kernel:%simple-fun-next object)))
1015 (call (sb-kernel:fun-code-header object))
1016 (call (sb-kernel:%simple-fun-name object))
1017 (call (sb-kernel:%simple-fun-arglist object))
1018 (call (sb-kernel:%simple-fun-type object))
1019 (call (sb-kernel:%simple-fun-info object)))
1021 (call (sb-kernel:%closure-fun object))
1022 (sb-kernel:do-closure-values (x object)
1024 (sb-kernel:funcallable-instance
1025 (call (sb-kernel:%funcallable-instance-function object))
1026 (loop for i from 1 below (- (1+ (sb-kernel:get-closure-length object))
1027 sb-vm::funcallable-instance-info-offset)
1028 do (call (sb-kernel:%funcallable-instance-info object i))))
1031 (dolist (thread (sb-thread:list-all-threads))
1032 (call (sb-thread:symbol-value-in-thread object thread nil))))
1034 ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg.
1035 (call (sb-ext:symbol-global-value object))
1036 (unbound-variable ()))
1037 (when (and ext (ignore-errors (fboundp object)))
1038 (call (fdefinition object))
1039 (call (macro-function object))
1040 (let ((class (find-class object nil)))
1041 (when class (call class))))
1042 (call (symbol-plist object))
1043 (call (symbol-name object))
1045 (call (symbol-package object))))
1046 (sb-kernel::random-class
1047 (case (sb-kernel:widetag-of object)
1048 (#.sb-vm::value-cell-header-widetag
1049 (call (sb-kernel::value-cell-ref object)))
1051 (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
1052 (sb-kernel:widetag-of object) object)))))))