;;;; 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
(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)))
(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)))))
\f
;;;; utilities for reading from fasl files
#!-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)))
+ `(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.
(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))))
-
-;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*
+ (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)
(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)))))
+ (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 ()
+ (declare (optimize (speed 0)))
+ (read-arg 1))
+
+(defun read-halfword-arg ()
+ (declare (optimize (speed 0)))
+ (read-arg #.(/ sb!vm:n-word-bytes 2)))
+
+(defun read-word-arg ()
+ (declare (optimize (speed 0)))
+ (read-arg #.sb!vm:n-word-bytes))
+
+(defun read-unsigned-byte-32-arg ()
+ (declare (optimize (speed 0)))
+ (read-arg 4))
-;;; FIXME: This deserves a more descriptive name, and should probably
-;;; be implemented as an ordinary function, not a macro.
-;;;
-;;; (for the names: There seem to be only two cases, so it could be
-;;; named READ-U-INTEGER-8 and READ-U-INTEGER-32 or something.)
\f
;;;; the fop table
(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)
`(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))))
\f
(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))
- (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))
+ (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))))))
;;; Call FUN with N arguments popped from STACK.
(defmacro %call-with-popped-args (fun n stack)
(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)))))
\f
;;;; Conditions signalled on invalid fasls (wrong fasl version, etc),
;;;; so that user code (esp. ASDF) can reasonably handle attempts to
(: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)
(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-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.~:@>"
- (invalid-fasl-stream condition)
- (invalid-fasl-variant condition)
- (invalid-fasl-version condition)
- (invalid-fasl-expected condition)))))
+ (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-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)
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)))))
+
+;;; 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
;;;;
;;; 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 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
+ :byte-nr 0
+ :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-arg 4))
- (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-arg 4)))
- (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))))
+ (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)))
+ (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
+ :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*)
+ (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.
(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)))
-
- ;; Do some debugging output.
- #!+sb-show
- (when *show-fops-p*
+ (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*
(let* ((stack *fop-stack*)
(ptr (1- (fill-pointer *fop-stack*))))
(fresh-line *trace-output*)
(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
(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)))
- (*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)
-
-;;; This is used in in target-load and also genesis, using
-;;; *COLD-FOREIGN-SYMBOL-TABLE*. All the speculative prefix-adding
-;;; code for foreign symbol lookup should be here.
-(defun find-foreign-symbol-in-table (name table)
- (let ((prefixes
- #!+(or osf1 sunos linux freebsd netbsd darwin) #("" "ldso_stub__")
- #!+openbsd #("")))
- (declare (notinline some)) ; to suppress bug 117 bogowarning
- (some (lambda (prefix)
- (gethash (concatenate 'string prefix name)
- table
- nil))
- prefixes)))
\f
;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
(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))))))
|#