X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fload.lisp;h=3b2a82fbac5d6a20c7825619e58bca146f707069;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=1a0bceaaa98d8bf1854cb45d4c2682c6aa50b7e5;hpb=cdc0994481502b7cce9c0a62b48d4cf28965d612;p=sbcl.git diff --git a/src/code/load.lisp b/src/code/load.lisp index 1a0bcea..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,8 +230,8 @@ 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) ((version :reader invalid-fasl-version :initarg :version)) @@ -269,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 @@ -278,10 +320,11 @@ ;;; 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. @@ -290,7 +333,7 @@ (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)) @@ -312,26 +355,25 @@ (read-string-as-bytes stream result) result))) ;; Read and validate implementation and version. - (let* ((implementation (keywordicate (string-from-stream))) - (fasl-version (read-word-arg)) + (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)) - (expected-implementation +backend-fasl-file-implementation+)) - (cond ((string/= expected-implementation implementation) - (error 'invalid-fasl-implementation - :stream stream - :implementation implementation - :expected expected-implementation)) - ((string/= expected-version sbcl-version) - (restart-case - (error 'invalid-fasl-version - :stream stream - :version sbcl-version - :expected expected-version) - (continue () - :report "Load the fasl file anyway"))))) + (expected-version (sb!xc:lisp-implementation-version))) + (unless (string= expected-version sbcl-version) + (restart-case + (error 'invalid-fasl-version + :stream stream + :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*) @@ -399,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))) @@ -414,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 (?)