0.8.1.9:

[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 92dac91..634e687 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -43,7 +43,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
@@ -56,7 +57,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))
@@ -80,7 +85,8 @@
                                     *
                                     :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
@@ -90,9 +96,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)))))
+        ,(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))
@@ -121,19 +130,29 @@
                               (*))
                 index)))))
 
-(deftransform %data-vector-and-index ((array index)
-                                     (simple-array t)
-                                     *
-                                     :important t)
+(deftransform %data-vector-and-index ((%array %index)
+                                     (simple-array t)
+                                     *
+                                     :important t)
+  ;; KLUDGE: why the percent signs?  Well, ARRAY and INDEX are
+  ;; respectively exported from the CL and SB!INT packages, which
+  ;; means that they're visible to all sorts of things.  If the
+  ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
+  ;; returns T or NIL, it will delete the irrelevant branch.  However,
+  ;; user code might have got here with a variable named CL:ARRAY, and
+  ;; quite often compiler code with a variable named SB!INT:INDEX, so
+  ;; this can generate code deletion notes for innocuous user code:
+  ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
+  ;; -- CSR, 2003-04-01
 
   ;; We do this solely for the -OR-GIVE-UP side effect, since we want
   ;; to know that the type can be figured out in the end before we
   ;; proceed, but we don't care yet what the type will turn out to be.
-  (upgraded-element-type-specifier-or-give-up array)
+  (upgraded-element-type-specifier-or-give-up %array)
 
-  '(if (array-header-p array)
-       (values (%array-data-vector array) index)
-       (values array index)))
+  '(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)
 ;;;
@@ -338,7 +357,7 @@
       (memmove (sap+ (sapify dst) dst-start)
               (sap+ (sapify src) src-start)
               (- dst-end dst-start)))
-     nil))
+     (values)))
 \f
 ;;;; transforms for EQL of floating point values