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-ALIEN")
19 (defstruct (alien-type
21 (:constructor make-alien-type
22 (&key hash bits alignment
24 (or alignment
(guess-alignment bits
))))))
25 ;; HASH is a derived from the contents, not just a pseudo-random number.
26 ;; The highest 5 bits of it imply the alien-type-class.
27 ;; (There are curretly 16 type-classes with room for expansion)
28 ;; These slots should be read-only, but alas they get modified by
29 ;; the parsers for ENUM and RECORD types.
30 ;; Maybe the sign bit could be used to indicate hash-consed versus non-hash-consed
31 ;; and so we can know whether it is a safe operation to mutate the thing?
32 (hash 0 :type
(and sb-xc
:fixnum unsigned-byte
))
33 ;; It's quasi-bogus that these can be NULL - it occurs when and only when parsing
34 ;; a structure type that involves self-recursion I think. The :type option is inadequate
35 ;; to enforce that atoms like {SINGLE,DOUBLE-}FLOAT always have an integer here.
36 (bits nil
:type
(or null unsigned-byte
))
37 (alignment nil
:type
(or null unsigned-byte
)))
39 (in-package "SB-KERNEL")
41 (!begin-collecting-cold-init-forms
)
43 ;; We can't make an instance of any CTYPE descendant until its type-class
44 ;; exists in *TYPE-CLASSES* and the quasi-random state has been made.
45 ;; By initializing the state and type-class storage vector at once,
46 ;; it is obvious that either both have been made or neither one has been.
48 (progn (defvar *ctype-lcg-state
* 1)
49 (defvar *ctype-hash-state
* (make-random-state))
50 ;; There are 5 bits in a type-class index, so at most 32 type-classes
51 ;; of which about 17 are currently defined.
52 (defvar *type-classes
* (make-array 32 :initial-element nil
))
53 ;; We track for each type-class whether it has any descendant class.
54 ;; Inheritance is implemented by copying the vtable from an ancestor
55 ;; to the descendant at the time the descendant is defined.
56 ;; So the following minimal example might not do what you expect:
57 ;; (DEFINE-TYPE-CLASS ROOT)
58 ;; (DEFINE-TYPE-CLASS CHILD :INHERITS ROOT)
59 ;; (DEFINE-TYPE-METHOD (ROOT :SOME-METHOD) ...)
60 ;; CHILD fails to copy a pointer to SOME-METHOD.
61 ;; This is subtle and perhaps unintuitive. As such, we guard against
62 ;; it by preventing DEFINE-TYPE-METHOD after use of :INHERITS.
63 (defvar *type-class-was-inherited
*
64 (make-array 32 :element-type
'bit
:initial-element
0)))
67 (macrolet ((def (name init-form
)
69 (define-load-time-global ,name
,init-form
)
70 (!cold-init-forms
(setq ,name
,init-form
)))))
71 (declaim (type (simple-array (and fixnum unsigned-byte
) (1))
73 (type (simple-vector 32) *type-classes
*)
74 (type fixnum
*type-cache-nonce
*))
75 (def *ctype-hash-state
* (make-array 1 :element-type
'(and fixnum unsigned-byte
)
77 (def *type-classes
* (make-array 32 :initial-element nil
))
78 ;; This is for "observers" who want to know if type names have been added.
79 ;; Rather than registering listeners, they can detect changes by comparing
80 ;; their stored nonce to the current nonce. Additionally the observers
81 ;; can detect whether function definitions have occurred.
82 (def *type-cache-nonce
* 0))
84 (defun must-supply-this (&rest foo
)
85 (/show0
"failing in MUST-SUPPLY-THIS")
86 (error "missing type method for ~S" foo
))
88 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
89 ;;; contains functions which are methods on that kind of type, but is
90 ;;; also used in EQ comparisons to determined if two types have the
92 (defstruct (type-class
94 (:print-object
(lambda (x stream
)
95 (print-unreadable-object (x stream
:type t
)
96 (prin1 (type-class-name x
) stream
)))))
97 ;; the name of this type class (used to resolve references at load time)
98 (name (missing-arg) :type symbol
:read-only t
)
99 ;; Dyadic type methods. If the classes of the two types are EQ, then
100 ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
101 ;; either type's class has a COMPLEX-xxx method, then we call it.
103 ;; Although it is undefined which method will get precedence when
104 ;; both types have a complex method, the complex method can assume
105 ;; that the second arg always is in its class, and the first always
106 ;; is not. The arguments to commutative operations will be swapped
107 ;; if the first argument has a complex method.
109 ;; Since SUBTYPEP is not commutative, we have two complex methods.
110 ;; The ARG1 method is only called when the first argument is in its
111 ;; class, and the ARG2 method is only called when called when the
112 ;; second type is. If either is specified, both must be.
113 ;; FIXME: "both must be" is false of CLASSOID type-class.
114 ;; Figure out if this is a comment bug or a logic bug.
115 ;; * (type-class-complex-subtypep-arg1 (type-class-or-lose 'classoid)) => NIL
116 ;; * (type-class-complex-subtypep-arg2 (type-class-or-lose 'classoid))
117 ;; => #<FUNCTION CLASSOID-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD>
118 (simple-subtypep #'must-supply-this
:type function
)
119 (complex-subtypep-arg1 nil
:type
(or function null
))
120 (complex-subtypep-arg2 nil
:type
(or function null
))
121 ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
122 ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
123 ;; a new type which expresses the result nicely, better than could
124 ;; be done by just stuffing the two component types into an
125 ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
126 ;; failure, or a CTYPE for success.
128 ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
129 ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
130 ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
131 ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
132 ;; wants to simplify unions and intersections by considering all
133 ;; possible pairwise simplifications (where the CMU CL code only
134 ;; considered simplifications between types which happened to appear
135 ;; next to each other the argument sequence).
137 ;; Differences in detail from old CMU CL methods:
138 ;; * SBCL's methods are more parallel between union and
139 ;; intersection forms. Each returns one values, (OR NULL CTYPE).
140 ;; * SBCL doesn't use type methods to deal with unions or
141 ;; intersections of the COMPOUND-TYPE of the corresponding form.
142 ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
143 ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
144 ;; (and deal with canonicalization/simplification issues at the
146 (simple-union2 #'hierarchical-union2
:type function
)
147 (complex-union2 nil
:type
(or function null
))
148 (simple-intersection2 #'hierarchical-intersection2
:type function
)
149 (complex-intersection2 nil
:type
(or function null
))
150 (simple-= #'must-supply-this
:type function
)
151 (complex-= nil
:type
(or function null
))
153 (negate #'must-supply-this
:type function
)
154 ;; a function which returns a Common Lisp type specifier
155 ;; representing this type
156 (unparse #'must-supply-this
:type function
)
158 ;; Can types of this type-class contain other types?
159 ;; A global property of our
160 ;; implementation (which unfortunately seems impossible to enforce
161 ;; with assertions or other in-the-code checks and constraints) is
162 ;; that subclasses which don't contain other types correspond to
163 ;; disjoint subsets (except of course for the NAMED-TYPE T, which
164 ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is
165 ;; is disjoint from MEMBER-TYPE and so forth. But types which can
166 ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can
167 ;; violate this rule.
168 (might-contain-other-types-p nil
:type boolean
:read-only t
)
169 ;; a function which returns T if the CTYPE could possibly be
170 ;; equivalent to a MEMBER type. If not a function, then it's
171 ;; a constant T or NIL for all instances of this type class.
172 ;; Note that the old comment for this slot was
173 ;; "True if this type has a fixed number of members, and as such
174 ;; could possibly be completely specified in a MEMBER type."
175 ;; The second half of that is right because of the "possibly,"
176 ;; but "has a fixed number" is too strong a claim, because we
177 ;; set enumerable=T for NEGATION and HAIRY and some other things.
178 ;; Conceptually the choices are really {yes, no, unknown}, but
179 ;; whereas "no" means "definitely not", T means "yes or maybe".
180 (enumerable-p nil
:type
(or function boolean
) :read-only t
)
181 ;; a function which returns T if the CTYPE is inhabited by a single
182 ;; object and, as a value, the object. Otherwise, returns NIL, NIL.
183 ;; The default case (NIL) is interpreted as a function that always
185 (singleton-p nil
:type
(or function null
))
188 Not used
, and not really right. Probably we want a TYPE
= alist for the
189 unary operations
, since there are lots of interesting unary predicates that
190 aren
't equivalent to an entire class
191 ;; Names of functions used for testing the type of objects in this type
192 ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
193 ;; passed both the object and the CTYPE. Normally one or the other will be
194 ;; supplied for any type that can be passed to TYPEP; there is no point in
196 (unary-typep nil
:type
(or symbol null
))
197 (typep nil
:type
(or symbol null
))
198 ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
200 (unary-coerce nil
:type
(or symbol null
))
201 (coerce :type
(or symbol null
))
204 (declaim (freeze-type type-class
))
206 (defun !type-class-or-lose
(name)
207 ;; Careful about NIL elements since they aren't populated strictly in order
208 (or (find-if (lambda (x) (and x
(eq (type-class-name x
) name
)))
210 (error "~S is not a defined type class." name
)))
214 ;; Return a number that increments by 1 for each word-pair allocation,
215 ;; barring complications such as exhaustion of the current page.
216 ;; The result is guaranteed to be a positive fixnum.
217 (declaim (inline address-based-counter-val quasi-random-address-based-hash
))
218 (defun address-based-counter-val ()
220 ;; Use the per-thread alloc region pointer when possible
221 #+(or x86-64 sb-thread
)
222 (sap-int (sb-vm::current-thread-offset-sap sb-vm
::thread-mixed-tlab-slot
))
223 ;; Otherwise mixed_region in static space
224 #-
(or x86-64 sb-thread
)
225 (sb-sys:sap-ref-word
(sb-sys:int-sap
(+ sb-vm
::static-space-start
226 sb-vm
::mixed-region-offset
))
228 ;; counter should increase by 1 for each cons cell allocated
229 (ash word
(- (1+ sb-vm
:word-shift
)))))
230 ;;; Return some bits that are dependent on the next address that will be
231 ;;; allocated, mixed with the previous state (in case addresses get recycled).
232 ;;; This algorithm, used for stuffing a hash-code into instances of CTYPE
233 ;;; subtypes and generic functions, is simpler than RANDOM.
234 ;;; I don't know whether it is more random or less random than a PRNG,
236 (defun quasi-random-address-based-hash (state mask
)
237 (declare (type (simple-array (and fixnum unsigned-byte
) (1)) state
))
238 ;; Ok with multiple threads - No harm, no foul.
239 (logand (setf (aref state
0) (mix (address-based-counter-val) (aref state
0)))
242 (defun ctype-random ()
244 (setq *ctype-lcg-state
*
245 (logand #x8fffff
(+ (* 1103515245 *ctype-lcg-state
*) 12345)))
247 (quasi-random-address-based-hash *ctype-hash-state
* #xfffffff
))
249 ;;; the base class for the internal representation of types
251 ;;; Each CTYPE instance (all subtypes thereof) has a random opaque hash value.
252 ;;; Hashes are mixed together to form a lookup key in the memoization wrappers
253 ;;; for most operations on CTYPES. This works because CTYPEs are immutable.
254 ;;; No more than N-FIXNUM-BITS for 32-bit machines are used, even for 64-bit words.
255 ;;; It's easiest this way. It could be host-fixnum-sized for the host, and then
256 ;;; target-fixnum-sized for the target, but that's not easy to do with DEF!STRUCT.
257 ;;; (In fact I think it's probably infeasible but I'm not certain of it)
258 ;;; You could always make it SB-XC:FIXNUM at the risk of forcing the host to
259 ;;; deal in bignums. Why cause it undue slowness when we don't need so many bits?
260 ;;; NOTE: we _do_ use the sign bit, leaving us 25 pseudorandom bits, but
261 ;;; the 2 bits of least significance are NOT pseudorandom, so it's best
262 ;;; not to use them directly in the hash index.
263 (defconstant ctype-hash-size
30) ; all significant bits, for the slot type specifier
264 (defconstant ctype-PRNG-nbits
25) ; from pseudorandom number generator
265 (defconstant ctype-contains-unknown
#b01
)
266 (defconstant ctype-contains-hairy
#b10
) ; any hairy type, including UNKNOWN
267 (defconstant +ctype-flag-mask
+ #b11
)
268 (defconstant +ctype-hash-mask
+ (logandc2 (1- (ash 1 ctype-PRNG-nbits
)) #b11
))
270 (defstruct (ctype (:conc-name type-
)
273 #-sb-xc-host
(:pure t
))
274 ;; bits 0..24: pseudorandom hash
275 ;; bits 25..29: 5 bits for type-class index
276 (%bits
(missing-arg) :type
(signed-byte #.ctype-hash-size
) :read-only t
))
278 ;;; Apparently the old CONTAINS-UNKNOWN-TYPE-P function could accept NIL
279 ;;; and return NIL. This seems kinda sloppy. Can we get rid of that "feature"?
280 (declaim (inline contains-unknown-type-p contains-hairy-type-p
))
281 (defun contains-unknown-type-p (ctype)
282 (if ctype
(oddp (type-%bits ctype
)) nil
))
283 (defun contains-hairy-type-p (ctype)
284 (logbitp 1 (type-%bits ctype
)))
286 (defun ok-to-memoize-p (arg)
288 (ctype (evenp (type-%bits arg
))) ; i.e. not CTYPE-CONTAINS-UNKNOWN
289 (list (dolist (elt arg t
)
290 (when (oddp (type-%bits elt
)) (return nil
))))))
292 (defmacro type-class-id
(ctype) `(ldb (byte 5 ,ctype-PRNG-nbits
) (type-%bits
,ctype
)))
293 (defmacro type-id-
>type-class
(id) `(truly-the type-class
(aref *type-classes
* ,id
)))
294 (defmacro type-class
(ctype) `(type-id->type-class
(type-class-id ,ctype
)))
296 (declaim (inline type-hash-value
))
297 (defun type-hash-value (ctype) (logand (type-%bits ctype
) sb-xc
:most-positive-fixnum
))
299 (defmacro type-flags
(ctype) `(logand (type-%bits
,ctype
) +ctype-flag-mask
+))
300 ;;; Hash caches can in general accept any signed fixnum as the hash.
301 ;;; Hashsets probably can as well, but if the mixing function entails MIX,
302 ;;; the inputs have to be positive fixnums.
303 ;;; I can't remember if our hash-tables that use arbitrary user-supplied
304 ;;; hash functions can accept negative fixnums.
305 (defun type-list-flags (list)
306 (let ((bits 0)) ; LOGIOR together and then mask once when done
307 (dolist (ctype list
(logand bits
+ctype-flag-mask
+))
308 (setq bits
(logior bits
(type-%bits ctype
))))))
310 (defglobal *ctype-hashsets
* nil
)
311 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
312 (defun ctype-class-bits (type-class)
313 (let* ((index (type-class-name->id type-class
))
316 (byte 5 ctype-PRNG-nbits
)
317 ;; ensure that the result is a (SIGNED-BYTE 30) by depositing
318 ;; into a -1 if the high bit of the class ID is on.
319 (if (logbitp 4 index
) (ash -
1 ctype-PRNG-nbits
) 0))))
320 (the (signed-byte #.ctype-hash-size
) shifted
)))
321 (defvar *type-class-list
*
322 ;; type-class and ctype instance types in that class
323 ;; The instance types MUST be list in descending order of DEPTHOID.
324 ;; See CTYPE->HASHSET-NAME for the rationale for this constraint.
328 (function fun-designator-type fun-type
)
329 (constant constant-type
)
330 (hairy unknown-type hairy-type
)
331 (intersection intersection-type
)
333 (negation negation-type
)
334 (number numeric-type
)
336 (character-set character-set-type
)
340 (simd-pack simd-pack-type
)
342 (simd-pack-256 simd-pack-256-type
)
343 ;; clearly alien-type-type is not consistent with the (FOO FOO-TYPE) theme
344 (alien alien-type-type
)))
345 (defun ctype-instance->type-class
(name)
347 (find name
*type-class-list
* :key
#'cdr
:test
#'member
)))))
348 (eval-when (#+sb-xc-host
:compile-toplevel
:load-toplevel
:execute
)
349 (defun type-class-name->id
(name)
350 (or #+sb-xc-host
(position name
*type-class-list
* :key
#'car
)
351 #-sb-xc-host
(position name
*type-classes
* :key
#'type-class-name
)
352 (error "~S is not a defined type class." name
))))
354 ;;; For system build-time only
355 (defun make-ctype-bits (type-class &optional
(hash (ctype-random)))
356 (logior (ctype-class-bits type-class
) (logand hash
+ctype-hash-mask
+)))
358 (declaim (inline type-might-contain-other-types-p
))
359 (defun type-might-contain-other-types-p (ctype)
360 (type-class-might-contain-other-types-p (type-class ctype
)))
362 (declaim (inline type-enumerable
))
363 (defun type-enumerable (ctype)
364 (let ((answer (type-class-enumerable-p (type-class ctype
))))
365 (if (functionp answer
)
366 (funcall answer ctype
)
370 (eval-when (:compile-toplevel
)
371 (assert (= (length (dd-slots (find-defstruct-description 'type-class
)))
372 ;; there exist two boolean slots, plus NAME
373 (+ (length type-class-fun-slots
) 3))))
375 ;; Unfortunately redundant with the slots in the DEF!STRUCT,
376 ;; but allows asserting about correctness of the constructor
377 ;; without relying on introspection in host Lisp.
378 (defconstant-eqx type-class-fun-slots
380 complex-subtypep-arg1
381 complex-subtypep-arg2
385 complex-intersection2
393 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
394 (defun type-class-fun-slot (name)
395 (unless (member name type-class-fun-slots
396 :key
(if (keywordp name
) 'keywordicate
'identity
))
397 (warn "Undefined type-class method ~S" name
))
398 (package-symbolicate "SB-KERNEL" "TYPE-CLASS-" name
)))
400 ;;; Sure we could infer this list by seeing what gets defined,
401 ;;; but doing that would introduce a requirement that TYPE= be defined
402 ;;; only after all the methods are.
403 ;;; No need to make this more complicated.
404 (defglobal classes-having-complex-
=-method
405 '(named intersection union negation member hairy
))
406 (eval-when (#-sb-xc-host
:compile-toplevel
)
407 (dolist (name classes-having-complex-
=-method
)
408 ;; Assert that NAME is valid and defines a COMPLEX-= method
409 (assert (functionp (type-class-complex-= (!type-class-or-lose name
))))))
411 (defmacro define-type-method
((class method
&rest more-methods
)
412 lambda-list
&body body
)
413 (when (and (eq method
:complex-
=)
414 (not (member class classes-having-complex-
=-method
)))
415 (error "Didn't expect to see a ~S method for type-class ~S"
417 (let* ((name (symbolicate class
"-" method
"-TYPE-METHOD"))
421 (number 'numeric-type
)
423 (alien 'alien-type-type
)
424 (t (symbolicate class
"-TYPE"))))
425 (first (car lambda-list
))
426 (second (cadr lambda-list
))
427 ;; make-host-1 verifies that type methods are invoked correctly,
428 ;; but afterwards we assume that they are
429 (operator #+sb-xc-host
'the
#-sb-xc-host
'truly-the
)
433 ((:complex-subtypep-arg1
:negate
:singleton-p
)
434 `((,first
(,operator
,arg-type
,first
))))
436 `((,second
(,operator
,arg-type
,second
))))
437 ((:complex-subtypep-arg2
)
438 `((,first
,first
) ; because there might be a DECLARE IGNORE on it
439 (,second
(,operator
,arg-type
,second
))))
440 ((:simple-intersection2
:simple-union2
:simple-subtypep
:simple-
=)
441 `((,first
(,operator
,arg-type
,first
))
442 (,second
(,operator
,arg-type
,second
))))))))
445 (when (plusp (bit *type-class-was-inherited
* (type-class-name->id
',class
)))
446 ;; This disallows one case that would be ok - a method definition for
447 ;; both an ancestor and its descendants on some method.
448 ;; Too bad for you- this throws the baby out with the bathwater.
449 (error "Can't define-type-method for class ~s: already inherited" ',class
))
450 (defun ,name
,lambda-list
451 #-sb-xc-host
(declare (optimize (sb-c::verify-arg-count
0)))
452 ,@(if (eq method
:unparse
) `((declare (ignorable ,(first lambda-list
)))))
453 ,@(if rebind
`((let ,rebind
,@body
)) body
))
455 ,@(mapcar (lambda (method)
456 `(setf (,(type-class-fun-slot method
)
457 (svref *type-classes
* ,(type-class-name->id class
)))
459 (cons method more-methods
)))
462 (defmacro define-type-class
(name &key inherits
463 (enumerable (unless inherits
(missing-arg))
464 enumerable-supplied-p
)
465 (might-contain-other-types
466 (unless inherits
(missing-arg))
467 might-contain-other-types-supplied-p
))
469 `(let* ,(if inherits
`((parent-index (type-class-name->id
',inherits
))
470 (parent (aref *type-classes
* parent-index
))))
473 `((setf (bit *type-class-was-inherited
* parent-index
) 1)))
476 :enumerable-p
,(if enumerable-supplied-p
478 `(type-class-enumerable-p parent
))
479 :might-contain-other-types-p
480 ,(if might-contain-other-types-supplied-p
481 might-contain-other-types
482 `(type-class-might-contain-other-types-p parent
))
484 (loop for name in type-class-fun-slots
485 append
`(,(keywordicate name
)
486 (,(type-class-fun-slot name
) parent
))))))))
489 ;; Careful: type-classes are very complicated things to redefine.
490 ;; For the sake of parallelized make-host-1 we have to allow
491 ;; redefinition, but it has to be a no-op.
492 (let ((index ,(type-class-name->id name
)))
493 (unless (aref *type-classes
* index
)
494 (setf (aref *type-classes
* index
) ,make-it
)))
495 ;; I have no idea what compiler bug could be worked around by adding a form here,
496 ;; but this certainly achieves something, somehow.
497 #+host-quirks-cmu
(print (aref *type-classes
* (1- (length *type-classes
*)))))
500 `(!cold-init-forms
(setf (svref *type-classes
* ,(type-class-name->id name
))
503 ;;; Define the translation from a type-specifier to a type structure for
504 ;;; some particular type. Syntax is identical to DEFTYPE.
505 ;;; Semantics are slightly different though: DEFTYPE causes the default
506 ;;; for missing &OPTIONAL arguments to be '* but a translator requires
507 ;;; an explicit default of '*, or else it assumes a default of NIL.
508 (defmacro def-type-translator
(name &rest stuff
)
509 (declare (type symbol name
))
510 (let* ((allow-atom (if (eq (car stuff
) :list
) (progn (pop stuff
) nil
) t
))
511 (lambda-list (pop stuff
))
512 (context-var-p (typep (car lambda-list
) '(cons (eql :context
))))
514 (if context-var-p
(cadr (pop lambda-list
)) (make-symbol "CONTEXT")))
515 ;; If atoms are allowed, then the internal destructuring-bind receives
516 ;; NIL when the spec is an atom; it should not take CDR of its input.
517 ;; (Note that a &WHOLE argument gets NIL, not the atom in that case)
518 ;; If atoms are disallowed, it's basically like a regular macro.
519 (lexpr (make-macro-lambda nil lambda-list stuff nil nil
520 :accessor
(if allow-atom
'identity
'cdr
)
522 (ll-decl (third lexpr
))
523 (defun-name (symbolicate "PARSE-<" name
">")))
524 (aver (and (eq (car ll-decl
) 'declare
) (caadr ll-decl
) 'sb-c
::lambda-list
))
526 (defun ,defun-name
(,context spec
)
528 ,@(unless context-var-p
`((declare (ignore ,context
))))
530 `(,lexpr
(and (listp spec
) (cdr spec
)))
531 `(if (listp spec
) (,lexpr spec
))))
533 (setf (info :type
:expander
',name
) (list #',defun-name
))))))
535 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
536 ;;; same class, invoke the simple method. Otherwise, invoke any
537 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
538 ;;; then swap the arguments when calling TYPE1's method. If no
539 ;;; applicable method, return DEFAULT.
540 (defmacro invoke-type-method
(simple complex-arg2 type1 type2
&key
541 ;; This default is counterintuitive.
542 ;; You'd think the most general default
543 ;; would be "don't know" (i.e. NIL NIL)
544 ;; instead of "Certainly no"
545 (default '(values nil t
))
546 ; assume complex fn is symmetric
547 ; unless told otherwise.
548 (complex-arg1 complex-arg2 complex-arg1-p
))
549 (declare (type keyword simple complex-arg1 complex-arg2
))
550 `(let* ((.L
,type1
) (id1 (type-class-id .L
))
551 (.R
,type2
) (id2 (type-class-id .R
))
552 (c2 (type-id->type-class id2
)))
554 (acond ((,(type-class-fun-slot complex-arg2
) c2
)
556 ((,(type-class-fun-slot complex-arg1
) (type-id->type-class id1
))
557 ;; if COMPLEX-ARG1 method was provided, the method accepts
558 ;; the arguments exactly as given. Otherwise, flip them.
559 (funcall it
,@(if complex-arg1-p
`(.L .R
) `(.R .L
))))
561 ,(if (eq simple
:none
)
563 `(funcall (,(type-class-fun-slot simple
) c2
) .L .R
)))))
565 ;;; This is a very specialized implementation of CLOS-style
566 ;;; CALL-NEXT-METHOD within our twisty little type class object
567 ;;; system, which works given that it's called from within a
568 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
569 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
570 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
571 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
572 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
574 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
575 ;;; everything would Just Work without us having to think about it. In
576 ;;; our goofy type dispatch system, it's messier to express. It's also
577 ;;; more fragile, since (0) there's no check that it's called from
578 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
579 ;;; rely on our global knowledge that the next (and only) relevant
580 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
581 ;;; knowledge of the appropriate default for the CSUBTYPEP function
582 ;;; when no next method exists. -- WHN 2002-04-07
584 ;;; (We miss CLOS! -- CSR and WHN)
585 (defun invoke-complex-subtypep-arg1-method (type1 type2
&optional subtypep win
)
586 (let* ((type-class (type-class type1
))
587 (method-fun (type-class-complex-subtypep-arg1 type-class
)))
589 (funcall (the function method-fun
) type1 type2
)
590 (values subtypep win
))))
592 (defvar *invoked-complex-
=-other-method
* nil
)
593 (defun invoke-complex-=-other-method
(type1 type2
)
594 (let* ((type-class (type-class type1
))
595 (method-fun (type-class-complex-= type-class
)))
596 (if (and method-fun
(not *invoked-complex-
=-other-method
*))
597 (let ((*invoked-complex-
=-other-method
* t
))
598 (funcall (the function method-fun
) type2 type1
))
603 ;;; Various hash mixing functions.
604 (declaim (inline hash-ctype-pair
))
605 (declaim (ftype (function (ctype ctype
) (signed-byte #.ctype-hash-size
)) hash-ctype-pair
))
606 (defun hash-ctype-pair (type1 type2
)
607 (logxor (ash (type-%bits type1
) -
3) (type-%bits type2
)))
609 (declaim (inline hash-ctype-list
))
610 (declaim (ftype (function (list) (signed-byte #.ctype-hash-size
)) hash-ctype-list
))
611 (defun hash-ctype-list (types)
612 (loop with res of-type
(signed-byte #.ctype-hash-size
) = 0
614 do
(setq res
(logxor (ash res -
1) (type-%bits type
)))
615 ;; This returns a positive number so that it can be passed to MIX
616 finally
(return (ldb (byte (1- ctype-hash-size
) 0) res
))))
618 (defun hash-ctype-set (types) ; ctype list hashed order-insensitively
619 (let ((hash (type-%bits
(car types
)))
621 (declare (type sb-xc
:fixnum hash
))
622 (dolist (type (cdr types
) (mix (logand hash sb-xc
:most-positive-fixnum
)
623 (the (integer 2) n
)))
625 (setq hash
(plus-mod-fixnum (type-%bits type
) hash
)))))
626 ;;; NOTE: despite the name, this does not operate only on lists of CTYPE.
627 ;;; Maybe pick a better name.
628 (defun ctype-set= (a b
)
629 ;; However, it might also be nice to canonicalize sets by putting any type containing
630 ;; SATISFIES to the right of any type that does not. This order would tend to have
631 ;; a beneficial effect of making TYPEP tests pass or fail "sooner" without calling
632 ;; a random predicate. It's just as well to compare sets elementwise for now
633 ;; rather than sorting them by some complicated set of criteria.
634 (and (= (length a
) (length b
)) (every (lambda (x) (memq x b
)) a
)))
636 (define-load-time-global *ctype-list-hashset
*
637 (make-hashset 32 #'list-elts-eq
#'hash-ctype-list
:weakness t
:synchronized t
))
638 (define-load-time-global *ctype-set-hashset
*
639 (make-hashset 32 #'ctype-set
= #'hash-ctype-set
:weakness t
:synchronized t
))
641 (defun intern-ctype-list (list)
643 (hashset-insert-if-absent *ctype-list-hashset
* list
#'ensure-heap-list
)))
644 (defun intern-ctype-set (set)
645 (aver set
) ; Sets of ctypes (as used by COMPOUND-TYPE) are nonempty lists
646 (hashset-insert-if-absent *ctype-set-hashset
* set
#'ensure-heap-list
))
648 ;;; DEF-TYPE-MODEL is like DEFSTRUCT, with the following differences:
649 ;;; 1. it inserts (:INCLUDE CTYPE) unless otherwise expressed
650 ;;; 2. it inserts (:COPIER NIL)
651 ;;; 3. it adds :READ-ONLY T to all slots
652 ;;; 4. it has slot options to help with hash-consing
653 (defmacro def-type-model
((name &rest options
) &rest direct-slots
)
654 ;; :CONSTRUCTOR* reminds you that it's not a direct translation to defstruct.
655 (aver (<= (count :constructor
* options
:key
#'car
) 1))
656 ;; The private constructor is always positional.
657 ;; (:CONSTRUCTOR* NAME (arg1 arg2)) has a private constructor
658 ;; and a public constructor. The latter will eventually
659 ;; become a caching constructor when that change is completed.
660 ;; (:CONSTRUCTOR* NIL (arg1 arg2)) specifies the argument order
661 ;; but asks for no automatically-defined public constructor.
662 ;; You might hand-define one which takes &KEY args if desired.
663 (let* ((public-ctor (assoc :constructor
* options
))
664 (public-ctor-args (third public-ctor
))
665 (private-ctor (unless (member name
'(compound-type args-type
))
666 (symbolicate "!ALLOC-" name
)))
667 (private-ctor-args (cons '%bits public-ctor-args
))
668 (conc-name (symbolicate name
"-"))
669 (include (awhen (assoc :include options
) (cadr it
)))
670 ;; list of triples #(SLOT-NAME HASHER COMPARATOR) of direct slots only.
671 ;; Inherited slots are mixed in by calling the supertype's hash function.
673 (mapcan (lambda (slot &aux
(type (getf (cddr slot
) :type
))
674 (hasher (getf (cddr slot
) :hasher
:fail
))
675 (comparator (getf (cddr slot
) :test
)))
676 (cond ((or comparator
(null hasher
))) ; ok
678 (setq comparator
'eq hasher
'type-hash-value
))
679 ((or (and (typep type
'(cons (eql member
)))
680 (every #'symbolp
(cdr type
)))
682 (setq comparator
'eq
)
683 (when (eq type
'boolean
)
684 (setq hasher
'(lambda (x) (if x
#xaa55aa
#x55aa55
)))))
685 (t (bug "Underspecified slot: ~S.~S type ~S~%"
686 name
(car slot
) type
)))
687 (when hasher
(list (vector (car slot
) hasher comparator
))))
690 ,@(when private-ctor
`((declaim (inline ,private-ctor
))))
691 (defstruct (,name
,@(unless include
'((:include ctype
)))
692 ,@(remove-if (lambda (x)
693 (member (car x
) '(:constructor
* :extra-mix-step
)))
696 `(:constructor
,private-ctor
,private-ctor-args
)
699 ,@(mapcar (lambda (slot &aux
(copy (copy-list slot
)))
702 (append copy
'(:read-only t
)))
704 ;; Always define hash-consing functions if any new slots, even if abstract.
708 `((defun ,(symbolicate "CALC-" name
"-HASH") (x)
709 #-sb-xc-host
(declare (optimize (safety 0)))
710 (,(if (assoc :extra-mix-step options
) 'type-hash-final-mix
'progn
)
712 ,@(when include
`((,(symbolicate "CALC-" include
"-HASH") x
)))
713 ,@(mapcar (lambda (slot &aux
(reader
714 (symbolicate conc-name
(svref slot
0))))
715 `(,(svref slot
1) (,reader x
)))
717 (defun ,(symbolicate name
"-EQUIV") (a b
)
718 #-sb-xc-host
(declare (optimize (safety 0)))
719 (and ,@(mapcar (lambda (slot &aux
(reader
720 (symbolicate conc-name
(svref slot
0))))
721 `(,(elt slot
2) (,reader a
) (,reader b
)))
723 ,@(when include
`((,(symbolicate include
"-EQUIV") a b
))))))))
725 ;; Define a hashset unless this is an abstract type
726 ,@(unless (member name
'(compound-type args-type
))
727 (let* ((stem (if direct-slots name include
))
728 (hashfn (symbolicate "CALC-" stem
"-HASH"))
729 (test (symbolicate stem
"-EQUIV"))
730 (hashset (symbolicate "*" name
"-HASHSET*")))
731 `((pushnew ',hashset
*ctype-hashsets
*)
732 (define-load-time-global ,hashset
733 (make-hashset 32 #',test
#',hashfn
:synchronized t
:weakness t
)))))
734 ;; If the internal constructor is wrapped in a hand-written constructor, then
735 ;; that other constructor invokes the cachine lookup macro. Don't do it here.
736 ;; See e.g. MAKE-CONS-TYPE which picks off 2 cases and then uses the cache.
737 ,@(when (second public-ctor
)
738 `((declaim (ftype (sfunction * ,name
) ,(second public-ctor
)))
739 (defun ,(second public-ctor
) ,public-ctor-args
741 ,(ecase name
; Compute or propagate the flag bits
742 (hairy-type ctype-contains-hairy
)
743 (unknown-type (logior ctype-contains-unknown ctype-contains-hairy
))
744 ((simd-pack-type simd-pack-256-type alien-type-type
) 0)
745 (negation-type '(type-flags type
))
746 (array-type '(type-flags element-type
)))
747 ,@(cdr private-ctor-args
))))))))
749 (defmacro type-hash-mix
(&rest args
) (reduce (lambda (a b
) `(mix ,a
,b
)) args
))
750 ;;; The final mix ensures that all bits affect the masked hash.
751 ;;; Since it takes non-zero time, only do it for NUMERIC and ARRAY, where it seems
752 ;;; to make a large difference in the maximum probe sequence length.
753 (defmacro type-hash-final-mix
(val) `(murmur-hash-word/+fixnum
,val
))
757 (defmacro sb-c
::number-hash
(x) `(sb-impl::number-sxhash
,x
))
758 ;; This is used on a HAIRY specifier which could be an UNKNOWN (just a symbol), or a SATISFIES.
759 ;; There is no reason at all that two distinct symbols should hash the same when their
760 ;; names are STRING= so really we want something better than SXHASH, but it does noeed to
762 (defmacro sb-c
::fallback-hash
(x) `(sxhash ,x
)))
764 ;; Singleton MEMBER types are best dealt with via a weak-value hash-table because:
765 ;; * (MEMBER THING) might lack an address-insensitive hash for THING
766 ;; but src/code/hashset goes through a lot of rigmarole to handle address-bashed
767 ;; hashing, and the end result for a single key would laboriously emulate an EQL table.
768 ;; This is especially important for the compiler because each time it asks itself the
769 ;; CTYPE-OF a constant leaf, the answer might be a singleton MEMBER type.
770 ;; * Symbols have slightly bad SXHASH values (by language requirement):
771 ;; "For any two objects, x and y which are symbols and which are similar
772 ;; (sxhash x) and (sxhash y) yield the same mathematical value even if x and y exist
773 ;; in different Lisp images of the same implementation."
774 ;; This seems to imply that pseudorandom hashes are disallowed for symbols,
775 ;; and that any two gensyms spelled the same hash the same.
776 ;; Consequently, a thousand occurrences of (MEMBER #:DUMMY) for different gensyms,
777 ;; will cause the hashset to exceed its probe sequence length limit.
778 ;; This isn't to say we couldn't assign some bits of SYMBOL-HASH pseudorandomly,
779 ;; and mask them out in the value returned by CL:SXHASH.
780 (define-load-time-global *eql-type-cache
* ; like EQL-SPECIALIZER-TABLE in PCL
781 (sb-impl::make-system-hash-table
:test
'eql
:weakness
:value
:synchronized nil
))
784 (defun ctype-hashset-insert-if-absent (hashset key function
)
785 (or (hashset-find hashset key
)
786 (let ((flags (funcall function key
)))
787 (with-system-mutex ((hashset-mutex hashset
))
788 (or (hashset-find hashset key
)
789 (hashset-insert hashset
(copy-ctype key flags
)))))))
791 (defvar *hashsets-preloaded
* nil
)
792 (defmacro new-ctype
(metatype flags-expr
&rest initargs
)
793 (let* ((hashset (package-symbolicate "SB-KERNEL" "*" metatype
"-HASHSET*"))
794 (allocator (package-symbolicate "SB-KERNEL" "!ALLOC-" metatype
))
795 (defer-flags (typep flags-expr
'(cons (member lambda function
))))
796 (flag-bits (if defer-flags
0 flags-expr
))
797 (class-bits (ctype-class-bits (ctype-instance->type-class metatype
))))
800 (let ((gensyms (make-gensym-list (length initargs
))))
801 `(multiple-value-bind ,gensyms
(values ,@initargs
)
802 (let ((temp (,allocator
803 (logior ,@(unless defer-flags
804 '((logand (ctype-random) +ctype-hash-mask
+)))
805 ,flag-bits
,class-bits
)
807 ;; If lazily computing flags, might have to make a second instance
808 ;; since the %BITS slot is immutable, so try to stack-allocate this.
810 `((declare (dynamic-extent temp
))
811 (or (hashset-find ,hashset temp
)
814 (,allocator
(logior (logand (ctype-random) +ctype-hash-mask
+)
815 (funcall ,flags-expr temp
) ,class-bits
)
817 `((hashset-insert-if-absent ,hashset temp
#'identity
))))))
819 ;; allocate temporary key, copy it if and only if not found.
820 ;; COPY-CTYPE can copy subparts like the numeric bound if arena-allocated
822 `(let ((temp (,allocator
(logior ,flag-bits
,class-bits
) ,@initargs
)))
823 (declare (dynamic-extent temp
))
824 #+nil
; or #+sb-devel as you see fit
825 (unless *hashsets-preloaded
*
826 (write-string "CTYPE hashset preload failure")
828 (truly-the (values ,metatype
&optional
)
830 `(ctype-hashset-insert-if-absent ,hashset temp
,flags-expr
)
831 `(hashset-insert-if-absent ,hashset temp
#'copy-ctype
))))))
833 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
834 ;;; special cases, as well as other special cases needed to
835 ;;; interpolate between regions of the type hierarchy, such as
836 ;;; INSTANCE (which corresponds to all those classes with slots which
837 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
838 ;;; slots which are funcallable) and EXTENDED-SEQUENCE (non-LIST
839 ;;; non-VECTOR classes which are also sequences). These special cases
840 ;;; are the ones that aren't really discussed by Baker in his
841 ;;; "Decision Procedure for SUBTYPEP" paper.
842 (defstruct (named-type (:include ctype
)
843 (:constructor
!make-named-type
(%bits name
))
845 (name nil
:type symbol
:read-only t
))
847 ;;; A HAIRY-TYPE represents a SATISFIES type or UNKNOWN type.
848 ;;; FIXME: those should be two distinct things (in HAIRY type-class)
849 ;;; so that we don't have to examine the sexpr repeatedly to decide its form.
850 ;;; And as a further improvement, we might want a table that maps
851 ;;; predicates to their exactly recognized type when possible.
852 ;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES*
853 ;;; as a starting point. But something like PLUSP isn't in there.
854 ;;; On the other hand, either of these points may not be sources of
855 ;;; inefficiency, and the latter if implemented might have undesirable
856 ;;; user-visible ramifications, though it seems unlikely.
857 (def-type-model (hairy-type (:constructor
* %make-hairy-type
(specifier)))
858 ;; the Common Lisp type-specifier of the type we represent.
859 ;; In UNKNOWN types this can only be a symbol.
860 ;; For other than an unknown type, this must be a (SATISFIES f) expression.
861 ;; The reason we can't constrain this to
862 ;; (OR SYMBOL (CONS (EQL SATISFIES) (CONS SYMBOL NULL)))
863 ;; is that apparently we'll store _illegal_ type specifiers in a hairy-type.
864 ;; There's an example in the regression test named
865 ;; :single-warning-for-single-undefined-type
866 (specifier nil
:type t
:test equal
:hasher sb-c
::fallback-hash
))
868 (macrolet ((hash-fp-zeros (x) ; order-insensitive
870 (dolist (x ,x h
) (setq h
(logxor (sb-xc:sxhash x
) h
)))))
872 `(let ((a ,a
) (b ,b
))
873 (and (= (length a
) (length b
))
874 (every (lambda (x) (member x b
)) a
)))))
875 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
876 ;;; bother with this at this level because MEMBER types are fairly
877 ;;; important and union and intersection are well defined.
878 (def-type-model (member-type (:constructor
* nil
(xset fp-zeroes
)))
879 (xset nil
:type xset
:hasher xset-elts-hash
:test xset
=)
880 (fp-zeroes nil
:type list
:hasher hash-fp-zeros
:test fp-zeros
=)))
881 (define-load-time-global *xset-mutex
* (or #-sb-xc-host
(sb-thread:make-mutex
:name
"xset")))
882 ;;; This hashset is guarded by *XSET-MUTEX*. It is _not_ declared as synchronized
883 ;;; so that HASHSET-INSERT-IF-ABSENT should not acquire a mutex inside a mutex
884 ;;; (stable hashes have to be assigned while holding the lock)
885 (define-load-time-global *member
/eq-type-hashset
*
886 (make-hashset 32 #'member-type-equiv
#'calc-member-type-hash
887 :weakness t
:synchronized nil
))
888 (pushnew '*member
/eq-type-hashset
* *ctype-hashsets
*)
890 ;;; An ARRAY-TYPE is used to represent any array type, including
891 ;;; things such as SIMPLE-BASE-STRING.
892 (macrolet ((hash-dims (list)
893 ;; We should not use our SXHASH on ARRAY-TYPE-DIMENSIONS because it cuts off at 5 items:
894 ;; * (loop for i from 4 to 7 do (format t "~d ~x~%" i (sxhash (make-list i))))
900 #x1980B71D
; = (ldb (byte 29 0) (sxhash '*)) not that it matters
902 (dolist (dim ,list h
)
903 (setq h
(mix (sb-xc:sxhash dim
) h
)))))))
904 (def-type-model (array-type
906 (:constructor
* %make-array-type
907 (dimensions complexp element-type
908 specialized-element-type
)))
909 ;; the dimensions of the array, or * if unspecified. If a dimension
910 ;; is unspecified, it is *.
911 (dimensions '* :type
(or list
(eql *)) :test equal
:hasher hash-dims
)
912 ;; Is this not a simple array type? (:MAYBE means that we don't know.)
913 (complexp :maybe
:type
(member t nil
:maybe
)
914 :hasher
(lambda (s) (case s
(:maybe
#36rMAYBE
) ((nil) #xffff
) (t 1))))
915 ;; the element type as originally specified
916 (element-type nil
:type ctype
)
917 ;; the element type as it is specialized in this implementation
918 ;; Strangely, this is *NOT* a pure function of ELEMENT-TYPE.
920 ;; The :unparse-safely test in 'type.pure' produces the following result:
921 ;; (describe (type-intersection (specifier-type '(vector (or bit character)))
922 ;; (specifier-type `(vector (or bit symbol)))))
924 ;; #<ARRAY-TYPE (VECTOR T)>
925 ;; [structure-object]
926 ;; Slots with :INSTANCE allocation:
927 ;; %BITS = 1443812512
930 ;; ELEMENT-TYPE = #<NUMERIC-TYPE BIT>
931 ;; SPECIALIZED-ELEMENT-TYPE = #<NAMED-TYPE T>
933 ;; Frankly I'm somewhat disinclined to believe this result
934 ;; because intuitively the specialization is what you would get if you
935 ;; asked the question "how would an array of <x> be specialized?"
936 (specialized-element-type nil
:type ctype
)))
938 (macrolet ((hash-ranges (list)
940 (dolist (pair ,list h
)
941 (setq h
(mix (sb-xc:sxhash
(cdr pair
))
942 (mix h
(sb-xc:sxhash
(car pair
)))))))))
943 (def-type-model (character-set-type (:constructor
* nil
(pairs)))
944 ;; these get canonically ordered by the parser
945 (pairs (missing-arg) :type list
:test equal
:hasher hash-ranges
)))
947 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
948 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
949 (def-type-model (compound-type) ; no direct instances
950 ;; Formerly defined in every CTYPE, but now just in the ones
951 ;; for which enumerability is variable.
952 ;; This is a pure function of TYPES and need not be part of the hash
953 (enumerable nil
:type boolean
:hasher nil
)
954 ;; This list must have at least 2 items in it.
955 ;; A singleton would not be a compound type.
956 ;; An empty OR is the type NIL, and an empty AND is type T.
957 (types nil
:type
(cons t cons
) :hasher hash-ctype-set
:test eq
)) ; list is hash-consed
958 (defun compound-type-flags (type) (type-list-flags (compound-type-types type
)))
960 ;;; A UNION-TYPE represents a use of the OR type specifier which we
961 ;;; couldn't canonicalize to something simpler. Canonical form:
962 ;;; 1. All possible pairwise simplifications (using the UNION2 type
963 ;;; methods) have been performed. Thus e.g. there is never more
964 ;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
965 ;;; this hadn't been fully implemented yet.
966 ;;; 2. There are never any UNION-TYPE components.
967 (def-type-model (union-type
968 (:constructor
* nil
(enumerable types
))
969 (:include compound-type
)))
971 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
972 ;;; which we couldn't canonicalize to something simpler. Canonical form:
973 ;;; 1. All possible pairwise simplifications (using the INTERSECTION2
974 ;;; type methods) have been performed. Thus e.g. there is never more
975 ;;; than one MEMBER-TYPE component.
976 ;;; 2. There are never any INTERSECTION-TYPE components: we've
977 ;;; flattened everything into a single INTERSECTION-TYPE object.
978 ;;; 3. There are never any UNION-TYPE components. Either we should
979 ;;; use the distributive rule to rearrange things so that
980 ;;; unions contain intersections and not vice versa, or we
981 ;;; should just punt to using a HAIRY-TYPE.
982 (def-type-model (intersection-type
983 (:constructor
* nil
(enumerable types
))
984 (:include compound-type
)))
986 (def-type-model (alien-type-type (:constructor
* %make-alien-type-type
(alien-type)))
987 (alien-type nil
:type alien-type
:hasher sb-alien
::alien-type-hash
:test eq
))
989 (def-type-model (negation-type (:constructor
* make-negation-type
(type)))
990 (type (missing-arg) :type ctype
))
992 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
993 ;;; defined). We make this distinction since we don't want to complain
994 ;;; about types that are hairy but defined.
995 (def-type-model (unknown-type (:constructor
* make-unknown-type
(specifier))
996 (:include hairy-type
)))
998 ;;; a list of all the float "formats" (i.e. internal representations;
999 ;;; nothing to do with #'FORMAT), in order of decreasing precision
1000 (defglobal *float-formats
*
1001 '(long-float double-float single-float short-float
))
1003 ;;; The type of a float format.
1004 (deftype float-format
() `(member ,@*float-formats
*))
1006 ;;; Using 3 separate fields to represent information with fewer than 4 bits
1007 ;;; of entropy is a terribly wasteful representation choice.
1008 ;;; (4 bits = 16 possibilities but in fact there are only 9 valid combinations)
1009 (defstruct (numtype-aspects
1010 (:constructor
!make-numeric-aspects
(complexp class precision id
))
1013 ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
1014 (complexp :real
:read-only t
:type
(member :real
:complex nil
))
1015 ;; the kind of numeric type we have, or NIL if the type is NUMBER.
1016 ;; The types corresponding to all of REAL or all of COMPLEX are UNION types,
1017 ;; and no constituent type thereof will have a NIL here.
1018 (class nil
:read-only t
:type
(member integer rational float nil
))
1019 ;; "precision" for a float type (i.e. type specifier for a CPU
1020 ;; representation of floating point, e.g. 'SINGLE-FLOAT).
1021 ;; NIL if and only if CLASS is not FLOAT
1022 (precision nil
:read-only t
:type
(member single-float double-float nil
))
1023 ;; a value that uniquely identifies this triple of <complexp,class,precision>
1024 (id 0 :read-only t
:type
(unsigned-byte 8)))
1026 ;;; There legal combinations of (COMPLEXP CLASS PRECISION) are as follows:
1027 ;;; 0. (NIL NIL NIL)
1028 ;;; 1. (:REAL FLOAT SINGLE-FLOAT) and 2. (:REAL FLOAT DOUBLE-FLOAT)
1029 ;;; 3. (:COMPLEX FLOAT SINGLE-FLOAT) and 4. (:COMPLEX FLOAT DOUBLE-FLOAT)
1030 ;;; 5. (:REAL INTEGER) 6. (:COMPLEX INTEGER)
1031 ;;; 7. (:REAL RATIONAL) 8. (:COMPLEX RATIONAL)
1032 ;;; any other combination that would attempt to carve out a subset
1033 ;;; of the numeric type space will instead be a UNION type.
1034 (declaim (inline !compute-numtype-aspect-id
))
1035 (defun !compute-numtype-aspect-id
(complexp class precision
)
1036 (declare (type (member :real
:complex nil
) complexp
)
1037 (type (member integer rational float nil
) class
)
1038 (type (member single-float double-float nil
) precision
))
1039 (unless (eq class
'float
) (aver (not precision
)))
1041 (float (+ (if (eq complexp
:real
) 1 3)
1042 (if (eq precision
'single-float
) 0 1)))
1043 (integer (if (eq complexp
:real
) 5 6))
1044 (rational (if (eq complexp
:real
) 7 8))
1045 (t (aver (not class
))
1046 (aver (not complexp
))
1048 (declaim (notinline !compute-numtype-aspect-id
))
1050 ;;; force the SBCL-default initial value, because genesis also 0-fills it
1051 (defglobal *numeric-aspects-v
* (make-array 9 :initial-element
0))
1052 (declaim (type (simple-vector 9) *numeric-aspects-v
*))
1053 (loop for
(complexp class precision
)
1055 (:real float single-float
) (:real float double-float
)
1056 (:complex float single-float
) (:complex float double-float
)
1057 (:real integer nil
) (:complex integer nil
)
1058 (:real rational nil
) (:complex rational nil
))
1059 do
(let ((index (!compute-numtype-aspect-id complexp class precision
)))
1060 (when (eql (aref *numeric-aspects-v
* index
) 0)
1061 (setf (aref *numeric-aspects-v
* index
)
1062 (!make-numeric-aspects complexp class precision index
)))))
1064 (defmacro get-numtype-aspects
(&rest rest
)
1066 (aref *numeric-aspects-v
* (!compute-numtype-aspect-id
,@rest
))))
1068 (macrolet ((numbound-hash (b)
1069 ;; It doesn't matter what the hash of a number is, as long as it's stable.
1072 (multiple-value-bind (h v
)
1074 (if x
(values #x55AA55
(car x
)) (return 0))
1076 (logxor h
(sb-c::number-hash v
))))))
1078 ;; Determine whether the 'low' and 'high' slots of two NUMERIC-TYPE instances
1079 ;; are "the same". It is a stricter test than in the SIMPLE-= method, because
1080 ;; the cache preserves distinctions that the type algebra does not,
1081 ;; specifically in regard to signed zeros.
1082 `(let ((a ,a
) (b ,b
))
1084 (and (listp b
) (eql (car a
) (car b
)))
1086 ;;; A NUMERIC-TYPE represents any numeric type, including things
1088 (def-type-model (numeric-type
1090 (:constructor
* nil
(aspects low high
)))
1091 (aspects (missing-arg) :type numtype-aspects
:hasher numtype-aspects-id
:test eq
)
1092 (low nil
:type
(or real
(cons real null
) null
)
1093 :hasher numbound-hash
:test numbound-eql
)
1094 (high nil
:type
(or real
(cons real null
) null
)
1095 :hasher numbound-hash
:test numbound-eql
)))
1096 (declaim (inline numeric-type-complexp numeric-type-class numeric-type-format
))
1097 (defun numeric-type-complexp (x) (numtype-aspects-complexp (numeric-type-aspects x
)))
1098 (defun numeric-type-class (x) (numtype-aspects-class (numeric-type-aspects x
)))
1099 (defun numeric-type-format (x) (numtype-aspects-precision (numeric-type-aspects x
)))
1101 ;;; A CONS-TYPE is used to represent a CONS type.
1102 (def-type-model (cons-type (:constructor
* nil
(car-type cdr-type
)))
1103 ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
1104 (car-type (missing-arg) :type ctype
)
1105 (cdr-type (missing-arg) :type ctype
))
1107 ;;; ARGS-TYPE objects are used both to represent VALUES types and
1108 ;;; to represent FUNCTION types.
1109 ;;; This used to contain slots for KEYP,KEYWORDS,ALLOWP which could never
1110 ;;; be useful in a VALUES-TYPE.
1111 ;;; CMUCL rev 2e8488e0ace2d21a3d7af217037bcb445cc93496 said
1112 ;;; "(values) <type translator>: Disallow &key and &allow-other-keys"
1113 ;;; but they kept all the slots in ARGS-TYPE.
1114 (macrolet ((hash-ctype-or-null (x)
1115 `(let ((x ,x
)) (if x
(type-hash-value x
) 0))))
1116 (def-type-model (args-type (:constructor
* nil
(required optional rest
)))
1117 ;; Lists of the type for each required and optional argument.
1118 (required nil
:type list
:hasher hash-ctype-list
:test eq
) ; hash-consed list
1119 (optional nil
:type list
:hasher hash-ctype-list
:test eq
) ; hash-consed list
1120 ;; The type for the rest arg. NIL if there is no &REST arg.
1121 (rest nil
:type
(or ctype null
) :hasher hash-ctype-or-null
:test eq
)))
1123 ;;; the description of a &KEY argument
1124 (declaim (inline !make-key-info
))
1125 (defstruct (key-info #-sb-xc-host
(:pure t
)
1126 (:constructor
!make-key-info
(name type
))
1128 ;; the key (not necessarily a keyword in ANSI Common Lisp)
1129 (name (missing-arg) :type symbol
:read-only t
)
1130 ;; the type of the argument value
1131 (type (missing-arg) :type ctype
:read-only t
))
1132 (declaim (freeze-type key-info
))
1134 (defmethod print-object ((self key-info
) stream
)
1135 (print-unreadable-object (self stream
:type t
)
1136 (format stream
"(~S ~S)"
1137 (key-info-name self
)
1138 (type-specifier (key-info-type self
)))))
1139 (defun key-info= (a b
)
1140 (declare (optimize (safety 0)))
1141 (and (eq (key-info-name a
) (key-info-name b
))
1142 (eq (key-info-type a
) (key-info-type b
))))
1143 (defun key-info-hash (x)
1144 (declare (optimize (safety 0)))
1145 (murmur-hash-word/+fixnum
1146 (mix (type-hash-value (key-info-type x
)) (symbol-hash (key-info-name x
)))))
1148 (defun hash-key-info-set (set) ; order-insensitive
1149 (declare (optimize (safety 0)))
1151 (declare (type sb-xc
:fixnum h
))
1152 ;; Don't need the answer to be positive for key-info-set-hashset,
1153 ;; but do need it to be positive when hashing ARGS-TYPE which uses MIX.
1154 (dolist (elt set
(logand h sb-xc
:most-positive-fixnum
))
1155 (setf h
(plus-mod-fixnum (truly-the sb-xc
:fixnum
(key-info-hash elt
)) h
)))))
1157 (defun key-info-list-flags (list)
1159 (dolist (elt list
(logand bits
+ctype-flag-mask
+))
1160 (setq bits
(logior bits
(type-%bits
(key-info-type elt
)))))))
1162 (define-load-time-global *key-info-hashset
*
1163 (make-hashset 32 #'key-info
= #'key-info-hash
:weakness t
:synchronized t
))
1164 (define-load-time-global *key-info-set-hashset
*
1165 (make-hashset 32 #'ctype-set
= #'hash-key-info-set
:weakness t
:synchronized t
))
1167 (defun make-key-info (key type
)
1168 (dx-let ((x (!make-key-info key type
)))
1169 (hashset-insert-if-absent *key-info-hashset
* x
1170 (named-lambda "MAKE-KEY-INFO" (x)
1171 (!make-key-info
(key-info-name x
) (key-info-type x
))))))
1172 (defun intern-key-infos (list)
1174 ;; I suppose we don't have to COPY-LIST to insert.
1175 (hashset-insert-if-absent *key-info-set-hashset
* list
#'identity
)))
1177 (def-type-model (values-type (:constructor
* nil
(required optional rest
))
1178 (:include args-type
)))
1179 (declaim (freeze-type values-type
))
1181 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
1182 (def-type-model (fun-type
1183 (:constructor
* nil
(required optional rest keyp keywords allowp
1185 (:include args-type
))
1186 ;; true if &KEY arguments are specified
1187 (keyp nil
:type boolean
)
1188 ;; list of KEY-INFO structures describing the &KEY arguments
1189 (keywords nil
:type list
:hasher hash-key-info-set
:test eq
) ; hash-consed already
1190 ;; true if other &KEY arguments are allowed
1191 (allowp nil
:type boolean
)
1192 ;; true if the arguments are unrestrictive, i.e. *
1193 (wild-args nil
:type boolean
)
1194 ;; type describing the return values. This is a values type
1195 ;; when multiple values were specified for the return.
1196 (returns (missing-arg) :type ctype
))
1198 (declaim (inline args-type-keyp args-type-keywords args-type-allowp
))
1199 (defun args-type-keyp (type) (and (fun-type-p type
) (fun-type-keyp type
)))
1200 (defun args-type-keywords (type) (and (fun-type-p type
) (fun-type-keywords type
)))
1201 (defun args-type-allowp (type) (and (fun-type-p type
) (fun-type-allowp type
)))
1203 (def-type-model (fun-designator-type
1204 (:constructor
* nil
(required optional rest keyp keywords allowp
1206 (:include fun-type
)))
1208 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
1209 ;;; "type specifier", which is only meaningful in function argument
1210 ;;; type specifiers used within the compiler. (It represents something
1211 ;;; that the compiler knows to be a constant.)
1212 (def-type-model (constant-type (:constructor
* nil
(type)))
1213 ;; The type which the argument must be a constant instance of for this type
1214 ;; specifier to win.
1215 (type (missing-arg) :type ctype
))
1218 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
1220 (def-type-model (simd-pack-type
1221 (:constructor
* %make-simd-pack-type
(tag-mask)))
1222 (tag-mask (missing-arg) ; bitmask over possible simd-pack-tag values
1223 :test
= :hasher identity
; the tag-mask is its own hash
1224 :type
(and (unsigned-byte #.
(length +simd-pack-element-types
+))
1228 (def-type-model (simd-pack-256-type
1229 (:constructor
* %make-simd-pack-256-type
(tag-mask)))
1230 (tag-mask (missing-arg)
1231 :test
= :hasher identity
; the tag-mask is its own hash
1232 :type
(and (unsigned-byte #.
(length +simd-pack-element-types
+))
1235 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) csubtypep
))
1236 ;;; Look for nice relationships for types that have nice relationships
1237 ;;; only when one is a hierarchical subtype of the other.
1238 (defun hierarchical-intersection2 (type1 type2
)
1239 ;; *EMPTY-TYPE* is involved in a dependency cycle: It wants to be a constant
1240 ;; instance of NAMED-TYPE. To construct an instance of a type, you need a
1241 ;; type-class. A type-class needs to refer to this function, which refers
1242 ;; to *EMPTY-TYPE*, which .... etc.
1243 ;; In the cross-compiler, it is actually a constant.
1244 #+sb-xc-host
(declare (special *empty-type
*))
1245 (multiple-value-bind (subtypep1 win1
) (csubtypep type1 type2
)
1246 (multiple-value-bind (subtypep2 win2
) (csubtypep type2 type1
)
1247 (cond (subtypep1 type1
)
1249 ((and win1 win2
) *empty-type
*)
1252 (defun hierarchical-union2 (type1 type2
)
1253 (cond ((csubtypep type1 type2
) type2
)
1254 ((csubtypep type2 type1
) type1
)
1257 (!defun-from-collected-cold-init-forms
!type-class-cold-init
)
1259 (defglobal *alien-type-hashsets
* nil
)
1260 (export 'show-ctype-ctor-cache-metrics
)
1261 ;;; The minimum hashset storage size is 64 elements, so a bunch of the caches
1262 ;;; start out with too-low load-factor, being somewhat oversized.
1263 ;;; The EQL table never sizes down (because our hash-tables don't)
1264 ;;; so it may operate at a fairly low load factor.
1265 ;;; Other than that we should expect load factors between 50% and 75%.
1266 ;;; So it's extremely unexpected that List starts out with a load-factor of 12%.
1267 ;;; Probably should investigate, though it's harmless.
1268 (defun show-ctype-ctor-cache-metrics ()
1271 (if (hash-table-p x
) (hash-table-count x
) (sb-impl::hashset-count x
)))
1272 (display (caches &aux
(total 0))
1273 (dolist (cache (sort caches
#'> ; decreasing cout
1274 :key
(lambda (x) (tablecount (second x
)))))
1276 ((name (first cache
))
1277 (table (second cache
))
1278 (count (tablecount table
))
1279 ((load seeks hit psl mask
)
1280 (if (hash-table-p table
)
1281 (values #+sb-xc-host nil
1284 (ash (length (sb-impl::hash-table-pairs table
)) -
1))
1285 nil nil nil nil nil
) ; FIXME: compute PSL and mask
1286 (let* ((cells (sb-impl::hss-cells
(sb-impl::hashset-storage table
)))
1287 (psl (sb-impl::hs-cells-max-psl cells
))
1288 (mask (sb-impl::hs-cells-mask cells
))
1289 (lf (/ count
(1+ mask
))))
1290 #-hashset-metrics
(values lf nil nil psl mask
)
1292 (let ((seeks (sb-impl::hashset-count-finds table
)))
1295 (/ (sb-impl::hashset-count-find-hits table
) seeks
))
1299 " ~16a: ~7D ~5,1,2F%~#[~:; ~:[ ~;~:*~8D~] ~:[ ~;~:*~4,1,2f%~]~
1302 (unless (hash-table-p table
) (list seeks hit psl mask
)))))
1303 (format t
" ~16A: ~7D~%" "Total" total
)))
1305 (push (list "List" *ctype-list-hashset
*) caches
)
1306 (push (list "Set" *ctype-set-hashset
*) caches
)
1307 (push (list "Key-Info" *key-info-hashset
*) caches
)
1308 (push (list "Key-Info-Set" *key-info-set-hashset
*) caches
)
1309 (push (list "EQL" *eql-type-cache
*) caches
)
1310 (dolist (symbol *ctype-hashsets
*)
1311 (push (list (subseq (string symbol
) 1
1312 (- (length (string symbol
)) (length "-TYPE-HASHSET*")))
1313 (symbol-value symbol
))
1315 (format t
"~&ctype cache metrics: Count LF Seek Hit maxPSL Mask~%")
1318 (format t
"~&Alien:~%")
1319 (dolist (symbol *alien-type-hashsets
*)
1320 (let ((name (subseq (string symbol
) 1
1321 (- (length (string symbol
)) (length "-TYPE-CACHE*")))))
1322 (push (list (if (char= (char name
0) #\A
) (subseq name
6) name
)
1323 (symbol-value symbol
))
1327 ;;; *TYPE-CLASS-LIST* is defined only in the host. When the cross-compiler
1328 ;;; expands TYPEP-IMPL-MACRO it get the value of this symbol from the host's
1329 ;;; value. This function avoids a warning about a missing symbol.
1330 (defun type-class-name-list () (mapcar 'car
(symbol-value '*type-class-list
*)))
1332 ;;; CAUTION: unhygienic macro specifically designed to expand into body code
1333 ;;; for TYPEP, CTYPEP (compiler-typep), or CROSS-TYPEP (cross-compiler-[c]typep)
1334 (defmacro typep-impl-macro
((thing &key
(defaults t
)) &rest more-clauses
&aux seen
)
1335 (labels ((convert-clause (clause)
1336 (let ((metatype (car clause
)))
1337 `(,(if (and (consp metatype
) (eq (car metatype
) 'or
))
1338 (mapcar #'metatype-name-
>class-id
(cdr metatype
))
1339 (list (metatype-name->class-id metatype
)))
1340 (let ((type (truly-the ,metatype type
))) ,@(cdr clause
)))))
1341 (metatype-name->class-id
(name)
1342 ;; See also DEFINE-TYPE-METHOD which needs the inverse mapping.
1343 ;; Maybe it should be stored globally in an alist?
1344 (let* ((type-class-name
1346 ((values-type constant-type
)
1347 (bug "Unexpected type ~S in CTYPEP-MACRO" name
))
1348 (classoid 'classoid
)
1349 (numeric-type 'number
)
1350 (fun-type 'function
)
1351 (alien-type-type 'alien
)
1352 ;; remove "-TYPE" suffix from name of type's type to get
1353 ;; name of type-class.
1354 (t (intern (subseq (string name
) 0 (- (length (string name
)) 5))
1356 (id (type-class-name->id type-class-name
)))
1357 (when (member type-class-name seen
)
1358 (bug "Duplicated type-class: ~S" name
))
1359 (push type-class-name seen
)
1364 `(;; Standard AND, NOT, OR combinators
1366 (any/type
#'recurse
,thing
(union-type-types type
)))
1368 (every/type
#'recurse
,thing
(intersection-type-types type
)))
1370 (multiple-value-bind (result certain
)
1371 (recurse ,thing
(negation-type-type type
))
1373 (values (not result
) t
)
1375 ;; CONS is basically an AND type and can be handled generically here.
1376 ;; This is correct in the cross-compiler so long as there are no atoms
1377 ;; in the host that represent target conses or vice-versa.
1381 (multiple-value-bind (result certain
)
1382 (recurse (car ,thing
) (cons-type-car-type type
))
1384 (recurse (cdr ,thing
) (cons-type-cdr-type type
))
1385 (values nil certain
)))))))
1387 `(named-let recurse
((,thing
,thing
) (type type
))
1388 (flet ((test-keywordp ()
1389 ;; answer with certainty sometimes
1390 (cond ((or (not (symbolp ,thing
))
1391 (let ((pkg (sb-xc:symbol-package
,thing
)))
1392 (or (eq pkg
*cl-package
*)
1393 ;; The user can't re-home our symbols in KEYWORD.
1394 (and pkg
(system-package-p pkg
)))))
1395 (values nil t
)) ; certainly no
1396 ((eq (sb-xc:symbol-package
,thing
) *keyword-package
*)
1397 (values t t
)) ; certainly yes
1399 (values nil nil
)))) ; can't decide
1400 (test-character-type (type)
1401 (when (characterp ,thing
)
1402 (let ((code (char-code ,thing
)))
1403 (dolist (pair (character-set-type-pairs type
) nil
)
1404 (destructuring-bind (low . high
) pair
1405 (when (<= low code high
)
1407 ;; It should always work to dispatch by class-id, but ALIEN-TYPE-TYPE
1408 ;; is a problem in the cross-compiler due to not having a type-class-id
1409 ;; when 'src/code/cross-type' is compiled. I briefly tried moving
1410 ;; it later, but then type-init failed to compile.
1412 (etypecase type
,@clauses
)
1414 (case (truly-the (mod ,(length *type-classes
*)) (type-class-id type
))
1415 ,@(let ((clauses (mapcar #'convert-clause clauses
)))
1416 (let ((absent (loop for class in
(type-class-name-list)
1417 unless
(or (member class
'(values constant
))
1418 (member class seen
))
1421 (error "Unhandled type-classes: ~S" absent
)))
1424 ;;; Common logic for %%TYPEP and CROSS-TYPEP to test numeric types
1425 (defmacro number-typep
(object type
)
1426 `(let ((object ,object
) (type ,type
))
1427 (and (numberp object
)
1428 (let ((num (if (complexp object
) (realpart object
) object
)))
1429 (ecase (numeric-type-class type
)
1430 (integer (and (integerp num
)
1431 ;; If the type is (COMPLEX INTEGER), it can
1432 ;; only match the object if both real and imag
1433 ;; parts are integers.
1434 (or (not (complexp object
))
1435 (integerp (imagpart object
)))))
1436 (rational (rationalp num
))
1438 (ecase (numeric-type-format type
)
1439 ;; (short-float (typep num 'short-float))
1440 (single-float (typep num
'single-float
))
1441 (double-float (typep num
'double-float
))
1442 ;; (long-float (typep num 'long-float))
1443 ((nil) (floatp num
))))
1445 (flet ((bound-test (val)
1446 (and (let ((low (numeric-type-low type
)))
1447 (cond ((null low
) t
)
1448 ((listp low
) (sb-xc:> val
(car low
)))
1449 (t (sb-xc:>= val low
))))
1450 (let ((high (numeric-type-high type
)))
1451 (cond ((null high
) t
)
1452 ((listp high
) (sb-xc:< val
(car high
)))
1453 (t (sb-xc:<= val high
)))))))
1454 (ecase (numeric-type-complexp type
)
1457 (and (complexp object
)
1458 (bound-test (realpart object
))
1459 (bound-test (imagpart object
))))
1461 (and (not (complexp object
))
1462 (bound-test object
))))))))
1464 ;;; Drop NILs, possibly reducing the storage vector length
1465 (defun rebuild-ctype-hashsets ()
1466 (dolist (sym (list* '*key-info-hashset
* '*key-info-set-hashset
*
1468 (sb-impl::hashset-rehash
(symbol-value sym
) nil
)))
1470 ;;; a flag that causes TYPE-SPECIFIER to represent UNKNOWN-TYPE
1471 ;;; as itself rather than the symbol naming the type so that the printed
1472 ;;; representation is not confusable for a good type of the same name.
1473 (defconstant +ctype-unparse-disambiguate
+ 1)
1474 ;;; a flag that causes all function types to unparse as FUNCTION.
1475 ;;; This is useful when we want a specifier that we can pass to TYPEP.
1476 (defconstant +unparse-fun-type-simplify
+ 2)
1478 (defmethod print-object ((ctype ctype
) stream
)
1480 (if (unknown-type-p ctype
)
1481 ;; Don't call the unparse method - it returns the instance itself
1482 ;; which would infinitely recurse back into print-object
1483 (unknown-type-specifier ctype
)
1484 (funcall (type-class-unparse (type-class ctype
))
1485 +ctype-unparse-disambiguate
+
1487 (print-unreadable-object (ctype stream
:type t
)
1488 (prin1 expr stream
))))