X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=f7bb13b6cae9e81211c06b15ecb05aeb9160c158;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=91fa04eae3e3da9422da58eaec731c40a1459691;hpb=60059052d267b3072ed8cefb1faf1e590f96adf7;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 91fa04e..f7bb13b 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -134,8 +134,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-word-arg)))
-(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-byte-arg)))
+(define-fop (fop-push 2) (ref-fop-table (read-word-arg)))
+(define-fop (fop-byte-push 3) (ref-fop-table (read-byte-arg)))
 
 (define-fop (fop-empty-list 4) ())
 (define-fop (fop-truth 5) t)
@@ -145,7 +145,7 @@
   #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
   (error "FOP-MISC-TRAP can't be defined without %PRIMITIVE.")
   #-sb-xc-host
-  (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag))
+  (%primitive sb!c:make-unbound-marker))
 
 (define-cloned-fops (fop-character 68) (fop-short-character 69)
   (code-char (clone-arg)))
@@ -184,37 +184,37 @@
 
 (define-fop (fop-verify-table-size 62 :stackp nil)
   (let ((expected-index (read-word-arg)))
-    (unless (= *current-fop-table-index* expected-index)
+    (unless (= (get-fop-table-index) expected-index)
       (bug "fasl table of improper size"))))
 (define-fop (fop-verify-empty-stack 63 :stackp nil)
-  (unless (zerop (length *fop-stack*))
+  (unless (fop-stack-empty-p)
     (bug "fasl stack not empty when it should be")))
 
 ;;;; fops for loading symbols
 
-(defun fop-intern (smallp package)
-  (let ((size (if smallp
-                  (read-byte-arg)
-                  (read-word-arg))))
-    (when (> size (length *fasl-symbol-buffer*))
-      (setq *fasl-symbol-buffer* (make-string (* size 2))))
-    (let ((buffer *fasl-symbol-buffer*))
-      #+sb-xc-host
-      (read-string-as-bytes *fasl-input-stream* buffer size)
-      #-sb-xc-host
-      (progn
-        #!+sb-unicode
-        (read-string-as-unsigned-byte-32 *fasl-input-stream* buffer size)
-        #!-sb-unicode
-        (read-string-as-bytes *fasl-input-stream* buffer size))
-      (push-fop-table (without-package-locks
-                        (intern* buffer
-                                 size
-                                 package))))))
+(defun aux-fop-intern (smallp package)
+  (declare (optimize speed))
+  (let* ((size (if smallp
+                   (read-byte-arg)
+                   (read-word-arg)))
+         (buffer (make-string size)))
+    #+sb-xc-host
+    (read-string-as-bytes *fasl-input-stream* buffer size)
+    #-sb-xc-host
+    (progn
+      #!+sb-unicode
+      (read-string-as-unsigned-byte-32 *fasl-input-stream* buffer size)
+      #!-sb-unicode
+      (read-string-as-bytes *fasl-input-stream* buffer size))
+    (push-fop-table (without-package-locks
+                      (intern* buffer
+                               size
+                               package
+                               :no-copy t)))))
 
 (macrolet ((def (name code smallp package-form)
              `(define-fop (,name ,code)
-                (fop-intern ,smallp ,package-form))))
+                (aux-fop-intern ,smallp ,package-form))))
 
   (def fop-lisp-symbol-save          75 nil *cl-package*)
   (def fop-lisp-small-symbol-save    76 t   *cl-package*)
@@ -227,13 +227,13 @@
   ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE
   ;; cloned fop pair could undo some of this bloat.
   (def fop-symbol-in-package-save             8 nil
-    (svref *current-fop-table* (read-word-arg)))
+    (ref-fop-table (read-word-arg)))
   (def fop-small-symbol-in-package-save       9 t
-    (svref *current-fop-table* (read-word-arg)))
+    (ref-fop-table (read-word-arg)))
   (def fop-symbol-in-byte-package-save       10 nil
-    (svref *current-fop-table* (read-byte-arg)))
+    (ref-fop-table (read-byte-arg)))
   (def fop-small-symbol-in-byte-package-save 11 t
-    (svref *current-fop-table* (read-byte-arg))))
+    (ref-fop-table (read-byte-arg))))
 
 (define-cloned-fops (fop-uninterned-symbol-save 12)
                     (fop-uninterned-small-symbol-save 13)
@@ -266,17 +266,18 @@
 
 ;;; Load a signed integer LENGTH bytes long from *FASL-INPUT-STREAM*.
 (defun load-s-integer (length)
-  (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)))
-       ((= index 0)
-        (if (logbitp 7 byte)    ; look at sign bit
-            (- result (ash 1 bits))
-            result))
-    (declare (fixnum index byte bits))))
+  (declare (fixnum length)
+           (optimize speed))
+  (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream*)
+    (do* ((index length (1- index))
+          (byte 0 (fast-read-byte))
+          (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))
+      (declare (fixnum index byte bits)))))
 
 (define-cloned-fops (fop-integer 33) (fop-small-integer 34)
   (load-s-integer (clone-arg)))
@@ -321,6 +322,12 @@
     #!+long-float
     (define-float-fop fop-long-float 52 long-float)))
 
+#!+sb-simd-pack
+(define-fop (fop-simd-pack 88)
+  (with-fast-read-byte ((unsigned-byte 8) *fasl-input-stream*)
+    (%make-simd-pack (fast-read-s-integer 8)
+                     (fast-read-u-integer 8)
+                     (fast-read-u-integer 8))))
 
 ;;;; loading lists
 
@@ -404,94 +411,32 @@
                       t)
     res))
 
-(define-fop (fop-single-float-vector 84)
-  (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-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)
+(defglobal **saetp-bits-per-length**
+    (let ((array (make-array (1+ sb!vm:widetag-mask)
+                             :element-type '(unsigned-byte 8)
+                             :initial-element 255)))
+      (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+            do
+            (setf (aref array (sb!vm:saetp-typecode saetp))
+                  (sb!vm:saetp-n-bits saetp)))
+      array)
+    "255 means bad entry.")
+(declaim (type (simple-array (unsigned-byte 8) (#.(1+ sb!vm:widetag-mask)))
+               **saetp-bits-per-length**))
+
+(define-fop (fop-spec-vector 43)
   (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-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:
-;;;   *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts.
-;;;   Size must be a directly supported I-vector element size, with no
-;;;   extra bits. This must be packed according to the local
-;;;   byte-ordering, allowing us to directly read the bits.
-(define-fop (fop-int-vector 43)
-  (let* ((len (read-word-arg))
-         (size (read-byte-arg))
-         (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))
-    (read-n-bytes *fasl-input-stream*
-                  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)
-  (let* ((len (read-word-arg))
-         (size (read-byte-arg))
-         (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))
-    (read-n-bytes *fasl-input-stream*
-                  res
-                  0
-                  (ceiling (the index (* size len)) sb!vm:n-byte-bits))
-    res))
+         (widetag (read-byte-arg))
+         (bits-per-length (aref **saetp-bits-per-length** widetag))
+         (bits (progn (aver (< bits-per-length 255))
+                      (* length bits-per-length)))
+         (bytes (ceiling bits sb!vm:n-byte-bits))
+         (words (ceiling bytes sb!vm:n-word-bytes))
+         (vector (allocate-vector widetag length words)))
+    (declare (type index length bytes words)
+             (type word bits))
+    (read-n-bytes *fasl-input-stream* vector 0 bytes)
+    vector))
 
 (define-fop (fop-eval 53)
   (if *skip-until*
@@ -545,20 +490,20 @@
 ;;;; fops for fixing up circularities
 
 (define-fop (fop-rplaca 200 :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-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-word-arg)))
+  (let ((obj (ref-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-word-arg))
-         (obj (svref *current-fop-table* obi))
+         (obj (ref-fop-table obi))
          (idx (read-word-arg))
          (val (pop-stack)))
     (if (%instancep obj)
@@ -566,7 +511,7 @@
         (setf (svref obj idx) val))))
 
 (define-fop (fop-structset 204 :pushp nil)
-  (setf (%instance-ref (svref *current-fop-table* (read-word-arg))
+  (setf (%instance-ref (ref-fop-table (read-word-arg))
                        (read-word-arg))
         (pop-stack)))
 
@@ -593,6 +538,9 @@
 (define-fop (fop-fdefinition 60)
   (fdefinition-object (pop-stack) t))
 
+(define-fop (fop-known-fun 65)
+  (%coerce-name-to-fun (pop-stack)))
+
 (define-fop (fop-sanctify-for-execution 61)
   (let ((component (pop-stack)))
     (sb!vm:sanctify-for-execution component)