X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=146bec97f22c2f428024ca58d57e064eb9782beb;hb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;hp=22df57fde772a7ac8b6af28f4b3e6fa48062532a;hpb=a8161e77843ee18a99ec30dd57f796264dfac05a;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 22df57f..146bec9 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -2,10 +2,16 @@
 
 (in-package "SB!FASL")
 
+;;; Sometimes we want to skip over any FOPs with side-effects (like
+;;; function calls) while executing other FOPs. *SKIP-UNTIL* will
+;;; either contain the position where the skipping will stop, or
+;;; NIL if we're executing normally.
+(defvar *skip-until* nil)
+
 ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP
 ;;; describes what the body does to the fop stack:
 ;;;   T
-;;;     The body might pop the fop stack. The result of the body is 
+;;;     The body might pop the fop stack. The result of the body is
 ;;;     pushed on the fop stack.
 ;;;   NIL
 ;;;     The body might pop the fop stack. The result of the body is
@@ -31,26 +37,26 @@
     (when (and ocode (/= ocode code))
       (error "multiple codes for fop name ~S: ~D and ~D" name code ocode)))
   (setf (svref *fop-names* code) name
-	(get name 'fop-code) code
-	(svref *fop-funs* code) (symbol-function name))
+        (get name 'fop-code) code
+        (svref *fop-funs* code) (symbol-function name))
   (values))
 
 ;;; Define a pair of fops which are identical except that one reads
 ;;; a four-byte argument while the other reads a one-byte argument. The
-;;; argument can be accessed by using the Clone-Arg macro.
+;;; argument can be accessed by using the CLONE-ARG macro.
 ;;;
 ;;; KLUDGE: It would be nice if the definition here encapsulated which
 ;;; value ranges went with which fop variant, and chose the correct
 ;;; fop code to use. Currently, since such logic isn't encapsulated,
 ;;; we see callers doing stuff like
-;;;	(cond ((and (< num-consts #x100) (< total-length #x10000))
-;;;	       (dump-fop 'sb!impl::fop-small-code file)
-;;;	       (dump-byte num-consts file)
-;;;	       (dump-integer-as-n-bytes total-length 2 file))
-;;;	      (t
-;;;	       (dump-fop 'sb!impl::fop-code file)
-;;;	       (dump-unsigned-32 num-consts file)
-;;;	       (dump-unsigned-32 total-length file))))
+;;;     (cond ((and (< num-consts #x100) (< total-length #x10000))
+;;;            (dump-fop 'sb!impl::fop-small-code file)
+;;;            (dump-byte num-consts file)
+;;;            (dump-integer-as-n-bytes total-length 2 file))
+;;;           (t
+;;;            (dump-fop 'sb!impl::fop-code file)
+;;;            (dump-word num-consts file)
+;;;            (dump-word total-length file))))
 ;;; in several places. It would be cleaner if this could be replaced with
 ;;; something like
 ;;;     (dump-fop file fop-code num-consts total-length)
@@ -58,30 +64,42 @@
 ;;; caller to know that it's a 1-byte-arg/4-byte-arg cloned fop pair, and to
 ;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902
 (defmacro define-cloned-fops ((name code &key (pushp t) (stackp t))
-			      (small-name small-code) &rest forms)
+                              (small-name small-code) &rest forms)
   (aver (member pushp '(nil t)))
   (aver (member stackp '(nil t)))
   `(progn
-     (macrolet ((clone-arg () '(read-arg 4)))
+     (macrolet ((clone-arg () '(read-word-arg)))
        (define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms))
-     (macrolet ((clone-arg () '(read-arg 1)))
+     (macrolet ((clone-arg () '(read-byte-arg)))
        (define-fop (,small-name ,small-code :pushp ,pushp :stackp stackp) ,@forms))))
 
 ;;; a helper function for reading string values from FASL files: sort
 ;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
 ;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
 ;;; for each element read
-(declaim (ftype (function (stream simple-string &optional index) (values)) read-string-as-bytes))
+(declaim (ftype (function (stream simple-string &optional index) (values))
+                read-string-as-bytes #!+sb-unicode read-string-as-words))
 (defun read-string-as-bytes (stream string &optional (length (length string)))
   (dotimes (i length)
     (setf (aref string i)
-	  (code-char (read-byte stream))))
+          (sb!xc:code-char (read-byte stream))))
   ;; FIXME: The classic CMU CL code to do this was
   ;;   (READ-N-BYTES FILE STRING START END).
   ;; It was changed for SBCL because we needed a portable version for
   ;; bootstrapping. Benchmark the non-portable version and see whether it's
   ;; significantly better than the portable version here. If it is, then use
-  ;; add as an alternate definition, protected with #-SB-XC-HOST.
+  ;; it as an alternate definition, protected with #-SB-XC-HOST.
+  (values))
+#!+sb-unicode
+(defun read-string-as-words (stream string &optional (length (length string)))
+  #+sb-xc-host (bug "READ-STRING-AS-WORDS called")
+  (dotimes (i length)
+    (setf (aref string i)
+          (let ((code 0))
+            ;; FIXME: is this the same as READ-WORD-ARG?
+            (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code))
+              (setf code (logior code (ash (read-byte stream)
+                                           (* k sb!vm:n-byte-bits))))))))
   (values))
 
 ;;;; miscellaneous fops
@@ -110,8 +128,8 @@
 
 (define-fop (fop-nop 0 :stackp nil))
 (define-fop (fop-pop 1 :pushp nil) (push-fop-table (pop-stack)))
-(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
-(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
+(define-fop (fop-push 2) (svref *current-fop-table* (read-word-arg)))
+(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-byte-arg)))
 
 (define-fop (fop-empty-list 4) ())
 (define-fop (fop-truth 5) t)
@@ -123,30 +141,32 @@
   #-sb-xc-host
   (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag))
 
-(define-fop (fop-character 68)
-  (code-char (read-arg 3)))
-;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current
-;;; SBCL as we have no extended characters, only 1-byte characters.
-;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.)
-(define-fop (fop-short-character 69)
-  (code-char (read-arg 1)))
+(define-cloned-fops (fop-character 68) (fop-short-character 69)
+  (code-char (clone-arg)))
 
 (define-cloned-fops (fop-struct 48) (fop-small-struct 49)
   (let* ((size (clone-arg))
-	 (res (%make-instance size)))
+         (res (%make-instance size)))
     (declare (type index size))
-    (do ((n (1- size) (1- n)))
-	((minusp n))
-      (declare (type index-or-minus-1 n))
-      (setf (%instance-ref res n) (pop-stack)))
+    (let* ((layout (pop-stack))
+           (nuntagged (layout-n-untagged-slots layout))
+           (ntagged (- size nuntagged)))
+      (setf (%instance-ref res 0) layout)
+      (dotimes (n (1- ntagged))
+        (declare (type index n))
+        (setf (%instance-ref res (1+ n)) (pop-stack)))
+      (dotimes (n nuntagged)
+        (declare (type index n))
+        (setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack))))
     res))
 
 (define-fop (fop-layout 45)
-  (let ((length (pop-stack))
-	(depthoid (pop-stack))
-	(inherits (pop-stack))
-	(name (pop-stack)))
-    (find-and-init-or-check-layout name length inherits depthoid)))
+  (let ((nuntagged (pop-stack))
+        (length (pop-stack))
+        (depthoid (pop-stack))
+        (inherits (pop-stack))
+        (name (pop-stack)))
+    (find-and-init-or-check-layout name length inherits depthoid nuntagged)))
 
 (define-fop (fop-end-group 64 :stackp nil)
   (/show0 "THROWing FASL-GROUP-END")
@@ -159,50 +179,46 @@
 (define-fop (fop-maybe-cold-load 82 :stackp nil))
 
 (define-fop (fop-verify-table-size 62 :stackp nil)
-  (let ((expected-index (read-arg 4)))
+  (let ((expected-index (read-word-arg)))
     (unless (= *current-fop-table-index* expected-index)
       (bug "fasl table of improper size"))))
 (define-fop (fop-verify-empty-stack 63 :stackp nil)
-  (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
+  (unless (zerop (length *fop-stack*))
     (bug "fasl stack not empty when it should be")))
 
 ;;;; fops for loading symbols
 
-(defvar *load-symbol-buffer* (make-string 100))
-(declaim (simple-string *load-symbol-buffer*))
-(defvar *load-symbol-buffer-size* 100)
-(declaim (type index *load-symbol-buffer-size*))
-;;; FIXME:
-;;;   (1) *LOAD-SYMBOL-BUFFER-SIZE* is redundant, should just be
-;;;       (LENGTH *LOAD-SYMBOL-BUFFER*).
-;;;   (2) *LOAD-SYMBOL-BUFFER* should not have a global value, but should
-;;;       be bound on entry to FASL loading, and it should be renamed to
-;;;       *FASL-SYMBOL-BUFFER*.
-
 (macrolet (;; FIXME: Should all this code really be duplicated inside
-	   ;; each fop? Perhaps it would be better for this shared
-	   ;; code to live in FLET FROB1 and FLET FROB4 (for the
-	   ;; two different sizes of counts).
-	   (frob (name code name-size package)
-	     (let ((n-package (gensym))
-		   (n-size (gensym))
-		   (n-buffer (gensym)))
-	       `(define-fop (,name ,code)
-		  (prepare-for-fast-read-byte *fasl-input-stream*
-		    (let ((,n-package ,package)
-			  (,n-size (fast-read-u-integer ,name-size)))
-		      (when (> ,n-size *load-symbol-buffer-size*)
-			(setq *load-symbol-buffer*
-			      (make-string (setq *load-symbol-buffer-size*
-						 (* ,n-size 2)))))
-		      (done-with-fast-read-byte)
-		      (let ((,n-buffer *load-symbol-buffer*))
-			(read-string-as-bytes *fasl-input-stream*
-					      ,n-buffer
-					      ,n-size)
-			(push-fop-table (intern* ,n-buffer
-						 ,n-size
-						 ,n-package)))))))))
+           ;; each fop? Perhaps it would be better for this shared
+           ;; code to live in FLET FROB1 and FLET FROB4 (for the
+           ;; two different sizes of counts).
+           (frob (name code name-size package)
+             (let ((n-package (gensym))
+                   (n-size (gensym))
+                   (n-buffer (gensym)))
+               `(define-fop (,name ,code)
+                  (prepare-for-fast-read-byte *fasl-input-stream*
+                    (let ((,n-package ,package)
+                          (,n-size (fast-read-u-integer ,name-size)))
+                      (when (> ,n-size (length *fasl-symbol-buffer*))
+                        (setq *fasl-symbol-buffer*
+                              (make-string (* ,n-size 2))))
+                      (done-with-fast-read-byte)
+                      (let ((,n-buffer *fasl-symbol-buffer*))
+                        #+sb-xc-host
+                        (read-string-as-bytes *fasl-input-stream*
+                                              ,n-buffer
+                                              ,n-size)
+                        #-sb-xc-host
+                        (#!+sb-unicode read-string-as-words
+                         #!-sb-unicode read-string-as-bytes
+                         *fasl-input-stream*
+                         ,n-buffer
+                         ,n-size)
+                        (push-fop-table (without-package-locks
+                                         (intern* ,n-buffer
+                                                  ,n-size
+                                                  ,n-package))))))))))
 
   ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but
   ;; since they made the behavior of the fasloader depend on the
@@ -219,12 +235,12 @@
   ;;       (SETF *PACKAGE* (FIND-PACKAGE :CL)))
   ;; which in CMU CL 2.4.9 defines a variable CL-USER::*FOO* instead of
   ;; defining CL::*FOO*. Therefore, we don't use those fops in SBCL.
-  ;;(frob fop-symbol-save		6 4 *package*)
-  ;;(frob fop-small-symbol-save	  7 1 *package*)
+  ;;(frob fop-symbol-save               6 4 *package*)
+  ;;(frob fop-small-symbol-save   7 1 *package*)
 
-  (frob fop-lisp-symbol-save	      75 4 *cl-package*)
+  (frob fop-lisp-symbol-save          75 #.sb!vm:n-word-bytes *cl-package*)
   (frob fop-lisp-small-symbol-save    76 1 *cl-package*)
-  (frob fop-keyword-symbol-save       77 4 *keyword-package*)
+  (frob fop-keyword-symbol-save       77 #.sb!vm:n-word-bytes *keyword-package*)
   (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
 
   ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an enormous number
@@ -232,20 +248,23 @@
   ;; fasl files. A new
   ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE
   ;; cloned fop pair could undo some of this bloat.
-  (frob fop-symbol-in-package-save 8 4
-    (svref *current-fop-table* (fast-read-u-integer 4)))
+  (frob fop-symbol-in-package-save 8 #.sb!vm:n-word-bytes
+    (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes)))
   (frob fop-small-symbol-in-package-save 9 1
-    (svref *current-fop-table* (fast-read-u-integer 4)))
-  (frob fop-symbol-in-byte-package-save 10 4
+    (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes)))
+  (frob fop-symbol-in-byte-package-save 10 #.sb!vm:n-word-bytes
     (svref *current-fop-table* (fast-read-u-integer 1)))
   (frob fop-small-symbol-in-byte-package-save 11 1
     (svref *current-fop-table* (fast-read-u-integer 1))))
 
 (define-cloned-fops (fop-uninterned-symbol-save 12)
-		    (fop-uninterned-small-symbol-save 13)
+                    (fop-uninterned-small-symbol-save 13)
   (let* ((arg (clone-arg))
-	 (res (make-string arg)))
+         (res (make-string arg)))
+    #!-sb-unicode
     (read-string-as-bytes *fasl-input-stream* res)
+    #!+sb-unicode
+    (read-string-as-words *fasl-input-stream* res)
     (push-fop-table (make-symbol res))))
 
 (define-fop (fop-package 14)
@@ -258,13 +277,13 @@
   (declare (fixnum length))
   ;; #+cmu (declare (optimize (inhibit-warnings 2)))
   (do* ((index length (1- index))
-	(byte 0 (read-byte *fasl-input-stream*))
-	(result 0 (+ result (ash byte bits)))
-	(bits 0 (+ bits 8)))
+        (byte 0 (read-byte *fasl-input-stream*))
+        (result 0 (+ result (ash byte bits)))
+        (bits 0 (+ bits 8)))
        ((= index 0)
-	(if (logbitp 7 byte)	; look at sign bit
-	    (- result (ash 1 bits))
-	    result))
+        (if (logbitp 7 byte)    ; look at sign bit
+            (- result (ash 1 bits))
+            result))
     (declare (fixnum index byte bits))))
 
 (define-cloned-fops (fop-integer 33) (fop-small-integer 34)
@@ -273,7 +292,7 @@
 (define-fop (fop-word-integer 35)
   (prepare-for-fast-read-byte *fasl-input-stream*
     (prog1
-     (fast-read-s-integer 4)
+     (fast-read-s-integer #.sb!vm:n-word-bytes)
      (done-with-fast-read-byte))))
 
 (define-fop (fop-byte-integer 36)
@@ -294,14 +313,7 @@
              '(make-single-float (fast-read-s-integer 4)))
            (fast-read-double-float ()
              '(let ((lo (fast-read-u-integer 4)))
-               (make-double-float (fast-read-s-integer 4) lo)))
-           #!+long-float
-           (fast-read-long-float ()
-             '(let ((lo (fast-read-u-integer 4))
-                    #!+sparc (mid (fast-read-u-integer 4))
-                    (hi (fast-read-u-integer 4)) ; XXX
-                    (exp (fast-read-s-integer #!+x86 2 #!+sparc 4)))
-               (make-long-float exp hi #!+sparc mid lo))))
+               (make-double-float (fast-read-s-integer 4) lo))))
   (macrolet ((define-complex-fop (name fop-code type)
                (let ((reader (symbolicate "FAST-READ-" type)))
                  `(define-fop (,name ,fop-code)
@@ -330,19 +342,19 @@
 
 (define-fop (fop-list 15)
   (do ((res () (cons (pop-stack) res))
-       (n (read-arg 1) (1- n)))
+       (n (read-byte-arg) (1- n)))
       ((zerop n) res)
     (declare (type index n))))
 
 (define-fop (fop-list* 16)
   (do ((res (pop-stack) (cons (pop-stack) res))
-       (n (read-arg 1) (1- n)))
+       (n (read-byte-arg) (1- n)))
       ((zerop n) res)
     (declare (type index n))))
 
 (macrolet ((frob (name op fun n)
-	     `(define-fop (,name ,op)
-		(call-with-popped-things ,fun ,n))))
+             `(define-fop (,name ,op)
+                (call-with-popped-args ,fun ,n))))
 
   (frob fop-list-1 17 list 1)
   (frob fop-list-2 18 list 2)
@@ -364,79 +376,71 @@
 
 ;;;; fops for loading arrays
 
-(define-cloned-fops (fop-string 37) (fop-small-string 38)
+(define-cloned-fops (fop-base-string 37) (fop-small-base-string 38)
   (let* ((arg (clone-arg))
-	 (res (make-string arg)))
+         (res (make-string arg :element-type 'base-char)))
     (read-string-as-bytes *fasl-input-stream* res)
     res))
 
+#!+sb-unicode
+(progn
+  #+sb-xc-host
+  (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162)
+    (bug "CHARACTER-STRING FOP encountered"))
+
+  #-sb-xc-host
+  (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162)
+    (let* ((arg (clone-arg))
+           (res (make-string arg)))
+      (read-string-as-words *fasl-input-stream* res)
+      res)))
+
 (define-cloned-fops (fop-vector 39) (fop-small-vector 40)
   (let* ((size (clone-arg))
-	 (res (make-array size)))
+         (res (make-array size)))
     (declare (fixnum size))
     (do ((n (1- size) (1- n)))
-	((minusp n))
+        ((minusp n))
       (setf (svref res n) (pop-stack)))
     res))
 
 (define-fop (fop-array 83)
-  (let* ((rank (read-arg 4))
-	 (vec (pop-stack))
-	 (length (length vec))
-	 (res (make-array-header sb!vm:simple-array-widetag rank)))
+  (let* ((rank (read-word-arg))
+         (vec (pop-stack))
+         (length (length vec))
+         (res (make-array-header sb!vm:simple-array-widetag rank)))
     (declare (simple-array vec)
-	     (type (unsigned-byte 24) rank))
-    (set-array-header res vec length length 0
-		      (do ((i rank (1- i))
-			   (dimensions () (cons (pop-stack) dimensions)))
-			  ((zerop i) dimensions)
-			(declare (type index i)))
-		      nil)
+             (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank))
+    (set-array-header res vec length nil 0
+                      (do ((i rank (1- i))
+                           (dimensions () (cons (pop-stack) dimensions)))
+                          ((zerop i) dimensions)
+                        (declare (type index i)))
+                      nil)
     res))
 
 (define-fop (fop-single-float-vector 84)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type 'single-float)))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type 'single-float)))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 4))
     result))
 
 (define-fop (fop-double-float-vector 85)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type 'double-float)))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2))
-    result))
-
-#!+long-float
-(define-fop (fop-long-float-vector 88)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type 'long-float)))
-    (read-n-bytes *fasl-input-stream*
-		  result
-		  0
-		  (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type 'double-float)))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 8))
     result))
 
 (define-fop (fop-complex-single-float-vector 86)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type '(complex single-float))))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type '(complex single-float))))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 8))
     result))
 
 (define-fop (fop-complex-double-float-vector 87)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type '(complex double-float))))
-    (read-n-bytes *fasl-input-stream*
-		  result
-		  0
-		  (* length sb!vm:n-word-bytes 2 2))
-    result))
-
-#!+long-float
-(define-fop (fop-complex-long-float-vector 89)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type '(complex long-float))))
-    (read-n-bytes *fasl-input-stream* result 0
-		  (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type '(complex double-float))))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 16))
     result))
 
 ;;; CMU CL comment:
@@ -446,118 +450,149 @@
 ;;;   byte-ordering, allowing us to directly read the bits.
 (define-fop (fop-int-vector 43)
   (prepare-for-fast-read-byte *fasl-input-stream*
-    (let* ((len (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (res (case size
-		  (1 (make-array len :element-type 'bit))
-		  (2 (make-array len :element-type '(unsigned-byte 2)))
-		  (4 (make-array len :element-type '(unsigned-byte 4)))
-		  (8 (make-array len :element-type '(unsigned-byte 8)))
-		  (16 (make-array len :element-type '(unsigned-byte 16)))
-		  (32 (make-array len :element-type '(unsigned-byte 32)))
-		  (t (bug "losing i-vector element size: ~S" size)))))
+    (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes))
+           (size (fast-read-byte))
+           (res (case size
+                  (0 (make-array len :element-type 'nil))
+                  (1 (make-array len :element-type 'bit))
+                  (2 (make-array len :element-type '(unsigned-byte 2)))
+                  (4 (make-array len :element-type '(unsigned-byte 4)))
+                  (7 (prog1 (make-array len :element-type '(unsigned-byte 7))
+                       (setf size 8)))
+                  (8 (make-array len :element-type '(unsigned-byte 8)))
+                  (15 (prog1 (make-array len :element-type '(unsigned-byte 15))
+                        (setf size 16)))
+                  (16 (make-array len :element-type '(unsigned-byte 16)))
+                  (31 (prog1 (make-array len :element-type '(unsigned-byte 31))
+                        (setf size 32)))
+                  (32 (make-array len :element-type '(unsigned-byte 32)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (63 (prog1 (make-array len :element-type '(unsigned-byte 63))
+                        (setf size 64)))
+                  (64 (make-array len :element-type '(unsigned-byte 64)))
+                  (t (bug "losing i-vector element size: ~S" size)))))
       (declare (type index len))
       (done-with-fast-read-byte)
       (read-n-bytes *fasl-input-stream*
-		    res
-		    0
-		    (ceiling (the index (* size len))
-			     sb!vm:n-byte-bits))
+                    res
+                    0
+                    (ceiling (the index (* size len)) sb!vm:n-byte-bits))
       res)))
 
 ;;; This is the same as FOP-INT-VECTOR, except this is for signed
 ;;; SIMPLE-ARRAYs.
 (define-fop (fop-signed-int-vector 50)
   (prepare-for-fast-read-byte *fasl-input-stream*
-    (let* ((len (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (res (case size
- 		  (8 (make-array len :element-type '(signed-byte 8)))
- 		  (16 (make-array len :element-type '(signed-byte 16)))
- 		  (30 (make-array len :element-type '(signed-byte 30)))
- 		  (32 (make-array len :element-type '(signed-byte 32)))
- 		  (t (bug "losing si-vector element size: ~S" size)))))
+    (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes))
+           (size (fast-read-byte))
+           (res (case size
+                  (8 (make-array len :element-type '(signed-byte 8)))
+                  (16 (make-array len :element-type '(signed-byte 16)))
+                  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+                  (29 (prog1 (make-array len :element-type '(unsigned-byte 29))
+                        (setf size 32)))
+                  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+                  (30 (prog1 (make-array len :element-type '(signed-byte 30))
+                        (setf size 32)))
+                  (32 (make-array len :element-type '(signed-byte 32)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (60 (prog1 (make-array len :element-type '(unsigned-byte 60))
+                        (setf size 64)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (61 (prog1 (make-array len :element-type '(signed-byte 61))
+                        (setf size 64)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (64 (make-array len :element-type '(signed-byte 64)))
+                  (t (bug "losing si-vector element size: ~S" size)))))
       (declare (type index len))
       (done-with-fast-read-byte)
       (read-n-bytes *fasl-input-stream*
-		    res
-		    0
- 		    (ceiling (the index (* (if (= size 30)
-					       32 ; Adjust for (signed-byte 30)
-					       size) len)) sb!vm:n-byte-bits))
+                    res
+                    0
+                    (ceiling (the index (* size len)) sb!vm:n-byte-bits))
       res)))
 
 (define-fop (fop-eval 53)
-  (let ((result (eval (pop-stack))))
-    ;; FIXME: CMU CL had this code here:
-    ;;   (when *load-print*
-    ;;     (load-fresh-line)
-    ;;     (prin1 result)
-    ;;     (terpri))
-    ;; Unfortunately, this dependence on the *LOAD-PRINT* global
-    ;; variable is non-ANSI, so for now we've just punted printing in
-    ;; fasl loading.
-    result))
+  (if *skip-until*
+      (pop-stack)
+      (let ((result (eval (pop-stack))))
+        ;; FIXME: CMU CL had this code here:
+        ;;   (when *load-print*
+        ;;     (load-fresh-line)
+        ;;     (prin1 result)
+        ;;     (terpri))
+        ;; Unfortunately, this dependence on the *LOAD-PRINT* global
+        ;; variable is non-ANSI, so for now we've just punted printing in
+        ;; fasl loading.
+        result)))
 
 (define-fop (fop-eval-for-effect 54 :pushp nil)
-  (let ((result (eval (pop-stack))))
-    ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
-    (declare (ignore result))
-    #+nil (when *load-print*
-	    (load-fresh-line)
-	    (prin1 result)
-	    (terpri))))
+  (if *skip-until*
+      (pop-stack)
+      (let ((result (eval (pop-stack))))
+        ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
+        (declare (ignore result))
+        #+nil (when *load-print*
+                (load-fresh-line)
+                (prin1 result)
+                (terpri)))))
 
 (define-fop (fop-funcall 55)
-  (let ((arg (read-arg 1)))
-    (if (zerop arg)
-	(funcall (pop-stack))
-	(do ((args () (cons (pop-stack) args))
-	     (n arg (1- n)))
-	    ((zerop n) (apply (pop-stack) args))
-	  (declare (type index n))))))
+  (let ((arg (read-byte-arg)))
+    (if *skip-until*
+        (dotimes (i (1+ arg))
+          (pop-stack))
+        (if (zerop arg)
+            (funcall (pop-stack))
+            (do ((args () (cons (pop-stack) args))
+                 (n arg (1- n)))
+                ((zerop n) (apply (pop-stack) args))
+              (declare (type index n)))))))
 
 (define-fop (fop-funcall-for-effect 56 :pushp nil)
-  (let ((arg (read-arg 1)))
-    (if (zerop arg)
-	(funcall (pop-stack))
-	(do ((args () (cons (pop-stack) args))
-	     (n arg (1- n)))
-	    ((zerop n) (apply (pop-stack) args))
-	  (declare (type index n))))))
+  (let ((arg (read-byte-arg)))
+    (if *skip-until*
+        (dotimes (i (1+ arg))
+          (pop-stack))
+        (if (zerop arg)
+            (funcall (pop-stack))
+            (do ((args () (cons (pop-stack) args))
+                 (n arg (1- n)))
+                ((zerop n) (apply (pop-stack) args))
+              (declare (type index n)))))))
 
 ;;;; fops for fixing up circularities
 
 (define-fop (fop-rplaca 200 :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4))
-	(val (pop-stack)))
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+        (idx (read-word-arg))
+        (val (pop-stack)))
     (setf (car (nthcdr idx obj)) val)))
 
 (define-fop (fop-rplacd 201 :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4))
-	(val (pop-stack)))
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+        (idx (read-word-arg))
+        (val (pop-stack)))
     (setf (cdr (nthcdr idx obj)) val)))
 
 (define-fop (fop-svset 202 :pushp nil)
-  (let* ((obi (read-arg 4))
-	 (obj (svref *current-fop-table* obi))
-	 (idx (read-arg 4))
-	 (val (pop-stack)))
-    (if (typep obj 'instance)
-	(setf (%instance-ref obj idx) val)
-	(setf (svref obj idx) val))))
+  (let* ((obi (read-word-arg))
+         (obj (svref *current-fop-table* obi))
+         (idx (read-word-arg))
+         (val (pop-stack)))
+    (if (%instancep obj)
+        (setf (%instance-ref obj idx) val)
+        (setf (svref obj idx) val))))
 
 (define-fop (fop-structset 204 :pushp nil)
-  (setf (%instance-ref (svref *current-fop-table* (read-arg 4))
-		       (read-arg 4))
-	(pop-stack)))
+  (setf (%instance-ref (svref *current-fop-table* (read-word-arg))
+                       (read-word-arg))
+        (pop-stack)))
 
 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
 ;;; to be T, even though that's what it defaults to in DEFINE-FOP.
 (define-fop (fop-nthcdr 203)
-  (nthcdr (read-arg 4) (pop-stack)))
+  (nthcdr (read-word-arg) (pop-stack)))
 
 ;;;; fops for loading functions
 
@@ -569,10 +604,10 @@
 ;;; fasl file header.)
 
 (define-fop (fop-code 58 :stackp nil)
-  (load-code (read-arg 4) (read-arg 4)))
+  (load-code (read-word-arg) (read-word-arg)))
 
 (define-fop (fop-small-code 59 :stackp nil)
-  (load-code (read-arg 1) (read-arg 2)))
+  (load-code (read-byte-arg) (read-halfword-arg)))
 
 (define-fop (fop-fdefinition 60)
   (fdefinition-object (pop-stack) t))
@@ -600,13 +635,13 @@ bug.~:@>")
   ;; depend more strongly than in CMU CL on FOP-FSET actually doing
   ;; something.)
   (let ((fn (pop-stack))
-	(name (pop-stack)))
+        (name (pop-stack)))
     (setf (fdefinition name) fn)))
 
 ;;; Modify a slot in a CONSTANTS object.
 (define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141)
   (let ((value (pop-stack))
-	(code (pop-stack)))
+        (code (pop-stack)))
     (setf (code-header-ref code (clone-arg)) value)
     (values)))
 
@@ -614,11 +649,12 @@ bug.~:@>")
   #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
   (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.")
   #-sb-xc-host
-  (let ((type (pop-stack))
-	(arglist (pop-stack))
-	(name (pop-stack))
-	(code-object (pop-stack))
-	(offset (read-arg 4)))
+  (let ((xrefs (pop-stack))
+        (type (pop-stack))
+        (arglist (pop-stack))
+        (name (pop-stack))
+        (code-object (pop-stack))
+        (offset (read-word-arg)))
     (declare (type index offset))
     (unless (zerop (logand offset sb!vm:lowtag-mask))
       (bug "unaligned function object, offset = #X~X" offset))
@@ -629,10 +665,11 @@ bug.~:@>")
       (setf (%simple-fun-name fun) name)
       (setf (%simple-fun-arglist fun) arglist)
       (setf (%simple-fun-type fun) type)
+      (setf (%simple-fun-xrefs fun) xrefs)
       ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
       #+nil (when *load-print*
-	      (load-fresh-line)
-	      (format t "~S defined~%" fun))
+              (load-fresh-line)
+              (format t "~S defined~%" fun))
       fun)))
 
 ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code
@@ -649,40 +686,96 @@ bug.~:@>")
 
 ;;;; assemblerish fops
 
-(define-fop (fop-foreign-fixup 147)
-  (let* ((kind (pop-stack))
-	 (code-object (pop-stack))
-	 (len (read-arg 1))
-	 (sym (make-string len)))
-    (read-n-bytes *fasl-input-stream* sym 0 len)
-    (sb!vm:fixup-code-object code-object
-			     (read-arg 4)
-			     (foreign-symbol-address-as-integer sym)
-			     kind)
-    code-object))
-
 (define-fop (fop-assembler-code 144)
   (error "cannot load assembler code except at cold load"))
 
 (define-fop (fop-assembler-routine 145)
   (error "cannot load assembler code except at cold load"))
 
+(define-fop (fop-foreign-fixup 147)
+  (let* ((kind (pop-stack))
+         (code-object (pop-stack))
+         (len (read-byte-arg))
+         (sym (make-string len :element-type 'base-char)))
+    (read-n-bytes *fasl-input-stream* sym 0 len)
+    (sb!vm:fixup-code-object code-object
+                             (read-word-arg)
+                             (foreign-symbol-address sym)
+                             kind)
+    code-object))
+
 (define-fop (fop-assembler-fixup 148)
   (let ((routine (pop-stack))
-	(kind (pop-stack))
-	(code-object (pop-stack)))
+        (kind (pop-stack))
+        (code-object (pop-stack)))
     (multiple-value-bind (value found) (gethash routine *assembler-routines*)
       (unless found
-	(error "undefined assembler routine: ~S" routine))
-      (sb!vm:fixup-code-object code-object (read-arg 4) value kind))
+        (error "undefined assembler routine: ~S" routine))
+      (sb!vm:fixup-code-object code-object (read-word-arg) value kind))
     code-object))
 
 (define-fop (fop-code-object-fixup 149)
   (let ((kind (pop-stack))
-	(code-object (pop-stack)))
+        (code-object (pop-stack)))
     ;; Note: We don't have to worry about GC moving the code-object after
     ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because
     ;; we can only use code-object fixups when code-objects don't move.
-    (sb!vm:fixup-code-object code-object (read-arg 4)
-			     (get-lisp-obj-address code-object) kind)
+    (sb!vm:fixup-code-object code-object (read-word-arg)
+                             (get-lisp-obj-address code-object) kind)
+    code-object))
+
+#!+linkage-table
+(define-fop (fop-foreign-dataref-fixup 150)
+  (let* ((kind (pop-stack))
+         (code-object (pop-stack))
+         (len (read-byte-arg))
+         (sym (make-string len :element-type 'base-char)))
+    (read-n-bytes *fasl-input-stream* sym 0 len)
+    (sb!vm:fixup-code-object code-object
+                             (read-word-arg)
+                             (foreign-symbol-address sym t)
+                             kind)
     code-object))
+
+;;; FOPs needed for implementing an IF operator in a FASL
+
+;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is
+;;; executed. While skipping, we execute most FOPs normally, except
+;;; for ones that a) funcall/eval b) start skipping. This needs to
+;;; be done to ensure that the fop table gets populated correctly
+;;; regardless of the execution path.
+(define-fop (fop-skip 151 :pushp nil)
+  (let ((position (pop-stack)))
+    (unless *skip-until*
+      (setf *skip-until* position)))
+  (values))
+
+;;; As before, but only start skipping if the top of the FOP stack is NIL.
+(define-fop (fop-skip-if-false 152 :pushp nil)
+  (let ((condition (pop-stack))
+        (position (pop-stack)))
+    (unless (or condition
+                *skip-until*)
+      (setf *skip-until* position)))
+  (values))
+
+;;; If skipping, pop the top of the stack and discard it. Needed for
+;;; ensuring that the stack stays balanced when skipping.
+(define-fop (fop-drop-if-skipping 153 :pushp nil)
+  (when *skip-until*
+    (pop-stack))
+  (values))
+
+;;; If skipping, push a dummy value on the stack. Needed for
+;;; ensuring that the stack stays balanced when skipping.
+(define-fop (fop-push-nil-if-skipping 154 :pushp nil)
+  (when *skip-until*
+    (push-stack nil))
+  (values))
+
+;;; Stop skipping if the top of the stack matches *SKIP-UNTIL*
+(define-fop (fop-maybe-stop-skipping 155 :pushp nil)
+  (let ((label (pop-stack)))
+    (when (eql *skip-until* label)
+      (setf *skip-until* nil)))
+  (values))