X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fload.lisp;h=eafe8a05b0c750effec89f5db996c806e8776616;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=2c3371b7b3dabdd28f5fbc62ff9c26ae731638b2;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/code/load.lisp b/src/code/load.lisp index 2c3371b..eafe8a0 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -30,8 +30,8 @@ (fresh-line) (let ((semicolons ";;;;;;;;;;;;;;;;")) (do ((count *load-depth* (- count (length semicolons)))) - ((< count (length semicolons)) - (write-string semicolons *standard-output* :end count)) + ((< count (length semicolons)) + (write-string semicolons *standard-output* :end count)) (declare (fixnum count)) (write-string semicolons)) (write-char #\space))) @@ -42,10 +42,10 @@ (when verbose (load-fresh-line) (let ((name #-sb-xc-host (file-name stream-we-are-loading-from) - #+sb-xc-host nil)) + #+sb-xc-host nil)) (if name - (format t "loading ~S~%" name) - (format t "loading stuff from ~S~%" stream-we-are-loading-from))))) + (format t "loading ~S~%" name) + (format t "loading stuff from ~S~%" stream-we-are-loading-from))))) ;;;; utilities for reading from fasl files @@ -60,22 +60,22 @@ (defmacro fast-read-u-integer (n) (declare (optimize (speed 0))) (do ((res '(fast-read-byte) - `(logior (fast-read-byte) - (ash ,res 8))) + `(logior (fast-read-byte) + (ash ,res 8))) (cnt 1 (1+ cnt))) ((>= cnt n) res))) ;;; like FAST-READ-U-INTEGER, but the size may be determined at run time (defmacro fast-read-var-u-integer (n) (let ((n-pos (gensym)) - (n-res (gensym)) - (n-cnt (gensym))) + (n-res (gensym)) + (n-cnt (gensym))) `(do ((,n-pos 8 (+ ,n-pos 8)) - (,n-cnt (1- ,n) (1- ,n-cnt)) - (,n-res - (fast-read-byte) - (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) - ((zerop ,n-cnt) ,n-res) + (,n-cnt (1- ,n) (1- ,n-cnt)) + (,n-res + (fast-read-byte) + (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) + ((zerop ,n-cnt) ,n-res) (declare (type index ,n-pos ,n-cnt))))) ;;; Read a signed integer. @@ -83,13 +83,13 @@ (declare (optimize (speed 0))) (let ((n-last (gensym))) (do ((res `(let ((,n-last (fast-read-byte))) - (if (zerop (logand ,n-last #x80)) - ,n-last - (logior ,n-last #x-100))) - `(logior (fast-read-byte) - (ash (the (signed-byte ,(* cnt 8)) ,res) 8))) - (cnt 1 (1+ cnt))) - ((>= cnt n) res)))) + (if (zerop (logand ,n-last #x80)) + ,n-last + (logior ,n-last #x-100))) + `(logior (fast-read-byte) + (ash (the (signed-byte ,(* cnt 8)) ,res) 8))) + (cnt 1 (1+ cnt))) + ((>= cnt n) res)))) ;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*. (defmacro read-arg (n) @@ -97,9 +97,9 @@ (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))))) + (prog1 + (fast-read-u-integer ,n) + (done-with-fast-read-byte))))) (declaim (inline read-byte-arg read-halfword-arg read-word-arg)) (defun read-byte-arg () @@ -141,7 +141,7 @@ (defun grow-fop-table () (let* ((new-size (* *current-fop-table-size* 2)) - (new-table (make-array new-size))) + (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) @@ -152,7 +152,7 @@ `(let ((,n-index *current-fop-table-index*)) (declare (fixnum ,n-index)) (when (= ,n-index (the fixnum *current-fop-table-size*)) - (grow-fop-table)) + (grow-fop-table)) (setq *current-fop-table-index* (1+ ,n-index)) (setf (svref *current-fop-table* ,n-index) ,thing)))) @@ -172,12 +172,12 @@ `(let ((,fop-stack *fop-stack*)) (declare (type (vector t) ,fop-stack)) (macrolet ((pop-stack () - `(vector-pop ,',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)))))) + `(vector-pop ,',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)))))) ;;; Call FUN with N arguments popped from STACK. (defmacro %call-with-popped-args (fun n stack) @@ -186,19 +186,19 @@ (with-unique-names (n-stack old-length new-length) (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) - ;; (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 - ;; we're using this only to pop stuff off *FOP-STACK*, and the - ;; entire *FOP-STACK* can be GCed as soon as LOAD returns.) - (,fun ,@argtmps))))) + (,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) + ;; (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 + ;; we're using this only to pop stuff off *FOP-STACK*, and the + ;; entire *FOP-STACK* can be GCed as soon as LOAD returns.) + (,fun ,@argtmps))))) ;;;; Conditions signalled on invalid fasls (wrong fasl version, etc), ;;;; so that user code (esp. ASDF) can reasonably handle attempts to @@ -212,7 +212,7 @@ (:report (lambda (condition stream) (format stream "~S is an invalid fasl file." - (invalid-fasl-stream condition))))) + (invalid-fasl-stream condition))))) (define-condition invalid-fasl-header (invalid-fasl) ((byte :reader invalid-fasl-byte :initarg :byte) @@ -221,10 +221,10 @@ (lambda (condition stream) (format stream "~@<~S contains an illegal byte in the FASL header at ~ 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-stream condition) + (invalid-fasl-byte-nr condition) + (invalid-fasl-byte condition) + (invalid-fasl-expected condition))))) (define-condition invalid-fasl-version (invalid-fasl) ((variant :reader invalid-fasl-variant :initarg :variant) @@ -233,24 +233,24 @@ (lambda (condition stream) (format stream "~@<~S is in ~A fasl file format version ~W, ~ but this version of SBCL uses format version ~W.~:@>" - (invalid-fasl-stream condition) - (invalid-fasl-variant condition) - (invalid-fasl-version condition) - (invalid-fasl-expected condition))))) + (invalid-fasl-stream condition) + (invalid-fasl-variant condition) + (invalid-fasl-version condition) + (invalid-fasl-expected condition))))) (define-condition invalid-fasl-implementation (invalid-fasl) ((implementation :reader invalid-fasl-implementation - :initarg :implementation)) - (:report + :initarg :implementation)) + (:report (lambda (condition stream) (format stream "~S was compiled for implementation ~A, but this is a ~A." - (invalid-fasl-stream condition) - (invalid-fasl-implementation condition) - (invalid-fasl-expected condition))))) + (invalid-fasl-stream condition) + (invalid-fasl-implementation condition) + (invalid-fasl-expected condition))))) (define-condition invalid-fasl-features (invalid-fasl) ((potential-features :reader invalid-fasl-potential-features - :initarg :potential-features) + :initarg :potential-features) (features :reader invalid-fasl-features :initarg :features)) (:report (lambda (condition stream) @@ -258,11 +258,11 @@ Of features affecting binary compatibility, ~4I~_~S~2I~_~ the fasl has ~4I~_~A,~2I~_~ while the runtime expects ~4I~_~A.~:>" - '*features* - (invalid-fasl-stream condition) - (invalid-fasl-potential-features condition) - (invalid-fasl-features condition) - (invalid-fasl-expected condition))))) + '*features* + (invalid-fasl-stream condition) + (invalid-fasl-potential-features condition) + (invalid-fasl-features condition) + (invalid-fasl-expected condition))))) ;;;; LOAD-AS-FASL ;;;; @@ -283,65 +283,65 @@ ;; 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 byte - :expected (char-code (schar fhsss 0)))) - (do ((byte (read-byte stream) (read-byte stream)) - (count 1 (1+ count))) - ((= byte +fasl-header-string-stop-char-code+) - t) - (declare (fixnum byte count)) - (when (and (< count fhsss-length) - (not (eql byte (char-code (schar fhsss count))))) - (error 'invalid-fasl-header - :stream stream - :byte-nr count - :byte byte - :expected (char-code (schar fhsss count)))))) + (fhsss-length (length fhsss))) + (unless (= byte (char-code (schar fhsss 0))) + (error 'invalid-fasl-header + :stream stream + :first-byte-p t + :byte byte + :expected (char-code (schar fhsss 0)))) + (do ((byte (read-byte stream) (read-byte stream)) + (count 1 (1+ count))) + ((= byte +fasl-header-string-stop-char-code+) + t) + (declare (fixnum byte count)) + (when (and (< count fhsss-length) + (not (eql byte (char-code (schar fhsss count))))) + (error 'invalid-fasl-header + :stream stream + :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)) - (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 - :stream stream - :implementation implementation - :expected +backend-fasl-file-implementation+)))) - ;; 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*) - (error 'invalid-fasl-features - :stream stream - :potential-features *features-potentially-affecting-fasl-format* - :expected *features-affecting-fasl-format* - :features faff-in-this-file))) - ;; success - t)))) + (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 + :stream stream + :implementation implementation + :expected +backend-fasl-file-implementation+)))) + ;; 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*) + (error 'invalid-fasl-features + :stream stream + :potential-features *features-potentially-affecting-fasl-format* + :expected *features-affecting-fasl-format* + :features faff-in-this-file))) + ;; success + t)))) ;; Setting this variable gives you a trace of fops as they are loaded and ;; executed. @@ -352,22 +352,22 @@ (defvar *fasl-symbol-buffer*) (declaim (simple-string *fasl-symbol-buffer*)) -;;; +;;; ;;; a helper function for LOAD-AS-FASL ;;; ;;; Return true if we successfully load a group from the stream, or ;;; NIL if EOF was encountered while trying to read from the stream. -;;; Dispatch to the right function for each fop. +;;; Dispatch to the right function for each fop. (defun load-fasl-group (stream) (when (check-fasl-header stream) (catch 'fasl-group-end (let ((*current-fop-table-index* 0)) - (loop - (let ((byte (read-byte stream))) + (loop + (let ((byte (read-byte stream))) - ;; Do some debugging output. - #!+sb-show - (when *show-fops-p* + ;; Do some debugging output. + #!+sb-show + (when *show-fops-p* (let* ((stack *fop-stack*) (ptr (1- (fill-pointer *fop-stack*)))) (fresh-line *trace-output*) @@ -386,8 +386,8 @@ (1- (file-position stream)) (svref *fop-funs* byte)))) - ;; Actually execute the fop. - (funcall (the function (svref *fop-funs* byte))))))))) + ;; Actually execute the fop. + (funcall (the function (svref *fop-funs* byte))))))))) (defun load-as-fasl (stream verbose print) ;; KLUDGE: ANSI says it's good to do something with the :PRINT @@ -401,17 +401,17 @@ (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))) + (*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)))) + (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)))) t) ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?) @@ -428,27 +428,27 @@ (defun analyze-counts () (let ((counts ()) - (total-count 0) - (times ()) - (total-time 0)) + (total-count 0) + (times ()) + (total-time 0)) (macrolet ((breakdown (lvar tvar vec) - `(progn - (dotimes (i 255) - (declare (fixnum i)) - (let ((n (svref ,vec i))) - (push (cons (svref *fop-names* i) n) ,lvar) - (incf ,tvar n))) - (setq ,lvar (subseq (sort ,lvar (lambda (x y) - (> (cdr x) (cdr y)))) - 0 10))))) + `(progn + (dotimes (i 255) + (declare (fixnum i)) + (let ((n (svref ,vec i))) + (push (cons (svref *fop-names* i) n) ,lvar) + (incf ,tvar n))) + (setq ,lvar (subseq (sort ,lvar (lambda (x y) + (> (cdr x) (cdr y)))) + 0 10))))) (breakdown counts total-count *fop-counts*) (breakdown times total-time *fop-times*) (format t "Total fop count is ~D~%" total-count) (dolist (c counts) - (format t "~30S: ~4D~%" (car c) (cdr c))) + (format t "~30S: ~4D~%" (car c) (cdr c))) (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0)) (dolist (m times) - (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) + (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) |#