X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fload.lisp;h=ede4e2d7a663d0789c53ba830dc78d367cad232f;hb=0338d1fc97a74b8ff332821ea275120b9de951c1;hp=1a0bceaaa98d8bf1854cb45d4c2682c6aa50b7e5;hpb=cdc0994481502b7cce9c0a62b48d4cf28965d612;p=sbcl.git diff --git a/src/code/load.lisp b/src/code/load.lisp index 1a0bcea..ede4e2d 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 @@ -51,19 +51,17 @@ #!-sb-fluid (declaim (inline read-byte)) -;;; FIXME: why do all of these reading functions and macros declare -;;; (SPEED 0)? was there some bug in the compiler which has since -;;; been fixed? --njf, 2004-09-08 - ;;; This expands into code to read an N-byte unsigned integer using ;;; FAST-READ-BYTE. (defmacro fast-read-u-integer (n) - (declare (optimize (speed 0))) - (do ((res '(fast-read-byte) - `(logior (fast-read-byte) - (ash ,res 8))) - (cnt 1 (1+ cnt))) - ((>= cnt n) res))) + (let (bytes) + `(let ,(loop for i from 0 below n + collect (let ((name (gensym "B"))) + (push name bytes) + `(,name ,(if (zerop i) + `(fast-read-byte) + `(ash (fast-read-byte) ,(* i 8)))))) + (logior ,@bytes)))) ;;; like FAST-READ-U-INTEGER, but the size may be determined at run time (defmacro fast-read-var-u-integer (n) @@ -96,10 +94,8 @@ (declare (optimize (speed 0))) (if (= n 1) `(the (unsigned-byte 8) (read-byte *fasl-input-stream*)) - `(prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (fast-read-u-integer ,n) - (done-with-fast-read-byte))))) + `(with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream*) + (fast-read-u-integer ,n)))) (declaim (inline read-byte-arg read-halfword-arg read-word-arg)) (defun read-byte-arg () @@ -122,84 +118,118 @@ ;;;; the fop table ;;; The table is implemented as a simple-vector indexed by the table -;;; offset. We may need to have several, since LOAD can be called -;;; recursively. - -;;; a list of free fop tables for the fasloader +;;; offset. The offset is kept in at index 0 of the vector. ;;; -;;; FIXME: Is it really a win to have this permanently bound? -;;; Couldn't we just bind it on entry to LOAD-AS-FASL? -(defvar *free-fop-tables* (list (make-array 1000))) - -;;; the current fop table -(defvar *current-fop-table*) -(declaim (simple-vector *current-fop-table*)) - -;;; the length of the current fop table -(defvar *current-fop-table-size*) -(declaim (type index *current-fop-table-size*)) - -;;; the index in the fop-table of the next entry to be used -(defvar *current-fop-table-index*) -(declaim (type index *current-fop-table-index*)) - -(defun grow-fop-table () - (let* ((new-size (* *current-fop-table-size* 2)) - (new-table (make-array new-size))) - (declare (fixnum new-size) (simple-vector new-table)) - (replace new-table (the simple-vector *current-fop-table*)) - (setq *current-fop-table* new-table) - (setq *current-fop-table-size* new-size))) - -(defmacro push-fop-table (thing) - (let ((n-index (gensym))) - `(let ((,n-index *current-fop-table-index*)) - (declare (fixnum ,n-index)) - (when (= ,n-index (the fixnum *current-fop-table-size*)) - (grow-fop-table)) - (setq *current-fop-table-index* (1+ ,n-index)) - (setf (svref *current-fop-table* ,n-index) ,thing)))) +;;; FOPs use the table to save stuff, other FOPs refer to the table by +;;; direct indexes via REF-FOP-TABLE. + +(defvar *fop-table*) +(declaim (simple-vector *fop-table*)) + +(declaim (inline ref-fop-table)) +(defun ref-fop-table (index) + (declare (type index index)) + (svref *fop-table* (the index (+ index 1)))) + +(defun get-fop-table-index () + (svref *fop-table* 0)) + +(defun reset-fop-table () + (setf (svref *fop-table* 0) 0)) + +(defun push-fop-table (thing) + (let* ((table *fop-table*) + (index (+ (the index (aref table 0)) 1))) + (declare (fixnum index) + (simple-vector table)) + (when (eql index (length table)) + (setf table (grow-fop-vector table index) + *fop-table* table)) + (setf (aref table 0) index + (aref table index) thing))) + +;;; These three routines are used for both the stack and the table. +(defun make-fop-vector (size) + (declare (type index size)) + (let ((vector (make-array size))) + (setf (aref vector 0) 0) + vector)) + +(defun grow-fop-vector (old-vector old-size) + (declare (simple-vector old-vector) + (type index old-size)) + (let* ((new-size (* old-size 2)) + (new-vector (make-array new-size))) + (declare (fixnum new-size) + (simple-vector new-vector old-vector)) + (replace new-vector old-vector) + (nuke-fop-vector old-vector) + new-vector)) + +(defun nuke-fop-vector (vector) + (declare (simple-vector vector) + #!-gencgc (ignore vector) + (optimize speed)) + ;; Make sure we don't keep any garbage. + #!+gencgc + (fill vector 0)) + ;;;; the fop stack -;;; (This is to be bound by LOAD to an adjustable (VECTOR T) with -;;; FILL-POINTER, for use as a stack with VECTOR-PUSH-EXTEND.) +;;; Much like the table, this is bound to a simple vector whose first +;;; element is the current index. (defvar *fop-stack*) -(declaim (type (vector t) *fop-stack*)) - -;;; Cache information about the fop stack in local variables. Define a -;;; local macro to pop from the stack. Push the result of evaluation +(declaim (simple-vector *fop-stack*)) + +(defun fop-stack-empty-p () + (eql 0 (svref *fop-stack* 0))) + +(defun pop-fop-stack () + (let* ((stack *fop-stack*) + (top (svref stack 0))) + (declare (type index top)) + (when (eql 0 top) + (error "FOP stack empty")) + (setf (svref stack 0) (1- top)) + (svref stack top))) + +(defun push-fop-stack (value) + (let* ((stack *fop-stack*) + (next (1+ (the index (svref stack 0))))) + (declare (type index next)) + (when (eql (length stack) next) + (setf stack (grow-fop-vector stack next) + *fop-stack* stack)) + (setf (svref stack 0) next + (svref stack next) value))) + +;;; Define a local macro to pop from the stack. Push the result of evaluation ;;; if PUSHP. (defmacro with-fop-stack (pushp &body forms) (aver (member pushp '(nil t :nope))) - (with-unique-names (fop-stack) - `(let ((,fop-stack *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 - `(vector-push-extend (progn ,@forms) ,fop-stack) - `(progn ,@forms)))))) + `(macrolet ((pop-stack () + `(pop-fop-stack)) + (push-stack (value) + `(push-fop-stack ,value))) + ,(if pushp + `(push-fop-stack (progn ,@forms)) + `(progn ,@forms)))) ;;; Call FUN with N arguments popped from STACK. -(defmacro %call-with-popped-args (fun n stack) +(defmacro call-with-popped-args (fun n) ;; N's integer value must be known at macroexpansion time. (declare (type index n)) - (with-unique-names (n-stack old-length new-length) + (with-unique-names (n-stack old-top new-top) (let ((argtmps (make-gensym-list n))) - `(let* ((,n-stack ,stack) - (,old-length (fill-pointer ,n-stack)) - (,new-length (- ,old-length ,n)) - ,@(loop for i from 0 below n collecting - `(,(nth i argtmps) - (aref ,n-stack (+ ,new-length ,i))))) - (declare (type (vector t) ,n-stack)) - (setf (fill-pointer ,n-stack) ,new-length) + `(let* ((,n-stack *fop-stack*) + (,old-top (svref ,n-stack 0)) + (,new-top (- ,old-top ,n)) + ,@(loop for i from 1 upto n collecting + `(,(nth (1- i) argtmps) + (aref ,n-stack (+ ,new-top ,i))))) + (declare (simple-vector ,n-stack)) + (setf (svref ,n-stack 0) ,new-top) ;; (For some applications it might be appropriate to FILL the ;; popped area with NIL here, to avoid holding onto garbage. For ;; sbcl-0.8.7.something, though, it shouldn't matter, because @@ -230,8 +260,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 +299,57 @@ (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) + (unless (and (member (stream-element-type stream) '(character base-char)) + ;; give up if it's not a file stream, or it's an + ;; fd-stream but it's either not bivalent or not + ;; seekable (doesn't really have a file) + (or (not (typep stream 'file-stream)) + (and (typep stream 'fd-stream) + (or (not (sb!impl::fd-stream-bivalent-p stream)) + (not (sb!impl::fd-stream-file stream)))))) + (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 +359,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 +372,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 +394,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*) @@ -348,10 +429,6 @@ #!+sb-show (defvar *show-fops-p* nil) -;; buffer for loading symbols -(defvar *fasl-symbol-buffer*) -(declaim (simple-string *fasl-symbol-buffer*)) - ;;; ;;; a helper function for LOAD-AS-FASL ;;; @@ -361,8 +438,8 @@ (defun load-fasl-group (stream) (when (check-fasl-header stream) (catch 'fasl-group-end - (let ((*current-fop-table-index* 0) - (*skip-until* nil)) + (reset-fop-table) + (let ((*skip-until* nil)) (declare (special *skip-until*)) (loop (let ((byte (read-byte stream))) @@ -370,12 +447,12 @@ #!+sb-show (when *show-fops-p* (let* ((stack *fop-stack*) - (ptr (1- (fill-pointer *fop-stack*)))) + (ptr (svref stack 0))) (fresh-line *trace-output*) ;; The FOP operations are stack based, so it's sorta ;; logical to display the operand before the operator. ;; ("reverse Polish notation") - (unless (= ptr -1) + (unless (= ptr 0) (write-char #\space *trace-output*) (prin1 (aref stack ptr) *trace-output*) (terpri *trace-output*)) @@ -399,21 +476,18 @@ (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*) - (let* ((*fasl-input-stream* stream) - (*fasl-symbol-buffer* (make-string 100)) - (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) - (*current-fop-table-size* (length *current-fop-table*)) - (*fop-stack* (make-array 100 :fill-pointer 0 :adjustable t))) - (unwind-protect - (loop while (load-fasl-group stream)) - (push *current-fop-table* *free-fop-tables*) - ;; NIL out the table, so that we don't hold onto garbage. - ;; - ;; FIXME: Could we just get rid of the free fop table pool so - ;; that this would go away? - (fill *current-fop-table* nil)))) + (let* ((*fasl-input-stream* stream) + (*fop-table* (make-fop-vector 1000)) + (*fop-stack* (make-fop-vector 100))) + (unwind-protect + (loop while (load-fasl-group stream)) + ;; Nuke the table and stack to avoid keeping garbage on + ;; conservatively collected platforms. + (nuke-fop-vector *fop-table*) + (nuke-fop-vector *fop-stack*))) t) + +(declaim (notinline read-byte)) ; Why is it even *declaimed* inline above? ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)