X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fload.lisp;h=3b2a82fbac5d6a20c7825619e58bca146f707069;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=8b3067df27ca8639abed6154e0fd6fb4ab4a3e90;hpb=3ca73f72116001579bde0f59e5aa1359cc41631e;p=sbcl.git diff --git a/src/code/load.lisp b/src/code/load.lisp index 8b3067d..3b2a82f 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -20,7 +20,7 @@ ;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess ;;;; around deciding how to thread-safetify it. So we use a Big Lock. ;;;; Because this code is mutually recursive with the compiler, we use -;;;; the *big-compiler-lock* +;;;; the **WORLD-LOCK**. ;;;; miscellaneous load utilities @@ -230,18 +230,16 @@ position ~A: Expected ~A, got ~A.~:@>" (invalid-fasl-stream condition) (invalid-fasl-byte-nr condition) - (invalid-fasl-byte condition) - (invalid-fasl-expected condition))))) + (invalid-fasl-expected condition) + (invalid-fasl-byte condition))))) (define-condition invalid-fasl-version (invalid-fasl) - ((variant :reader invalid-fasl-variant :initarg :variant) - (version :reader invalid-fasl-version :initarg :version)) + ((version :reader invalid-fasl-version :initarg :version)) (:report (lambda (condition stream) - (format stream "~@<~S is in ~A fasl file format version ~W, ~ - but this version of SBCL uses format version ~W.~:@>" + (format stream "~@<~S is a fasl file compiled with SBCL ~W, and ~ + can't be loaded into SBCL ~W.~:@>" (invalid-fasl-stream condition) - (invalid-fasl-variant condition) (invalid-fasl-version condition) (invalid-fasl-expected condition))))) @@ -271,6 +269,48 @@ (invalid-fasl-features condition) (invalid-fasl-expected condition))))) +;;; Skips past the shebang line on stream, if any. +(defun maybe-skip-shebang-line (stream) + (let ((p (file-position stream))) + (flet ((next () (read-byte stream nil))) + (unwind-protect + (when (and (eq (next) (char-code #\#)) + (eq (next) (char-code #\!))) + (setf p nil) + (loop for x = (next) + until (or (not x) (eq x (char-code #\newline))))) + (when p + (file-position stream p)))) + t)) + +;;; Returns T if the stream is a binary input stream with a FASL header. +(defun fasl-header-p (stream &key errorp) + (let ((p (file-position stream))) + (unwind-protect + (let* ((header *fasl-header-string-start-string*) + (buffer (make-array (length header) :element-type '(unsigned-byte 8))) + (n 0)) + (flet ((scan () + (maybe-skip-shebang-line stream) + (setf n (read-sequence buffer stream)))) + (if errorp + (scan) + (or (ignore-errors (scan)) + ;; no a binary input stream + (return-from fasl-header-p nil)))) + (if (mismatch buffer header + :test #'(lambda (code char) (= code (char-code char)))) + ;; Immediate EOF is valid -- we want to match what + ;; CHECK-FASL-HEADER does... + (or (zerop n) + (when errorp + (error 'fasl-header-missing + :stream stream + :fhsss buffer + :expected header))) + t)) + (file-position stream p)))) + ;;;; LOAD-AS-FASL ;;;; ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with @@ -280,21 +320,20 @@ ;;; a helper function for LOAD-FASL-GROUP ;;; -;;; Return true if we successfully read a FASL header from the stream, -;;; or NIL if EOF was hit before anything was read. Signal an error if -;;; we encounter garbage. +;;; Return true if we successfully read a FASL header from the stream, or NIL +;;; if EOF was hit before anything except the optional shebang line was read. +;;; Signal an error if we encounter garbage. (defun check-fasl-header (stream) - + (maybe-skip-shebang-line stream) (let ((byte (read-byte stream nil))) (when byte - ;; Read and validate constant string prefix in fasl header. (let* ((fhsss *fasl-header-string-start-string*) (fhsss-length (length fhsss))) (unless (= byte (char-code (schar fhsss 0))) (error 'invalid-fasl-header :stream stream - :first-byte-p t + :byte-nr 0 :byte byte :expected (char-code (schar fhsss 0)))) (do ((byte (read-byte stream) (read-byte stream)) @@ -309,7 +348,6 @@ :byte-nr count :byte byte :expected (char-code (schar fhsss count)))))) - ;; Read and validate version-specific compatibility stuff. (flet ((string-from-stream () (let* ((length (read-unsigned-byte-32-arg)) @@ -317,28 +355,25 @@ (read-string-as-bytes stream result) result))) ;; Read and validate implementation and version. - (let* ((implementation (keywordicate (string-from-stream))) - ;; FIXME: The logic above to read a keyword from the fasl file - ;; could probably be shared with the read-a-keyword fop. - (version (read-word-arg))) - (flet ((check-version (variant - possible-implementation - needed-version) - (when (string= possible-implementation implementation) - (or (= version needed-version) - (error 'invalid-fasl-version - ;; :error :wrong-version - :stream stream - :variant variant - :version version - :expected needed-version))))) - (or (check-version "native code" - +backend-fasl-file-implementation+ - +fasl-file-version+) - (error 'invalid-fasl-implementation + (let ((implementation (keywordicate (string-from-stream))) + (expected-implementation +backend-fasl-file-implementation+)) + (unless (string= expected-implementation implementation) + (error 'invalid-fasl-implementation + :stream stream + :implementation implementation + :expected expected-implementation))) + (let* ((fasl-version (read-word-arg)) + (sbcl-version (if (<= fasl-version 76) + "1.0.11.18" + (string-from-stream))) + (expected-version (sb!xc:lisp-implementation-version))) + (unless (string= expected-version sbcl-version) + (restart-case + (error 'invalid-fasl-version :stream stream - :implementation implementation - :expected +backend-fasl-file-implementation+)))) + :version sbcl-version + :expected expected-version) + (continue () :report "Load the fasl file anyway")))) ;; Read and validate *FEATURES* which affect binary compatibility. (let ((faff-in-this-file (string-from-stream))) (unless (string= faff-in-this-file *features-affecting-fasl-format*) @@ -406,7 +441,7 @@ (when (zerop (file-length stream)) (error "attempt to load an empty FASL file:~% ~S" (namestring stream))) (maybe-announce-load stream verbose) - (sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*) + (with-world-lock () (let* ((*fasl-input-stream* stream) (*fasl-symbol-buffer* (make-string 100)) (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) @@ -421,6 +456,8 @@ ;; that this would go away? (fill *current-fop-table* nil)))) t) + +(declaim (notinline read-byte)) ; Why is it even *declaimed* inline above? ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)