X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=c5d80afa04b375509c7c7e18ddb82776e41f77c8;hb=6fd5fc37c44cc49ff0cb587022df4c881683a111;hp=735d92fd0c57adee9c74b6eb41d3ec346651d32d;hpb=e5334bc7f2c88a5819e45e2d6e1cfe18af355169;p=sbcl.git diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 735d92f..c5d80af 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -31,6 +31,7 @@ (:export "ALLOCATION-INFORMATION" "FUNCTION-ARGLIST" "FUNCTION-LAMBDA-LIST" + "FUNCTION-TYPE" "DEFTYPE-LAMBDA-LIST" "VALID-FUNCTION-NAME-P" "FIND-DEFINITION-SOURCE" @@ -95,7 +96,8 @@ include the pathname of the file and the position of the definition." (elt (sb-c::compiled-debug-info-fun-map debug-info) 0)) (defun valid-function-name-p (name) - "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION " + "True if NAME denotes a valid function name, ie. one that can be passed to +FBOUNDP." (and (sb-int:valid-function-name-p name) t)) ;;;; Finding definitions @@ -358,7 +360,7 @@ If an unsupported TYPE is requested, the function will return NIL. ((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) @@ -451,7 +453,46 @@ function designator." "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))) @@ -639,6 +680,8 @@ 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? @@ -670,6 +713,8 @@ 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 @@ -689,9 +734,10 @@ Experimental. result)))) (defun canonicalize-class-designator (class-designator) - (etypecase class-designator - (symbol (find-class class-designator)) - (class 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))) @@ -730,12 +776,26 @@ For :HEAP objects the secondary value is a plist: 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 even if :PINNED in NIL if the GC has not had the need to mark the the page as pinned. (GENCGC and :SPACE :DYNAMIC only.) + :WRITE-PROTECTED + Indicates that the page on which the object starts is write-protected, + which indicates for :BOXED objects that it hasn't been written to since + the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.) + + :PAGE + The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC + only.) + For :STACK objects secondary value is the thread on whose stack the object is allocated. @@ -781,8 +841,10 @@ Experimental: interface subject to change." (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))))) + :large (logbitp 6 flags) + :page index)))) (list :space space)) #-gencgc (list :space space))))))