;;; TODO
;;; 1) structs don't have within-file location info. problem for the
-;;; structure itself, accessors and the predicate
+;;; structure itself, accessors, the copier and the predicate
;;; 3) error handling. Signal random errors, or handle and resignal 'our'
;;; error, or return NIL?
;;; 4) FIXMEs
"DEFINITION-SOURCE-CHARACTER-OFFSET"
"DEFINITION-SOURCE-FILE-WRITE-DATE"
"DEFINITION-SOURCE-PLIST"
- "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
"FIND-FUNCTION-CALLEES"
"FIND-FUNCTION-CALLERS"
"MAP-ROOT"
;; is.
(description nil :type list))
+(defun vop-sources-from-fun-templates (name)
+ (let ((fun-info (sb-int:info :function :info name)))
+ (when fun-info
+ (loop for vop in (sb-c::fun-info-templates fun-info)
+ for source = (find-definition-source
+ (sb-c::vop-info-generator-function vop))
+ do (setf (definition-source-description source)
+ (list (sb-c::template-name vop)
+ (sb-c::template-note vop)))
+ collect source))))
+
+(defun find-vop-source (name)
+ (let* ((templates (vop-sources-from-fun-templates name))
+ (vop (gethash name sb-c::*backend-template-names*))
+ (source (and vop
+ (find-definition-source
+ (sb-c::vop-info-generator-function vop)))))
+ (when source
+ (setf (definition-source-description source)
+ (list name)))
+ (if source
+ (cons source templates)
+ templates)))
+
(defun find-definition-sources-by-name (name type)
"Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
defined with name NAME. NAME may be a symbol or a extended function
((:function :generic-function)
(when (and (fboundp name)
(or (not (symbolp name))
- (not (macro-function name))))
+ (not (macro-function name))
+ (special-operator-p name)))
(let ((fun (real-fdefinition name)))
(when (eq (not (typep fun 'generic-function))
(not (eq type :generic-function)))
(let ((expander (or (sb-int:info :setf :inverse name)
(sb-int:info :setf :expander name))))
(when expander
- (sb-introspect:find-definition-source (if (symbolp expander)
- (symbol-function expander)
- expander)))))
+ (find-definition-source (if (symbolp expander)
+ (symbol-function expander)
+ expander)))))
((:structure)
(let ((class (get-class name)))
(if class
(list note)))
collect source)))))
((:optimizer)
- (when (symbolp name)
- (let ((fun-info (sb-int:info :function :info name)))
- (when fun-info
- (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
- (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
- (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
- (sb-c::fun-info-optimizer . sb-c:optimizer))))
- (loop for (reader . name) in otypes
- for fn = (funcall reader fun-info)
- when fn collect
- (let ((source (find-definition-source fn)))
- (setf (definition-source-description source)
- (list name))
- source)))))))
+ (let ((fun-info (and (symbolp name)
+ (sb-int:info :function :info name))))
+ (when fun-info
+ (let ((otypes '((sb-c:fun-info-derive-type . sb-c:derive-type)
+ (sb-c:fun-info-ltn-annotate . sb-c:ltn-annotate)
+ (sb-c:fun-info-optimizer . sb-c:optimizer)
+ (sb-c:fun-info-ir2-convert . sb-c:ir2-convert)
+ (sb-c::fun-info-stack-allocate-result
+ . sb-c::stack-allocate-result))))
+ (loop for (reader . name) in otypes
+ for fn = (funcall reader fun-info)
+ when fn collect
+ (let ((source (find-definition-source fn)))
+ (setf (definition-source-description source)
+ (list name))
+ source))))))
((:vop)
(when (symbolp name)
- (let ((fun-info (sb-int:info :function :info name)))
- (when fun-info
- (loop for vop in (sb-c::fun-info-templates fun-info)
- for source = (find-definition-source
- (sb-c::vop-info-generator-function vop))
- do (setf (definition-source-description source)
- (list (sb-c::template-name vop)
- (sb-c::template-note vop)))
- collect source)))))
+ (find-vop-source name)))
((:source-transform)
(when (symbolp name)
(let ((transform-fun (sb-int:info :function :source-transform name)))
(when transform-fun
- (sb-introspect:find-definition-source transform-fun)))))
+ (find-definition-source transform-fun)))))
(t
nil)))))
((struct-predicate-p object)
(find-definition-source
(struct-predicate-structure-class object)))
+ ((struct-copier-p object)
+ (find-definition-source
+ (struct-copier-structure-class object)))
(t
(find-function-definition-source object))))
((or condition standard-object structure-object)
;; :COMPILE-TOPLEVEL). Until that's fixed, don't return a
;; DEFINITION-SOURCE with a pathname. (When that's fixed, take
;; out the (not (debug-source-form ...)) test.
- (if (and (sb-c::debug-source-namestring debug-source)
- (not (sb-c::debug-source-form debug-source)))
- (parse-namestring (sb-c::debug-source-namestring debug-source)))
+ (when (stringp (sb-c::debug-source-namestring debug-source))
+ (parse-namestring (sb-c::debug-source-namestring debug-source)))
:character-offset
(if tlf
(elt (sb-c::debug-source-start-positions debug-source) tlf))
(sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
(defvar *struct-predicate*
(sb-vm::%simple-fun-self #'definition-source-p))
+(defvar *struct-copier*
+ (sb-vm::%simple-fun-self #'copy-definition-source))
(defun struct-accessor-p (function)
(let ((self (sb-vm::%simple-fun-self function)))
(member self (list *struct-slotplace-reader*
*struct-slotplace-writer*))))
+(defun struct-copier-p (function)
+ (let ((self (sb-vm::%simple-fun-self function)))
+ ;; FIXME there may be other structure copier functions
+ (member self (list *struct-copier*))))
+
(defun struct-predicate-p (function)
(let ((self (sb-vm::%simple-fun-self function)))
;; FIXME there may be other structure predicate functions
type
(sb-impl::%fun-type function-designator)))))))
+;;; FIXME: These three are pretty terrible. Can we place have some proper metadata
+;;; instead.
+
(defun struct-accessor-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
(cond
(sb-kernel:%closure-index-ref function 1)))))
)))
+(defun struct-copier-structure-class (function)
+ (let ((self (sb-vm::%simple-fun-self function)))
+ (cond
+ ((member self (list *struct-copier*))
+ (find-class
+ (sb-kernel::classoid-name
+ (sb-kernel::layout-classoid
+ (sb-kernel:%closure-index-ref function 0)))))
+ )))
+
(defun struct-predicate-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
(cond
(lambda (obj header size)
(when (= sb-vm:code-header-widetag header)
(funcall fn obj size)))
- space
- t)))
+ space)))
(declaim (inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
(loop for i from 0 below (length array) by 2
for xref-name = (aref array i)
for xref-path = (aref array (1+ i))
- do (when (eql xref-name wanted-name)
+ do (when (equal xref-name wanted-name)
(let ((source-location
(find-function-definition-source simple-fun)))
;; Use the more accurate source path from
(let* ((addr (sb-kernel:get-lisp-obj-address object))
(space
(cond ((< sb-vm:read-only-space-start addr
- (* sb-vm:*read-only-space-free-pointer*
- sb-vm:n-word-bytes))
+ (ash sb-vm:*read-only-space-free-pointer*
+ sb-vm:n-fixnum-tag-bits))
:read-only)
((< sb-vm:static-space-start addr
- (* sb-vm:*static-space-free-pointer*
- sb-vm:n-word-bytes))
+ (ash sb-vm:*static-space-free-pointer*
+ sb-vm:n-fixnum-tag-bits))
:static)
((< (sb-kernel:current-dynamic-space-start) addr
(sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
thread-local symbol values in other threads fall into this category.
NOTE: calling MAP-ROOT with a THREAD does not currently map over
-conservative roots from the thread stack & interrupt contexts.
+conservative roots from the thread registers and interrupt contexts.
Experimental: interface subject to change."
(let ((fun (coerce function 'function))
(funcall fun part))))
(when ext
(let ((table sb-pcl::*eql-specializer-table*))
- (call (sb-ext:with-locked-hash-table (table)
+ (call (sb-int:with-locked-system-table (table)
(gethash object table)))))
(etypecase object
((or bignum float sb-sys:system-area-pointer fixnum))
0)))
(dotimes (i (- len nuntagged))
(call (sb-kernel:%instance-ref object i))))
+ #+sb-thread
(when (typep object 'sb-thread:thread)
- (dolist (value (sb-thread::%thread-local-values object))
- (call value))))
+ (cond ((eq object sb-thread:*current-thread*)
+ (dolist (value (sb-thread::%thread-local-references))
+ (call value))
+ (sb-vm::map-stack-references #'call))
+ (t
+ ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
+ ;; the alternative would be stopping the world...
+ #+sb-thread
+ (let ((sem (sb-thread:make-semaphore))
+ (refs nil))
+ (handler-case
+ (progn
+ (sb-thread:interrupt-thread
+ object
+ (lambda ()
+ (setf refs (sb-thread::%thread-local-references))
+ (sb-vm::map-stack-references (lambda (x) (push x refs)))
+ (sb-thread:signal-semaphore sem)))
+ (sb-thread:wait-on-semaphore sem))
+ (sb-thread:interrupt-thread-error ()))
+ (mapc #'call refs))))))
(array
(if (simple-vector-p object)
(dotimes (i (length object))
(case (sb-kernel:widetag-of object)
(#.sb-vm::value-cell-header-widetag
(call (sb-kernel::value-cell-ref object)))
- #+(and sb-lutex sb-thread)
- (#.sb-vm::lutex-widetag)
(t
(warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
(sb-kernel:widetag-of object) object)))))))