From 646a14a9099c3c6bbb60ff09f7fb6a781a030815 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 3 Aug 2008 19:35:14 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ contrib/sb-grovel/def-to-lisp.lisp | 1 + src/compiler/array-tran.lisp | 48 ++++++++++++++++++++++---------------- tests/compiler.pure.lisp | 24 +++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 56 insertions(+), 21 deletions(-) diff --git a/NEWS b/NEWS index c4b334614..e4c5f05e7 100644 --- 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 7549b86e2..585a84a11 100644 --- 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 a57dc9361..9f90545be 100644 --- 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 af716d55b..755547f57 100644 --- 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 27133ca09..c02ee2c3f 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.19.15" +"1.0.19.16" -- 2.11.4.GIT