;;; This code is currently essentially the same as code posted by Eric
;;; Marsden to cmucl-imp, to detect stale symbols in a core.
;;;
;;; 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.

(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)))
        (t
         (format stream "~w" obj))))

(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)))))))
     space)))