1.0.37.4: robuster page table pickup
[sbcl.git] / 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                              ;; These two are changed by PURIFY.
139                              cl::*static-space-free-pointer*
140                              cl::*static-space-end-pointer*)
141                       ))
142       (setf (gethash symbol result) t))
143     result))
144
145 ;;; specialized version of SNAPSHOT-DIFF to check on the COMMON-LISP package,
146 ;;; throwing away reports of differences in variables which are known to change
147 ;;; regularly
148 ;;;
149 ;;; Note: The warnings from this code were somewhat useful when first setting
150 ;;; up the cross-compilation system, have a rather low signal/noise ratio in
151 ;;; the mature system. They can generally be safely ignored.
152 #!+sb-show
153 (progn
154   (defun cl-snapshot-diff (cl-snapshot)
155     (remove-if (lambda (entry)
156                  (gethash (first entry) *cl-ignorable-diffs*))
157                (snapshot-diff cl-snapshot (take-snapshot :common-lisp))))
158   (defun warn-when-cl-snapshot-diff (cl-snapshot)
159     (let ((cl-snapshot-diff (cl-snapshot-diff cl-snapshot)))
160       (when cl-snapshot-diff
161         (let ((*print-length* 30)
162               (*print-circle* t))
163           (warn "CL snapshot differs:")
164           (print cl-snapshot-diff *error-output*)))))
165   (compile 'cl-snapshot-diff)
166   (compile 'warn-when-cl-snapshot-diff))