X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fstale-symbols.lisp;h=e59e79595eedba1caf6d0a4a2b57a8aa46b7fc75;hb=7f4bf063d5f4716b87d34cc706f05b27ad3906b1;hp=0803bf5e9c4d3f5a57ac935dd7d71374df6151ae;hpb=316eddc9b2b1aa24012ed826ce700105fdbcdfdb;p=sbcl.git

diff --git a/contrib/stale-symbols.lisp b/contrib/stale-symbols.lisp
index 0803bf5..e59e795 100644
--- a/contrib/stale-symbols.lisp
+++ b/contrib/stale-symbols.lisp
@@ -3,48 +3,98 @@
 ;;;
 ;;; 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.
+;;;
+;;; Comment from Eric Marsden:
+;;;
+;;; This file contains code that attempts to identify symbols in a
+;;; CMUCL image that are stale. For example, the package descriptions
+;;; in src/code/package.lisp can get out of sync with the source code,
+;;; leading to symbols that are exported without being used anywhere.
+;;;
+;;; The routines work by walking all the objects allocated in a heap
+;;; image (using the function VM::MAP-ALLOCATED-OBJECTS). For each
+;;; object of type symbol, it scans the entire heap for objects that
+;;; reference that symbol. If it finds no references, or if there is
+;;; 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
+;;; 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 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-function-p obj)
-         (format stream "#<compiled-debug-function ~a>"
-                 (sb-c::compiled-debug-function-name obj)))
+        ((sb-c::compiled-debug-fun-p obj)
+         (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)))