X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=7b73c568c9fe862b457f7a4a7e578a7dcbe25f09;hb=d1287b8413141509ca384971f615dde98979583e;hp=baa9a8e99a1ea582513828dc810ba1d227ebe2fa;hpb=30e14368c96ec7eb0a9efe29df6742bbf66be8de;p=sbcl.git

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index baa9a8e..7b73c56 100644
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -24,7 +24,7 @@
 ;;; 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")
@@ -34,6 +34,8 @@
 	   "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
 	   "DEFINITION-SOURCE-FORM-PATH"
 	   "DEFINITION-SOURCE-CHARACTER-OFFSET"
+	   "FIND-FUNCTION-CALLEES"
+	   "FIND-FUNCTION-CALLERS"
 	   ))
 (in-package :sb-introspect)
 
@@ -44,8 +46,8 @@
 
 (defun function-arglist (function)
   "Describe the lambda list for the function designator FUNCTION.
-Works for macros, simple functions and generic functions.  Signals error
-if not found"
+Works for special-operators, macros, simple functions and generic
+functions.  Signals error if not found"
   (cond ((valid-function-name-p function) 
          (function-arglist
 	  (or (macro-function function) (fdefinition function))))
@@ -80,20 +82,16 @@ Returns a DEFINITION-SOURCE object"))
 
 ;; 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
@@ -164,3 +162,83 @@ Returns a DEFINITION-SOURCE object"))
 	   (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)