1.0.7.30: be more paranoid about saps

[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 f3791f0..a4fb8fd 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -33,7 +33,7 @@
   '(if (< x 0) (- x) x))
 
 ;;; We don't want to clutter the bignum code.
-#!+x86
+#!+(or x86 x86-64)
 (define-source-transform sb!bignum:%bignum-ref (bignum index)
   ;; KLUDGE: We use TRULY-THE here because even though the bignum code
   ;; is (currently) compiled with (SAFETY 0), the compiler insists on
@@ -45,7 +45,7 @@
   `(sb!bignum:%bignum-ref-with-offset ,bignum
                                       (truly-the bignum-index ,index) 0))
 
-#!+x86
+#!+(or x86 x86-64)
 (defun fold-index-addressing (fun-name element-size lowtag data-offset
                               index offset &optional setter-p)
   (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2)
@@ -65,7 +65,7 @@
            (,fun-name thing index (,func off2 off1) ,@(when setter-p
                                                         '(value))))))))
 
-#!+x86
+#!+(or x86 x86-64)
 (deftransform sb!bignum:%bignum-ref-with-offset
     ((bignum index offset) * * :node node)
   (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset
@@ -172,31 +172,26 @@
                           index)))))
 
 ;;; Transform data vector access to a form that opens up optimization
-;;; opportunities.
-#!+x86
-(deftransform data-vector-ref ((array index) ((or (simple-unboxed-array (*))
-                                                  simple-vector)
-                                              t))
+;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
+;;; DATA-VECTOR-REF is not supported at all.
+#!+(or x86 x86-64)
+(define-source-transform data-vector-ref (array index)
+  `(data-vector-ref-with-offset ,array ,index 0))
+
+#!+(or x86 x86-64)
+(deftransform data-vector-ref-with-offset ((array index offset))
   (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
+    (when (or (not (array-type-p array-type))
+              (eql (array-type-specialized-element-type array-type)
+                   *wild-type*))
       (give-up-ir1-transform))
+    ;; It shouldn't be possible to get here with anything but a non-complex
+    ;; vector.
+    (aver (not (array-type-complexp array-type)))
     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
            (saetp (find-saetp element-type)))
-      (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
+      (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
         (give-up-ir1-transform))
-      `(data-vector-ref-with-offset array index 0))))
-
-#!+x86
-(deftransform data-vector-ref-with-offset ((array index offset)
-                                           ((or (simple-unboxed-array (*))
-                                                simple-vector)
-                                            t t))
-  (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
-           (saetp (find-saetp element-type)))
-      (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
       (fold-index-addressing 'data-vector-ref-with-offset
                              (sb!vm:saetp-n-bits saetp)
                              sb!vm:other-pointer-lowtag
@@ -262,30 +257,24 @@
 
 ;;; Transform data vector access to a form that opens up optimization
 ;;; opportunities.
-#!+x86
-(deftransform data-vector-set ((array index new-value)
-                               ((or (simple-unboxed-array (*)) simple-vector)
-                                t t))
-  (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
-           (saetp (find-saetp element-type)))
-      (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
-        (give-up-ir1-transform))
-      `(data-vector-set-with-offset array index 0 new-value))))
+#!+(or x86 x86-64)
+(define-source-transform data-vector-set (array index new-value)
+  `(data-vector-set-with-offset ,array ,index 0 ,new-value))
 
-#!+x86
-(deftransform data-vector-set-with-offset ((array index offset new-value)
-                                           ((or (simple-unboxed-array (*))
-                                                simple-vector)
-                                            t t t))
+#!+(or x86 x86-64)
+(deftransform data-vector-set-with-offset ((array index offset new-value))
   (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
+    (when (or (not (array-type-p array-type))
+              (eql (array-type-specialized-element-type array-type)
+                   *wild-type*))
+      ;; We don't yet know the exact element type, but will get that
+      ;; knowledge after some more type propagation.
       (give-up-ir1-transform))
+    (aver (not (array-type-complexp array-type)))
     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
            (saetp (find-saetp element-type)))
-      (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
+      (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
+        (give-up-ir1-transform))
       (fold-index-addressing 'data-vector-set-with-offset
                              (sb!vm:saetp-n-bits saetp)
                              sb!vm:other-pointer-lowtag
@@ -610,7 +599,7 @@
               ;; declare it in the DEFKNOWN too.)
               ((simple-unboxed-array (*)) (vector-sap thing)))))
      (declare (inline sapify))
-     (without-gcing
+    (with-pinned-objects (dst src)
       (memmove (sap+ (sapify dst) dst-start)
                (sap+ (sapify src) src-start)
                (- dst-end dst-start)))