From 8d29e8f3101bedd3a2889422bcdb7c220f4c0203 Mon Sep 17 00:00:00 2001
From: Daniel Barlow <dan@telent.net>
Date: Sat, 18 Oct 2003 17:17:43 +0000
Subject: [PATCH] 0.8.4.32 	More for SB-INTROSPECT, shamelessly inspired
 by Helmut 	Eller's SLIME code for CMUCL.

	FIND-FUNCTION-CALLERS, FIND-FUNCTION-CALLEES search in CODE
	objects for FDEFN references and return functions.  Users of
	the former interface are probably advised to cache the
	answers, or to accept that it's presently rather slow.
---
 contrib/sb-introspect/sb-introspect.lisp |   81 ++++++++++++++++++++++++++++++
 version.lisp-expr                        |    2 +-
 2 files changed, 82 insertions(+), 1 deletion(-)

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index 2923ab7..a00e254 100644
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -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)
 
@@ -160,4 +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)
diff --git a/version.lisp-expr b/version.lisp-expr
index 87fb53d..746df8e 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.4.31"
+"0.8.4.32"
-- 
1.7.10.4