(in-package "SB!FASL")
\f
+;;;; There looks to be an exciting amount of state being modified
+;;;; 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*
+
;;;; miscellaneous load utilities
;;; Output the current number of semicolons after a fresh-line.
(write-string semicolons))
(write-char #\space)))
-;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how we're
-;;; loading from STREAM-WE-ARE-LOADING-FROM.
-;;; FIXME: non-mnemonic name
-(defun do-load-verbose (stream-we-are-loading-from verbose)
+;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how
+;;; we're loading from STREAM-WE-ARE-LOADING-FROM.
+(defun maybe-announce-load (stream-we-are-loading-from verbose)
(when verbose
(load-fresh-line)
(let ((name #-sb-xc-host (file-name stream-we-are-loading-from)
#!-sb-fluid (declaim (inline read-byte))
-;;; Expands into code to read an N-byte unsigned integer using
-;;; fast-read-byte.
+;;; 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)
(cnt 1 (1+ cnt)))
((>= cnt n) res)))
-;;; Like Fast-Read-U-Integer, but the size may be determined at run time.
+;;; 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))
\f
;;;; the fop stack
-;;; (This is in a SIMPLE-VECTOR, but it grows down, since it is
-;;; somewhat cheaper to test for overflow that way.)
-(defvar *fop-stack* (make-array 100))
-(declaim (simple-vector *fop-stack*))
-
-;;; the index of the most recently pushed item on the fop stack
-(defvar *fop-stack-pointer* 100)
-
-;;; the current index into the fop stack when we last recursively
-;;; entered LOAD
-(defvar *fop-stack-pointer-on-entry*)
-(declaim (type index *fop-stack-pointer* *fop-stack-pointer-on-entry*))
-
-(defun grow-fop-stack ()
- (let* ((size (length (the simple-vector *fop-stack*)))
- (new-size (* size 2))
- (new-stack (make-array new-size)))
- (declare (fixnum size new-size) (simple-vector new-stack))
- (replace new-stack (the simple-vector *fop-stack*) :start1 size)
- (incf *fop-stack-pointer-on-entry* size)
- (setq *fop-stack-pointer* size)
- (setq *fop-stack* new-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.)
+(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
-;;; if specified.
+;;; if PUSHP.
(defmacro with-fop-stack (pushp &body forms)
(aver (member pushp '(nil t :nope)))
- (let ((n-stack (gensym))
- (n-index (gensym))
- (n-res (gensym)))
- `(let ((,n-stack *fop-stack*)
- (,n-index *fop-stack-pointer*))
- (declare (simple-vector ,n-stack) (type index ,n-index))
+ (with-unique-names (fop-stack)
+ `(let ((,fop-stack *fop-stack*))
+ (declare (type (vector t) ,fop-stack))
(macrolet ((pop-stack ()
- `(prog1
- (svref ,',n-stack ,',n-index)
- (incf ,',n-index)))
- (call-with-popped-things (fun n)
- (let ((n-start (gensym)))
- `(let ((,n-start (+ ,',n-index ,n)))
- (declare (type index ,n-start))
- (setq ,',n-index ,n-start)
- (,fun ,@(make-list n :initial-element
- `(svref ,',n-stack
- (decf ,n-start))))))))
+ `(vector-pop ,',fop-stack))
+ (call-with-popped-args (fun n)
+ `(%call-with-popped-args ,fun ,n ,',fop-stack)))
,(if pushp
- `(let ((,n-res (progn ,@forms)))
- (when (zerop ,n-index)
- (grow-fop-stack)
- (setq ,n-index *fop-stack-pointer*
- ,n-stack *fop-stack*))
- (decf ,n-index)
- (setq *fop-stack-pointer* ,n-index)
- (setf (svref ,n-stack ,n-index) ,n-res))
- `(prog1
- (progn ,@forms)
- (setq *fop-stack-pointer* ,n-index)))))))
+ `(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)
+ ;; N's integer value must be known at macroexpansion time.
+ (declare (type index n))
+ (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)))))
\f
+;;;; Conditions signalled on invalid fasls (wrong fasl version, etc),
+;;;; so that user code (esp. ASDF) can reasonably handle attempts to
+;;;; load such fasls by recompiling them, etc. For simplicity's sake
+;;;; make only condition INVALID-FASL part of the public interface,
+;;;; and keep the guts internal.
+
+(define-condition invalid-fasl (error)
+ ((stream :reader invalid-fasl-stream :initarg :stream)
+ (expected :reader invalid-fasl-expected :initarg :expected))
+ (:report
+ (lambda (condition stream)
+ (format stream "~S is an invalid fasl file."
+ (invalid-fasl-stream condition)))))
+
+(define-condition invalid-fasl-header (invalid-fasl)
+ ((byte :reader invalid-fasl-byte :initarg :byte)
+ (byte-nr :reader invalid-fasl-byte-nr :initarg :byte-nr))
+ (:report
+ (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)))))
+
+(define-condition invalid-fasl-version (invalid-fasl)
+ ((variant :reader invalid-fasl-variant :initarg :variant)
+ (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)))))
+
+(define-condition invalid-fasl-implementation (invalid-fasl)
+ ((implementation :reader invalid-fasl-implementation
+ :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)))))
+
+(define-condition invalid-fasl-features (invalid-fasl)
+ ((potential-features :reader invalid-fasl-potential-features
+ :initarg :potential-features)
+ (features :reader invalid-fasl-features :initarg :features))
+ (:report
+ (lambda (condition stream)
+ (format stream "~@<incompatible ~S in fasl file ~S: ~2I~_~
+ 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)))))
+
;;;; LOAD-AS-FASL
;;;;
;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
(let ((byte (read-byte stream nil)))
(when byte
- ;; Read the string part of the fasl header, or die.
+ ;; 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 "illegal first byte in fasl file header"))
+ (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+)
(declare (fixnum byte count))
(when (and (< count fhsss-length)
(not (eql byte (char-code (schar fhsss count)))))
- (error
- "illegal subsequent (not first) byte in fasl file header"))))
-
- ;; Read and validate implementation and version, or die.
- (let* ((implementation-length (read-arg 4))
- (implementation-string (make-string implementation-length))
- (ignore (read-string-as-bytes stream implementation-string))
- (implementation (keywordicate implementation-string))
- ;; 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)))
- (declare (ignore ignore))
- (flet ((check-version (variant possible-implementation needed-version)
- (when (string= possible-implementation implementation)
- (unless (= version needed-version)
- (error "~@<~S is in ~A fasl file format version ~W, ~
- but this version of SBCL uses ~
- format version ~W.~:@>"
- stream
- variant
- version
- needed-version))
- t)))
- (or (check-version "native code"
- +backend-fasl-file-implementation+
- +fasl-file-version+)
- (error "~S was compiled for implementation ~A, but this is a ~A."
- stream
- implementation
- +backend-fasl-file-implementation+)))))))
+ (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))))
;; Setting this variable gives you a trace of fops as they are loaded and
;; executed.
#!+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
;;;
;;; 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. Special-case
-;;; FOP-BYTE-PUSH since it is real common.
+;;; Dispatch to the right function for each fop.
(defun load-fasl-group (stream)
(when (check-fasl-header stream)
(catch 'fasl-group-end
;; Do some debugging output.
#!+sb-show
(when *show-fops-p*
- (let ((ptr *fop-stack-pointer*)
- (stack *fop-stack*))
- (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 (length stack))
- (write-char #\space *trace-output*)
- (prin1 (svref stack ptr) *trace-output*)
- (terpri *trace-output*))
- ;; Display the operator.
- (format *trace-output*
- "~&~S (#X~X at ~D) (~S)~%"
- (svref *fop-names* byte)
- byte
- (1- (file-position stream))
- (svref *fop-functions* byte))))
+ (let* ((stack *fop-stack*)
+ (ptr (1- (fill-pointer *fop-stack*))))
+ (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)
+ (write-char #\space *trace-output*)
+ (prin1 (aref stack ptr) *trace-output*)
+ (terpri *trace-output*))
+ ;; Display the operator.
+ (format *trace-output*
+ "~&~S (#X~X at ~D) (~S)~%"
+ (aref *fop-names* byte)
+ byte
+ (1- (file-position stream))
+ (svref *fop-funs* byte))))
;; Actually execute the fop.
- (if (eql byte 3)
- ;; FIXME: This is the special case for FOP-BYTE-PUSH.
- ;; Benchmark to see whether it's really worth special
- ;; casing it. If it is, at least express the test in
- ;; terms of a symbolic name for the FOP-BYTE-PUSH code,
- ;; not a bare '3' (!). Failing that, remove the special
- ;; case (and the comment at the head of this function
- ;; which mentions it).
- (let ((index *fop-stack-pointer*))
- (declare (type index index))
- (when (zerop index)
- (grow-fop-stack)
- (setq index *fop-stack-pointer*))
- (decf index)
- (setq *fop-stack-pointer* index)
- (setf (svref *fop-stack* index)
- (svref *current-fop-table* (read-byte stream))))
- (funcall (the function (svref *fop-functions* byte))))))))))
+ (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
(declare (ignore print))
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
- (do-load-verbose stream verbose)
- (let* ((*fasl-input-stream* stream)
- (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
- (*current-fop-table-size* (length *current-fop-table*))
- (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
- (unwind-protect
- ;; FIXME: This should probably become
- ;; (LOOP WHILE (LOAD-FASL-GROUP-STREAM))
- ;; but as a LOOP newbie I don't want to do that until I can
- ;; test it.
- (do ((loaded-group (load-fasl-group stream) (load-fasl-group stream)))
- ((not loaded-group)))
- (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
- (push *current-fop-table* *free-fop-tables*)
- ;; NIL out the stack and table, so that we don't hold onto garbage.
- ;;
- ;; FIXME: Couldn't we just get rid of the free fop table pool so
- ;; that some of this NILing out would go away?
- (fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
- (fill *current-fop-table* nil)))
+ (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))))
t)
;;; This is used in in target-load and also genesis, using
;;; code for foreign symbol lookup should be here.
(defun find-foreign-symbol-in-table (name table)
(let ((prefixes
- #!+(or linux freebsd) #("" "ldso_stub__")
- #!+openbsd #("" "_")))
+ #!+(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 (?)