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