1.0.4.37: Delete some dead code in pack.lisp

[sbcl.git] / src / compiler / array-tran.lisp

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 0af3b83..ffc9dda 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -28,18 +28,33 @@
 ;;; type is going to be the array upgraded element type.
 (defun extract-upgraded-element-type (array)
   (let ((type (lvar-type array)))
-    ;; Note that this IF mightn't be satisfied even if the runtime
-    ;; value is known to be a subtype of some specialized ARRAY, because
-    ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
-    ;; which are represented in the compiler as INTERSECTION-TYPE, not
-    ;; array type.
-    (if (array-type-p type)
-        (array-type-specialized-element-type type)
-        ;; KLUDGE: there is no good answer here, but at least
-        ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
-        ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
-        ;; 2002-08-21
-        *wild-type*)))
+    (cond
+      ;; Note that this IF mightn't be satisfied even if the runtime
+      ;; value is known to be a subtype of some specialized ARRAY, because
+      ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
+      ;; which are represented in the compiler as INTERSECTION-TYPE, not
+      ;; array type.
+      ((array-type-p type) (array-type-specialized-element-type type))
+      ;; fix for bug #396.  This type logic corresponds to the special
+      ;; case for strings in HAIRY-DATA-VECTOR-REF
+      ;; (generic/vm-tran.lisp)
+      ((csubtypep type (specifier-type 'simple-string))
+       (cond
+         ((csubtypep type (specifier-type '(simple-array character (*))))
+          (specifier-type 'character))
+         #!+sb-unicode
+         ((csubtypep type (specifier-type '(simple-array base-char (*))))
+          (specifier-type 'base-char))
+         ((csubtypep type (specifier-type '(simple-array nil (*))))
+          *empty-type*)
+         ;; see KLUDGE below.
+         (t *wild-type*)))
+      (t
+       ;; KLUDGE: there is no good answer here, but at least
+       ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+       ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+       ;; 2002-08-21
+       *wild-type*))))
 
 (defun extract-declared-element-type (array)
   (let ((type (lvar-type array)))
@@ -101,9 +116,15 @@
   (extract-upgraded-element-type array))
 (defoptimizer (data-vector-ref derive-type) ((array index))
   (extract-upgraded-element-type array))
+#!+x86
+(defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
+  (extract-upgraded-element-type array))
 
 (defoptimizer (data-vector-set derive-type) ((array index new-value))
   (assert-new-value-type new-value array))
+#!+x86
+(defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value))
+  (assert-new-value-type new-value array))
 (defoptimizer (hairy-data-vector-set derive-type) ((array index new-value))
   (assert-new-value-type new-value array))
 
@@ -188,8 +209,7 @@
          ,@(mapcar (lambda (el)
                      (once-only ((n-val el))
                        `(locally (declare (optimize (safety 0)))
-                                 (setf (svref ,n-vec ,(incf n))
-                                       ,n-val))))
+                          (setf (svref ,n-vec ,(incf n)) ,n-val))))
                    elements)
          ,n-vec))))
 
@@ -528,7 +548,7 @@
 ;;; compile-time or we are generating unsafe code, don't bother with
 ;;; the VOP.
 (deftransform %check-bound ((array dimension index) * * :node node)
-  (cond ((policy node (and (> speed safety) (= safety 0)))
+  (cond ((policy node (= insert-array-bounds-checks 0))
          'index)
         ((not (constant-lvar-p dimension))
          (give-up-ir1-transform))
@@ -727,11 +747,24 @@
   (deftransform aref ((array &rest indices))
     (with-row-major-index (array indices index)
       (hairy-data-vector-ref array index)))
+
   (deftransform %aset ((array &rest stuff))
     (let ((indices (butlast stuff)))
       (with-row-major-index (array indices index new-value)
         (hairy-data-vector-set array index new-value)))))
 
+(deftransform aref ((array index) ((or simple-vector
+                                       simple-unboxed-array)
+                                   index))
+  (let ((type (lvar-type array)))
+    (unless (array-type-p type)
+      ;; Not an exactly specified one-dimensional simple array -> punt
+      ;; to the complex version.
+      (give-up-ir1-transform)))
+  `(data-vector-ref array (%check-bound array
+                                        (array-dimension array 0)
+                                        index)))
+
 ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
 ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
 ;;; array total size.