(:export "ALLOCATION-INFORMATION"
"FUNCTION-ARGLIST"
"FUNCTION-LAMBDA-LIST"
+ "FUNCTION-TYPE"
"DEFTYPE-LAMBDA-LIST"
"VALID-FUNCTION-NAME-P"
"FIND-DEFINITION-SOURCE"
"WHO-CALLS"
"WHO-REFERENCES"
"WHO-SETS"
- "WHO-MACROEXPANDS"))
+ "WHO-MACROEXPANDS"
+ "WHO-SPECIALIZES-DIRECTLY"
+ "WHO-SPECIALIZES-GENERALLY"))
(in-package :sb-introspect)
((or condition standard-object structure-object)
(find-definition-source (class-of object)))
(t
- (error "Don't know how to retrieve source location for a ~S~%"
+ (error "Don't know how to retrieve source location for a ~S"
(type-of object)))))
(defun find-function-definition-source (function)
"Returns the lambda list of TYPESPEC-OPERATOR as first return
value, and a flag whether the arglist could be found as second
value."
- (sb-int:info :type :lambda-list typespec-operator))
+ (check-type typespec-operator symbol)
+ (case (sb-int:info :type :kind typespec-operator)
+ (:defined
+ (sb-int:info :type :lambda-list typespec-operator))
+ (:primitive
+ (let ((translator-fun (sb-int:info :type :translator typespec-operator)))
+ (if translator-fun
+ (values (sb-kernel:%fun-lambda-list translator-fun) t)
+ ;; Some builtin types (e.g. STRING) do not have a
+ ;; translator, but they were actually defined via DEFTYPE
+ ;; in src/code/deftypes-for-target.lisp.
+ (sb-int:info :type :lambda-list typespec-operator))))
+ (t (values nil nil))))
+
+(defun function-type (function-designator)
+ "Returns the ftype of FUNCTION-DESIGNATOR, or NIL."
+ (flet ((ftype-of (function-designator)
+ (sb-kernel:type-specifier
+ (sb-int:info :function :type function-designator))))
+ (etypecase function-designator
+ (symbol
+ (when (and (fboundp function-designator)
+ (not (macro-function function-designator))
+ (not (special-operator-p function-designator)))
+ (ftype-of function-designator)))
+ (cons
+ (when (and (sb-int:legal-fun-name-p function-designator)
+ (fboundp function-designator))
+ (ftype-of function-designator)))
+ (generic-function
+ (function-type (sb-pcl:generic-function-name function-designator)))
+ (function
+ ;; Give declared type in globaldb priority over derived type
+ ;; because it contains more accurate information e.g. for
+ ;; struct-accessors.
+ (let ((type (function-type (sb-kernel:%fun-name
+ (sb-impl::%fun-fun function-designator)))))
+ (if type
+ type
+ (sb-impl::%fun-type function-designator)))))))
(defun struct-accessor-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
definition-source pairs."
(collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
+(defun who-specializes-directly (class-designator)
+ "Search for source locations of methods directly specializing on
+CLASS-DESIGNATOR. Returns an alist of method name, definition-source
+pairs.
+
+A method matches the criterion either if it specializes on the same
+class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
+specializers), or if it eql-specializes on an instance of the
+designated class.
+
+Experimental.
+"
+ (let ((class (canonicalize-class-designator class-designator)))
+ (unless class
+ (return-from who-specializes-directly nil))
+ (let ((result (collect-specializing-methods
+ #'(lambda (specl)
+ ;; Does SPECL specialize on CLASS directly?
+ (typecase specl
+ (sb-pcl::class-eq-specializer
+ (eq (sb-pcl::specializer-object specl) class))
+ (sb-pcl::eql-specializer
+ (let ((obj (sb-mop:eql-specializer-object specl)))
+ (eq (class-of obj) class)))
+ ((not sb-pcl::standard-specializer)
+ nil)
+ (t
+ (eq specl class)))))))
+ (map-into result #'(lambda (m)
+ (cons `(method ,(method-generic-function-name m))
+ (find-definition-source m)))
+ result))))
+
+(defun who-specializes-generally (class-designator)
+ "Search for source locations of methods specializing on
+CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
+name, definition-source pairs.
+
+A method matches the criterion either if it specializes on the
+designated class itself or a subclass of it (this includes CLASS-EQ
+specializers), or if it eql-specializes on an instance of the
+designated class or a subclass of it.
+
+Experimental.
+"
+ (let ((class (canonicalize-class-designator class-designator)))
+ (unless class
+ (return-from who-specializes-generally nil))
+ (let ((result (collect-specializing-methods
+ #'(lambda (specl)
+ ;; Does SPECL specialize on CLASS or a subclass
+ ;; of it?
+ (typecase specl
+ (sb-pcl::class-eq-specializer
+ (subtypep (sb-pcl::specializer-object specl) class))
+ (sb-pcl::eql-specializer
+ (typep (sb-mop:eql-specializer-object specl) class))
+ ((not sb-pcl::standard-specializer)
+ nil)
+ (t
+ (subtypep specl class)))))))
+ (map-into result #'(lambda (m)
+ (cons `(method ,(method-generic-function-name m))
+ (find-definition-source m)))
+ result))))
+
+(defun canonicalize-class-designator (class-designator)
+ (typecase class-designator
+ (symbol (find-class class-designator nil))
+ (class class-designator)
+ (t nil)))
+
+(defun method-generic-function-name (method)
+ (sb-mop:generic-function-name (sb-mop:method-generic-function method)))
+
+(defun collect-specializing-methods (predicate)
+ (let ((result '()))
+ (sb-pcl::map-specializers
+ #'(lambda (specl)
+ (when (funcall predicate specl)
+ (let ((methods (sb-mop:specializer-direct-methods specl)))
+ (setf result (append methods result))))))
+ (delete-duplicates result)))
+
+
;;;; ALLOCATION INTROSPECTION
(defun allocation-information (object)
Indicates a \"large\" object subject to non-copying
promotion. (GENCGC and :SPACE :DYNAMIC only.)
+ :BOXED
+ Indicates that the object is allocated in a boxed region. Unboxed
+ allocation is used for eg. specialized arrays after they have survived one
+ collection. (GENCGC and :SPACE :DYNAMIC only.)
+
:PINNED
Indicates that the page(s) on which the object resides are kept live due
to conservative references. Note that object may reside on a pinned page
(list :space space
:generation (sb-alien:slot page 'sb-vm::gen)
:write-protected (logbitp 0 flags)
+ :boxed (logbitp 2 flags)
:pinned (logbitp 5 flags)
:large (logbitp 6 flags)))))
(list :space space))
projects / sbcl.git / blobdiff