;;; 5) would be nice to have some interface to the compiler that lets us
;;; fake the filename and position, for use with C-M-x
-(declaim (optimize (debug 3)))
+(declaim (optimize (debug 1)))
(defpackage :sb-introspect
(:use "CL")
"DEFINITION-NOT-FOUND" "DEFINITION-NAME"
"DEFINITION-SOURCE-FORM-PATH"
"DEFINITION-SOURCE-CHARACTER-OFFSET"
+ "FIND-FUNCTION-CALLEES"
+ "FIND-FUNCTION-CALLERS"
))
(in-package :sb-introspect)
;; Internal-only, don't call this directly
(defun find-function-definition-source (o)
- (let* ((name (sb-vm::%simple-fun-name o))
- (debug-info
+ (let* ((debug-info
(sb-kernel:%code-debug-info
(sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
(debug-source
(car (sb-c::compiled-debug-info-source debug-info)))
- (debug-fun
- (loop for debug-fun
- across (sb-c::compiled-debug-info-fun-map debug-info)
- when (and (sb-c::debug-fun-p debug-fun)
- (eql (sb-c::compiled-debug-fun-name debug-fun) name))
- return debug-fun))
+ (debug-fun (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
(tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
- ;; FIXME why only the first debug-source? can there be >1?
+ ;; HAZARDOUS ASSUMPTION: in CMUCL it's possible to get >1 debug-source
+ ;; for a debug-info (one per file). In SBCL the function that builds
+ ;; debug-sources always produces singleton lists
(sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info))))
(make-definition-source
:pathname
(sb-int:info :type :classoid (class-name o))))))
(find-definition-source constructor)))
+;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
+
+;;; This interface is trmendously experimental.
+
+;;; For the moment I'm taking the view that FDEFN is an internal
+;;; object (one out of one CMUCL developer surveyed didn't know what
+;;; they were for), so these routines deal in FUNCTIONs
+
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(declaim (inline map-code-constants))
+(defun map-code-constants (code fn)
+ "Call FN for each constant in CODE's constant pool."
+ (check-type code sb-kernel:code-component)
+ (loop for i from sb-vm:code-constants-offset below
+ (sb-kernel:get-header-data code)
+ do (funcall fn (sb-kernel:code-header-ref code i))))
+
+(defun find-function-callees (function)
+ "Return functions called by FUNCTION."
+ (let ((callees '()))
+ (map-code-constants
+ (sb-kernel:fun-code-header function)
+ (lambda (obj)
+ (when (sb-kernel:fdefn-p obj)
+ (push (sb-kernel:fdefn-fun obj)
+ callees))))
+ callees))
+
+(declaim (inline map-allocated-code-components))
+(defun map-allocated-code-components (spaces fn)
+ "Call FN for each allocated code component in one of SPACES. FN
+receives the object and its size as arguments. SPACES should be a
+list of the symbols :dynamic, :static, or :read-only."
+ (dolist (space spaces)
+ (sb-vm::map-allocated-objects
+ (lambda (obj header size)
+ (when (= sb-vm:code-header-widetag header)
+ (funcall fn obj size)))
+ space)))
+
+(declaim (inline map-caller-code-components))
+(defun map-caller-code-components (function spaces fn)
+ "Call FN for each code component with a fdefn for FUNCTION in its
+constant pool."
+ (let ((function (coerce function 'function)))
+ (map-allocated-code-components
+ spaces
+ (lambda (obj size)
+ (declare (ignore size))
+ (map-code-constants
+ obj
+ (lambda (constant)
+ (when (and (sb-kernel:fdefn-p constant)
+ (eq (sb-kernel:fdefn-fun constant)
+ function))
+ (funcall fn obj))))))))
+
+(defun find-function-callers (function &optional (spaces '(:read-only :static
+ :dynamic)))
+ "Return functions which call FUNCTION, by searching SPACES for code objects"
+ (let ((referrers '()))
+ (map-caller-code-components
+ function
+ spaces
+ (lambda (code)
+ (let ((entry (sb-kernel:%code-entry-points code)))
+ (cond ((not entry)
+ (push (princ-to-string code) referrers))
+ (t
+ (loop for e = entry then (sb-kernel::%simple-fun-next e)
+ while e
+ do (pushnew e referrers)))))))
+ referrers))
+
+(provide 'sb-introspect)