[Sbcl-commits] CVS: sbcl/contrib stale-symbols.lisp,1.4,1.5

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/contrib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6924/contrib

Modified Files:
	stale-symbols.lisp 
Log Message:
0.8.13.1:
	Implement MAP-REFERENCING-OBJECTS, and make the implementation 
	of LIST-REFERENCING-OBJECTS use it.
	... note potential badness of cutoff point in space search.  
		(could this be the problem in ROOM T?)
	Improvements to stale-symbols script.
	... if there is more than one reference, don't bother chasing 
		all the others down;
	... closures can contain stuff;
	... print symbols and references a little more nicely.
	


Index: stale-symbols.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/stale-symbols.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- stale-symbols.lisp	14 Jan 2004 16:53:17 -0000	1.4
+++ stale-symbols.lisp	26 Jul 2004 10:15:39 -0000	1.5
@@ -3,8 +3,6 @@
 ;;;
 ;;; Known deficiencies:
 ;;;
-;;; * flags CATCH tags as stale;
-;;; * flags constants (under certain circumstances) as stale;
 ;;; * output is not necessarily terribly clear;
 ;;; * takes a long time (several hours on CSR's 300MHz x86 desktop) to
 ;;;   run.
@@ -23,67 +21,80 @@
 ;;; only one reference that looks like it is likely from the internals
 ;;; of a package-related datastructure, the name of the symbol and its
 ;;; package is displayed.
+;;;
 ;;; The "references to that symbol" are found using the function
-;;; VM::LIST-REFERENCING-OBJECTS. Consider for example a function that
-;;; uses the value of a symbol. The code-object for that function
+;;; SB-VM::MAP-REFERENCING-OBJECTS. Consider for example a function
+;;; that uses the value of a symbol. The code-object for that function
 ;;; contains a reference to the symbol, so that a call to SYMBOL-VALUE
 ;;; can be made at runtime. The data structures corresponding to a
 ;;; package must maintain a list of its exported an imported symbols.
 ;;; They contain a hashtable, which contains a vector, which contains
-;;; symbols. So all exported symbols will have at least one referencing
-;;; object: a vector related to some package.
-;;;
-;;; Limitations: these routines will provide a number of false
-;;; positives (symbols that are not actually stale). Throw/catch tags
-;;; are displayed, but are not stale. It displays the names of
-;;; restarts. Worse, it displays the names of CMUCL-internal constants.
-;;; These symbols that name constants are not referenced from anywhere
-;;; except the package datastructures because the compiler can
-;;; substitute their value wherever they're used in the CMUCL source
-;;; code, without keeping a reference to the symbol hanging around.
-;;; There are also a number of PCL-related symbols that are displayed,
-;;; but probably used internally by PCL.
+;;; symbols. So all exported symbols will have at least one
+;;; referencing object: a vector related to some package.
 ;;;
-;;; Moral: the output of these routines must be checked carefully
-;;; before going on a code deletion spree.
+;;; Limitations: these routines may provide a number of false
+;;; positives (symbols that are not actually stale).  There are also a
+;;; number of PCL-related symbols that are displayed, but probably
+;;; used internally by PCL.  Moral: the output of these routines must
+;;; be checked carefully before going on a code deletion spree.
 
 (defun print-stale-reference (obj stream)
   (cond ((vectorp obj)
          (format stream "vector (probable package internals)"))
         ((sb-c::compiled-debug-fun-p obj)
-         (format stream "#<compiled-debug-fun ~a>"
+         (format stream "#<compiled-debug-fun ~A>"
                  (sb-c::compiled-debug-fun-name obj)))
+	((sb-kernel:code-component-p obj)
+	 (format stream "#<code ~A>"
+		 (let ((dinfo (sb-kernel:%code-debug-info obj)))
+		   (cond
+		     ((eq dinfo :bogus-lra) "BOGUS-LRA")
+		     (t (sb-c::debug-info-name dinfo))))))
         (t
          (format stream "~w" obj))))
 
+(defun external-symbol-p (obj)
+  (declare (type symbol obj))
+  (let ((package (symbol-package obj)))
+    (and package
+	 (eq (nth-value 1 (find-symbol (symbol-name obj) package))
+	     :external))))
+
 (defun find-stale-objects ()
   (dolist (space '(:static :dynamic :read-only))
     (sb-vm::map-allocated-objects
      (lambda (obj type size)
        (declare (optimize (safety 0))
                 (ignore size))
-       (when (eql type sb-vm:symbol-header-widetag)
-         (ignore-errors
-           (let ((read-only-space-refs (sb-vm::list-referencing-objects :read-only obj))
-                 (static-space-refs (sb-vm::list-referencing-objects :static obj))
-                 (dynamic-space-refs (sb-vm::list-referencing-objects :dynamic obj)))
-             (when (>= 1 (+ (length read-only-space-refs)
-                            (length static-space-refs)
-                            (length dynamic-space-refs)))
-               (format t "Symbol ~a::~a~%"
-                       (and (symbol-package obj)
-			    (package-name (symbol-package obj)))
-                       (symbol-name obj))
-               (unless (null read-only-space-refs)
-                 (princ "   Reference in read-only space: ")
-                 (print-stale-reference (car read-only-space-refs) t)
-                 (terpri))
-               (unless (null static-space-refs)
-                 (princ "   Reference in static space: ")
-                 (print-stale-reference (car static-space-refs) t)
-                 (terpri))
-               (unless (null dynamic-space-refs)
-                 (princ "   Reference in dynamic space: ")
-                 (print-stale-reference (car dynamic-space-refs) t)
-                 (terpri)))))))
+       (block mapper
+	 (when (eql type sb-vm:symbol-header-widetag)
+	   (ignore-errors
+	     (let ((refs (let ((res nil)
+			       (count 0))
+			   (dolist (space '(:static :dynamic :read-only))
+			     (sb-vm::map-referencing-objects
+			      (lambda (o)
+				(when (> (incf count) 1)
+				  (return-from mapper nil))
+				(push (cons space o) res))
+			      space obj))
+			   res)))
+	       (let ((externalp (external-symbol-p obj)))
+		 (format t "~:[S~;External s~]ymbol ~:[#~;~:*~A:~]~2:*~:[:~;~]~*~A~%"
+			 externalp
+			 (and (symbol-package obj)
+			      (package-name (symbol-package obj)))
+			 (symbol-name obj)))
+	       (if (null refs)
+		   (progn (princ "   No references found") (terpri))
+		   (progn
+		     (ecase (caar refs)
+		       (:read-only
+			(princ "   Reference in read-only space: "))
+		       (:static
+			(princ "   Reference in static space: "))
+		       (:dynamic
+			(princ "   Reference in dynamic space: ")))
+		     (print-stale-reference (cdar refs) t)
+		     (terpri))))))))
      space)))