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-FORM-NUMBER"
43 "DEFINITION-SOURCE-CHARACTER-OFFSET"
44 "DEFINITION-SOURCE-FILE-WRITE-DATE"
45 "DEFINITION-SOURCE-PLIST"
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 (sb-int:sfunction
(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 (sb-int:sfunction
(function) debug-source
) function-debug-source
))
88 (defun function-debug-source (function)
89 (debug-info-source (function-debug-info function
)))
91 (declaim (ftype (sb-int:sfunction
(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 (sb-int:sfunction
(t debug-info
) debug-function
) debug-info-debug-function
))
96 (defun debug-info-debug-function (function debug-info
)
97 (let ((map (sb-c::compiled-debug-info-fun-map debug-info
))
98 (name (sb-kernel:%simple-fun-name
(sb-kernel:%fun-fun function
))))
103 (sb-c::compiled-debug-fun-p x
)
104 (eq (sb-c::compiled-debug-fun-name x
) name
)))
108 (defun valid-function-name-p (name)
109 "True if NAME denotes a valid function name, ie. one that can be passed to
111 (and (sb-int:valid-function-name-p name
) t
))
113 ;;;; Utilities for code
115 (declaim (inline map-code-constants
))
116 (defun map-code-constants (code fn
)
117 "Call FN for each constant in CODE's constant pool."
118 (check-type code sb-kernel
:code-component
)
119 (loop for i from sb-vm
:code-constants-offset below
120 (sb-kernel:code-header-words code
)
121 do
(funcall fn
(sb-kernel:code-header-ref code i
))))
123 (declaim (inline map-allocated-code-components
))
124 (defun map-allocated-code-components (spaces fn
)
125 "Call FN for each allocated code component in one of SPACES. FN
126 receives the object and its size as arguments. SPACES should be a
127 list of the symbols :dynamic, :static, or :read-only."
128 (dolist (space spaces
)
129 (sb-vm::map-allocated-objects
130 (lambda (obj header size
)
131 (when (= sb-vm
:code-header-widetag header
)
132 (funcall fn obj size
)))
135 (declaim (inline map-caller-code-components
))
136 (defun map-caller-code-components (function spaces fn
)
137 "Call FN for each code component with a fdefn for FUNCTION in its
139 (let ((function (coerce function
'function
)))
140 (map-allocated-code-components
143 (declare (ignore size
))
147 (when (and (sb-kernel:fdefn-p constant
)
148 (eq (sb-kernel:fdefn-fun constant
)
150 (funcall fn obj
))))))))
152 ;;;; Finding definitions
154 (defstruct definition-source
155 ;; Pathname of the source file that the definition was compiled from.
156 ;; This is null if the definition was not compiled from a file.
157 (pathname nil
:type
(or null pathname
))
158 ;; Source-path of the definition within the file.
159 ;; This may be incomplete depending on the debug level at which the
160 ;; source was compiled.
161 (form-path '() :type list
)
162 ;; Depth first number of the form.
163 ;; FORM-PATH above usually contains just the top-level form number,
164 ;; ideally the proper form path could be dervied from the
165 ;; form-number and the tlf-number, but it's a bit complicated and
166 ;; Slime already knows how to deal with form numbers, so delegate
167 ;; that job to Slime.
168 (form-number nil
:type
(or null unsigned-byte
))
169 ;; Character offset of the top-level-form containing the definition.
170 ;; This corresponds to the first element of form-path.
171 (character-offset nil
:type
(or null unsigned-byte
))
172 ;; File-write-date of the source file when compiled.
173 ;; Null if not compiled from a file.
174 (file-write-date nil
:type
(or null unsigned-byte
))
175 ;; plist from WITH-COMPILATION-UNIT
177 ;; Any extra metadata that the caller might be interested in. For
178 ;; example the specializers of the method whose definition-source this
180 (description nil
:type list
))
182 (defun vop-sources-from-fun-templates (name)
183 (let ((fun-info (sb-int:info
:function
:info name
)))
185 (loop for vop in
(sb-c::fun-info-templates fun-info
)
186 for source
= (find-definition-source
187 (sb-c::vop-info-generator-function vop
))
188 do
(setf (definition-source-description source
)
189 (if (sb-c::template-note vop
)
190 (list (sb-c::template-name vop
)
191 (sb-c::template-note vop
))
192 (list (sb-c::template-name vop
))))
195 (defun find-vop-source (name)
196 (let* ((templates (vop-sources-from-fun-templates name
))
197 (vop (gethash name sb-c
::*backend-template-names
*))
199 (sb-c::vop-info-generator-function vop
)))
200 (source (when generator
201 (find-definition-source generator
))))
204 (setf (definition-source-description source
)
206 (cons source templates
))
210 (defun find-definition-sources-by-name (name type
)
211 "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
212 defined with name NAME. NAME may be a symbol or a extended function
213 name. Type can currently be one of the following:
241 If an unsupported TYPE is requested, the function will return NIL.
243 (flet ((get-class (name)
245 (find-class name nil
)))
246 (real-fdefinition (name)
247 ;; for getting the real function object, even if the
248 ;; function is being profiled
249 (let ((profile-info (gethash name sb-profile
::*profiled-fun-name-
>info
*)))
251 (sb-profile::profile-info-encapsulated-fun profile-info
)
252 (fdefinition name
)))))
256 (when (and (symbolp name
)
257 (member (sb-int:info
:variable
:kind name
)
258 '(:global
:special
:alien
)))
259 (translate-source-location (sb-int:info
:source-location type name
))))
261 (when (and (symbolp name
)
262 (eq (sb-int:info
:variable
:kind name
) :constant
))
263 (translate-source-location (sb-int:info
:source-location type name
))))
265 (when (and (symbolp name
)
266 (eq (sb-int:info
:variable
:kind name
) :macro
))
267 (translate-source-location (sb-int:info
:source-location type name
))))
269 (when (and (symbolp name
)
270 (macro-function name
))
271 (find-definition-source (macro-function name
))))
273 (when (compiler-macro-function name
)
274 (find-definition-source (compiler-macro-function name
))))
276 (let ((converter (sb-int:info
:function
:ir1-convert name
)))
278 (find-definition-source converter
))))
279 ((:function
:generic-function
)
280 (when (and (fboundp name
)
283 (not (macro-function name
))
284 (not (special-operator-p name
)))))
285 (let ((fun (real-fdefinition name
)))
286 (when (eq (not (typep fun
'generic-function
))
287 (not (eq type
:generic-function
)))
288 (find-definition-source fun
)))))
290 ;; Source locations for types are saved separately when the expander
291 ;; is a closure without a good source-location.
292 (let ((loc (sb-int:info
:type
:source-location name
)))
294 (translate-source-location loc
)
295 (let ((expander-fun (sb-int:info
:type
:expander name
)))
296 (when (functionp expander-fun
)
297 (find-definition-source expander-fun
))))))
300 (let ((fun (real-fdefinition name
)))
301 (when (typep fun
'generic-function
)
302 (loop for method in
(sb-mop::generic-function-methods
304 for source
= (find-definition-source method
)
305 when source collect source
)))))
307 (when (and (consp name
)
308 (eq (car name
) 'setf
))
309 (setf name
(cadr name
)))
310 (let ((expander (sb-int:info
:setf
:expander name
)))
312 (find-definition-source
313 (cond ((symbolp expander
) (symbol-function expander
))
314 ((listp expander
) (cdr expander
))
317 (let ((class (get-class name
)))
319 (when (typep class
'sb-pcl
::structure-class
)
320 (find-definition-source class
))
321 (when (sb-int:info
:typed-structure
:info name
)
322 (translate-source-location
323 (sb-int:info
:source-location
:typed-structure name
))))))
325 (let ((class (get-class name
)))
327 (not (typep class
'sb-pcl
::structure-class
)))
328 (when (eq (not (typep class
'sb-pcl
::condition-class
))
329 (not (eq type
:condition
)))
330 (find-definition-source class
)))))
331 ((:method-combination
)
332 (let ((combination-fun
333 (find-method #'sb-mop
:find-method-combination
335 (list (find-class 'generic-function
)
339 (when combination-fun
340 (find-definition-source combination-fun
))))
343 (let ((package (find-package name
)))
345 (find-definition-source package
)))))
346 ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
349 (let ((fun-info (sb-int:info
:function
:info name
)))
351 (loop for xform in
(sb-c::fun-info-transforms fun-info
)
352 for source
= (find-definition-source
353 (sb-c::transform-function xform
))
354 for typespec
= (sb-kernel:type-specifier
355 (sb-c::transform-type xform
))
356 for note
= (sb-c::transform-note xform
)
357 do
(setf (definition-source-description source
)
359 (list (second typespec
) note
)
363 (let ((fun-info (and (symbolp name
)
364 (sb-int:info
:function
:info name
))))
366 (let ((otypes '((sb-c:fun-info-derive-type . sb-c
:derive-type
)
367 (sb-c:fun-info-ltn-annotate . sb-c
:ltn-annotate
)
368 (sb-c:fun-info-optimizer . sb-c
:optimizer
)
369 (sb-c:fun-info-ir2-convert . sb-c
:ir2-convert
)
370 (sb-c::fun-info-stack-allocate-result
371 . sb-c
::stack-allocate-result
)
372 (sb-c::fun-info-constraint-propagate
373 . sb-c
::constraint-propagate
)
374 (sb-c::fun-info-constraint-propagate-if
375 . sb-c
::constraint-propagate-if
)
376 (sb-c::fun-info-call-type-deriver
377 . sb-c
::call-type-deriver
))))
378 (loop for
(reader . name
) in otypes
379 for fn
= (funcall reader fun-info
)
381 (let ((source (find-definition-source fn
)))
382 (setf (definition-source-description source
)
386 (let ((loc (sb-int:info
:source-location type name
)))
388 (translate-source-location loc
)
389 (find-vop-source name
))))
391 (let ((loc (sb-int:info
:source-location type name
)))
393 (translate-source-location loc
))))
395 (let* ((transform-fun
396 (or (sb-int:info
:function
:source-transform name
)
397 (and (typep name
'(cons (eql setf
) (cons symbol null
)))
398 (sb-int:info
:function
:source-transform
400 ;; A cons for the :source-transform is essentially the same
401 ;; info that was formerly in :structure-accessor.
402 (accessor (and (consp transform-fun
) (cdr transform-fun
))))
403 ;; Structure accessors have source transforms, but the
404 ;; returned locations will neither show the actual place
405 ;; where it's defined, nor is really interesting.
406 (when (and transform-fun
408 (find-definition-source transform-fun
))))
410 (let ((locations (sb-int:info
:source-location
:declaration name
)))
411 (loop for
(kind loc
) on locations by
#'cddr
413 collect
(let ((loc (translate-source-location loc
)))
414 (setf (definition-source-description loc
)
415 ;; Copy list to ensure that user code
416 ;; cannot mutate the original.
417 (copy-list (sb-int:ensure-list kind
)))
422 (defun find-definition-source (object)
424 ((or sb-pcl
::condition-class sb-pcl
::structure-class
)
425 (let ((classoid (sb-impl::find-classoid
(class-name object
))))
427 (let ((layout (sb-impl::classoid-layout classoid
)))
429 (translate-source-location
430 (sb-kernel::layout-source-location layout
)))))))
433 (find-definition-sources-by-name
434 (sb-pcl::method-combination-type-name object
) :method-combination
)))
436 (translate-source-location (sb-impl::package-source-location object
)))
437 ((or class sb-mop
:slot-definition
)
438 (translate-source-location (sb-pcl::definition-source object
)))
439 ;; Use the PCL definition location information instead of the function
440 ;; debug-info for methods and generic functions. Sometimes the
441 ;; debug-info would point into PCL internals instead of the proper
444 (let ((source (translate-source-location
445 (sb-pcl::definition-source object
))))
447 (setf (definition-source-description source
)
448 (list (sb-mop:generic-function-lambda-list object
))))
451 (let ((source (translate-source-location
452 (sb-pcl::definition-source object
))))
454 (setf (definition-source-description source
)
455 (append (method-qualifiers object
)
456 (if (sb-mop:method-generic-function object
)
457 (sb-pcl::unparse-specializers
458 (sb-mop:method-generic-function object
)
459 (sb-mop:method-specializers object
))
460 (sb-mop:method-specializers object
)))))
463 (sb-eval:interpreted-function
464 (let ((source (translate-source-location
465 (sb-eval:interpreted-function-source-location object
))))
468 (sb-interpreter:interpreted-function
469 (translate-source-location (sb-interpreter:fun-source-location object
)))
471 (find-function-definition-source object
))
472 ((or condition standard-object structure-object
)
473 (find-definition-source (class-of object
)))
475 (error "Don't know how to retrieve source location for a ~S"
478 (defun find-function-definition-source (function)
479 (let* ((debug-info (function-debug-info function
))
480 (debug-source (debug-info-source debug-info
))
481 (debug-fun (debug-info-debug-function function debug-info
))
482 (tlf (if debug-fun
(sb-c::compiled-debug-fun-tlf-number debug-fun
))))
483 (make-definition-source
485 (when (stringp (sb-c::debug-source-namestring debug-source
))
486 (parse-namestring (sb-c::debug-source-namestring debug-source
)))
489 (elt (sb-c::debug-source-start-positions debug-source
) tlf
))
490 :form-path
(if tlf
(list tlf
))
491 :form-number
(sb-c::compiled-debug-fun-form-number debug-fun
)
492 :file-write-date
(sb-c::debug-source-created debug-source
)
493 :plist
(sb-c::debug-source-plist debug-source
))))
495 (defun translate-source-location (location)
497 (make-definition-source
498 :pathname
(let ((n (sb-c:definition-source-location-namestring location
)))
500 (parse-namestring n
)))
502 (let ((number (sb-c:definition-source-location-toplevel-form-number
506 :form-number
(sb-c:definition-source-location-form-number
508 :plist
(sb-c:definition-source-location-plist location
))
509 (make-definition-source)))
511 (sb-int:define-deprecated-function
:late
"1.0.24.5" function-arglist function-lambda-list
513 (function-lambda-list function
))
515 (defun function-lambda-list (function)
516 "Describe the lambda list for the extended function designator FUNCTION.
517 Works for special-operators, macros, simple functions, interpreted functions,
518 and generic functions. Signals an error if FUNCTION is not a valid extended
519 function designator."
520 ;; FIXME: sink this logic into SB-KERNEL:%FUN-LAMBDA-LIST and just call that?
521 (cond ((and (symbolp function
) (special-operator-p function
))
522 (function-lambda-list (sb-int:info
:function
:ir1-convert function
)))
523 ((valid-function-name-p function
)
524 (function-lambda-list (or (and (symbolp function
)
525 (macro-function function
))
526 (fdefinition function
))))
527 ((typep function
'generic-function
)
528 (sb-pcl::generic-function-pretty-arglist function
))
530 (sb-kernel:%fun-lambda-list function
))))
532 (defun deftype-lambda-list (typespec-operator)
533 "Returns the lambda list of TYPESPEC-OPERATOR as first return
534 value, and a flag whether the arglist could be found as second
536 (check-type typespec-operator symbol
)
537 ;; Don't return a lambda-list for combinators AND,OR,NOT.
538 (let* ((f (and (sb-int:info
:type
:kind typespec-operator
)
539 (sb-int:info
:type
:expander typespec-operator
)))
540 (f (if (listp f
) (car f
) f
)))
542 (values (sb-kernel:%fun-lambda-list f
) t
)
545 (defun function-type (function-designator)
546 "Returns the ftype of FUNCTION-DESIGNATOR, or NIL."
547 (flet ((ftype-of (function-designator)
548 (sb-kernel:type-specifier
549 (sb-int:proclaimed-ftype function-designator
))))
550 (etypecase function-designator
552 (when (and (fboundp function-designator
)
553 (not (macro-function function-designator
))
554 (not (special-operator-p function-designator
)))
555 (ftype-of function-designator
)))
557 (when (and (sb-int:legal-fun-name-p function-designator
)
558 (fboundp function-designator
))
559 (ftype-of function-designator
)))
561 (function-type (sb-pcl:generic-function-name function-designator
)))
563 ;; Give declared type in globaldb priority over derived type
564 ;; because it contains more accurate information e.g. for
566 (let ((type (function-type (sb-kernel:%fun-name
567 (sb-impl::%fun-fun function-designator
)))))
570 (sb-impl::%fun-type function-designator
)))))))
572 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
574 ;;; This interface is tremendously experimental.
576 ;;; For the moment I'm taking the view that FDEFN is an internal
577 ;;; object (one out of one CMUCL developer surveyed didn't know what
578 ;;; they were for), so these routines deal in FUNCTIONs
580 ;;; Find callers and callees by looking at the constant pool of
581 ;;; compiled code objects. We assume every fdefn object in the
582 ;;; constant pool corresponds to a call to that function. A better
583 ;;; strategy would be to use the disassembler to find actual
586 (defun find-function-callees (function)
587 "Return functions called by FUNCTION."
588 (declare (sb-kernel:simple-fun function
))
591 (sb-kernel:fun-code-header function
)
593 (when (sb-kernel:fdefn-p obj
)
594 (push (sb-kernel:fdefn-fun obj
)
598 (defun find-function-callers (function &optional
(spaces '(:read-only
:static
600 "Return functions which call FUNCTION, by searching SPACES for code objects"
601 (let ((referrers '()))
602 (map-caller-code-components
606 (let ((entry (sb-kernel:%code-entry-points code
)))
608 (push (princ-to-string code
) referrers
))
610 (loop for e
= entry then
(sb-kernel::%simple-fun-next e
)
612 do
(pushnew e referrers
)))))))
617 (defun collect-xref (wanted-kind wanted-name
)
619 (sb-c::map-simple-funs
621 (sb-int:binding
* ((xrefs (sb-kernel:%simple-fun-xrefs fun
) :exit-if-null
))
622 (sb-c::map-packed-xref-data
623 (lambda (xref-kind xref-name xref-form-number
)
624 (when (and (eq xref-kind wanted-kind
)
625 (equal xref-name wanted-name
))
626 (let ((source-location (find-function-definition-source fun
)))
627 ;; Use the more accurate source path from the xref
629 (setf (definition-source-form-number source-location
)
631 (push (cons name source-location
) result
))))
635 (defun who-calls (function-name)
636 "Use the xref facility to search for source locations where the
637 global function named FUNCTION-NAME is called. Returns a list of
638 function name, definition-source pairs."
639 (collect-xref :calls function-name
))
641 (defun who-binds (symbol)
642 "Use the xref facility to search for source locations where the
643 special variable SYMBOL is rebound. Returns a list of function name,
644 definition-source pairs."
645 (collect-xref :binds symbol
))
647 (defun who-references (symbol)
648 "Use the xref facility to search for source locations where the
649 special variable or constant SYMBOL is read. Returns a list of function
650 name, definition-source pairs."
651 (collect-xref :references symbol
))
653 (defun who-sets (symbol)
654 "Use the xref facility to search for source locations where the
655 special variable SYMBOL is written to. Returns a list of function name,
656 definition-source pairs."
657 (collect-xref :sets symbol
))
659 (defun who-macroexpands (macro-name)
660 "Use the xref facility to search for source locations where the
661 macro MACRO-NAME is expanded. Returns a list of function name,
662 definition-source pairs."
663 (collect-xref :macroexpands macro-name
))
665 (defun who-specializes-directly (class-designator)
666 "Search for source locations of methods directly specializing on
667 CLASS-DESIGNATOR. Returns an alist of method name, definition-source
670 A method matches the criterion either if it specializes on the same
671 class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
672 specializers), or if it eql-specializes on an instance of the
677 (let ((class (canonicalize-class-designator class-designator
)))
679 (return-from who-specializes-directly nil
))
680 (let ((result (collect-specializing-methods
682 ;; Does SPECL specialize on CLASS directly?
684 (sb-pcl::class-eq-specializer
685 (eq (sb-pcl::specializer-object specl
) class
))
686 (sb-pcl::eql-specializer
687 (let ((obj (sb-mop:eql-specializer-object specl
)))
688 (eq (class-of obj
) class
)))
689 ((not sb-pcl
::standard-specializer
)
692 (eq specl class
)))))))
693 (map-into result
#'(lambda (m)
694 (cons `(method ,(method-generic-function-name m
))
695 (find-definition-source m
)))
698 (defun who-specializes-generally (class-designator)
699 "Search for source locations of methods specializing on
700 CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
701 name, definition-source pairs.
703 A method matches the criterion either if it specializes on the
704 designated class itself or a subclass of it (this includes CLASS-EQ
705 specializers), or if it eql-specializes on an instance of the
706 designated class or a subclass of it.
710 (let ((class (canonicalize-class-designator class-designator
)))
712 (return-from who-specializes-generally nil
))
713 (let ((result (collect-specializing-methods
715 ;; Does SPECL specialize on CLASS or a subclass
718 (sb-pcl::class-eq-specializer
719 (subtypep (sb-pcl::specializer-object specl
) class
))
720 (sb-pcl::eql-specializer
721 (typep (sb-mop:eql-specializer-object specl
) class
))
722 ((not sb-pcl
::standard-specializer
)
725 (subtypep specl class
)))))))
726 (map-into result
#'(lambda (m)
727 (cons `(method ,(method-generic-function-name m
))
728 (find-definition-source m
)))
731 (defun canonicalize-class-designator (class-designator)
732 (typecase class-designator
733 (symbol (find-class class-designator nil
))
734 (class class-designator
)
737 (defun method-generic-function-name (method)
738 (sb-mop:generic-function-name
(sb-mop:method-generic-function method
)))
740 (defun collect-specializing-methods (predicate)
742 (sb-pcl::map-specializers
744 (when (funcall predicate specl
)
745 (let ((methods (sb-mop:specializer-direct-methods specl
)))
746 (setf result
(append methods result
))))))
747 (delete-duplicates result
)))
750 ;;;; ALLOCATION INTROSPECTION
752 (defun allocation-information (object)
754 "Returns information about the allocation of OBJECT. Primary return value
755 indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
758 Possible secondary return value provides additional information about the
761 For :HEAP objects the secondary value is a plist:
764 Indicates the heap segment the object is allocated in.
767 Is the current generation of the object: 0 for nursery, 6 for pseudo-static
768 generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
771 Indicates a \"large\" object subject to non-copying
772 promotion. (GENCGC and :SPACE :DYNAMIC only.)
775 Indicates that the object is allocated in a boxed region. Unboxed
776 allocation is used for eg. specialized arrays after they have survived one
777 collection. (GENCGC and :SPACE :DYNAMIC only.)
780 Indicates that the page(s) on which the object resides are kept live due
781 to conservative references. Note that object may reside on a pinned page
782 even if :PINNED in NIL if the GC has not had the need to mark the the page
783 as pinned. (GENCGC and :SPACE :DYNAMIC only.)
786 Indicates that the page on which the object starts is write-protected,
787 which indicates for :BOXED objects that it hasn't been written to since
788 the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
791 The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
794 For :STACK objects secondary value is the thread on whose stack the object is
797 Expected use-cases include introspection to gain insight into allocation and
798 GC behaviour and restricting memoization to heap-allocated arguments.
800 Experimental: interface subject to change."
801 ;; FIXME: Would be nice to provide the size of the object as well, though
802 ;; maybe that should be a separate function, and something like MAP-PARTS
803 ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
804 ;; as well if they want to.
806 ;; FIXME: For the memoization use-case possibly we should also provide a
807 ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC
808 ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for
809 ;; checking if an object has been stack-allocated by a given thread for
810 ;; testing purposes might not come amiss.
811 (if (typep object
'(or fixnum character
812 #.
(if (= sb-vm
:n-word-bits
64) 'single-float
(values))))
813 (values :immediate nil
)
815 (sb-sys:without-gcing
816 ;; Disable GC so the object cannot move to another page while
817 ;; we have the address.
818 (let* ((addr (sb-kernel:get-lisp-obj-address object
))
820 (cond ((< sb-vm
:read-only-space-start addr
821 (ash sb-vm
:*read-only-space-free-pointer
*
822 sb-vm
:n-fixnum-tag-bits
))
824 ((< sb-vm
:static-space-start addr
825 (ash sb-vm
:*static-space-free-pointer
*
826 sb-vm
:n-fixnum-tag-bits
))
828 ((< (sb-kernel:current-dynamic-space-start
) addr
829 (sb-sys:sap-int
(sb-kernel:dynamic-space-free-pointer
)))
833 (if (eq :dynamic space
)
834 (let ((index (sb-vm::find-page-index addr
)))
835 (symbol-macrolet ((page (sb-alien:deref sb-vm
::page-table index
)))
836 (let ((flags (sb-alien:slot page
'sb-vm
::flags
)))
838 :generation
(sb-alien:slot page
'sb-vm
::gen
)
839 :write-protected
(logbitp 0 flags
)
840 :boxed
(logbitp 2 flags
)
841 :pinned
(logbitp 5 flags
)
842 :large
(logbitp 6 flags
)
846 (list :space space
))))))
848 (values :heap plist
))
850 (let ((sap (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address object
))))
851 ;; FIXME: Check other stacks as well.
853 (dolist (thread (sb-thread:list-all-threads
))
854 (let ((c-start (sb-di::descriptor-sap
855 (sb-thread::%symbol-value-in-thread
856 'sb-vm
:*control-stack-start
*
858 (c-end (sb-di::descriptor-sap
859 (sb-thread::%symbol-value-in-thread
860 'sb-vm
:*control-stack-end
*
862 (when (and c-start c-end
)
863 (when (and (sb-sys:sap
<= c-start sap
)
864 (sb-sys:sap
< sap c-end
))
865 (return-from allocation-information
866 (values :stack thread
))))))
868 (when (sb-vm:control-stack-pointer-valid-p sap nil
)
869 (return-from allocation-information
870 (values :stack sb-thread
::*current-thread
*))))
873 (defun map-root (function object
&key simple
(ext t
))
874 "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
877 If SIMPLE is true (default is NIL), elides those pointers that are not
878 notionally part of certain built-in objects, but backpointers to a
879 conceptual parent: eg. elides the pointer from a SYMBOL to the
880 corresponding PACKAGE.
882 If EXT is true (default is T), includes some pointers that are not
883 actually contained in the object, but found in certain well-known
884 indirect containers: FDEFINITIONs, EQL specializers, classes, and
885 thread-local symbol values in other threads fall into this category.
887 NOTE: calling MAP-ROOT with a THREAD does not currently map over
888 conservative roots from the thread registers and interrupt contexts.
890 Experimental: interface subject to change."
891 (let ((fun (coerce function
'function
))
892 (seen (sb-int:alloc-xset
)))
894 (when (and (member (sb-kernel:lowtag-of part
)
895 `(,sb-vm
:instance-pointer-lowtag
896 ,sb-vm
:list-pointer-lowtag
897 ,sb-vm
:fun-pointer-lowtag
898 ,sb-vm
:other-pointer-lowtag
))
899 (not (sb-int:xset-member-p part seen
)))
900 (sb-int:add-to-xset part seen
)
901 (funcall fun part
))))
903 (let ((table sb-pcl
::*eql-specializer-table
*))
904 (call (sb-int:with-locked-system-table
(table)
905 (gethash object table
)))))
907 ((or bignum float sb-sys
:system-area-pointer fixnum
))
909 (call (sb-ext:weak-pointer-value object
)))
913 (when (and ext
(ignore-errors (fboundp object
)))
914 (call (fdefinition object
))))
916 (call (numerator object
))
917 (call (denominator object
)))
919 (call (realpart object
))
920 (call (realpart object
)))
922 (call (sb-kernel:%instance-layout object
))
923 (sb-kernel:do-instance-tagged-slot
(i object
)
924 (call (sb-kernel:%instance-ref object i
)))
926 (when (typep object
'sb-thread
:thread
)
927 (cond ((eq object sb-thread
:*current-thread
*)
928 (dolist (value (sb-thread::%thread-local-references
))
930 (sb-vm::map-stack-references
#'call
))
932 ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
933 ;; the alternative would be stopping the world...
935 (let ((sem (sb-thread:make-semaphore
))
939 (sb-thread:interrupt-thread
942 (setf refs
(sb-thread::%thread-local-references
))
943 (sb-vm::map-stack-references
(lambda (x) (push x refs
)))
944 (sb-thread:signal-semaphore sem
)))
945 (sb-thread:wait-on-semaphore sem
))
946 (sb-thread:interrupt-thread-error
()))
947 (mapc #'call refs
))))))
949 (if (simple-vector-p object
)
950 (dotimes (i (length object
))
951 (call (aref object i
)))
952 (when (sb-kernel:array-header-p object
)
953 (call (sb-kernel::%array-data-vector object
))
954 (call (sb-kernel::%array-displaced-p object
))
956 (call (sb-kernel::%array-displaced-from object
))))))
957 (sb-kernel:code-component
958 (call (sb-kernel:%code-entry-points object
))
959 (call (sb-kernel:%code-debug-info object
))
960 (loop for i from sb-vm
:code-constants-offset
961 below
(sb-kernel:code-header-words object
)
962 do
(call (sb-kernel:code-header-ref object i
))))
964 (call (sb-kernel:fdefn-name object
))
965 (call (sb-kernel:fdefn-fun object
)))
966 (sb-kernel:simple-fun
968 (call (sb-kernel:%simple-fun-next object
)))
969 (call (sb-kernel:fun-code-header object
))
970 (call (sb-kernel:%simple-fun-name object
))
971 (call (sb-kernel:%simple-fun-arglist object
))
972 (call (sb-kernel:%simple-fun-type object
))
973 (call (sb-kernel:%simple-fun-info object
)))
975 (call (sb-kernel:%closure-fun object
))
976 (sb-kernel:do-closure-values
(x object
)
978 (sb-kernel:funcallable-instance
979 (call (sb-kernel:%funcallable-instance-function object
))
980 (loop for i from
1 below
(- (1+ (sb-kernel:get-closure-length object
))
981 sb-vm
::funcallable-instance-info-offset
)
982 do
(call (sb-kernel:%funcallable-instance-info object i
))))
985 (dolist (thread (sb-thread:list-all-threads
))
986 (call (sb-thread:symbol-value-in-thread object thread nil
))))
988 ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg.
989 (call (sb-ext:symbol-global-value object
))
990 (unbound-variable ()))
991 ;; These first two are probably unnecessary.
992 ;; The functoid values, if present, are in SYMBOL-INFO
993 ;; which is traversed whether or not EXT was true.
994 ;; But should we traverse SYMBOL-INFO?
995 ;; I don't know what is expected of this interface.
996 (when (and ext
(ignore-errors (fboundp object
)))
997 (call (fdefinition object
))
998 (call (macro-function object
))
999 (let ((class (find-class object nil
)))
1000 (when class
(call class
))))
1001 (call (symbol-plist object
)) ; perhaps SB-KERNEL:SYMBOL-INFO instead?
1002 (call (symbol-name object
))
1004 (call (symbol-package object
))))
1005 (sb-kernel::random-class
1006 (case (sb-kernel:widetag-of object
)
1007 (#.sb-vm
::value-cell-header-widetag
1008 (call (sb-kernel::value-cell-ref object
)))
1010 (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
1011 (sb-kernel:widetag-of object
) object
)))))))