X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fsnapshot.lisp;h=4e01ec3ed6a4c7a6c371b03c6427150913477397;hb=debae3c18d31b5222be4d5de8dcb2601336e24a4;hp=846c06f73cca8fb31c933025518f474c03812ca3;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/cold/snapshot.lisp b/src/cold/snapshot.lisp index 846c06f..4e01ec3 100644 --- a/src/cold/snapshot.lisp +++ b/src/cold/snapshot.lisp @@ -1,4 +1,23 @@ ;;;; code to detect whether a package has changed +;;;; +;;;; This is really old code which was most useful when first +;;;; bootstrapping SBCL when only CMU CL was available as an XC host. +;;;; Its main purpose was to check that legacy code like DEFMACRO +;;;; DOLIST and DEFUN IR1-OPTIMIZE-UNTIL-DONE was all correctly +;;;; converted from code which mutated the XC host into code which +;;;; built things for the target. +;;;; +;;;; These days, things like DEFUN IR1-OPTIMIZE-UNTIL-DONE can't very +;;;; well be mutating the cross-compiler host because we can build +;;;; successfully under OpenMCL, which shouldn't have the same +;;;; packages or symbols. So we don't need to worry very much about +;;;; modifying the XC host's private packages. However, it's still +;;;; conceivable that something affecting the XC host's CL package +;;;; (maybe DEFMACRO DOLIST?) could be written in such a way that it +;;;; would silently compile under SBCL, CMU CL, and even OpenMCL, and +;;;; still be fundamentally wrong. Since it'd be good to prevent such +;;;; modifications of the XC host's CL package, this code is still +;;;; retained despite being a little strange. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -13,8 +32,8 @@ (defstruct snapshot (hash-table (make-hash-table :test 'eq) - :type hash-table - :read-only t)) + :type hash-table + :read-only t)) ;;; Return a SNAPSHOT object representing the current state of the ;;; package associated with PACKAGE-DESIGNATOR. @@ -23,58 +42,58 @@ ;;; type definitions and documentation strings. (defun take-snapshot (package-designator) (let ((package (find-package package-designator)) - (result (make-snapshot))) + (result (make-snapshot))) (unless package (error "can't find package ~S" package-designator)) (do-symbols (symbol package) (multiple-value-bind (symbol-ignore status) - (find-symbol (symbol-name symbol) package) - (declare (ignore symbol-ignore)) - (let ((symbol-properties nil)) - (ecase status - (:inherited - (values)) - ((:internal :external) - (when (boundp symbol) - (push (cons :symbol-value (symbol-value symbol)) - symbol-properties)) - (when (fboundp symbol) - (push (cons :symbol-function (symbol-function symbol)) - symbol-properties)) - (when (macro-function symbol) - (push (cons :macro-function (macro-function symbol)) - symbol-properties)) - (when (special-operator-p symbol) - (push :special-operator - symbol-properties)))) - (push status symbol-properties) - (setf (gethash symbol (snapshot-hash-table result)) - symbol-properties)))) + (find-symbol (symbol-name symbol) package) + (declare (ignore symbol-ignore)) + (let ((symbol-properties nil)) + (ecase status + (:inherited + (values)) + ((:internal :external) + (when (boundp symbol) + (push (cons :symbol-value (symbol-value symbol)) + symbol-properties)) + (when (fboundp symbol) + (push (cons :symbol-function (symbol-function symbol)) + symbol-properties)) + (when (macro-function symbol) + (push (cons :macro-function (macro-function symbol)) + symbol-properties)) + (when (special-operator-p symbol) + (push :special-operator + symbol-properties)))) + (push status symbol-properties) + (setf (gethash symbol (snapshot-hash-table result)) + symbol-properties)))) result)) (compile 'take-snapshot) (defun snapshot-diff (x y) (let ((xh (snapshot-hash-table x)) - (yh (snapshot-hash-table y)) - (result nil)) + (yh (snapshot-hash-table y)) + (result nil)) (flet ((1way (ah bh) - (maphash (lambda (key avalue) - (declare (ignore avalue)) - (multiple-value-bind (bvalue bvalue?) (gethash key bh) - (declare (ignore bvalue)) - (unless bvalue? - (push (list key ah) - result)))) - ah))) + (maphash (lambda (key avalue) + (declare (ignore avalue)) + (multiple-value-bind (bvalue bvalue?) (gethash key bh) + (declare (ignore bvalue)) + (unless bvalue? + (push (list key ah) + result)))) + ah))) (1way xh yh) (1way yh xh)) (maphash (lambda (key xvalue) - (multiple-value-bind (yvalue yvalue?) (gethash key yh) - (when yvalue? - (unless (equalp xvalue yvalue) - (push (list key xvalue yvalue) - result))))) - xh) + (multiple-value-bind (yvalue yvalue?) (gethash key yh) + (when yvalue? + (unless (equalp xvalue yvalue) + (push (list key xvalue yvalue) + result))))) + xh) result)) (compile 'snapshot-diff) @@ -85,37 +104,41 @@ *cl-ignorable-diffs* (let ((result (make-hash-table :test 'eq))) (dolist (symbol `(;; These change regularly: - * ** *** - / // /// - + ++ +++ - - - *gensym-counter* - ;; These are bound when compiling and/or loading: - *package* - *compile-file-truename* - *compile-file-pathname* - *load-truename* - *load-pathname* - ;; These change because CMU CL uses them as internal - ;; variables: - ,@' - #-cmu nil - #+cmu (cl::*gc-trigger* - cl::inch-ptr - cl::*internal-symbol-output-fun* - cl::ouch-ptr - cl::*previous-case* - cl::read-buffer - cl::read-buffer-length - cl::*string-output-streams* - cl::*available-buffers* - cl::*current-unwind-protect-block* - cl::*load-depth* - cl::*free-fop-tables* - ;; These two are changed by PURIFY. - cl::*static-space-free-pointer* - cl::*static-space-end-pointer*) - )) + * ** *** + / // /// + + ++ +++ + - + *gensym-counter* + ;; These are bound when compiling and/or loading: + *package* + *compile-file-truename* + *compile-file-pathname* + *load-truename* + *load-pathname* + ;; These change because CMU CL uses them as internal + ;; variables: + ,@' + #-cmu nil + #+cmu (cl::*gc-trigger* + cl::inch-ptr + cl::*internal-symbol-output-function* + cl::ouch-ptr + cl::*previous-case* + cl::read-buffer + cl::read-buffer-length + cl::*string-output-streams* + cl::*available-buffers* + cl::*current-unwind-protect-block* + cl::*load-depth* + cl::*free-fop-tables* + cl::*load-symbol-buffer* + cl::*load-symbol-buffer-size* + cl::in-index + cl::in-buffer + ;; These two are changed by PURIFY. + cl::*static-space-free-pointer* + cl::*static-space-end-pointer*) + )) (setf (gethash symbol result) t)) result)) @@ -130,14 +153,14 @@ (progn (defun cl-snapshot-diff (cl-snapshot) (remove-if (lambda (entry) - (gethash (first entry) *cl-ignorable-diffs*)) - (snapshot-diff cl-snapshot (take-snapshot :common-lisp)))) + (gethash (first entry) *cl-ignorable-diffs*)) + (snapshot-diff cl-snapshot (take-snapshot :common-lisp)))) (defun warn-when-cl-snapshot-diff (cl-snapshot) (let ((cl-snapshot-diff (cl-snapshot-diff cl-snapshot))) (when cl-snapshot-diff - (let ((*print-length* 30) - (*print-circle* t)) - (warn "CL snapshot differs:") - (print cl-snapshot-diff *error-output*))))) + (let ((*print-length* 30) + (*print-circle* t)) + (warn "CL snapshot differs:") + (print cl-snapshot-diff *error-output*))))) (compile 'cl-snapshot-diff) (compile 'warn-when-cl-snapshot-diff))