contrib/stale-symbols.lisp

   1 ;;; This code is currently essentially the same as code posted by Eric
   2 ;;; Marsden to cmucl-imp, to detect stale symbols in a core.
   3 ;;;
   4 ;;; Known deficiencies:
   5 ;;;
   6 ;;; * flags CATCH tags as stale;
   7 ;;; * flags constants (under certain circumstances) as stale;
   8 ;;; * output is not necessarily terribly clear;
   9 ;;; * takes a long time (several hours on CSR's 300MHz x86 desktop) to
  10 ;;;   run.
  11
  12 (defun print-stale-reference (obj stream)
  13   (cond ((vectorp obj)
  14          (format stream "vector (probable package internals)"))
  15         ((sb-c::compiled-debug-function-p obj)
  16          (format stream "#<compiled-debug-function ~a>"
  17                  (sb-c::compiled-debug-function-name obj)))
  18         (t
  19          (format stream "~w" obj))))
  20
  21 (defun find-stale-objects ()
  22   (dolist (space '(:static :dynamic :read-only))
  23     (sb-vm::map-allocated-objects
  24      (lambda (obj type size)
  25        (declare (optimize (safety 0))
  26                 (ignore size))
  27        (when (eql type sb-vm:symbol-header-widetag)
  28          (ignore-errors
  29            (let ((read-only-space-refs (sb-vm::list-referencing-objects :read-only obj))
  30                  (static-space-refs (sb-vm::list-referencing-objects :static obj))
  31                  (dynamic-space-refs (sb-vm::list-referencing-objects :dynamic obj)))
  32              (when (>= 1 (+ (length read-only-space-refs)
  33                             (length static-space-refs)
  34                             (length dynamic-space-refs)))
  35                (format t "Symbol ~a::~a~%"
  36                        (and (symbol-package obj) (package-name (symbol-package obj)))
  37                        (symbol-name obj))
  38                (unless (null read-only-space-refs)
  39                  (princ "   Reference in read-only space: ")
  40                  (print-stale-reference (car read-only-space-refs) t)
  41                  (terpri))
  42                (unless (null static-space-refs)
  43                  (princ "   Reference in static space: ")
  44                  (print-stale-reference (car static-space-refs) t)
  45                  (terpri))
  46                (unless (null dynamic-space-refs)
  47                  (princ "   Reference in dynamic space: ")
  48                  (print-stale-reference (car dynamic-space-refs) t)
  49                  (terpri)))))))
  50      space)))