From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 28 Feb 2010 19:37:09 +0000 (+0000)
Subject: 1.0.36.6: array data vector type derivation
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=47c0c169c106f17a212593cb781bb792355cb5d3;p=sbcl.git

1.0.36.6: array data vector type derivation

 * Needs to be done for ARRAY-STORAGE-VECTOR and %ARRAY-DATA-VECTOR
   in addition to %DATA-VECTOR-AND-INDEX.

 * If the array is simple, we may be able to derive the exact length
   of the data vector, not just the element type.
---

diff --git a/NEWS b/NEWS
index 8cb4f36..3a4401a 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,9 @@ changes relative to sbcl-1.0.36:
   * optimization: SLOT-VALUE and (SETF SLOT-VALUE) take advantage of
     constraint propgation, allowing better compilation eg. when used to
     access structures with WITH-SLOTS. (lp#520366)
+  * optimization: the compiler is now more aware of the type of the underlying
+    storage vector for multidimensional simple arrays resulting in better code
+    for accessing such arrays.
   * bug fix: Fix compiler error involving MAKE-ARRAY and IF forms
     in :INITIAL-CONTENTS. (lp#523612)
   * bug fix: FUNCTION-LAMBDA-EXPRESSION lost declarations from interpreted
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 6ae1abe..435eb5f 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1388,6 +1388,9 @@
 (defknown get-bytes-consed () unsigned-byte (flushable))
 (defknown mask-signed-field ((integer 0 *) integer) integer
           (movable flushable foldable))
+
+(defknown array-storage-vector (array) (simple-array * (*))
+    (any))
 
 ;;;; magical compiler frobs
 
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 4ea3aba..cd67518 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -264,14 +264,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)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3df48f9..422da06 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3420,6 +3420,23 @@
     (assert (not warningp))
     (assert (= 1.0d0 (funcall fun)))))
 
+(with-test (:name :%array-data-vector-type-derivation)
+  (let* ((f (compile nil
+                     `(lambda (ary)
+                        (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+                        (setf (aref ary 0 0) 0))))
+         (text (with-output-to-string (s)
+                 (disassemble f :stream s))))
+    (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
+
+(with-test (:name :array-storage-vector-type-derivation)
+  (let ((f (compile nil
+                    `(lambda (ary)
+                       (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+                       (ctu:compiler-derived-type (array-storage-vector ary))))))
+    (assert (equal '(simple-array (unsigned-byte 32) (9))
+                   (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
+
 (with-test (:name :bug-523612)
   (let ((fun
          (compile nil
diff --git a/version.lisp-expr b/version.lisp-expr
index f34d9ad..f19e997 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.36.5"
+"1.0.36.6"