src/cold/snapshot.lisp

   1 ;;;; code to detect whether a package has changed
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-COLD")
  13
  14 ;;;; $Header$
  15
  16 (defstruct snapshot
  17   (hash-table (make-hash-table :test 'eq)
  18               :type hash-table
  19               :read-only t))
  20
  21 ;;; Return a SNAPSHOT object representing the current state of the
  22 ;;; package associated with PACKAGE-DESIGNATOR.
  23 ;;;
  24 ;;; This could be made more sensitive, checking for more things, such as
  25 ;;; type definitions and documentation strings.
  26 (defun take-snapshot (package-designator)
  27   (let ((package (find-package package-designator))
  28         (result (make-snapshot)))
  29     (unless package
  30       (error "can't find package ~S" package-designator))
  31     (do-symbols (symbol package)
  32       (multiple-value-bind (symbol-ignore status)
  33           (find-symbol (symbol-name symbol) package)
  34         (declare (ignore symbol-ignore))
  35         (let ((symbol-properties nil))
  36           (ecase status
  37             (:inherited
  38              (values))
  39             ((:internal :external)
  40              (when (boundp symbol)
  41                (push (cons :symbol-value (symbol-value symbol))
  42                      symbol-properties))
  43              (when (fboundp symbol)
  44                (push (cons :symbol-function (symbol-function symbol))
  45                      symbol-properties))
  46              (when (macro-function symbol)
  47                (push (cons :macro-function (macro-function symbol))
  48                      symbol-properties))
  49              (when (special-operator-p symbol)
  50                (push :special-operator
  51                      symbol-properties))))
  52           (push status symbol-properties)
  53           (setf (gethash symbol (snapshot-hash-table result))
  54                 symbol-properties))))
  55     result))
  56 (compile 'take-snapshot)
  57
  58 (defun snapshot-diff (x y)
  59   (let ((xh (snapshot-hash-table x))
  60         (yh (snapshot-hash-table y))
  61         (result nil))
  62     (flet ((1way (ah bh)
  63              (maphash (lambda (key avalue)
  64                         (declare (ignore avalue))
  65                         (multiple-value-bind (bvalue bvalue?) (gethash key bh)
  66                           (declare (ignore bvalue))
  67                           (unless bvalue?
  68                             (push (list key ah)
  69                                   result))))
  70                       ah)))
  71       (1way xh yh)
  72       (1way yh xh))
  73     (maphash (lambda (key xvalue)
  74                (multiple-value-bind (yvalue yvalue?) (gethash key yh)
  75                  (when yvalue?
  76                    (unless (equalp xvalue yvalue)
  77                      (push (list key xvalue yvalue)
  78                            result)))))
  79              xh)
  80     result))
  81 (compile 'snapshot-diff)
  82
  83 ;;;; symbols in package COMMON-LISP which change regularly in the course of
  84 ;;;; execution even if we don't mess with them, so that reporting changes
  85 ;;;; would be more confusing than useful
  86 (defparameter
  87   *cl-ignorable-diffs*
  88   (let ((result (make-hash-table :test 'eq)))
  89     (dolist (symbol `(;; These change regularly:
  90                       * ** ***
  91                       / // ///
  92                       + ++ +++
  93                       -
  94                       *gensym-counter*
  95                       ;; These are bound when compiling and/or loading:
  96                       *package*
  97                       *compile-file-truename*
  98                       *compile-file-pathname*
  99                       *load-truename*
 100                       *load-pathname*
 101                       ;; These change because CMU CL uses them as internal
 102                       ;; variables:
 103                       ,@'
 104                       #-cmu nil
 105                       #+cmu (cl::*gc-trigger*
 106                              cl::inch-ptr
 107                              cl::*internal-symbol-output-function*
 108                              cl::ouch-ptr
 109                              cl::*previous-case*
 110                              cl::read-buffer
 111                              cl::read-buffer-length
 112                              cl::*string-output-streams*
 113                              cl::*available-buffers*
 114                              cl::*current-unwind-protect-block*
 115                              cl::*load-depth*
 116                              cl::*free-fop-tables*
 117                              ;; These two are changed by PURIFY.
 118                              cl::*static-space-free-pointer*
 119                              cl::*static-space-end-pointer*)
 120                       ))
 121       (setf (gethash symbol result) t))
 122     result))
 123
 124 ;;; specialized version of SNAPSHOT-DIFF to check on the COMMON-LISP package,
 125 ;;; throwing away reports of differences in variables which are known to change
 126 ;;; regularly
 127 ;;;
 128 ;;; Note: The warnings from this code were somewhat useful when first setting
 129 ;;; up the cross-compilation system, have a rather low signal/noise ratio in
 130 ;;; the mature system. They can generally be safely ignored.
 131 #!+sb-show
 132 (progn
 133   (defun cl-snapshot-diff (cl-snapshot)
 134     (remove-if (lambda (entry)
 135                  (gethash (first entry) *cl-ignorable-diffs*))
 136                (snapshot-diff cl-snapshot (take-snapshot :common-lisp))))
 137   (defun warn-when-cl-snapshot-diff (cl-snapshot)
 138     (let ((cl-snapshot-diff (cl-snapshot-diff cl-snapshot)))
 139       (when cl-snapshot-diff
 140         (let ((*print-length* 30)
 141               (*print-circle* t))
 142           (warn "CL snapshot differs:")
 143           (print cl-snapshot-diff *error-output*)))))
 144   (compile 'cl-snapshot-diff)
 145   (compile 'warn-when-cl-snapshot-diff))