0.8.1.34:

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 3298c81..37fdb87 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -52,7 +52,8 @@
 
 (deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
   "avoid runtime dispatch on array element type"
-  (let ((element-ctype (extract-upgraded-element-type array)))
+  (let ((element-ctype (extract-upgraded-element-type array))
+       (declared-element-ctype (extract-declared-element-type array)))
     (declare (type ctype element-ctype))
     (when (eq *wild-type* element-ctype)
       (give-up-ir1-transform
@@ -65,7 +66,11 @@
       `(multiple-value-bind (array index)
           (%data-vector-and-index array index)
         (declare (type (simple-array ,element-type-specifier 1) array))
-        (data-vector-ref array index)))))
+        ,(let ((bare-form '(data-vector-ref array index)))
+           (if (type= element-ctype declared-element-ctype)
+               bare-form
+               `(the ,(type-specifier declared-element-ctype)
+                     ,bare-form)))))))
 
 (deftransform data-vector-ref ((array index)
                                (simple-array t))
@@ -84,12 +89,25 @@
                                      (%array-data-vector array))
                           index)))))
 
+(deftransform hairy-data-vector-set ((string index new-value)
+                                    (simple-string t t))
+  (let ((ctype (continuation-type string)))
+    (if (array-type-p ctype)
+       ;; the other transform will kick in, so that's OK
+       (give-up-ir1-transform)
+       `(typecase string
+         ((simple-array character (*))
+          (data-vector-set string index new-value))
+         ((simple-array nil (*))
+          (data-vector-set string index new-value))))))
+
 (deftransform hairy-data-vector-set ((array index new-value)
                                     (array t t)
                                     *
                                     :important t)
   "avoid runtime dispatch on array element type"
-  (let ((element-ctype (extract-upgraded-element-type array)))
+  (let ((element-ctype (extract-upgraded-element-type array))
+       (declared-element-ctype (extract-declared-element-type array)))
     (declare (type ctype element-ctype))
     (when (eq *wild-type* element-ctype)
       (give-up-ir1-transform
@@ -99,21 +117,12 @@
           (%data-vector-and-index array index)
         (declare (type (simple-array ,element-type-specifier 1) array)
                  (type ,element-type-specifier new-value))
-        (data-vector-set array
-                         index
-                         new-value)))))
-
-(deftransform hairy-data-vector-set ((string index new-value)
-                                    (simple-string t t))
-  (let ((ctype (continuation-type string)))
-    (if (array-type-p ctype)
-       ;; the other transform will kick in, so that's OK
-       (give-up-ir1-transform)
-       `(typecase string
-         ((simple-array character (*))
-          (data-vector-set string index new-value))
-         ((simple-array nil (*))
-          (data-vector-set string index new-value))))))
+        ,(if (type= element-ctype declared-element-ctype)
+             '(data-vector-set array index new-value)
+             `(truly-the ,(type-specifier declared-element-ctype)
+                (data-vector-set array index
+                 (the ,(type-specifier declared-element-ctype)
+                      new-value))))))))
 
 (deftransform data-vector-set ((array index new-value)
                                (simple-array t t))