X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=c4044a3039c1d61b0d6df88109e5e33f51224ce5;hb=7f579b076a1fc54587538ead07e506e7f06f3fe8;hp=4ea3aba2da5114d81474b7d8835ea39a519728da;hpb=1f03c7f326823245708a84af86b31ac72bdb1742;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 4ea3aba..c4044a3 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -109,11 +109,12 @@
 ;;; This and the corresponding -SET transform work equally well on non-simple
 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
 ;;; where it actually helped with non-simple arrays -- to the contrary, it
-;;; only made for bigger and up 1o 100% slower code.
+;;; only made for bigger and up to 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)
@@ -604,14 +624,13 @@
   ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
   ;; don't have a true Alpha64 port yet, we'll have to stick to
   ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
-  #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
-  (progn
-    #!+x86 (def sb!vm::ash-left-smod30 :tagged 30 t)
-    (def sb!vm::ash-left-mod32 :untagged 32 nil))
-  #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
-  (progn
-    #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t)
-    (def sb!vm::ash-left-mod64 :untagged 64 nil)))
+  #.`(progn
+       #!+(or x86 x86-64)
+       (def sb!vm::ash-left-modfx
+           :tagged ,(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) t)
+       (def ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)
+                     "SB!VM")
+           :untagged ,sb!vm:n-machine-word-bits nil)))
 
 ;;;; word-wise logical operations