1 ;;;; This file contains the definition of the CTYPE (Compiler TYPE)
2 ;;;; structure, as well as the TYPE-CLASS structure which is a metaobject
3 ;;;; that factors out commonality amongst the subtypes of CTYPE.
4 ;;;; Together they form a sort of mini object system with slightly
5 ;;;; odd dispatching rules. The TYPE-CLASS is a vtable, essentially.
6 ;;;; Various macros related to manipulating those things are here too.
8 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
17 (in-package "SB!KERNEL")
19 (!begin-collecting-cold-init-forms
)
21 ;; We can't make an instance of any CTYPE descendant until its type-class
22 ;; exists in *TYPE-CLASSES* and the quasi-random state has been made.
23 ;; By initializing the state and type-class storage vector at once,
24 ;; it is obvious that either both have been made or neither one has been.
26 (progn (defvar *ctype-lcg-state
* 1)
27 (defvar *ctype-hash-state
* (make-random-state))
28 (defvar *type-classes
* (make-array 20 :fill-pointer
0)))
31 (let* ((state-type `(unsigned-byte ,sb
!vm
:n-positive-fixnum-bits
))
32 (initform `(make-array 1 :element-type
',state-type
))
33 (n (length *type-classes
*)))
35 (declaim (type (simple-array ,state-type
(1))
37 (type (simple-vector ,n
) *type-classes
*))
38 ;; The value forms are for type-correctness only.
39 ;; COLD-INIT-FORMS will already have been run.
40 (defglobal *ctype-hash-state
* ,initform
)
41 (defglobal *type-classes
* (make-array ,n
))
43 (setq *ctype-hash-state
* ,initform
44 *type-classes
* (make-array ,n
)))))))
47 (defun type-class-or-lose (name)
48 (or (find name
*type-classes
* :key
#'type-class-name
)
49 (error "~S is not a defined type class." name
)))
52 (define-compiler-macro type-class-or-lose
(&whole form name
)
53 ;; If NAME is a quoted constant, the resultant form should be
54 ;; a fixed index into *TYPE-CLASSES* except that during the building
55 ;; of the cross-compiler the array hasn't been populated yet.
56 ;; One solution to that, which I favored, is that DEFINE-TYPE-CLASS
57 ;; appear before the structure definition that uses the corresponding
58 ;; type-class in its slot initializer. That posed a problem for
59 ;; the :INHERITS option, because the constructor of a descendant
60 ;; grabs all the methods [sic] from its ancestor at the time the
61 ;; descendant is defined, which means the methods of the ancestor
62 ;; should have been filled in, which means at least one DEFINE-TYPE-CLASS
63 ;; wants to appear _after_ a structure definition that uses it.
65 (let ((name (constant-form-value name
)))
67 ,(or (position name
*type-classes
* :key
#'type-class-name
)
68 (error "~S is not a defined type class." name
))))
71 (defun must-supply-this (&rest foo
)
72 (/show0
"failing in MUST-SUPPLY-THIS")
73 (error "missing type method for ~S" foo
))
75 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) csubtypep
))
76 ;;; Look for nice relationships for types that have nice relationships
77 ;;; only when one is a hierarchical subtype of the other.
78 (defun hierarchical-intersection2 (type1 type2
)
79 (multiple-value-bind (subtypep1 win1
) (csubtypep type1 type2
)
80 (multiple-value-bind (subtypep2 win2
) (csubtypep type2 type1
)
81 (cond (subtypep1 type1
)
83 ((and win1 win2
) *empty-type
*)
85 (defun hierarchical-union2 (type1 type2
)
86 (cond ((csubtypep type1 type2
) type2
)
87 ((csubtypep type2 type1
) type1
)
90 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
91 ;;; contains functions which are methods on that kind of type, but is
92 ;;; also used in EQ comparisons to determined if two types have the
94 (def!struct
(type-class
95 #-no-ansi-print-object
96 (:print-object
(lambda (x stream
)
97 (print-unreadable-object (x stream
:type t
)
98 (prin1 (type-class-name x
) stream
)))))
99 ;; the name of this type class (used to resolve references at load time)
100 (name (missing-arg) :type symbol
:read-only t
)
101 ;; Dyadic type methods. If the classes of the two types are EQ, then
102 ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
103 ;; either type's class has a COMPLEX-xxx method, then we call it.
105 ;; Although it is undefined which method will get precedence when
106 ;; both types have a complex method, the complex method can assume
107 ;; that the second arg always is in its class, and the first always
108 ;; is not. The arguments to commutative operations will be swapped
109 ;; if the first argument has a complex method.
111 ;; Since SUBTYPEP is not commutative, we have two complex methods.
112 ;; The ARG1 method is only called when the first argument is in its
113 ;; class, and the ARG2 method is only called when called when the
114 ;; second type is. If either is specified, both must be.
115 ;; FIXME: "both must be" is false of CLASSOID type-class.
116 ;; Figure out if this is a comment bug or a logic bug.
117 ;; * (type-class-complex-subtypep-arg1 (type-class-or-lose 'classoid)) => NIL
118 ;; * (type-class-complex-subtypep-arg2 (type-class-or-lose 'classoid))
119 ;; => #<FUNCTION CLASSOID-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD>
120 (simple-subtypep #'must-supply-this
:type function
)
121 (complex-subtypep-arg1 nil
:type
(or function null
))
122 (complex-subtypep-arg2 nil
:type
(or function null
))
123 ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
124 ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
125 ;; a new type which expresses the result nicely, better than could
126 ;; be done by just stuffing the two component types into an
127 ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
128 ;; failure, or a CTYPE for success.
130 ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
131 ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
132 ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
133 ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
134 ;; wants to simplify unions and intersections by considering all
135 ;; possible pairwise simplifications (where the CMU CL code only
136 ;; considered simplifications between types which happened to appear
137 ;; next to each other the argument sequence).
139 ;; Differences in detail from old CMU CL methods:
140 ;; * SBCL's methods are more parallel between union and
141 ;; intersection forms. Each returns one values, (OR NULL CTYPE).
142 ;; * SBCL doesn't use type methods to deal with unions or
143 ;; intersections of the COMPOUND-TYPE of the corresponding form.
144 ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
145 ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
146 ;; (and deal with canonicalization/simplification issues at the
148 (simple-union2 #'hierarchical-union2
:type function
)
149 (complex-union2 nil
:type
(or function null
))
150 (simple-intersection2 #'hierarchical-intersection2
:type function
)
151 (complex-intersection2 nil
:type
(or function null
))
152 (simple-= #'must-supply-this
:type function
)
153 (complex-= nil
:type
(or function null
))
155 (negate #'must-supply-this
:type function
)
156 ;; a function which returns a Common Lisp type specifier
157 ;; representing this type
158 (unparse #'must-supply-this
:type function
)
160 ;; Can types of this type-class contain other types?
161 ;; A global property of our
162 ;; implementation (which unfortunately seems impossible to enforce
163 ;; with assertions or other in-the-code checks and constraints) is
164 ;; that subclasses which don't contain other types correspond to
165 ;; disjoint subsets (except of course for the NAMED-TYPE T, which
166 ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is
167 ;; is disjoint from MEMBER-TYPE and so forth. But types which can
168 ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can
169 ;; violate this rule.
170 (might-contain-other-types-p nil
)
171 ;; a function which returns T if the CTYPE could possibly be
172 ;; equivalent to a MEMBER type. If not a function, then it's
173 ;; a constant T or NIL for all instances of this type class.
174 ;; Note that the old comment for this slot was
175 ;; "True if this type has a fixed number of members, and as such
176 ;; could possibly be completely specified in a MEMBER type."
177 ;; The second half of that is right because of the "possibly,"
178 ;; but "has a fixed number" is too strong a claim, because we
179 ;; set enumerable=T for NEGATION and HAIRY and some other things.
180 ;; Conceptually the choices are really {yes, no, unknown}, but
181 ;; whereas "no" means "definitely not", T means "yes or maybe".
182 (enumerable-p nil
:type
(or function null t
))
183 ;; a function which returns T if the CTYPE is inhabited by a single
184 ;; object and, as a value, the object. Otherwise, returns NIL, NIL.
185 ;; The default case (NIL) is interpreted as a function that always
187 (singleton-p nil
:type
(or function null
))
190 Not used
, and not really right. Probably we want a TYPE
= alist for the
191 unary operations
, since there are lots of interesting unary predicates that
192 aren
't equivalent to an entire class
193 ;; Names of functions used for testing the type of objects in this type
194 ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
195 ;; passed both the object and the CTYPE. Normally one or the other will be
196 ;; supplied for any type that can be passed to TYPEP; there is no point in
198 (unary-typep nil
:type
(or symbol null
))
199 (typep nil
:type
(or symbol null
))
200 ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
202 (unary-coerce nil
:type
(or symbol null
))
203 (coerce :type
(or symbol null
))
206 #!-sb-fluid
(declaim (freeze-type type-class
))
209 (defun ctype-random (mask)
210 (logand (setq *ctype-lcg-state
*
211 (logand #x8fffff
(+ (* 1103515245 *ctype-lcg-state
*) 12345)))
214 ;;; the base class for the internal representation of types
216 ;; Each CTYPE instance (incl. subtypes thereof) has a random opaque hash value.
217 ;; Hashes are mixed together to form a lookup key in the memoization wrappers
218 ;; for most operations in CTYPES. This works because CTYPEs are immutable.
219 ;; But 2 bits are "stolen" from the hash to use as flag bits.
220 ;; The sign bit indicates that the object is the *only* object representing
221 ;; its type-specifier - it is an "interned" object.
222 ;; The next highest bit indicates that the object, if compared for TYPE=
223 ;; against an interned object can quickly return false when not EQ.
224 ;; Complicated types don't admit the quick failure check.
225 ;; At any rate, the totally opaque pseudo-random bits are under this mask.
226 (defconstant +ctype-hash-mask
+
227 (ldb (byte (1- sb
!vm
:n-positive-fixnum-bits
) 0) -
1))
229 (def!struct
(ctype (:conc-name type-
)
231 (:make-load-form-fun make-type-load-form
)
232 #-sb-xc-host
(:pure t
))
233 ;; the class of this type
235 ;; FIXME: It's unnecessarily confusing to have a structure accessor
236 ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure
237 ;; even though the TYPE-CLASS structure also exists in the system.
238 ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something.
239 ;; [or TYPE-VTABLE or TYPE-METHODS either of which basically equates
240 ;; a type-class with the set of things it can do, while avoiding
241 ;; ambiguity to whether it is a 'CLASS-INFO' slot in a 'TYPE'
242 ;; or an 'INFO' slot in a 'TYPE-CLASS']
243 (class-info (missing-arg) :type type-class
)
244 ;; an arbitrary hash code used in EQ-style hashing of identity
245 ;; (since EQ hashing can't be done portably)
246 ;; - in the host lisp, generate a hash value using a known, simple
247 ;; random number generator (rather than the host lisp's
248 ;; implementation of RANDOM)
249 ;; - in the target, use scrambled bits from the allocation pointer
252 #+sb-xc-host
(ctype-random +ctype-hash-mask
+)
253 #-sb-xc-host
(sb!impl
::quasi-random-address-based-hash
254 *ctype-hash-state
* +ctype-hash-mask
+)
255 :type
(signed-byte #.sb
!vm
:n-fixnum-bits
)
256 ;; FIXME: is there a better way to initialize the hash value
257 ;; and its flag bit simultaneously rather than have it
258 ;; be a read/write slot?
261 ;; Set the sign bit (the "interned" bit) of the hash-value of OBJ to 1.
262 ;; This is an indicator that the object is the unique internal representation
263 ;; of any ctype that is TYPE= to this object.
264 ;; Everything starts out assumed non-unique.
265 ;; The hash-cache logic (a/k/a memoization) tends to ignore high bits when
266 ;; creating cache keys because the mixing function is XOR and the caches
267 ;; are power-of-2 sizes. Lkewise making the low bits non-random is bad
268 ;; for cache distribution.
269 (defconstant +type-admits-type
=-optimization
+
270 (ash 1 (- sb
!vm
:n-positive-fixnum-bits
1))) ; highest bit in fixnum
271 (defun mark-ctype-interned (obj)
272 (setf (type-hash-value obj
)
273 (logior sb
!xc
:most-negative-fixnum
274 (if (eq (type-class-name (type-class-info obj
)) 'array
)
276 +type-admits-type
=-optimization
+)
277 (type-hash-value obj
)))
280 (declaim (inline type-might-contain-other-types-p
))
281 (defun type-might-contain-other-types-p (ctype)
282 (type-class-might-contain-other-types-p (type-class-info ctype
)))
284 (declaim (inline type-enumerable
))
285 (defun type-enumerable (ctype)
286 (let ((answer (type-class-enumerable-p (type-class-info ctype
))))
287 (if (functionp answer
)
288 (funcall answer ctype
)
292 (eval-when (:compile-toplevel
)
293 (assert (= (length (dd-slots (find-defstruct-description 'type-class
)))
294 ;; there exist two boolean slots, plus NAME
295 (+ (length !type-class-fun-slots
) 3))))
297 ;; Unfortunately redundant with the slots in the DEF!STRUCT,
298 ;; but allows asserting about correctness of the constructor
299 ;; without relying on introspection in host Lisp.
300 (defconstant-eqx !type-class-fun-slots
302 complex-subtypep-arg1
303 complex-subtypep-arg2
307 complex-intersection2
315 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
316 (defun !type-class-fun-slot
(name)
317 (unless (member name
!type-class-fun-slots
318 :key
(if (keywordp name
) 'keywordicate
'identity
))
319 (warn "Undefined type-class method ~S" name
))
320 (symbolicate "TYPE-CLASS-" name
)))
322 (defmacro !define-type-method
((class method
&rest more-methods
)
323 lambda-list
&body body
)
324 (let ((name (symbolicate class
"-" method
"-TYPE-METHOD")))
326 (defun ,name
,lambda-list
329 ,@(mapcar (lambda (method)
330 `(setf (,(!type-class-fun-slot method
)
331 (type-class-or-lose ',class
))
333 (cons method more-methods
)))
336 (defmacro !define-type-class
(name &key inherits
337 (enumerable (unless inherits
(must-supply-this))
338 enumerable-supplied-p
)
339 (might-contain-other-types
340 (unless inherits
(must-supply-this))
341 might-contain-other-types-supplied-p
))
343 `(let ,(if inherits
`((parent (type-class-or-lose ',inherits
))))
346 :enumerable-p
,(if enumerable-supplied-p
348 `(type-class-enumerable-p parent
))
349 :might-contain-other-types-p
350 ,(if might-contain-other-types-supplied-p
351 might-contain-other-types
352 `(type-class-might-contain-other-types-p parent
))
354 (loop for name in
!type-class-fun-slots
355 append
`(,(keywordicate name
)
356 (,(!type-class-fun-slot name
) parent
))))))))
359 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
360 (unless (find ',name
*type-classes
* :key
#'type-class-name
)
361 (vector-push-extend ,make-it
*type-classes
*))))
364 (setf (svref *type-classes
*
365 ,(position name
*type-classes
* :key
#'type-class-name
))
368 ;;; Define the translation from a type-specifier to a type structure for
369 ;;; some particular type. Syntax is identical to DEFTYPE.
370 ;;; Semantics are slightly different though: DEFTYPE causes the default
371 ;;; for missing &OPTIONAL arguments to be '* but a translator requires
372 ;;; an explicit default of '*, or else it assumes a default of NIL.
373 (defmacro !def-type-translator
(name &rest stuff
)
374 (declare (type symbol name
))
375 (let* ((allow-atom (if (eq (car stuff
) :list
) (progn (pop stuff
) nil
) t
))
376 ;; If atoms are allowed, then the internal destructuring-bind receives
377 ;; NIL when the spec is an atom; it should not take CDR of its input.
378 ;; (Note that a &WHOLE argument gets NIL, not the atom in that case)
379 ;; If atoms are disallowed, it's basically like a regular macro.
380 (lexpr (make-macro-lambda nil
(pop stuff
) stuff nil nil
381 :accessor
(if allow-atom
'identity
'cdr
)
383 (ll-decl (third lexpr
)))
384 (aver (and (eq (car ll-decl
) 'declare
) (caadr ll-decl
) 'sb
!c
::lambda-list
))
386 (setf (info :type
:translator
',name
)
387 (named-lambda ,(format nil
"~A-TYPE-PARSE" name
) (spec)
390 `(,lexpr
(and (listp spec
) (cdr spec
)))
391 `(if (listp spec
) (,lexpr spec
))))))))
393 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
394 ;;; same class, invoke the simple method. Otherwise, invoke any
395 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
396 ;;; then swap the arguments when calling TYPE1's method. If no
397 ;;; applicable method, return DEFAULT.
399 ;;; KLUDGE: It might be a lot easier to understand this and the rest
400 ;;; of the type system code if we used CLOS to express it instead of
401 ;;; trying to maintain this squirrely hand-crufted object system.
402 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
403 ;;; all the compilation can get done by the cross-compiler, which I
404 ;;; suspect is hard, so we'll bear with the old system for the time
405 ;;; being. -- WHN 2001-03-11
406 (defmacro !invoke-type-method
(simple complex-arg2 type1 type2
&key
407 (default '(values nil t
))
408 ; assume complex fn is symmetric
409 ; unless told otherwise.
410 (complex-arg1 complex-arg2 complex-arg1-p
))
411 (declare (type keyword simple complex-arg1 complex-arg2
))
412 (once-only ((left type1
)
414 (once-only ((class1 `(type-class-info ,left
))
415 (class2 `(type-class-info ,right
)))
416 `(if (eq ,class1
,class2
)
417 (funcall (,(!type-class-fun-slot simple
) ,class1
) ,left
,right
)
418 (acond ((,(!type-class-fun-slot complex-arg2
) ,class2
)
419 (funcall it
,left
,right
))
420 ((,(!type-class-fun-slot complex-arg1
) ,class1
)
421 ;; if COMPLEX-ARG1 method was provided, the method accepts
422 ;; the arguments exactly as given. Otherwise, flip them.
423 (funcall it
,@(if complex-arg1-p
424 `(,left
,right
) `(,right
,left
))))
427 ;;; This is a very specialized implementation of CLOS-style
428 ;;; CALL-NEXT-METHOD within our twisty little type class object
429 ;;; system, which works given that it's called from within a
430 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
431 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
432 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
433 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
434 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
436 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
437 ;;; everything would Just Work without us having to think about it. In
438 ;;; our goofy type dispatch system, it's messier to express. It's also
439 ;;; more fragile, since (0) there's no check that it's called from
440 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
441 ;;; rely on our global knowledge that the next (and only) relevant
442 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
443 ;;; knowledge of the appropriate default for the CSUBTYPEP function
444 ;;; when no next method exists. -- WHN 2002-04-07
446 ;;; (We miss CLOS! -- CSR and WHN)
447 (defun invoke-complex-subtypep-arg1-method (type1 type2
&optional subtypep win
)
448 (let* ((type-class (type-class-info type1
))
449 (method-fun (type-class-complex-subtypep-arg1 type-class
)))
451 (funcall (the function method-fun
) type1 type2
)
452 (values subtypep win
))))
454 ;;; KLUDGE: This function is dangerous, as its overuse could easily
455 ;;; cause stack exhaustion through unbounded recursion. We only use
456 ;;; it in one place; maybe it ought not to be a function at all?
457 (defun invoke-complex-=-other-method
(type1 type2
)
458 (let* ((type-class (type-class-info type1
))
459 (method-fun (type-class-complex-= type-class
)))
461 (funcall (the function method-fun
) type2 type1
)
466 ;;; Hash two things (types) down to a target fixnum. In CMU CL this was an EQ
467 ;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at
468 ;;; cross-compile time, it's now based on the CTYPE-HASH-VALUE field
471 ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is
472 ;;; it important for it to be INLINE, or could be become an ordinary
473 ;;; function without significant loss? -- WHN 19990413
474 #!-sb-fluid
(declaim (inline type-cache-hash
))
475 (declaim (ftype (function (ctype ctype
) (signed-byte #.sb
!vm
:n-fixnum-bits
))
477 (defun type-cache-hash (type1 type2
)
478 (logxor (ash (type-hash-value type1
) -
3) (type-hash-value type2
)))
480 #!-sb-fluid
(declaim (inline type-list-cache-hash
))
481 (declaim (ftype (function (list) (signed-byte #.sb
!vm
:n-fixnum-bits
))
482 type-list-cache-hash
))
483 (defun type-list-cache-hash (types)
484 (loop with res of-type
(signed-byte #.sb
!vm
:n-fixnum-bits
) = 0
486 do
(setq res
(logxor (ash res -
1) (type-hash-value type
)))
487 finally
(return res
)))
489 (!defun-from-collected-cold-init-forms
!type-class-cold-init
)