X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fload.lisp;h=ede4e2d7a663d0789c53ba830dc78d367cad232f;hb=0338d1fc97a74b8ff332821ea275120b9de951c1;hp=193f393daf09408afc3444452b94ad33f43a27f5;hpb=a3706c5d9d95ebb5a14e7ab7313c5781e5c86713;p=sbcl.git diff --git a/src/code/load.lisp b/src/code/load.lisp index 193f393..ede4e2d 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -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) @@ -120,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 @@ -283,7 +315,14 @@ ;;; Returns T if the stream is a binary input stream with a FASL header. (defun fasl-header-p (stream &key errorp) - (unless (member (stream-element-type stream) '(character base-char)) + (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*) @@ -390,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 ;;; @@ -403,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))) @@ -412,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*)) @@ -441,20 +476,15 @@ (when (zerop (file-length stream)) (error "attempt to load an empty FASL file:~% ~S" (namestring stream))) (maybe-announce-load stream verbose) - (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))) - (*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?