src/code/shaketree.lisp

   1 (in-package sb-impl)
   2
   3 ;;; Remove all symbols from all packages, storing them in weak pointers,
   4 ;;; then collect garbage, and re-intern all symbols that survived GC.
   5 ;;; Any symbol satisfying PREDICATE will be strongly referenced during GC
   6 ;;; so that it doesn't disappear, regardless of whether it appeared unused.
   7 (defun shake-packages (predicate &key print verbose query)
   8   (declare (function predicate))
   9   (let (list)
  10     (flet ((weaken (table accessibility)
  11              (let ((cells (symtbl-cells table))
  12                    (result))
  13                (dovector (x cells)
  14                  (when (symbolp x)
  15                    (if (funcall predicate x accessibility)
  16                        (push x result) ; keep a strong reference to this symbol
  17                        (push (cons (string x) (make-weak-pointer x)) result))))
  18                (fill cells 0)
  19                (resize-symbol-table table 0 t)
  20                result)))
  21       (dolist (package (list-all-packages))
  22         ;; Never discard standard symbols
  23         (unless (eq package sb-int:*cl-package*)
  24           (push (list* (weaken (package-internal-symbols package) :internal)
  25                        (weaken (package-external-symbols package) :external)
  26                        package)
  27                 list))))
  28     (gc :gen 7)
  29     (when query
  30       (sb-ext:search-roots query :criterion :static))
  31     (let ((n-dropped 0))
  32       (flet ((reintern (symbols table package access)
  33                (declare (ignore package))
  34                (dolist (item symbols)
  35                  (if (symbolp item)
  36                      (add-symbol table item)
  37                      (let ((symbol (weak-pointer-value (cdr item))))
  38                        (cond (symbol
  39                               (add-symbol table symbol))
  40                              (t
  41                               (when print
  42                                 (format t "  (~a)~A~%" access (car item)))
  43                               (incf n-dropped))))))))
  44         (loop for (internals externals . package) in list
  45               do (when print
  46                    (format t "~&Package ~A~%" package))
  47                  (reintern internals (package-internal-symbols package)
  48                            package #\i)
  49                  (reintern externals (package-external-symbols package)
  50                            package #\e))
  51         (when verbose
  52           (format t "~&Dropped ~D symbols~%" n-dropped))
  53         (force-output)))))