0.8.8.9:

	Reinstate some compiler transforms for STRINGoid types.
	... since STRING is now a union type, some compiler transforms
		would give up (unnecessarily) with arguments of such
		a type, even when the conditions were otherwise
		favourable;
	... extend the logic in those transforms to deal with arrays
		with the same 'shape' but different specialized
		array element type

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 619920a..02cbb75 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -385,12 +385,41 @@
 ;;; Transforms for various array properties. If the property is know
 ;;; at compile time because of a type spec, use that constant value.
 
+;;; Most of this logic may end up belonging in code/late-type.lisp;
+;;; however, here we also need the -OR-GIVE-UP for the transforms, and
+;;; maybe this is just too sloppy for actual type logic.  -- CSR,
+;;; 2004-02-18
+(defun array-type-dimensions-or-give-up (type)
+  (typecase type
+    (array-type (array-type-dimensions type))
+    (union-type
+     (let ((types (union-type-types type)))
+       ;; there are at least two types, right?
+       (aver (> (length types) 1))
+       (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))))))
+    ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ]
+    (t (give-up-ir1-transform))))
+
+(defun conservative-array-type-complexp (type)
+  (typecase type
+    (array-type (array-type-complexp type))
+    (union-type
+     (let ((types (union-type-types type)))
+       (aver (> (length types) 1))
+       (let ((result (conservative-array-type-complexp (car types))))
+        (dolist (type (cdr types) result)
+          (unless (eq (conservative-array-type-complexp type) result)
+            (return-from conservative-array-type-complexp :maybe))))))
+    ;; FIXME: intersection type
+    (t :maybe)))
+
 ;;; If we can tell the rank from the type info, use it instead.
 (deftransform array-rank ((array))
   (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (if (not (listp dims))
          (give-up-ir1-transform
           "The array rank is not known at compile time: ~S"
@@ -407,9 +436,7 @@
     (give-up-ir1-transform "The axis is not constant."))
   (let ((array-type (lvar-type array))
        (axis (lvar-value axis)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (unless (listp dims)
        (give-up-ir1-transform
         "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
@@ -421,7 +448,7 @@
        (cond ((integerp dim)
               dim)
              ((= (length dims) 1)
-              (ecase (array-type-complexp array-type)
+              (ecase (conservative-array-type-complexp array-type)
                 ((t)
                  '(%array-dimension array 0))
                 ((nil)
@@ -436,9 +463,7 @@
 (deftransform length ((vector)
                      ((simple-array * (*))))
   (let ((type (lvar-type vector)))
-    (unless (array-type-p type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions type)))
+    (let ((dims (array-type-dimensions-or-give-up type)))
       (unless (and (listp dims) (integerp (car dims)))
        (give-up-ir1-transform
         "Vector length is unknown, must call LENGTH at runtime."))
@@ -455,12 +480,12 @@
 ;;; compile-time constant.
 (deftransform vector-length ((vector))
   (let ((vtype (lvar-type vector)))
-    (if (and (array-type-p vtype)
-            (not (array-type-complexp vtype)))
-       (let ((dim (first (array-type-dimensions vtype))))
-         (when (eq dim '*) (give-up-ir1-transform))
-         dim)
-       (give-up-ir1-transform))))
+    (let ((dim (first (array-type-dimensions-or-give-up vtype))))
+      (when (eq dim '*)
+       (give-up-ir1-transform))
+      (when (conservative-array-type-complexp vtype)
+       (give-up-ir1-transform))
+      dim)))
 
 ;;; Again, if we can tell the results from the type, just use it.
 ;;; Otherwise, if we know the rank, convert into a computation based
@@ -470,9 +495,7 @@
 (deftransform array-total-size ((array)
                                (array))
   (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (unless (listp dims)
        (give-up-ir1-transform "can't tell the rank at compile time"))
       (if (member '* dims)
@@ -485,12 +508,10 @@
 ;;; Only complex vectors have fill pointers.
 (deftransform array-has-fill-pointer-p ((array))
   (let ((array-type (lvar-type array)))
-    (unless (array-type-p array-type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions array-type)))
+    (let ((dims (array-type-dimensions-or-give-up array-type)))
       (if (and (listp dims) (not (= (length dims) 1)))
          nil
-         (ecase (array-type-complexp array-type)
+         (ecase (conservative-array-type-complexp array-type)
            ((t)
             t)
            ((nil)
@@ -758,6 +779,7 @@
 (defoptimizer (array-header-p derive-type) ((array))
   (let ((type (lvar-type array)))
     (cond ((not (array-type-p type))
+          ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
            nil)
           (t
            (let ((dims (array-type-dimensions type)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 294293c..646566b 100644 (file)
--- 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".)
-"0.8.8.8"
+"0.8.8.9"