From 8b3c9d0eb3bb0fd0f26d9c74542876252b600d02 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Wed, 4 Feb 2015 22:13:16 -0500 Subject: [PATCH] Move 2 slots from most instances of CTYPE into their TYPE-CLASS. ENUMERABLE and MIGHT-CONTAIN-OTHER-TYPES-P are almost always constant for all instances of a type-class, so by making them into possibly-constant pseudo-methods in the manner of SINGLETON-P, the compiler conses about 1% less and is no slower for it. The cagey remark that ENUMERABLE is "Meaningless in translated classes" is contradicted by the fact that CHARACTER is painstakingly arranged to be enumerable unlike any other classoid. If "meaningless" equates to "not used" or "is bogus, do not look at it", then why do this? I've no idea, but that aspect is preserved for no discernable reason except compatibility. Also make TYPE-CLASS-NAME read-only. --- src/code/alien-type.lisp | 2 +- src/code/class.lisp | 24 +++++++++------ src/code/early-type.lisp | 40 +++++++++++++++---------- src/code/late-type.lisp | 36 ++++++++++++++++------- src/code/type-class.lisp | 76 +++++++++++++++++++++++++++++++++++++++++++----- src/code/typedefs.lisp | 27 ++++++++--------- 6 files changed, 147 insertions(+), 58 deletions(-) diff --git a/src/code/alien-type.lisp b/src/code/alien-type.lisp index 7cd968cbd..99f230db4 100644 --- a/src/code/alien-type.lisp +++ b/src/code/alien-type.lisp @@ -24,7 +24,7 @@ (:copier nil)) (alien-type nil :type alien-type :read-only t)) -(!define-type-class alien) +(!define-type-class alien :enumerable nil :might-contain-other-types nil) (!define-type-method (alien :negate) (type) (make-negation-type :type type)) diff --git a/src/code/class.lisp b/src/code/class.lisp index 10944f4ba..163c2267a 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -874,7 +874,20 @@ between the ~A definition and the ~A definition" ;;;; CLASS type operations -(!define-type-class classoid) +;; referenced right away by !DEFINE-TYPE-CLASS. +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Actually this definition makes very little sense because + ;; (TYPE-ENUMERABLE (FIND-CLASSOID 'CHARACTER)) => T + ;; but (TYPE-ENUMERABLE (SPECIFIER-TYPE 'CHARACTER)) => NIL. + ;; You should never see the CLASSOID used as a type though, + ;; at least not from parsing and set operations. + ;; On a related note, (TYPE-ENUMERABLE (FIND-CLASSOID 'NULL)) + ;; should probably be T, but you'll never see that type either. + ;; Perhaps a better definition of this function would be + ;; (if (classoid-translation x) (bug "enumerable-p classoid?") nil) + (defun classoid-enumerable-p (x) (eq (classoid-name x) 'character))) +(!define-type-class classoid :enumerable #'classoid-enumerable-p + :might-contain-other-types nil) ;;; We might be passed classoids with invalid layouts; in any pairwise ;;; class comparison, we must ensure that both are valid before @@ -1051,10 +1064,6 @@ between the ~A definition and the ~A definition" ;;; object because in general we want to be able to include more ;;; information than just the class (e.g. for numeric types.) ;;; -;;; :ENUMERABLE (default NIL) -;;; The value of the :ENUMERABLE slot in the created class. -;;; Meaningless in translated classes. -;;; ;;; :STATE (default :SEALED) ;;; The value of CLASS-STATE which we want on completion, ;;; indicating whether subclasses can be created at run-time. @@ -1077,8 +1086,7 @@ between the ~A definition and the ~A definition" (!defvar *!built-in-classes* ;; To me these data would look nicer with commas instead of "#." '((t :state :read-only :translation t) - (character :enumerable t - :codes (#.sb!vm:character-widetag) + (character :codes (#.sb!vm:character-widetag) :translation (character-set) :prototype-form (code-char 42)) (symbol :codes (#.sb!vm:symbol-header-widetag) @@ -1430,7 +1438,6 @@ between the ~A definition and the ~A definition" (translation nil trans-p) inherits codes - enumerable state depth prototype-form @@ -1444,7 +1451,6 @@ between the ~A definition and the ~A definition" () (cons t (reverse inherits)))) (classoid (make-built-in-classoid - :enumerable enumerable :name name :translation (if trans-p :initializing nil) :direct-superclasses diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index aa238ff85..2a7649c3b 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -18,15 +18,18 @@ ;;; and unreasonably complicated types involving AND. We just remember ;;; the original type spec. (defstruct (hairy-type (:include ctype - (class-info (type-class-or-lose 'hairy)) - (enumerable t) - (might-contain-other-types-p t)) + (class-info (type-class-or-lose 'hairy))) (:copier nil) #!+cmu (:pure nil)) ;; the Common Lisp type-specifier of the type we represent (specifier nil :type t :read-only t)) -(!define-type-class hairy) +;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type. +;; e.g. any SATISFIES with a predicate returning T over a finite domain. +;; But in practice there's nothing that can be done with this information, +;; because we don't call random predicates when performing operations on types +;; as objects, only when checking for inclusion of something in the type. +(!define-type-class hairy :enumerable t :might-contain-other-types t) ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet ;;; defined). We make this distinction since we don't want to complain @@ -55,16 +58,16 @@ t)))) (defstruct (negation-type (:include ctype - (class-info (type-class-or-lose 'negation)) - ;; FIXME: is this right? It's - ;; what they had before, anyway - (enumerable t) - (might-contain-other-types-p t)) + (class-info (type-class-or-lose 'negation))) (:copier nil) #!+cmu (:pure nil)) (type (missing-arg) :type ctype :read-only t)) -(!define-type-class negation) +;; Former comment was: +;; FIXME: is this right? It's what they had before, anyway +;; But I think the reason it's right is that "enumerable :t" is equivalent +;; to "maybe" which is actually the conservative assumption, same as HAIRY. +(!define-type-class negation :enumerable t :might-contain-other-types t) ;;; ARGS-TYPE objects are used both to represent VALUES types and ;;; to represent FUNCTION types. @@ -180,7 +183,8 @@ (t (make-values-type-cached required optional rest allowp))))) -(!define-type-class values) +(!define-type-class values :enumerable nil + :might-contain-other-types nil) ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes (defstruct (fun-type (:include args-type @@ -240,6 +244,9 @@ (class-info (type-class-or-lose 'number))) (:constructor %make-numeric-type) (:copier nil)) + ;; Formerly defined in every CTYPE, but now just in the ones + ;; for which enumerability is variable. + (enumerable nil :read-only t) ;; the kind of numeric type we have, or NIL if not specified (just ;; NUMBER or COMPLEX) ;; @@ -317,7 +324,7 @@ (complexp (numeric-type-complexp base)) (low (numeric-type-low base)) (high (numeric-type-high base)) - (enumerable (numeric-type-enumerable base))) + (enumerable (type-enumerable base))) (make-numeric-type :class class :format format :complexp complexp @@ -380,8 +387,7 @@ ;;; bother with this at this level because MEMBER types are fairly ;;; important and union and intersection are well defined. (defstruct (member-type (:include ctype - (class-info (type-class-or-lose 'member)) - (enumerable t)) + (class-info (type-class-or-lose 'member))) (:copier nil) (:constructor %make-member-type (xset fp-zeroes)) #-sb-xc-host (:pure nil)) @@ -459,10 +465,12 @@ ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. -(defstruct (compound-type (:include ctype - (might-contain-other-types-p t)) +(defstruct (compound-type (:include ctype) (:constructor nil) (:copier nil)) + ;; Formerly defined in every CTYPE, but now just in the ones + ;; for which enumerability is variable. + (enumerable nil :read-only t) (types nil :type list :read-only t)) ;;; A UNION-TYPE represents a use of the OR type specifier which we diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 792e7cdf4..d2526a5b8 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -181,7 +181,8 @@ (!define-type-method (values :simple-=) (type1 type2) (type=-args type1 type2)) -(!define-type-class function) +(!define-type-class function :enumerable nil + :might-contain-other-types nil) ;;; a flag that we can bind to cause complex function types to be ;;; unparsed as FUNCTION. This is useful when we want a type that we @@ -1106,7 +1107,7 @@ ;;;; built-in types -(!define-type-class named) +(!define-type-class named :enumerable nil :might-contain-other-types nil) (!cold-init-forms (macrolet ((frob (name var) @@ -1637,7 +1638,8 @@ ;;;; numeric types -(!define-type-class number) +(!define-type-class number :enumerable #'numeric-type-enumerable + :might-contain-other-types nil) (declaim (inline numeric-type-equal)) (defun numeric-type-equal (type1 type2) @@ -2398,7 +2400,8 @@ used for a COMPLEX component.~:@>" ;;;; array types -(!define-type-class array) +(!define-type-class array :enumerable nil + :might-contain-other-types nil) (!define-type-method (array :simple-=) (type1 type2) (cond ((not (and (equal (array-type-dimensions type1) @@ -2773,7 +2776,8 @@ used for a COMPLEX component.~:@>" ;;;; MEMBER types -(!define-type-class member) +(!define-type-class member :enumerable t + :might-contain-other-types nil) (!define-type-method (member :negate) (type) (let ((xset (member-type-xset type)) @@ -2933,7 +2937,9 @@ used for a COMPLEX component.~:@>" ;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types ;;;; involving AND. -(!define-type-class intersection) +(!define-type-class intersection + :enumerable #'compound-type-enumerable + :might-contain-other-types t) (!define-type-method (intersection :negate) (type) (apply #'type-union @@ -3064,7 +3070,9 @@ used for a COMPLEX component.~:@>" ;;;; union types -(!define-type-class union) +(!define-type-class union + :enumerable #'compound-type-enumerable + :might-contain-other-types t) (!define-type-method (union :negate) (type) (declare (type ctype type)) @@ -3237,7 +3245,7 @@ used for a COMPLEX component.~:@>" ;;;; CONS types -(!define-type-class cons) +(!define-type-class cons :enumerable nil :might-contain-other-types nil) (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) (let ((car-type (single-value-specifier-type car-type-spec)) @@ -3384,7 +3392,14 @@ used for a COMPLEX component.~:@>" ;;;; CHARACTER-SET types -(!define-type-class character-set) +;; all character-set types are enumerable, but it's not possible +;; for one to be TYPE= to a MEMBER type because (MEMBER #\x) +;; is not internally represented as a MEMBER type. +;; So in case it wasn't clear already ENUMERABLE-P does not mean +;; "possibly a MEMBER type in the Lisp-theoretic sense", +;; but means "could be implemented in SBCL as a MEMBER type". +(!define-type-class character-set :enumerable nil + :might-contain-other-types nil) (!def-type-translator character-set (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit))))) @@ -3615,7 +3630,8 @@ used for a COMPLEX component.~:@>" ;;;; SIMD-PACK types #!+sb-simd-pack (progn - (!define-type-class simd-pack) + (!define-type-class simd-pack :enumerable nil + :might-contain-other-types nil) (!def-type-translator simd-pack (&optional (element-type-spec '*)) (if (eql element-type-spec '*) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index c082de2c4..c26791624 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -77,7 +77,7 @@ (print-unreadable-object (x stream :type t) (prin1 (type-class-name x) stream))))) ;; the name of this type class (used to resolve references at load time) - (name (missing-arg) :type symbol) + (name (missing-arg) :type symbol :read-only t) ;; Dyadic type methods. If the classes of the two types are EQ, then ;; we call the SIMPLE-xxx method. If the classes are not EQ, and ;; either type's class has a COMPLEX-xxx method, then we call it. @@ -131,6 +131,30 @@ ;; a function which returns a Common Lisp type specifier ;; representing this type (unparse #'must-supply-this :type function) + + ;; Can types of this type-class contain other types? + ;; A global property of our + ;; implementation (which unfortunately seems impossible to enforce + ;; with assertions or other in-the-code checks and constraints) is + ;; that subclasses which don't contain other types correspond to + ;; disjoint subsets (except of course for the NAMED-TYPE T, which + ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is + ;; is disjoint from MEMBER-TYPE and so forth. But types which can + ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can + ;; violate this rule. + (might-contain-other-types-p nil) + ;; a function which returns T if the CTYPE could possibly be + ;; equivalent to a MEMBER type. If not a function, then it's + ;; a constant T or NIL for all instances of this type class. + ;; Note that the old comment for this slot was + ;; "True if this type has a fixed number of members, and as such + ;; could possibly be completely specified in a MEMBER type." + ;; The second half of that is right because of the "possibly," + ;; but "has a fixed number" is too strong a claim, because we + ;; set enumerable=T for NEGATION and HAIRY and some other things. + ;; Conceptually the choices are really {yes, no, unknown}, but + ;; whereas "no" means "definitely not", T means "yes or maybe". + (enumerable-p nil :type (or function null t)) ;; a function which returns T if the CTYPE is inhabited by a single ;; object and, as a value, the object. Otherwise, returns NIL, NIL. ;; The default case (NIL) is interpreted as a function that always @@ -156,10 +180,34 @@ ) #!-sb-fluid (declaim (freeze-type type-class)) +#+sb-xc +(eval-when (:compile-toplevel) + (assert (= (length (dd-slots (find-defstruct-description 'type-class))) + ;; there exist two boolean slots, plus NAME + (+ (length !type-class-fun-slots) 3)))) + (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun !type-class-fun-slot (name) (symbolicate "TYPE-CLASS-" name))) +;; Unfortunately redundant with the slots in the DEF!STRUCT, +;; but allows asserting about correctness of the constructor +;; without relying on introspection in host Lisp. +(defconstant-eqx !type-class-fun-slots + '(simple-subtypep + complex-subtypep-arg1 + complex-subtypep-arg2 + simple-union2 + complex-union2 + simple-intersection2 + complex-intersection2 + simple-= + complex-= + negate + unparse + singleton-p) + #'equal) + (defmacro !define-type-method ((class method &rest more-methods) lambda-list &body body) (let ((name (symbolicate class "-" method "-TYPE-METHOD"))) @@ -174,13 +222,27 @@ (cons method more-methods))) ',name))) -(defmacro !define-type-class (name &key inherits) +(defmacro !define-type-class (name &key inherits + (enumerable (unless inherits (must-supply-this)) + enumerable-supplied-p) + (might-contain-other-types + (unless inherits (must-supply-this)) + might-contain-other-types-supplied-p)) (let ((make-it - (if inherits - `(let ((class (copy-structure (type-class-or-lose ',inherits)))) - (setf (type-class-name class) ',name) - class) - `(make-type-class :name ',name)))) + `(let ,(if inherits `((parent (type-class-or-lose ',inherits)))) + (make-type-class + :name ',name + :enumerable-p ,(if enumerable-supplied-p + enumerable + `(type-class-enumerable-p parent)) + :might-contain-other-types-p + ,(if might-contain-other-types-supplied-p + might-contain-other-types + `(type-class-might-contain-other-types-p parent)) + ,@(when inherits + (loop for name in !type-class-fun-slots + append `(,(keywordicate name) + (,(!type-class-fun-slot name) parent)))))))) #-sb-xc `(progn (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 4c54d1600..ad727401b 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -80,10 +80,6 @@ ;; ambiguity to whether it is a 'CLASS-INFO' slot in a 'TYPE' ;; or an 'INFO' slot in a 'TYPE-CLASS'] (class-info (missing-arg) :type type-class) - ;; True if this type has a fixed number of members, and as such - ;; could possibly be completely specified in a MEMBER type. This is - ;; used by the MEMBER type methods. - (enumerable nil :read-only t) ;; an arbitrary hash code used in EQ-style hashing of identity ;; (since EQ hashing can't be done portably) ;; - in the host lisp, generate a hash value using a known, simple @@ -95,21 +91,22 @@ #+sb-xc-host (ctype-random) #-sb-xc-host (sb!impl::quasi-random-address-based-hash *ctype-hash-state*) :type (and #-sb-xc-host fixnum unsigned-byte) - :read-only t) - ;; Can this object contain other types? A global property of our - ;; implementation (which unfortunately seems impossible to enforce - ;; with assertions or other in-the-code checks and constraints) is - ;; that subclasses which don't contain other types correspond to - ;; disjoint subsets (except of course for the NAMED-TYPE T, which - ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is - ;; is disjoint from MEMBER-TYPE and so forth. But types which can - ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can - ;; violate this rule. - (might-contain-other-types-p nil :read-only t)) + :read-only t)) (def!method print-object ((ctype ctype) stream) (print-unreadable-object (ctype stream :type t) (prin1 (type-specifier ctype) stream))) +(declaim (inline type-might-contain-other-types-p)) +(defun type-might-contain-other-types-p (ctype) + (type-class-might-contain-other-types-p (type-class-info ctype))) + +(declaim (inline type-enumerable)) +(defun type-enumerable (ctype) + (let ((answer (type-class-enumerable-p (type-class-info ctype)))) + (if (functionp answer) + (funcall answer ctype) + answer))) + ;;; Just dump it as a specifier. (We'll convert it back upon loading.) (defun make-type-load-form (type) (declare (type ctype type)) -- 2.11.4.GIT