0.9.2.43:
[sbcl.git] / src / code / load.lisp
index 2c3371b..eafe8a0 100644 (file)
@@ -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)))
   (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
 
 (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))))
+                 (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 ()
 
 (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
     `(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)
   (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-byte condition)
+             (invalid-fasl-expected condition)))))
 
 (define-condition invalid-fasl-version (invalid-fasl)
   ((variant :reader invalid-fasl-variant :initarg :variant)
    (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)
                      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
 ;;;;
 
       ;; 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.
 (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*)
                         (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
   (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)
 \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))))))
 |#