X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=d70cdb536e065660d887a0f35a5e6558e083ef65;hb=9304704f68a18894fa8eb985b387465e5d25e1d5;hp=34d88402f2f1d0d5862350a9f2b536521a4f52b1;hpb=67a805dee41b93fa03c6e72f3d1ce3078dfe88eb;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 34d8840..d70cdb5 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -169,6 +169,11 @@
     (block nil
       (let ((dimensions (array-type-dimensions-or-give-up
                          (lvar-conservative-type array))))
+        ;; Might be *. (Note: currently this is never true, because the type
+        ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
+        ;; let's keep this future proof.)
+        (when (eq '* dimensions)
+          (give-up-ir1-transform "array bounds unknown"))
         ;; shortcut for zero dimensions
         (when (some (lambda (dim)
                       (and (bound-known-p dim) (zerop dim)))
@@ -180,9 +185,11 @@
         (flet ((subscript-bounds (subscript)
                  (let* ((type1 (lvar-type subscript))
                         (type2 (if (csubtypep type1 (specifier-type 'integer))
-                                   (weaken-integer-type type1)
+                                   (weaken-integer-type type1 :range-only t)
                                    (give-up)))
-                        (low (numeric-type-low type2))
+                        (low (if (integer-type-p type2)
+                                 (numeric-type-low type2)
+                                 (give-up)))
                         (high (numeric-type-high type2)))
                    (cond
                      ((and (or (not (bound-known-p low)) (minusp low))
@@ -365,7 +372,8 @@
                    (values dimensions nil))))
         (let ((initial-contents (getf keyargs :initial-contents)))
           (when (and initial-contents rank)
-            (setf (getf keyargs :initial-contents)
+            (setf keyargs (copy-list keyargs)
+                  (getf keyargs :initial-contents)
                   (rewrite-initial-contents rank initial-contents env))))
         `(locally (declare (notinline list vector))
            (make-array ,new-dimensions ,@keyargs)))))
@@ -601,7 +609,12 @@
     (unless (constant-lvar-p dims)
       (give-up-ir1-transform
        "The dimension list is not constant; cannot open code array creation."))
-    (let ((dims (lvar-value dims)))
+    (let ((dims (lvar-value dims))
+          (element-type-ctype (and (constant-lvar-p element-type)
+                                   (ir1-transform-specifier-type
+                                    (lvar-value element-type)))))
+      (when (unknown-type-p element-type-ctype)
+        (give-up-ir1-transform))
       (unless (every #'integerp dims)
         (give-up-ir1-transform
          "The dimension list contains something other than an integer: ~S"
@@ -618,9 +631,7 @@
                  (rank (length dims))
                  (spec `(simple-array
                          ,(cond ((null element-type) t)
-                                ((and (constant-lvar-p element-type)
-                                      (ir1-transform-specifier-type
-                                       (lvar-value element-type)))
+                                (element-type-ctype
                                  (sb!xc:upgraded-array-element-type
                                   (lvar-value element-type)))
                                 (t '*))
@@ -998,10 +1009,44 @@
                   `(aref (the ,',type ,a) ,i))
                 (define-source-transform ,setter (a i v)
                   `(%aset (the ,',type ,a) ,i ,v)))))
-  (define-frob svref %svset simple-vector)
   (define-frob schar %scharset simple-string)
   (define-frob char %charset string))
 
+;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
+;;; around 100 times faster than going through the general-purpose AREF
+;;; transform which ends up doing a lot of work -- and introducing many
+;;; intermediate lambdas, each meaning a new trip through the compiler -- to
+;;; get the same result.
+;;;
+;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
+;;; treatment.
+(define-source-transform svref (vector index)
+  (let ((elt-type (or (when (symbolp vector)
+                        (let ((var (lexenv-find vector vars)))
+                          (when (lambda-var-p var)
+                            (type-specifier
+                             (array-type-declared-element-type (lambda-var-type var))))))
+                      t)))
+    (with-unique-names (n-vector)
+      `(let ((,n-vector ,vector))
+         (the ,elt-type (data-vector-ref
+                         (the simple-vector ,n-vector)
+                         (%check-bound ,n-vector (length ,n-vector) ,index)))))))
+
+(define-source-transform %svset (vector index value)
+  (let ((elt-type (or (when (symbolp vector)
+                        (let ((var (lexenv-find vector vars)))
+                          (when (lambda-var-p var)
+                            (type-specifier
+                             (array-type-declared-element-type (lambda-var-type var))))))
+                      t)))
+    (with-unique-names (n-vector)
+      `(let ((,n-vector ,vector))
+         (truly-the ,elt-type (data-vector-set
+                               (the simple-vector ,n-vector)
+                               (%check-bound ,n-vector (length ,n-vector) ,index)
+                               (the ,elt-type ,value)))))))
+
 (macrolet (;; This is a handy macro for computing the row-major index
            ;; given a set of indices. We wrap each index with a call
            ;; to %CHECK-BOUND to ensure that everything works out