0.7.6.23:
[sbcl.git] / 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))