src/cold/snapshot.lisp

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