X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=5aaf16ae5fd6f55067dcd436cb589507bab0e24e;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=4c0688decaf5360d8cdfdc63fd49cb7cb1a82a2c;hpb=091f0c20d4661994be7be4cc707c2aba4ef86418;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 4c0688d..5aaf16a 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -17,13 +17,15 @@
 ;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be
 ;;; determined.
 (defun upgraded-element-type-specifier-or-give-up (lvar)
-  (let* ((element-ctype (extract-upgraded-element-type lvar))
-         (element-type-specifier (type-specifier element-ctype)))
+  (let ((element-type-specifier (upgraded-element-type-specifier lvar)))
     (if (eq element-type-specifier '*)
         (give-up-ir1-transform
          "upgraded array element type not known at compile time")
         element-type-specifier)))
 
+(defun upgraded-element-type-specifier (lvar)
+  (type-specifier (extract-upgraded-element-type lvar)))
+
 ;;; Array access functions return an object from the array, hence its type is
 ;;; going to be the array upgraded element type. Secondary return value is the
 ;;; known supertype of the upgraded-array-element-type, if if the exact
@@ -112,6 +114,63 @@
   (assert-array-rank array (length indices))
   *universal-type*)
 
+(deftransform array-in-bounds-p ((array &rest subscripts))
+  (flet ((give-up ()
+           (give-up-ir1-transform
+            "~@<lower array bounds unknown or negative and upper bounds not ~
+             negative~:@>"))
+         (bound-known-p (x)
+           (integerp x))) ; might be NIL or *
+    (block nil
+      (let ((dimensions (array-type-dimensions-or-give-up
+                         (lvar-conservative-type array))))
+        ;; shortcut for zero dimensions
+        (when (some (lambda (dim)
+                      (and (bound-known-p dim) (zerop dim)))
+                    dimensions)
+          (return nil))
+        ;; we first collect the subscripts LVARs' bounds and see whether
+        ;; we can already decide on the result of the optimization without
+        ;; even taking a look at the dimensions.
+        (flet ((subscript-bounds (subscript)
+                 (let* ((type (lvar-type subscript))
+                        (low (numeric-type-low type))
+                        (high (numeric-type-high type)))
+                   (cond
+                     ((and (or (not (bound-known-p low)) (minusp low))
+                           (or (not (bound-known-p high)) (not (minusp high))))
+                      ;; can't be sure about the lower bound and the upper bound
+                      ;; does not give us a definite clue either.
+                      (give-up))
+                     ((and (bound-known-p high) (minusp high))
+                      (return nil))     ; definitely below lower bound (zero).
+                     (t
+                      (cons low high))))))
+          (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts))
+                 (subscripts-lower-bound (mapcar #'car subscripts-bounds))
+                 (subscripts-upper-bound (mapcar #'cdr subscripts-bounds))
+                 (in-bounds 0))
+            (mapcar (lambda (low high dim)
+                      (cond
+                        ;; first deal with infinite bounds
+                        ((some (complement #'bound-known-p) (list low high dim))
+                         (when (and (bound-known-p dim) (bound-known-p low) (<= dim low))
+                           (return nil)))
+                        ;; now we know all bounds
+                        ((>= low dim)
+                         (return nil))
+                        ((< high dim)
+                         (aver (not (minusp low)))
+                         (incf in-bounds))
+                        (t
+                         (give-up))))
+                    subscripts-lower-bound
+                    subscripts-upper-bound
+                    dimensions)
+            (if (eql in-bounds (length dimensions))
+                t
+                (give-up))))))))
+
 (defoptimizer (aref derive-type) ((array &rest indices) node)
   (assert-array-rank array (length indices))
   (derive-aref-type array))
@@ -556,9 +615,14 @@
        (let ((result (array-type-dimensions-or-give-up (car types))))
          (dolist (type (cdr types) result)
            (unless (equal (array-type-dimensions-or-give-up type) result)
-             (give-up-ir1-transform))))))
+             (give-up-ir1-transform
+              "~@<dimensions of arrays in union type ~S do not match~:@>"
+              (type-specifier type)))))))
     ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ]
-    (t (give-up-ir1-transform))))
+    (t
+     (give-up-ir1-transform
+      "~@<don't know how to extract array dimensions from type ~S~:@>"
+      (type-specifier type)))))
 
 (defun conservative-array-type-complexp (type)
   (typecase type