1.0.19.16: derive the type of (AREF (THE STRING X) Y) as CHARACTER

 * Even though we don't know the exact upgraded array element type, we
   do know the result is a character.

 * Noticed while wondering why C-ESCAPE had a call to %MEMBER instead
   of %MEMBER-EQ.

diff --git a/NEWS b/NEWS
index c4b3346..e4c5f05 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,8 @@ changes in sbcl-1.0.20 relative to 1.0.19:
     as ASSOC and MEMEBER.
   * optimization: runtime lookup of function definitions can be
     elided in more cases, eg: (let ((x 'foo)) (funcall foo)).
+  * optimization: compiler is able to derive the return type of
+    (AREF (THE STRING X) Y) as being CHARACTER.
   * bug fix: fixed #427: unused local aliens no longer cause compiler
     breakage. (reported by Stelian Ionescu, Andy Hefner and Stanislaw
     Halik)

diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp
index 7549b86..585a84a 100644 (file)
--- a/contrib/sb-grovel/def-to-lisp.lisp
+++ b/contrib/sb-grovel/def-to-lisp.lisp
@@ -16,6 +16,7 @@
 
 (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\))
   "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR."
+  (declare (simple-string string))
   (coerce (loop for c across string
                 if (member c dangerous-chars) collect escape-char
                 collect c)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index a57dc93..9f90545 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -24,8 +24,11 @@
          "upgraded array element type not known at compile time")
         element-type-specifier)))
 
-;;; Array access functions return an object from the array, hence its
-;;; type is going to be the array upgraded element type.
+;;; 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
+;;; U-A-E-T is not known. (If it is NIL, the primary return value is as good
+;;; as it gets.)
 (defun extract-upgraded-element-type (array)
   (let ((type (lvar-type array)))
     (cond
@@ -34,27 +37,28 @@
       ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
       ;; which are represented in the compiler as INTERSECTION-TYPE, not
       ;; array type.
-      ((array-type-p type) (array-type-specialized-element-type type))
-      ;; fix for bug #396.  This type logic corresponds to the special
-      ;; case for strings in HAIRY-DATA-VECTOR-REF
-      ;; (generic/vm-tran.lisp)
-      ((csubtypep type (specifier-type 'simple-string))
+      ((array-type-p type)
+       (values (array-type-specialized-element-type type) nil))
+      ;; fix for bug #396. This type logic corresponds to the special case for
+      ;; strings in HAIRY-DATA-VECTOR-REF (generic/vm-tran.lisp)
+      ((csubtypep type (specifier-type 'string))
        (cond
-         ((csubtypep type (specifier-type '(simple-array character (*))))
-          (specifier-type 'character))
+         ((csubtypep type (specifier-type '(array character (*))))
+          (values (specifier-type 'character) nil))
          #!+sb-unicode
-         ((csubtypep type (specifier-type '(simple-array base-char (*))))
-          (specifier-type 'base-char))
-         ((csubtypep type (specifier-type '(simple-array nil (*))))
-          *empty-type*)
-         ;; see KLUDGE below.
-         (t *wild-type*)))
+         ((csubtypep type (specifier-type '(array base-char (*))))
+          (values (specifier-type 'base-char) nil))
+         ((csubtypep type (specifier-type '(array nil (*))))
+          (values *empty-type* nil))
+         (t
+          ;; See KLUDGE below.
+          (values *wild-type* (specifier-type 'character)))))
       (t
        ;; KLUDGE: there is no good answer here, but at least
        ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
        ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
        ;; 2002-08-21
-       *wild-type*))))
+       (values *wild-type* nil)))))
 
 (defun extract-declared-element-type (array)
   (let ((type (lvar-type array)))
@@ -100,13 +104,17 @@
    (specifier-type `(array * ,(make-list rank :initial-element '*)))
    (lexenv-policy (node-lexenv (lvar-dest array)))))
 
+(defun derive-aref-type (array)
+  (multiple-value-bind (uaet other) (extract-upgraded-element-type array)
+    (or other uaet)))
+
 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
   *universal-type*)
 
 (defoptimizer (aref derive-type) ((array &rest indices) node)
   (assert-array-rank array (length indices))
-  (extract-upgraded-element-type array))
+  (derive-aref-type array))
 
 (defoptimizer (%aset derive-type) ((array &rest stuff))
   (assert-array-rank array (1- (length stuff)))
@@ -114,14 +122,14 @@
 
 (macrolet ((define (name)
              `(defoptimizer (,name derive-type) ((array index))
-                (extract-upgraded-element-type array))))
+                (derive-aref-type array))))
   (define hairy-data-vector-ref)
   (define hairy-data-vector-ref/check-bounds)
   (define data-vector-ref))
 
 #!+(or x86 x86-64)
 (defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
-  (extract-upgraded-element-type array))
+  (derive-aref-type array))
 
 (macrolet ((define (name)
              `(defoptimizer (,name derive-type) ((array index new-value))
@@ -153,7 +161,7 @@
   *universal-type*)
 
 (defoptimizer (row-major-aref derive-type) ((array index))
-  (extract-upgraded-element-type array))
+  (derive-aref-type array))
 
 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
   (assert-new-value-type new-value array))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index af716d5..755547f 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -11,6 +11,16 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(cl:in-package :sb-c)
+
+(defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
+
+(deftransform compiler-derived-type ((x))
+ `(values ',(type-specifier (lvar-type x)) t))
+
+(defun compiler-derived-type (x)
+  (values t nil))
+
 (cl:in-package :cl-user)
 
 ;; The tests in this file assume that EVAL will use the compiler
@@ -2570,3 +2580,17 @@
                         (type (member integer values) p2))
                        (coerce 2 p2))))
            (funcall (compile nil form) 'integer))))
+
+(with-test (:name :string-aref-type)
+ (assert (eq 'character
+             (funcall (compile nil
+                               '(lambda (s)
+                                 (sb-c::compiler-derived-type (aref (the string s) 0))))
+                      "foo"))))
+
+(with-test (:name :base-string-aref-type)
+ (assert (eq 'base-char
+             (funcall (compile nil
+                               '(lambda (s)
+                                 (sb-c::compiler-derived-type (aref (the base-string s) 0))))
+                      (coerce "foo" 'base-string)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 27133ca..c02ee2c 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".)
-"1.0.19.15"
+"1.0.19.16"