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 (sb-di::compiled-debug-fun-from-pc debug-info
98 (sb-di::function-start-pc-offset function
)))
100 (defun valid-function-name-p (name)
101 "True if NAME denotes a valid function name, ie. one that can be passed to
103 (and (sb-int:valid-function-name-p name
) t
))
105 ;;;; Utilities for code
107 (declaim (inline map-code-constants
))
108 (defun map-code-constants (code fn
)
109 "Call FN for each constant in CODE's constant pool."
110 (check-type code sb-kernel
:code-component
)
111 (loop for i from sb-vm
:code-constants-offset below
112 (sb-kernel:code-header-words code
)
113 do
(funcall fn
(sb-kernel:code-header-ref code i
))))
115 (declaim (inline map-allocated-code-components
))
116 (defun map-allocated-code-components (spaces fn
)
117 "Call FN for each allocated code component in one of SPACES. FN
118 receives the object and its size as arguments. SPACES should be a
119 list of the symbols :dynamic, :static, or :read-only."
120 (apply #'sb-vm
::map-allocated-objects
121 (lambda (obj header size
)
122 (when (= sb-vm
:code-header-widetag header
)
123 (funcall fn obj size
)))
126 (declaim (inline map-caller-code-components
))
127 (defun map-caller-code-components (function spaces fn
)
128 "Call FN for each code component with a fdefn for FUNCTION in its
130 (let ((function (coerce function
'function
)))
131 (map-allocated-code-components
134 (declare (ignore size
))
138 (when (and (sb-kernel:fdefn-p constant
)
139 (eq (sb-kernel:fdefn-fun constant
)
141 (funcall fn obj
))))))))
143 ;;;; Finding definitions
145 (defstruct definition-source
146 ;; Pathname of the source file that the definition was compiled from.
147 ;; This is null if the definition was not compiled from a file.
148 (pathname nil
:type
(or null pathname
))
149 ;; Source-path of the definition within the file.
150 ;; This may be incomplete depending on the debug level at which the
151 ;; source was compiled.
152 (form-path '() :type list
)
153 ;; Depth first number of the form.
154 ;; FORM-PATH above usually contains just the top-level form number,
155 ;; ideally the proper form path could be dervied from the
156 ;; form-number and the tlf-number, but it's a bit complicated and
157 ;; Slime already knows how to deal with form numbers, so delegate
158 ;; that job to Slime.
159 (form-number nil
:type
(or null unsigned-byte
))
160 ;; Character offset of the top-level-form containing the definition.
161 ;; This corresponds to the first element of form-path.
162 (character-offset nil
:type
(or null unsigned-byte
))
163 ;; File-write-date of the source file when compiled.
164 ;; Null if not compiled from a file.
165 (file-write-date nil
:type
(or null unsigned-byte
))
166 ;; plist from WITH-COMPILATION-UNIT
168 ;; Any extra metadata that the caller might be interested in. For
169 ;; example the specializers of the method whose definition-source this
171 (description nil
:type list
))
173 (defun vop-sources-from-fun-templates (name)
174 (let ((fun-info (sb-int:info
:function
:info name
)))
176 (loop for vop in
(sb-c::fun-info-templates fun-info
)
177 for source
= (find-definition-source
178 (sb-c::vop-info-generator-function vop
))
179 do
(setf (definition-source-description source
)
180 (if (sb-c::template-note vop
)
181 (list (sb-c::template-name vop
)
182 (sb-c::template-note vop
))
183 (list (sb-c::template-name vop
))))
186 (defun find-vop-source (name)
187 (let* ((templates (vop-sources-from-fun-templates name
))
188 (vop (gethash name sb-c
::*backend-template-names
*))
190 (sb-c::vop-info-generator-function vop
)))
191 (source (when generator
192 (find-definition-source generator
))))
195 (setf (definition-source-description source
)
197 (cons source templates
))
201 (defun find-definition-sources-by-name (name type
)
202 "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
203 defined with name NAME. NAME may be a symbol or a extended function
204 name. Type can currently be one of the following:
232 If an unsupported TYPE is requested, the function will return NIL.
234 (flet ((get-class (name)
236 (find-class name nil
)))
237 (real-fdefinition (name)
238 ;; for getting the real function object, even if the
239 ;; function is being profiled
240 (let ((profile-info (gethash name sb-profile
::*profiled-fun-name-
>info
*)))
242 (sb-profile::profile-info-encapsulated-fun profile-info
)
243 (fdefinition name
)))))
247 (when (and (symbolp name
)
248 (member (sb-int:info
:variable
:kind name
)
249 '(:global
:special
:alien
)))
250 (translate-source-location (sb-int:info
:source-location type name
))))
252 (when (and (symbolp name
)
253 (eq (sb-int:info
:variable
:kind name
) :constant
))
254 (translate-source-location (sb-int:info
:source-location type name
))))
256 (when (and (symbolp name
)
257 (eq (sb-int:info
:variable
:kind name
) :macro
))
258 (translate-source-location (sb-int:info
:source-location type name
))))
260 (when (and (symbolp name
)
261 (macro-function name
))
262 (find-definition-source (macro-function name
))))
264 (when (compiler-macro-function name
)
265 (find-definition-source (compiler-macro-function name
))))
267 (let ((converter (sb-int:info
:function
:ir1-convert name
)))
269 (find-definition-source converter
))))
270 ((:function
:generic-function
)
271 (when (and (fboundp name
)
274 (not (macro-function name
))
275 (not (special-operator-p name
)))))
276 (let ((fun (real-fdefinition name
)))
277 (when (eq (not (typep fun
'generic-function
))
278 (not (eq type
:generic-function
)))
279 (find-definition-source fun
)))))
281 ;; Source locations for types are saved separately when the expander
282 ;; is a closure without a good source-location.
283 (let ((loc (sb-int:info
:type
:source-location name
)))
285 (translate-source-location loc
)
286 (let ((expander-fun (sb-int:info
:type
:expander name
)))
287 (when (functionp expander-fun
)
288 (find-definition-source expander-fun
))))))
291 (let ((fun (real-fdefinition name
)))
292 (when (typep fun
'generic-function
)
293 (loop for method in
(sb-mop::generic-function-methods
295 for source
= (find-definition-source method
)
296 when source collect source
)))))
298 (when (and (consp name
)
299 (eq (car name
) 'setf
))
300 (setf name
(cadr name
)))
301 (let ((expander (sb-int:info
:setf
:expander name
)))
303 (find-definition-source
304 (cond ((symbolp expander
) (symbol-function expander
))
305 ((listp expander
) (cdr expander
))
308 (let ((class (get-class name
)))
310 (when (typep class
'sb-pcl
::structure-class
)
311 (find-definition-source class
))
312 (when (sb-int:info
:typed-structure
:info name
)
313 (translate-source-location
314 (sb-int:info
:source-location
:typed-structure name
))))))
316 (let ((class (get-class name
)))
318 (not (typep class
'sb-pcl
::structure-class
)))
319 (when (eq (not (typep class
'sb-pcl
::condition-class
))
320 (not (eq type
:condition
)))
321 (find-definition-source class
)))))
322 ((:method-combination
)
323 (let ((combination-fun
324 (find-method #'sb-mop
:find-method-combination
326 (list (find-class 'generic-function
)
330 (when combination-fun
331 (find-definition-source combination-fun
))))
334 (let ((package (find-package name
)))
336 (find-definition-source package
)))))
337 ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
340 (let ((fun-info (sb-int:info
:function
:info name
)))
342 (loop for xform in
(sb-c::fun-info-transforms fun-info
)
343 for source
= (find-definition-source
344 (sb-c::transform-function xform
))
345 for typespec
= (sb-kernel:type-specifier
346 (sb-c::transform-type xform
))
347 for note
= (sb-c::transform-note xform
)
348 do
(setf (definition-source-description source
)
350 (list (second typespec
) note
)
354 (let ((fun-info (and (symbolp name
)
355 (sb-int:info
:function
:info name
))))
357 (let ((otypes '((sb-c:fun-info-derive-type . sb-c
:derive-type
)
358 (sb-c:fun-info-ltn-annotate . sb-c
:ltn-annotate
)
359 (sb-c:fun-info-optimizer . sb-c
:optimizer
)
360 (sb-c:fun-info-ir2-convert . sb-c
:ir2-convert
)
361 (sb-c::fun-info-stack-allocate-result
362 . sb-c
::stack-allocate-result
)
363 (sb-c::fun-info-constraint-propagate
364 . sb-c
::constraint-propagate
)
365 (sb-c::fun-info-constraint-propagate-if
366 . sb-c
::constraint-propagate-if
)
367 (sb-c::fun-info-call-type-deriver
368 . sb-c
::call-type-deriver
))))
369 (loop for
(reader . name
) in otypes
370 for fn
= (funcall reader fun-info
)
372 (let ((source (find-definition-source fn
)))
373 (setf (definition-source-description source
)
377 (let ((loc (sb-int:info
:source-location type name
))
378 (translated (find-vop-source name
)))
380 (cons (translate-source-location loc
)
384 (let ((loc (sb-int:info
:source-location type name
)))
386 (translate-source-location loc
))))
388 (let* ((transform-fun
389 (or (sb-int:info
:function
:source-transform name
)
390 (and (typep name
'(cons (eql setf
) (cons symbol null
)))
391 (sb-int:info
:function
:source-transform
393 ;; A cons for the :source-transform is essentially the same
394 ;; info that was formerly in :structure-accessor.
395 (accessor (and (consp transform-fun
) (cdr transform-fun
))))
396 ;; Structure accessors have source transforms, but the
397 ;; returned locations will neither show the actual place
398 ;; where it's defined, nor is really interesting.
399 (when (and transform-fun
401 (find-definition-source transform-fun
))))
403 (let ((locations (sb-int:info
:source-location
:declaration name
)))
404 (loop for
(kind loc
) on locations by
#'cddr
406 collect
(let ((loc (translate-source-location loc
)))
407 (setf (definition-source-description loc
)
408 ;; Copy list to ensure that user code
409 ;; cannot mutate the original.
410 (copy-list (sb-int:ensure-list kind
)))
415 (defun find-definition-source (object)
417 ((or sb-pcl
::condition-class sb-pcl
::structure-class
)
418 (let ((classoid (sb-impl::find-classoid
(class-name object
))))
420 (let ((layout (sb-impl::classoid-layout classoid
)))
422 (translate-source-location
423 (sb-kernel::layout-source-location layout
)))))))
426 (find-definition-sources-by-name
427 (sb-pcl::method-combination-type-name object
) :method-combination
)))
429 (translate-source-location (sb-impl::package-source-location object
)))
430 ((or class sb-mop
:slot-definition
)
431 (translate-source-location (sb-pcl::definition-source object
)))
432 ;; Use the PCL definition location information instead of the function
433 ;; debug-info for methods and generic functions. Sometimes the
434 ;; debug-info would point into PCL internals instead of the proper
437 (let ((source (translate-source-location
438 (sb-pcl::definition-source object
))))
440 (setf (definition-source-description source
)
441 (list (sb-mop:generic-function-lambda-list object
))))
444 (let ((source (translate-source-location
445 (sb-pcl::definition-source object
))))
447 (setf (definition-source-description source
)
448 (append (method-qualifiers object
)
449 (if (sb-mop:method-generic-function object
)
450 (sb-pcl::unparse-specializers
451 (sb-mop:method-generic-function object
)
452 (sb-mop:method-specializers object
))
453 (sb-mop:method-specializers object
)))))
456 (sb-eval:interpreted-function
457 (let ((source (translate-source-location
458 (sb-eval:interpreted-function-source-location object
))))
461 (sb-interpreter:interpreted-function
462 (translate-source-location (sb-interpreter:fun-source-location object
)))
464 (find-function-definition-source object
))
465 ((or condition standard-object structure-object
)
466 (find-definition-source (class-of object
)))
468 (error "Don't know how to retrieve source location for a ~S"
471 (defun find-function-definition-source (function)
472 (let* ((debug-info (function-debug-info function
))
473 (debug-source (debug-info-source debug-info
))
474 (debug-fun (debug-info-debug-function function debug-info
))
475 (tlf (sb-c::compiled-debug-info-tlf-number debug-info
)))
476 (make-definition-source
478 (when (stringp (sb-c::debug-source-namestring debug-source
))
479 (parse-namestring (sb-c::debug-source-namestring debug-source
)))
481 (sb-c::compiled-debug-info-char-offset debug-info
)
482 :form-path
(if tlf
(list tlf
))
483 :form-number
(sb-c::compiled-debug-fun-form-number debug-fun
)
484 :file-write-date
(sb-c::debug-source-created debug-source
)
485 :plist
(sb-c::debug-source-plist debug-source
))))
487 (defun translate-source-location (location)
489 (make-definition-source
490 :pathname
(let ((n (sb-c:definition-source-location-namestring location
)))
492 (parse-namestring n
)))
494 (let ((number (sb-c:definition-source-location-toplevel-form-number
498 :form-number
(sb-c:definition-source-location-form-number
500 :plist
(sb-c:definition-source-location-plist location
))
501 (make-definition-source)))
503 (sb-int:define-deprecated-function
:late
"1.0.24.5" function-arglist function-lambda-list
505 (function-lambda-list function
))
507 (defun function-lambda-list (function)
508 "Describe the lambda list for the extended function designator FUNCTION.
509 Works for special-operators, macros, simple functions, interpreted functions,
510 and generic functions. Signals an error if FUNCTION is not a valid extended
511 function designator."
512 ;; FIXME: sink this logic into SB-KERNEL:%FUN-LAMBDA-LIST and just call that?
513 (cond ((and (symbolp function
) (special-operator-p function
))
514 (function-lambda-list (sb-int:info
:function
:ir1-convert function
)))
515 ((valid-function-name-p function
)
516 (function-lambda-list (or (and (symbolp function
)
517 (macro-function function
))
518 (fdefinition function
))))
519 ((typep function
'generic-function
)
520 (sb-pcl::generic-function-pretty-arglist function
))
522 (sb-kernel:%fun-lambda-list function
))))
524 (defun deftype-lambda-list (typespec-operator)
525 "Returns the lambda list of TYPESPEC-OPERATOR as first return
526 value, and a flag whether the arglist could be found as second
528 (check-type typespec-operator symbol
)
529 ;; Don't return a lambda-list for combinators AND,OR,NOT.
530 (let* ((f (and (sb-int:info
:type
:kind typespec-operator
)
531 (sb-int:info
:type
:expander typespec-operator
)))
532 (f (if (listp f
) (car f
) f
)))
534 (values (sb-kernel:%fun-lambda-list f
) t
)
537 (defun function-type (function-designator)
538 "Returns the ftype of FUNCTION-DESIGNATOR, or NIL."
539 (flet ((ftype-of (function-designator)
540 (sb-kernel:type-specifier
541 (sb-int:proclaimed-ftype function-designator
))))
542 (etypecase function-designator
544 (when (and (fboundp function-designator
)
545 (not (macro-function function-designator
))
546 (not (special-operator-p function-designator
)))
547 (ftype-of function-designator
)))
549 (when (and (sb-int:legal-fun-name-p function-designator
)
550 (fboundp function-designator
))
551 (ftype-of function-designator
)))
553 (function-type (sb-pcl:generic-function-name function-designator
)))
555 ;; Give declared type in globaldb priority over derived type
556 ;; because it contains more accurate information e.g. for
558 (let ((type (function-type (sb-kernel:%fun-name
559 (sb-impl::%fun-fun function-designator
)))))
562 (sb-impl::%fun-type function-designator
)))))))
564 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
566 ;;; This interface is tremendously experimental.
568 ;;; For the moment I'm taking the view that FDEFN is an internal
569 ;;; object (one out of one CMUCL developer surveyed didn't know what
570 ;;; they were for), so these routines deal in FUNCTIONs
572 ;;; Find callers and callees by looking at the constant pool of
573 ;;; compiled code objects. We assume every fdefn object in the
574 ;;; constant pool corresponds to a call to that function. A better
575 ;;; strategy would be to use the disassembler to find actual
578 (defun find-function-callees (function)
579 "Return functions called by FUNCTION."
580 (declare (sb-kernel:simple-fun function
))
583 (sb-kernel:fun-code-header function
)
585 (when (sb-kernel:fdefn-p obj
)
586 (push (sb-kernel:fdefn-fun obj
)
590 (defun find-function-callers (function &optional
(spaces '(:read-only
:static
592 "Return functions which call FUNCTION, by searching SPACES for code objects"
593 (let ((referrers '()))
594 (map-caller-code-components
598 (dotimes (i (sb-kernel:code-n-entries code
))
599 (pushnew (sb-kernel:%code-entry-point code i
) referrers
))))
604 (defun collect-xref (wanted-kind wanted-name
)
606 (sb-c::map-simple-funs
608 (sb-int:binding
* ((xrefs (sb-kernel:%simple-fun-xrefs fun
) :exit-if-null
))
609 (sb-c::map-packed-xref-data
610 (lambda (xref-kind xref-name xref-form-number
)
611 (when (and (eq xref-kind wanted-kind
)
612 (equal xref-name wanted-name
))
613 (let ((source-location (find-function-definition-source fun
)))
614 ;; Use the more accurate source path from the xref
616 (setf (definition-source-form-number source-location
)
618 (push (cons name source-location
) result
))))
622 (defun who-calls (function-name)
623 "Use the xref facility to search for source locations where the
624 global function named FUNCTION-NAME is called. Returns a list of
625 function name, definition-source pairs."
626 (collect-xref :calls function-name
))
628 (defun who-binds (symbol)
629 "Use the xref facility to search for source locations where the
630 special variable SYMBOL is rebound. Returns a list of function name,
631 definition-source pairs."
632 (collect-xref :binds symbol
))
634 (defun who-references (symbol)
635 "Use the xref facility to search for source locations where the
636 special variable or constant SYMBOL is read. Returns a list of function
637 name, definition-source pairs."
638 (collect-xref :references symbol
))
640 (defun who-sets (symbol)
641 "Use the xref facility to search for source locations where the
642 special variable SYMBOL is written to. Returns a list of function name,
643 definition-source pairs."
644 (collect-xref :sets symbol
))
646 (defun who-macroexpands (macro-name)
647 "Use the xref facility to search for source locations where the
648 macro MACRO-NAME is expanded. Returns a list of function name,
649 definition-source pairs."
650 (collect-xref :macroexpands macro-name
))
652 (defun who-specializes-directly (class-designator)
653 "Search for source locations of methods directly specializing on
654 CLASS-DESIGNATOR. Returns an alist of method name, definition-source
657 A method matches the criterion either if it specializes on the same
658 class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
659 specializers), or if it eql-specializes on an instance of the
664 (let ((class (canonicalize-class-designator class-designator
)))
666 (return-from who-specializes-directly nil
))
667 (let ((result (collect-specializing-methods
669 ;; Does SPECL specialize on CLASS directly?
671 (sb-pcl::class-eq-specializer
672 (eq (sb-pcl::specializer-object specl
) class
))
673 (sb-pcl::eql-specializer
674 (let ((obj (sb-mop:eql-specializer-object specl
)))
675 (eq (class-of obj
) class
)))
676 ((not sb-pcl
::standard-specializer
)
679 (eq specl class
)))))))
680 (map-into result
#'(lambda (m)
681 (cons `(method ,(method-generic-function-name m
))
682 (find-definition-source m
)))
685 (defun who-specializes-generally (class-designator)
686 "Search for source locations of methods specializing on
687 CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
688 name, definition-source pairs.
690 A method matches the criterion either if it specializes on the
691 designated class itself or a subclass of it (this includes CLASS-EQ
692 specializers), or if it eql-specializes on an instance of the
693 designated class or a subclass of it.
697 (let ((class (canonicalize-class-designator class-designator
)))
699 (return-from who-specializes-generally nil
))
700 (let ((result (collect-specializing-methods
702 ;; Does SPECL specialize on CLASS or a subclass
705 (sb-pcl::class-eq-specializer
706 (subtypep (sb-pcl::specializer-object specl
) class
))
707 (sb-pcl::eql-specializer
708 (typep (sb-mop:eql-specializer-object specl
) class
))
709 ((not sb-pcl
::standard-specializer
)
712 (subtypep specl class
)))))))
713 (map-into result
#'(lambda (m)
714 (cons `(method ,(method-generic-function-name m
))
715 (find-definition-source m
)))
718 (defun canonicalize-class-designator (class-designator)
719 (typecase class-designator
720 (symbol (find-class class-designator nil
))
721 (class class-designator
)
724 (defun method-generic-function-name (method)
725 (sb-mop:generic-function-name
(sb-mop:method-generic-function method
)))
727 (defun collect-specializing-methods (predicate)
729 (sb-pcl::map-specializers
731 (when (funcall predicate specl
)
732 (let ((methods (sb-mop:specializer-direct-methods specl
)))
733 (setf result
(append methods result
))))))
734 (delete-duplicates result
)))
737 ;;;; ALLOCATION INTROSPECTION
739 (defun allocation-information (object)
741 "Returns information about the allocation of OBJECT. Primary return value
742 indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
745 Possible secondary return value provides additional information about the
748 For :HEAP objects the secondary value is a plist:
751 Indicates the heap segment the object is allocated in.
754 Is the current generation of the object: 0 for nursery, 6 for pseudo-static
755 generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
758 Indicates a \"large\" object subject to non-copying
759 promotion. (GENCGC and :SPACE :DYNAMIC only.)
762 Indicates that the object is allocated in a boxed region. Unboxed
763 allocation is used for eg. specialized arrays after they have survived one
764 collection. (GENCGC and :SPACE :DYNAMIC only.)
767 Indicates that the page(s) on which the object resides are kept live due
768 to conservative references. Note that object may reside on a pinned page
769 even if :PINNED in NIL if the GC has not had the need to mark the the page
770 as pinned. (GENCGC and :SPACE :DYNAMIC only.)
773 Indicates that the page on which the object starts is write-protected,
774 which indicates for :BOXED objects that it hasn't been written to since
775 the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
778 The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
781 For :STACK objects secondary value is the thread on whose stack the object is
784 Expected use-cases include introspection to gain insight into allocation and
785 GC behaviour and restricting memoization to heap-allocated arguments.
787 Experimental: interface subject to change."
788 ;; FIXME: Would be nice to provide the size of the object as well, though
789 ;; maybe that should be a separate function, and something like MAP-PARTS
790 ;; for mapping over parts of arbitrary objects so users can get "deep sizes"
791 ;; as well if they want to.
793 ;; FIXME: For the memoization use-case possibly we should also provide a
794 ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC
795 ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for
796 ;; checking if an object has been stack-allocated by a given thread for
797 ;; testing purposes might not come amiss.
798 (if (typep object
'(or fixnum character
799 #.
(if (= sb-vm
:n-word-bits
64) 'single-float
(values))))
800 (values :immediate nil
)
802 (sb-sys:without-gcing
803 ;; Disable GC so the object cannot move to another page while
804 ;; we have the address.
805 (let* ((addr (sb-kernel:get-lisp-obj-address object
))
807 (cond ((< sb-vm
:read-only-space-start addr
808 (ash sb-vm
:*read-only-space-free-pointer
*
809 sb-vm
:n-fixnum-tag-bits
))
811 ((< sb-vm
:static-space-start addr
812 (ash sb-vm
:*static-space-free-pointer
*
813 sb-vm
:n-fixnum-tag-bits
))
815 ((< (sb-kernel:current-dynamic-space-start
) addr
816 (sb-sys:sap-int
(sb-kernel:dynamic-space-free-pointer
)))
820 (if (eq :dynamic space
)
821 (let ((index (sb-vm::find-page-index addr
)))
822 (symbol-macrolet ((page (sb-alien:deref sb-vm
::page-table index
)))
823 (let* ((flags (sb-alien:slot page
'sb-vm
::flags
))
824 (allocated (ldb (byte 3 0) flags
)))
826 :generation
(sb-alien:slot page
'sb-vm
::gen
)
827 :write-protected
(logbitp 3 flags
)
828 :boxed
(logbitp 0 allocated
)
829 :pinned
(logbitp 5 flags
)
830 :large
(logbitp 7 flags
)
834 (list :space space
))))))
836 (values :heap plist
))
838 (let ((sap (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address object
))))
839 ;; FIXME: Check other stacks as well.
841 (dolist (thread (sb-thread:list-all-threads
))
842 (let ((c-start (sb-di::descriptor-sap
843 (sb-thread::%symbol-value-in-thread
844 'sb-vm
:*control-stack-start
*
846 (c-end (sb-di::descriptor-sap
847 (sb-thread::%symbol-value-in-thread
848 'sb-vm
:*control-stack-end
*
850 (when (and c-start c-end
)
851 (when (and (sb-sys:sap
<= c-start sap
)
852 (sb-sys:sap
< sap c-end
))
853 (return-from allocation-information
854 (values :stack thread
))))))
856 (when (sb-vm:control-stack-pointer-valid-p sap nil
)
857 (return-from allocation-information
858 (values :stack sb-thread
::*current-thread
*))))
861 (defun map-root (function object
&key simple
(ext t
))
862 "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
865 If SIMPLE is true (default is NIL), elides those pointers that are not
866 notionally part of certain built-in objects, but backpointers to a
867 conceptual parent: eg. elides the pointer from a SYMBOL to the
868 corresponding PACKAGE.
870 If EXT is true (default is T), includes some pointers that are not
871 actually contained in the object, but found in certain well-known
872 indirect containers: FDEFINITIONs, EQL specializers, classes, and
873 thread-local symbol values in other threads fall into this category.
875 NOTE: calling MAP-ROOT with a THREAD does not currently map over
876 conservative roots from the thread registers and interrupt contexts.
878 Experimental: interface subject to change."
879 (let ((fun (coerce function
'function
))
880 (seen (sb-int:alloc-xset
)))
882 (when (and (member (sb-kernel:lowtag-of part
)
883 `(,sb-vm
:instance-pointer-lowtag
884 ,sb-vm
:list-pointer-lowtag
885 ,sb-vm
:fun-pointer-lowtag
886 ,sb-vm
:other-pointer-lowtag
))
887 (not (sb-int:xset-member-p part seen
)))
888 (sb-int:add-to-xset part seen
)
889 (funcall fun part
))))
891 (let ((table sb-pcl
::*eql-specializer-table
*))
892 (call (sb-int:with-locked-system-table
(table)
893 (gethash object table
)))))
895 ((or bignum float sb-sys
:system-area-pointer fixnum
))
897 (call (sb-ext:weak-pointer-value object
)))
901 (when (and ext
(ignore-errors (fboundp object
)))
902 (call (fdefinition object
))))
904 (call (numerator object
))
905 (call (denominator object
)))
907 (call (realpart object
))
908 (call (realpart object
)))
910 (call (sb-kernel:%instance-layout object
))
911 (sb-kernel:do-instance-tagged-slot
(i object
)
912 (call (sb-kernel:%instance-ref object i
)))
914 (when (typep object
'sb-thread
:thread
)
915 (cond ((eq object sb-thread
:*current-thread
*)
916 (dolist (value (sb-thread::%thread-local-references
))
918 (sb-vm::map-stack-references
#'call
))
920 ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
921 ;; the alternative would be stopping the world...
923 (let ((sem (sb-thread:make-semaphore
))
927 (sb-thread:interrupt-thread
930 (setf refs
(sb-thread::%thread-local-references
))
931 (sb-vm::map-stack-references
(lambda (x) (push x refs
)))
932 (sb-thread:signal-semaphore sem
)))
933 (sb-thread:wait-on-semaphore sem
))
934 (sb-thread:interrupt-thread-error
()))
935 (mapc #'call refs
))))))
937 (if (simple-vector-p object
)
938 (dotimes (i (length object
))
939 (call (aref object i
)))
940 (when (sb-kernel:array-header-p object
)
941 (call (sb-kernel::%array-data-vector object
))
942 (call (sb-kernel::%array-displaced-p object
))
944 (call (sb-kernel::%array-displaced-from object
))))))
945 (sb-kernel:code-component
946 (call (sb-kernel:%code-debug-info object
))
947 (loop for i from sb-vm
:code-constants-offset
948 below
(sb-kernel:code-header-words object
)
949 do
(call (sb-kernel:code-header-ref object i
)))
950 (loop for i below
(sb-kernel:code-n-entries object
)
951 do
(call (sb-kernel:%code-entry-point object i
))))
953 (call (sb-kernel:fdefn-name object
))
954 (call (sb-kernel:fdefn-fun object
)))
955 (sb-kernel:simple-fun
956 (call (sb-kernel:fun-code-header object
))
957 (call (sb-kernel:%simple-fun-name object
))
958 (call (sb-kernel:%simple-fun-arglist object
))
959 (call (sb-kernel:%simple-fun-type object
))
960 (call (sb-kernel:%simple-fun-info object
)))
962 (call (sb-kernel:%closure-fun object
))
963 (sb-kernel:do-closure-values
(x object
)
965 (sb-kernel:funcallable-instance
966 (call (sb-kernel:%funcallable-instance-function object
))
967 (loop for i from sb-vm
:instance-data-start
968 below
(- (1+ (sb-kernel:get-closure-length object
))
969 sb-vm
:funcallable-instance-info-offset
)
970 do
(call (sb-kernel:%funcallable-instance-info object i
))))
973 (dolist (thread (sb-thread:list-all-threads
))
974 (call (sb-thread:symbol-value-in-thread object thread nil
))))
976 ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg.
977 (call (sb-ext:symbol-global-value object
))
978 (unbound-variable ()))
979 ;; These first two are probably unnecessary.
980 ;; The functoid values, if present, are in SYMBOL-INFO
981 ;; which is traversed whether or not EXT was true.
982 ;; But should we traverse SYMBOL-INFO?
983 ;; I don't know what is expected of this interface.
984 (when (and ext
(ignore-errors (fboundp object
)))
985 (call (fdefinition object
))
986 (call (macro-function object
))
987 (let ((class (find-class object nil
)))
988 (when class
(call class
))))
989 (call (symbol-plist object
)) ; perhaps SB-KERNEL:SYMBOL-INFO instead?
990 (call (symbol-name object
))
992 (call (symbol-package object
))))
993 (sb-kernel::random-class
994 (case (sb-kernel:widetag-of object
)
995 (#.sb-vm
:value-cell-widetag
996 (call (sb-kernel:value-cell-ref object
)))
998 (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
999 (sb-kernel:widetag-of object
) object
)))))))