From b2f0204834bd0c314d44942dd92475c15ffa8c89 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 28 Feb 2007 16:05:57 +0000 Subject: [PATCH] 1.0.3.5: slightly different SEQUENCE type handling. The UNION TYPE= issue affects type derivation as in (defun foo (x) (declare (type (simple-array character) x)) (subseq x 1 2)) where the system fails to derive that the intersection of consed-sequence and (simple-array character) is distinct from consed-sequence. Change SEQUENCE to be an explicit union of LIST, VECTOR and an EXTENDED-SEQUENCE named type, defining appropriate type methods, and the symptom (but not the cause) goes away. (Note: it may well be that the EXTENDED-SEQUENCE named type disappears again, to be replaced by an actual protocol class similar to FUNDAMENTAL-STREAM for Gray streams, for reasons of future extensibility and ease of compatibility with other Lisps. Waiting for ILC feedback...) --- BUGS | 19 ++++++++++++++++++ package-data-list.lisp-expr | 3 +++ src/code/class.lisp | 17 +--------------- src/code/deftypes-for-target.lisp | 2 +- src/code/early-type.lisp | 13 ++++++++---- src/code/late-type.lisp | 39 ++++++++++++++++++++++++++++++++++-- src/code/pred.lisp | 16 +++++++++++++++ src/code/primordial-type.lisp | 1 + src/code/typep.lisp | 1 + src/compiler/generic/primtype.lisp | 1 + src/compiler/generic/vm-fndb.lisp | 2 +- src/compiler/typetran.lisp | 1 + version.lisp-expr | 2 +- 13 files changed, 92 insertions(+), 25 deletions(-) diff --git a/BUGS b/BUGS index f7c265b..93c7c37 100644 --- a/BUGS +++ b/BUGS @@ -1789,3 +1789,22 @@ WORKAROUND: TYPE/= do, and writing an explanation which is so clear that one can see immediately what it's supposed to mean in odd cases like (TYPE= '(SATISFIES X) 'INTEGER) when X isn't defined yet. + +409: MORE TYPE SYSTEM PROBLEMS + Found while investigating an optimization failure for extended + sequences. The extended sequence type implementation was altered to + work around the problem, but the fundamental problem remains, to wit: + (sb-kernel:type= (sb-kernel:specifier-type '(or float ratio)) + (sb-kernel:specifier-type 'single-float)) + returns NIL, NIL on sbcl-1.0.3. + (probably related to bug #408) + +410: read circularities and type declarations + Consider the definition + (defstruct foo (a 0 :type (not symbol))) + followed by + (setf *print-circle* t) ; just in case + (read-from-string "#1=#s(foo :a #1#)") + This gives a type error (#:G1 is not a (NOT SYMBOL)) because of the + implementation of read circularity, using a symbol as a marker for + the previously-referenced object. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 66adb49..bd09585 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1557,6 +1557,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%MAKE-SYMBOL" "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH" + "EXTENDED-SEQUENCE" "*EXTENDED-SEQUENCE-TYPE*" + "EXTENDED-SEQUENCE-P" + "BUILT-IN-CLASSOID" "CONDITION-CLASSOID-P" "CONDITION-CLASSOID-SLOTS" "MAKE-UNDEFINED-CLASSOID" "FIND-CLASSOID" "CLASSOID" "CLASSOID-DIRECT-SUPERCLASSES" diff --git a/src/code/class.lisp b/src/code/class.lisp index 4e06f52..4629a86 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -913,22 +913,6 @@ NIL is returned when no such class exists." ;; uncertain, since a subclass of both might be defined nil))) -;;; KLUDGE: we need this for the special-case SEQUENCE type, which -;;; (because of multiple inheritance with ARRAY for the VECTOR types) -;;; doesn't have the nice hierarchical properties we want. This is -;;; basically DELEGATE-COMPLEX-INTERSECTION2 with a special-case for -;;; SEQUENCE/ARRAY interactions. -(!define-type-method (classoid :complex-intersection2) (type1 class2) - (cond - ((and (eq class2 (find-classoid 'sequence)) - (array-type-p type1)) - (type-intersection2 (specifier-type 'vector) type1)) - (t - (let ((method (type-class-complex-intersection2 (type-class-info type1)))) - (if (and method (not (eq method #'delegate-complex-intersection2))) - :call-other-method - (hierarchical-intersection2 type1 class2)))))) - ;;; KLUDGE: we need this to deal with the special-case INSTANCE and ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR ;;; discovered that this was incompatible with the MOP class @@ -1112,6 +1096,7 @@ NIL is returned when no such class exists." :inherits (array) :prototype-form (make-array nil)) (sequence + :translation (or cons (member nil) vector extended-sequence) :state :read-only :depth 2) (vector diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 103047c..d26547f 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -155,7 +155,7 @@ ;;; a consed sequence result. If a vector, is a simple array. (sb!xc:deftype consed-sequence () - '(or (simple-array * (*)) (and sequence (not vector)))) + '(or (simple-array * (*)) list extended-sequence)) ;;; the :END arg to a sequence (sb!xc:deftype sequence-end () '(or null index)) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 5b88476..6bc004e 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -221,10 +221,15 @@ ;; specifier to win. (type (missing-arg) :type ctype)) -;;; The NAMED-TYPE is used to represent *, T and NIL. These types must -;;; be super- or sub-types of all types, not just classes and * and -;;; NIL aren't classes anyway, so it wouldn't make much sense to make -;;; them built-in classes. +;;; The NAMED-TYPE is used to represent *, T and NIL, the standard +;;; special cases, as well as other special cases needed to +;;; interpolate between regions of the type hierarchy, such as +;;; INSTANCE (which corresponds to all those classes with slots which +;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with +;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST +;;; non-VECTOR classes which are also sequences). These special cases +;;; are the ones that aren't really discussed by Baker in his +;;; "Decision Procedure for SUBTYPEP" paper. (defstruct (named-type (:include ctype (class-info (type-class-or-lose 'named))) (:copier nil)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 0e284b0..007950a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1051,7 +1051,11 @@ ;; required to be a subclass of STANDARD-OBJECT. -- CSR, ;; 2005-09-09 (frob instance *instance-type*) - (frob funcallable-instance *funcallable-instance-type*)) + (frob funcallable-instance *funcallable-instance-type*) + ;; new in sbcl-1.0.3.3: necessary to act as a join point for the + ;; extended sequence hierarchy. (Might be removed later if we use + ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.) + (frob extended-sequence *extended-sequence-type*)) (setf *universal-fun-type* (make-fun-type :wild-args t :returns *wild-type*))) @@ -1155,6 +1159,12 @@ ;; member types can be subtypep INSTANCE and ;; FUNCALLABLE-INSTANCE in surprising ways. (invoke-complex-subtypep-arg1-method type1 type2)) + ((and (eq type2 *extended-sequence-type*) (classoid-p type1)) + (let* ((layout (classoid-layout type1)) + (inherits (layout-inherits layout)) + (sequencep (find (classoid-layout (find-classoid 'sequence)) + inherits))) + (values (if sequencep t nil) t))) ((and (eq type2 *instance-type*) (classoid-p type1)) (if (member type1 *non-instance-classoid-types* :key #'find-classoid) (values nil t) @@ -1192,6 +1202,21 @@ ;; Perhaps when bug 85 is fixed it can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond + ((eq type2 *extended-sequence-type*) + (typecase type1 + (structure-classoid *empty-type*) + (classoid + (if (member type1 *non-instance-classoid-types* :key #'find-classoid) + *empty-type* + (if (find (classoid-layout (find-classoid 'sequence)) + (layout-inherits (classoid-layout type1))) + type1 + nil))) + (t + (if (or (type-might-contain-other-types-p type1) + (member-type-p type1)) + nil + *empty-type*)))) ((eq type2 *instance-type*) (typecase type1 (structure-classoid type1) @@ -1232,6 +1257,15 @@ ;; Perhaps when bug 85 is fixed this can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond + ((eq type2 *extended-sequence-type*) + (if (classoid-p type1) + (if (or (member type1 *non-instance-classoid-types* + :key #'find-classoid) + (not (find (classoid-layout (find-classoid 'sequence)) + (layout-inherits (classoid-layout type1))))) + nil + type2) + nil)) ((eq type2 *instance-type*) (if (classoid-p type1) (if (or (member type1 *non-instance-classoid-types* @@ -1260,7 +1294,8 @@ ((eq x *universal-type*) *empty-type*) ((eq x *empty-type*) *universal-type*) ((or (eq x *instance-type*) - (eq x *funcallable-instance-type*)) + (eq x *funcallable-instance-type*) + (eq x *extended-sequence-type*)) (make-negation-type :type x)) (t (bug "NAMED type unexpected: ~S" x)))) diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 6de30db..7d006cc 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -24,6 +24,22 @@ (do ((data (%array-data-vector x) (%array-data-vector data))) ((not (array-header-p data)) (simple-vector-p data)))))) +;;; Is X an extended sequence? +(defun extended-sequence-p (x) + (and (not (listp x)) + (not (vectorp x)) + (let* ((slayout #.(info :type :compiler-layout 'sequence)) + (depthoid #.(layout-depthoid (info :type :compiler-layout 'sequence))) + (layout (layout-of x))) + (when (layout-invalid layout) + (setq layout (update-object-layout-or-invalid x slayout))) + (if (eq layout slayout) + t + (let ((inherits (layout-inherits layout))) + (declare (optimize (safety 0))) + (and (> (length inherits) depthoid) + (eq (svref inherits depthoid) slayout))))))) + ;;; Is X a SEQUENCE? Harder than just (OR VECTOR LIST) (defun sequencep (x) (or (listp x) diff --git a/src/code/primordial-type.lisp b/src/code/primordial-type.lisp index e131dcd..a89b208 100644 --- a/src/code/primordial-type.lisp +++ b/src/code/primordial-type.lisp @@ -19,6 +19,7 @@ (defvar *universal-fun-type*) (defvar *instance-type*) (defvar *funcallable-instance-type*) +(defvar *extended-sequence-type*) ;;; a vector that maps type codes to layouts, used for quickly finding ;;; the layouts of built-in classes diff --git a/src/code/typep.lisp b/src/code/typep.lisp index ca3c349..f52c5e7 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -39,6 +39,7 @@ ((* t) t) ((instance) (%instancep object)) ((funcallable-instance) (funcallable-instance-p object)) + ((extended-sequence) (extended-sequence-p object)) ((nil) nil))) (numeric-type (and (numberp object) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index e3e59b2..5bf2533 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -356,6 +356,7 @@ ((t *) (values *backend-t-primitive-type* t)) ((instance) (exactly instance)) ((funcallable-instance) (part-of function)) + ((extended-sequence) (any)) ((nil) (any)))) (character-set-type (let ((pairs (character-set-type-pairs type))) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 8db4fe6..355cf7b 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -25,7 +25,7 @@ #!+sb-unicode character-string-p #!+sb-unicode simple-character-string-p array-header-p - sequencep + sequencep extended-sequence-p simple-array-p simple-array-nil-p vector-nil-p simple-array-unsigned-byte-2-p simple-array-unsigned-byte-4-p simple-array-unsigned-byte-7-p diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 62d2dcd..0eba7aa 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -137,6 +137,7 @@ (define-type-predicate rationalp rational) (define-type-predicate realp real) (define-type-predicate sequencep sequence) + (define-type-predicate extended-sequence-p extended-sequence) (define-type-predicate simple-bit-vector-p simple-bit-vector) (define-type-predicate simple-string-p simple-string) (define-type-predicate simple-vector-p simple-vector) diff --git a/version.lisp-expr b/version.lisp-expr index a300f9c..83360b1 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.3.4" +"1.0.3.5" -- 1.7.10.4