X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fload.lisp;h=3b2a82fbac5d6a20c7825619e58bca146f707069;hb=b5696612c774dac57abff3b5abe3f04ebe0ce2c7;hp=eafe8a05b0c750effec89f5db996c806e8776616;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/load.lisp b/src/code/load.lisp index eafe8a0..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 @@ -114,6 +114,10 @@ (declare (optimize (speed 0))) (read-arg #.sb!vm:n-word-bytes)) +(defun read-unsigned-byte-32-arg () + (declare (optimize (speed 0))) + (read-arg 4)) + ;;;; the fop table @@ -170,9 +174,12 @@ (aver (member pushp '(nil t :nope))) (with-unique-names (fop-stack) `(let ((,fop-stack *fop-stack*)) - (declare (type (vector t) ,fop-stack)) + (declare (type (vector t) ,fop-stack) + (ignorable ,fop-stack)) (macrolet ((pop-stack () `(vector-pop ,',fop-stack)) + (push-stack (value) + `(vector-push-extend ,value ,',fop-stack)) (call-with-popped-args (fun n) `(%call-with-popped-args ,fun ,n ,',fop-stack))) ,(if pushp @@ -223,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))))) @@ -264,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 @@ -273,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)) @@ -302,36 +348,32 @@ :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-word-arg)) + (let* ((length (read-unsigned-byte-32-arg)) (result (make-string length))) (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*) @@ -361,10 +403,11 @@ (defun load-fasl-group (stream) (when (check-fasl-header stream) (catch 'fasl-group-end - (let ((*current-fop-table-index* 0)) + (let ((*current-fop-table-index* 0) + (*skip-until* nil)) + (declare (special *skip-until*)) (loop (let ((byte (read-byte stream))) - ;; Do some debugging output. #!+sb-show (when *show-fops-p* @@ -398,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))) @@ -413,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 (?)