X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=287162b519b1d1425081143b0a3042acc0bb9221;hb=74cfbf6d0572b7df1b3492563408a7cb3ae103cf;hp=5b3787645b0733cb099b3921d80bc2b1e1c3a243;hpb=8f571a2c80ba0de2a69f6a142d149d3838412a28;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 5b37876..287162b 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -112,8 +112,9 @@
 ;;; only made for bigger and up 1o 100% slower code.
 (deftransform hairy-data-vector-ref ((array index) (simple-array t) *)
   "avoid runtime dispatch on array element type"
-  (let ((element-ctype (extract-upgraded-element-type array))
-        (declared-element-ctype (extract-declared-element-type array)))
+  (let* ((type (lvar-type array))
+         (element-ctype (array-type-upgraded-element-type type))
+         (declared-element-ctype (array-type-declared-element-type type)))
     (declare (type ctype element-ctype))
     (when (eq *wild-type* element-ctype)
       (give-up-ir1-transform
@@ -200,8 +201,9 @@
                                      (simple-array t t)
                                      *)
   "avoid runtime dispatch on array element type"
-  (let ((element-ctype (extract-upgraded-element-type array))
-        (declared-element-ctype (extract-declared-element-type array)))
+  (let* ((type (lvar-type array))
+         (element-ctype (array-type-upgraded-element-type type))
+         (declared-element-ctype (array-type-declared-element-type type)))
     (declare (type ctype element-ctype))
     (when (eq *wild-type* element-ctype)
       (give-up-ir1-transform
@@ -264,14 +266,32 @@
                              sb!vm:vector-data-offset
                              index offset t))))
 
-(defoptimizer (%data-vector-and-index derive-type) ((array index))
-  (let ((atype (lvar-type array)))
+(defun maybe-array-data-vector-type-specifier (array-lvar)
+  (let ((atype (lvar-type array-lvar)))
     (when (array-type-p atype)
-      (values-specifier-type
-       `(values (simple-array ,(type-specifier
-                                (array-type-specialized-element-type atype))
-                              (*))
-                index)))))
+      (let ((dims (array-type-dimensions atype)))
+        (if (or (array-type-complexp atype)
+                (eq '* dims)
+                (notevery #'integerp dims))
+           `(simple-array ,(type-specifier
+                            (array-type-specialized-element-type atype))
+                          (*))
+           `(simple-array ,(type-specifier
+                            (array-type-specialized-element-type atype))
+                          (,(apply #'* dims))))))))
+
+(macrolet ((def (name)
+             `(defoptimizer (,name derive-type) ((array-lvar))
+                (let ((spec (maybe-array-data-vector-type-specifier array-lvar)))
+                  (when spec
+                    (specifier-type spec))))))
+  (def %array-data-vector)
+  (def array-storage-vector))
+
+(defoptimizer (%data-vector-and-index derive-type) ((array index))
+  (let ((spec (maybe-array-data-vector-type-specifier array)))
+    (when spec
+      (values-specifier-type `(values ,spec index)))))
 
 (deftransform %data-vector-and-index ((%array %index)
                                       (simple-array t)
@@ -295,41 +315,6 @@
   '(if (array-header-p %array)
        (values (%array-data-vector %array) %index)
        (values %array %index)))
-
-;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
-;;;
-;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
-;;; we fix them or should we delete them? (Perhaps these definitions
-;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
-;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
-#+nil
-(macrolet
-    ((frob (type bits)
-       (let ((elements-per-word (truncate sb!vm:n-word-bits bits)))
-         `(progn
-            (deftransform data-vector-ref ((vector index)
-                                           (,type *))
-              `(multiple-value-bind (word bit)
-                   (floor index ,',elements-per-word)
-                 (ldb ,(ecase sb!vm:target-byte-order
-                         (:little-endian '(byte ,bits (* bit ,bits)))
-                         (:big-endian '(byte ,bits (- sb!vm:n-word-bits
-                                                      (* (1+ bit) ,bits)))))
-                      (%vector-raw-bits vector word))))
-            (deftransform data-vector-set ((vector index new-value)
-                                           (,type * *))
-              `(multiple-value-bind (word bit)
-                   (floor index ,',elements-per-word)
-                 (setf (ldb ,(ecase sb!vm:target-byte-order
-                               (:little-endian '(byte ,bits (* bit ,bits)))
-                               (:big-endian
-                                '(byte ,bits (- sb!vm:n-word-bits
-                                                (* (1+ bit) ,bits)))))
-                            (%vector-raw-bits vector word))
-                       new-value)))))))
-  (frob simple-bit-vector 1)
-  (frob (simple-array (unsigned-byte 2) (*)) 2)
-  (frob (simple-array (unsigned-byte 4) (*)) 4))
 
 ;;;; BIT-VECTOR hackery
 
@@ -584,10 +569,11 @@
      (values)))
 
 ;;;; transforms for EQL of floating point values
-
+#!-float-eql-vops
 (deftransform eql ((x y) (single-float single-float))
   '(= (single-float-bits x) (single-float-bits y)))
 
+#!-float-eql-vops
 (deftransform eql ((x y) (double-float double-float))
   '(and (= (double-float-low-bits x) (double-float-low-bits y))
         (= (double-float-high-bits x) (double-float-high-bits y))))