1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!KERNEL")
12 (eval-when (:compile-toplevel
#+sb-xc-host
:load-toplevel
:execute
)
13 ;; The following macros expand into either constructor calls,
14 ;; if building the cross-compiler, or forms which reference
15 ;; previously constructed objects, if running the cross-compiler.
18 (defmacro literal-ctype
(constructor &optional specifier
)
19 (declare (ignore specifier
))
20 ;; Technically the instances are not read-only,
21 ;; because the hash-value slot is rewritten.
22 `(load-time-value (mark-ctype-interned ,constructor
) nil
))
24 (defmacro literal-ctype-vector
(var)
25 `(load-time-value ,var nil
)))
29 ;; Omitting the specifier works only if the unparser method has been
30 ;; defined in time to use it, and you're sure that constructor's result
31 ;; can be unparsed - some unparsers may be confused if called on a
32 ;; non-canonical object, such as an instance of (CONS T T) that is
33 ;; not EQ to the interned instance.
34 (sb!xc
:defmacro literal-ctype
(constructor
35 &optional
(specifier nil specifier-p
))
36 ;; The source-transform for SPECIFIER-TYPE turns this call into
37 ;; (LOAD-TIME-VALUE (!SPECIFIER-TYPE ',specifier)).
38 ;; It's best to go through the transform rather than expand directly
39 ;; into that, because the transform canonicalizes the spec,
40 ;; ensuring correctness of the hash lookups performed during genesis.
41 `(specifier-type ',(if specifier-p
43 (type-specifier (symbol-value constructor
)))))
45 (sb!xc
:defmacro literal-ctype-vector
(var)
46 (let ((vector (symbol-value var
)))
47 `(truly-the (simple-vector ,(length vector
))
52 `(!specifier-type
',(type-specifier x
))
53 x
)) ; allow NIL or 0 in the vector
56 (!begin-collecting-cold-init-forms
)
58 ;;;; representations of types
60 ;;; A HAIRY-TYPE represents anything too weird to be described
61 ;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
62 ;;; and unreasonably complicated types involving AND. We just remember
63 ;;; the original type spec.
64 ;;; A possible improvement would be for HAIRY-TYPE to have a subtype
65 ;;; named SATISFIES-TYPE for the hairy types which are specifically
66 ;;; of the form (SATISFIES pred) so that we don't have to examine
67 ;;; the sexpr repeatedly to decide whether it takes that form.
68 ;;; And as a further improvement, we might want a table that maps
69 ;;; predicates to their exactly recognized type when possible.
70 ;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES*
71 ;;; as a starting point. But something like PLUSP isn't in there.
72 ;;; On the other hand, either of these points may not be sources of
73 ;;; inefficiency, and the latter if implemented might have undesirable
74 ;;; user-visible ramifications, though it seems unlikely.
75 (defstruct (hairy-type (:include ctype
76 (class-info (type-class-or-lose 'hairy
)))
77 (:constructor %make-hairy-type
(specifier))
80 ;; the Common Lisp type-specifier of the type we represent
81 (specifier nil
:type t
:read-only t
))
83 ;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
84 ;; e.g. any SATISFIES with a predicate returning T over a finite domain.
85 ;; But in practice there's nothing that can be done with this information,
86 ;; because we don't call random predicates when performing operations on types
87 ;; as objects, only when checking for inclusion of something in the type.
88 (!define-type-class hairy
:enumerable t
:might-contain-other-types t
)
90 ;;; Without some special HAIRY cases, we massively pollute the type caches
91 ;;; with objects that are all equivalent to *EMPTY-TYPE*. e.g.
92 ;;; (AND (SATISFIES LEGAL-FUN-NAME-P) (SIMPLE-ARRAY CHARACTER (*))) and
93 ;;; (AND (SATISFIES KEYWORDP) CONS). Since the compiler doesn't know
94 ;;; that they're just *EMPTY-TYPE*, its keeps building more and more complex
95 ;;; expressions involving them. I'm not sure why those two are so prevalent
96 ;;; but they definitely seem to be. We can improve performance by reducing
97 ;;; them to *EMPTY-TYPE* which means we need a way to recognize those hairy
98 ;;; types in order reason about them. Interning them is how we recognize
99 ;;; them, as they can be compared by EQ.
102 (defvar *satisfies-keywordp-type
*
103 (mark-ctype-interned (%make-hairy-type
'(satisfies keywordp
))))
104 (defvar *fun-name-type
*
105 (mark-ctype-interned (%make-hairy-type
'(satisfies legal-fun-name-p
)))))
107 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
108 ;;; defined). We make this distinction since we don't want to complain
109 ;;; about types that are hairy but defined.
110 (defstruct (unknown-type (:include hairy-type
)
113 (defun maybe-reparse-specifier (type)
114 (when (unknown-type-p type
)
115 (let* ((spec (unknown-type-specifier type
))
116 (name (if (consp spec
)
119 (when (info :type
:kind name
)
120 (let ((new-type (specifier-type spec
)))
121 (unless (unknown-type-p new-type
)
125 (defmacro maybe-reparse-specifier
! (type)
126 (assert (symbolp type
))
127 (with-unique-names (new-type)
128 `(let ((,new-type
(maybe-reparse-specifier ,type
)))
130 (setf ,type
,new-type
)
133 (defstruct (negation-type (:include ctype
134 (class-info (type-class-or-lose 'negation
)))
136 (:constructor make-negation-type
(type))
138 (type (missing-arg) :type ctype
:read-only t
))
140 ;; Former comment was:
141 ;; FIXME: is this right? It's what they had before, anyway
142 ;; But I think the reason it's right is that "enumerable :t" is equivalent
143 ;; to "maybe" which is actually the conservative assumption, same as HAIRY.
144 (!define-type-class negation
:enumerable t
:might-contain-other-types t
)
146 (defun canonicalize-args-type-args (required optional rest
&optional keyp
)
147 (when (eq rest
*empty-type
*)
150 (loop with last-not-rest
= nil
153 do
(cond ((eq opt
*empty-type
*)
154 (return (values required
(subseq optional i
) rest
)))
155 ((and (not keyp
) (neq opt rest
))
156 (setq last-not-rest i
)))
157 finally
(return (values required
161 (subseq optional
0 (1+ last-not-rest
))))
164 ;; CONTEXT is the cookie passed down from the outermost surrounding call
165 ;; of VALUES-SPECIFIER-TYPE. INNER-CONTEXT-KIND is an indicator of whether
166 ;; we are currently parsing a FUNCTION or a VALUES compound type specifier.
167 (defun parse-args-types (context lambda-listy-thing inner-context-kind
)
168 (multiple-value-bind (llks required optional rest keys
)
171 :context inner-context-kind
172 :accept
(ecase inner-context-kind
173 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
174 (:function-type
(lambda-list-keyword-mask
175 '(&optional
&rest
&key
&allow-other-keys
))))
177 (flet ((parse-list (list)
178 (mapcar (lambda (x) (single-value-specifier-type-r context x
))
180 (let ((required (parse-list required
))
181 (optional (parse-list optional
))
182 (rest (when rest
(single-value-specifier-type-r context
(car rest
))))
184 (collect ((key-info))
186 (unless (proper-list-of-length-p key
2)
187 (error "Keyword type description is not a two-list: ~S." key
))
188 (let ((kwd (first key
)))
189 (when (find kwd
(key-info) :key
#'key-info-name
)
190 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
191 kwd lambda-listy-thing
))
194 ;; MAKE-KEY-INFO will complain if KWD is not a symbol.
195 ;; That's good enough - we don't need an extra check here.
197 :type
(single-value-specifier-type-r context
(second key
))))))
199 (multiple-value-bind (required optional rest
)
200 (canonicalize-args-type-args required optional rest
202 (values llks required optional rest keywords
))))))
204 (defstruct (values-type
206 (class-info (type-class-or-lose 'values
)))
207 (:constructor %make-values-type
)
208 (:predicate %values-type-p
)
211 (declaim (inline values-type-p
))
212 (defun values-type-p (x)
213 (or (eq x
*wild-type
*)
216 (defun-cached (make-values-type-cached
219 (lambda (req opt rest allowp
)
220 (logxor (type-list-cache-hash req
)
221 (type-list-cache-hash opt
)
223 (type-hash-value rest
)
225 ;; Results (logand #xFF (sxhash t/nil))
226 ;; hardcoded to avoid relying on the xc host.
227 ;; [but (logand (sxhash nil) #xff) => 2
228 ;; for me, so the code and comment disagree,
229 ;; but not in a way that matters.]
233 ((required equal-but-no-car-recursion
)
234 (optional equal-but-no-car-recursion
)
237 (%make-values-type
:required required
242 (defun make-values-type (&key required optional rest allowp
)
243 (multiple-value-bind (required optional rest
)
244 (canonicalize-args-type-args required optional rest
)
245 (cond ((and (null required
)
247 (eq rest
*universal-type
*))
249 ((memq *empty-type
* required
)
251 (t (make-values-type-cached required optional
254 (!define-type-class values
:enumerable nil
255 :might-contain-other-types nil
)
257 (!define-type-class function
:enumerable nil
258 :might-contain-other-types nil
)
261 (defvar *interned-fun-types
*
264 (%make-fun-type
(make-list n
:initial-element
*universal-type
*)
265 nil nil nil nil nil nil
*wild-type
*))))
266 (vector (fun-type 0) (fun-type 1) (fun-type 2) (fun-type 3))))
268 (defun make-fun-type (&key required optional rest
271 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
272 (n (length required
)))
274 (not optional
) (not rest
) (not keyp
)
275 (not keywords
) (not allowp
) (not wild-args
)
276 (eq returns
*wild-type
*)
277 (not (find *universal-type
* required
:test
#'neq
)))
278 (svref (literal-ctype-vector *interned-fun-types
*) n
)
279 (%make-fun-type required optional rest keyp keywords
280 allowp wild-args returns
))))
282 ;; This seems to be used only by cltl2, and within 'cross-type',
283 ;; where it is never used, which makes sense, since pretty much we
284 ;; never want this object, but instead the classoid FUNCTION
285 ;; if we know nothing about a function's signature.
286 ;; Maybe this should not exist unless cltl2 is loaded???
287 (defvar *universal-fun-type
*
288 (make-fun-type :wild-args t
:returns
*wild-type
*))
290 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
291 ;;; "type specifier", which is only meaningful in function argument
292 ;;; type specifiers used within the compiler. (It represents something
293 ;;; that the compiler knows to be a constant.)
294 (defstruct (constant-type
296 (class-info (type-class-or-lose 'constant
)))
298 ;; The type which the argument must be a constant instance of for this type
300 (type (missing-arg) :type ctype
:read-only t
))
302 (!define-type-class number
:enumerable
#'numeric-type-enumerable
303 :might-contain-other-types nil
)
307 ;; Work around an ABCL bug. This fails to load:
308 ;; (macrolet ((foo-it (x) `(- ,x))) (defvar *var* (foo-it 3)))
309 (defvar *interned-signed-byte-types
*)
310 (defvar *interned-unsigned-byte-types
*)
311 (macrolet ((int-type (low high
)
312 `(mark-ctype-interned
313 (%make-numeric-type
:class
'integer
:enumerable t
314 :low
,low
:high
,high
))))
315 (setq *interned-signed-byte-types
*
316 (let ((v (make-array sb
!vm
:n-word-bits
))
318 (dotimes (i sb
!vm
:n-word-bits v
)
319 (setf (svref v i
) (int-type j
(lognot j
)) j
(ash j
1)))))
320 (setq *interned-unsigned-byte-types
*
321 (let ((v (make-array (1+ sb
!vm
:n-word-bits
))))
322 (dotimes (i (length v
) v
)
323 (setf (svref v i
) (int-type 0 (1- (ash 1 i
)))))))))
325 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
326 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
328 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
329 ;;; come from parsing MEMBER. But bounded integer ranges,
330 ;;; however large, are enumerable:
331 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
332 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
333 ;;; but, in contrast,
334 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
335 ;;; I can't figure out whether this is supposed to matter.
336 ;;; Moreover, it seems like this function should be responsible
337 ;;; for figuring out the right value so that callers don't have to.
338 (defun make-numeric-type (&key class format
(complexp :real
) low high
340 (multiple-value-bind (low high
)
343 ;; INTEGER types always have their LOW and HIGH bounds
344 ;; represented as inclusive, not exclusive values.
345 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
346 (if (consp high
) (1- (type-bound-number high
)) high
)))
348 ;; no canonicalization necessary
350 ;; if interval is empty
352 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
353 (>= (type-bound-number low
) (type-bound-number high
))
355 (return-from make-numeric-type
*empty-type
*))
356 (when (and (eq class
'rational
) (integerp low
) (eql low high
))
357 (setf class
'integer
))
358 ;; Either lookup the canonical interned object for
359 ;; a point in the type lattice, or construct a new one.
362 (macrolet ((float-type (fmt complexp
)
364 (%make-numeric-type
:class
'float
:complexp
,complexp
365 :format
',fmt
:enumerable nil
)
366 ,(if (eq complexp
:complex
) `(complex ,fmt
) fmt
))))
367 (when (and (null low
) (null high
))
371 (:real
(float-type single-float
:real
))
372 (:complex
(float-type single-float
:complex
))))
375 (:real
(float-type double-float
:real
))
376 (:complex
(float-type double-float
:complex
))))))))
378 (macrolet ((int-type (low high
)
381 :class
'integer
:low
,low
:high
,high
382 :enumerable
(if (and ,low
,high
) t nil
))
383 (integer ,(or low
'*) ,(or high
'*)))))
384 (cond ((neq complexp
:real
) nil
)
385 ((and (eql low
0) (eql high
(1- sb
!xc
:array-dimension-limit
)))
386 (int-type 0 #.
(1- sb
!xc
:array-dimension-limit
))) ; INDEX type
388 (cond ((not low
) (int-type nil nil
))
389 ((eql low
0) (int-type 0 nil
))
390 ((eql low
(1+ sb
!xc
:most-positive-fixnum
))
392 (int-type #.
(1+ sb
!xc
:most-positive-fixnum
) nil
))))
393 ((or (eql high most-positive-word
)
394 ;; is (1+ high) a power-of-2 ?
395 (and (typep high
'word
) (zerop (logand (1+ high
) high
))))
397 (svref (literal-ctype-vector *interned-unsigned-byte-types
*)
398 (integer-length (truly-the word high
))))
399 ((and (< high most-positive-word
) (eql low
(lognot high
)))
400 (svref (literal-ctype-vector *interned-signed-byte-types
*)
401 (integer-length (truly-the word high
))))))
402 ((and (not low
) (eql high
(1- sb
!xc
:most-negative-fixnum
)))
404 (int-type nil
#.
(1- sb
!xc
:most-negative-fixnum
))))))
406 (when (and (eq complexp
:real
) (null low
) (eq high low
))
407 (literal-ctype (%make-numeric-type
:class
'rational
) rational
))))
408 (let ((result (%make-numeric-type
:class class
:format format
411 :enumerable enumerable
)))
412 (setf (type-hash-value result
)
413 (logior (type-hash-value result
) +type-admits-type
=-optimization
+))
416 (defun modified-numeric-type (base
418 (class (numeric-type-class base
))
419 (format (numeric-type-format base
))
420 (complexp (numeric-type-complexp base
))
421 (low (numeric-type-low base
))
422 (high (numeric-type-high base
))
423 (enumerable (type-enumerable base
)))
424 (make-numeric-type :class class
429 :enumerable enumerable
))
431 ;; all character-set types are enumerable, but it's not possible
432 ;; for one to be TYPE= to a MEMBER type because (MEMBER #\x)
433 ;; is not internally represented as a MEMBER type.
434 ;; So in case it wasn't clear already ENUMERABLE-P does not mean
435 ;; "possibly a MEMBER type in the Lisp-theoretic sense",
436 ;; but means "could be implemented in SBCL as a MEMBER type".
437 (!define-type-class character-set
:enumerable nil
438 :might-contain-other-types nil
)
440 (defun make-character-set-type (pairs)
441 ; (aver (equal (mapcar #'car pairs)
442 ; (sort (mapcar #'car pairs) #'<)))
443 ;; aver that the cars of the list elements are sorted into increasing order
445 (do ((p pairs
(cdr p
)))
447 (aver (<= (caar p
) (caadr p
)))))
448 (let ((pairs (let (result)
449 (do ((pairs pairs
(cdr pairs
)))
450 ((null pairs
) (nreverse result
))
451 (destructuring-bind (low . high
) (car pairs
)
452 (loop for
(low1 . high1
) in
(cdr pairs
)
453 if
(<= low1
(1+ high
))
454 do
(progn (setf high
(max high high1
))
455 (setf pairs
(cdr pairs
)))
456 else do
(return nil
))
458 ((>= low sb
!xc
:char-code-limit
))
460 (t (push (cons (max 0 low
)
461 (min high
(1- sb
!xc
:char-code-limit
)))
464 (return-from make-character-set-type
*empty-type
*))
466 (macrolet ((range (low high
)
467 `(return-from make-character-set-type
468 (literal-ctype (%make-character-set-type
'((,low .
,high
)))
469 (character-set ((,low .
,high
)))))))
470 (let* ((pair (car pairs
))
473 (cond ((eql high
(1- sb
!xc
:char-code-limit
))
474 (cond ((eql low
0) (range 0 #.
(1- sb
!xc
:char-code-limit
)))
476 ((eql low base-char-code-limit
)
477 (range #.base-char-code-limit
478 #.
(1- sb
!xc
:char-code-limit
)))))
480 ((and (eql low
0) (eql high
(1- base-char-code-limit
)))
481 (range 0 #.
(1- base-char-code-limit
)))))))
482 (%make-character-set-type pairs
)))
484 (!define-type-class array
:enumerable nil
485 :might-contain-other-types nil
)
487 ;; For all ctypes which are the element types of specialized arrays,
488 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
489 ;; one for each of simple, maybe-simple, and non-simple (in that order),
490 ;; and 2 ctype objects for unknown-rank arrays, one each for simple
491 ;; and maybe-simple. (Unknown rank, known-non-simple isn't important)
493 (defvar *interned-array-types
*
494 (labels ((make-1 (type-index dims complexp type
)
495 (setf (!ctype-saetp-index type
) type-index
)
496 (mark-ctype-interned (%make-array-type dims complexp type type
)))
497 (make-all (element-type type-index array
)
499 (list (make-1 type-index
'(*) nil element-type
)
500 (make-1 type-index
'(*) :maybe element-type
)
501 (make-1 type-index
'(*) t element-type
)
502 (make-1 type-index
'* nil element-type
)
503 (make-1 type-index
'* :maybe element-type
))
504 :start1
(* type-index
5)))
505 (integer-range (low high
)
506 (make-numeric-type :class
'integer
:complexp
:real
507 :enumerable t
:low low
:high high
)))
508 (let ((array (make-array (* 32 5)))
510 ;; Index 31 is available to store *WILD-TYPE*
511 ;; because there are fewer than 32 array widetags.
512 (make-all *wild-type
* 31 array
)
513 (dolist (x *specialized-array-element-types
*
514 (progn (aver (< index
31)) array
))
516 ;; Produce element-type representation without parsing a spec.
517 ;; (SPECIFIER-TYPE doesn't work when bootstrapping.)
518 ;; The MAKE- constructors return an interned object as appropriate.
520 ((cons (eql unsigned-byte
))
521 (integer-range 0 (1- (ash 1 (second x
)))))
522 ((cons (eql signed-byte
))
523 (let ((lim (ash 1 (1- (second x
)))))
524 (integer-range (- lim
) (1- lim
))))
525 ((eql bit
) (integer-range 0 1))
526 ;; FIXNUM is its own thing, why? See comment in vm-array
527 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
528 ((eql fixnum
) ; One good kludge deserves another.
529 (integer-range sb
!xc
:most-negative-fixnum
530 sb
!xc
:most-positive-fixnum
))
531 ((member single-float double-float
)
532 (make-numeric-type :class
'float
:format x
:complexp
:real
))
533 ((cons (eql complex
))
534 (make-numeric-type :class
'float
:format
(cadr x
)
537 (make-character-set-type `((0 .
,(1- sb
!xc
:char-code-limit
)))))
540 (make-character-set-type `((0 .
,(1- base-char-code-limit
)))))
541 ((eql t
) *universal-type
*)
542 ((eql nil
) *empty-type
*))
546 (declaim (ftype (sfunction (t &key
(:complexp t
)
548 (:specialized-element-type t
))
549 ctype
) make-array-type
))
550 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
551 (specialized-element-type *wild-type
*))
552 (if (and (eq element-type specialized-element-type
)
553 (or (and (eq dimensions
'*) (neq complexp t
))
554 (typep dimensions
'(cons (eql *) null
))))
555 (let ((res (svref (literal-ctype-vector *interned-array-types
*)
556 (+ (* (!ctype-saetp-index element-type
) 5)
557 (if (listp dimensions
) 0 3)
558 (ecase complexp
((nil) 0) ((:maybe
) 1) ((t) 2))))))
559 (aver (eq (array-type-element-type res
) element-type
))
561 (%make-array-type dimensions
562 complexp element-type specialized-element-type
)))
564 (!define-type-class member
:enumerable t
565 :might-contain-other-types nil
)
567 (declaim (ftype (sfunction (xset list
) ctype
) make-member-type
))
568 (defun member-type-from-list (members)
569 (let ((xset (alloc-xset))
571 (dolist (elt members
(make-member-type xset fp-zeroes
))
573 (pushnew elt fp-zeroes
)
574 (add-to-xset elt xset
)))))
575 (defun make-eql-type (elt) (member-type-from-list (list elt
)))
576 ;; Return possibly a union of a MEMBER type and a NUMERIC type,
577 ;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET
578 ;; and the FP-ZEROES. XSET should not contains characters or real numbers.
579 (defun make-member-type (xset fp-zeroes
)
580 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
581 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
582 ;; ranges are compared by arithmetic operators (while MEMBERship is
583 ;; compared by EQL). -- CSR, 2003-04-23
587 (when fp-zeroes
; avoid doing two passes of nothing
589 (dolist (z fp-zeroes
)
590 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
595 #!+long-float
(long-float 4)))))
597 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
598 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
600 (push (ctype-of z
) float-types
))
601 (push z unpaired
)))))))
605 (macrolet ((member-type (&rest elts
)
607 (%make-member-type
(xset-from-list ',elts
) nil
)
609 (let ((elts (xset-data xset
)))
610 (when (singleton-p elts
)
612 ((nil) (return (member-type nil
)))
613 ((t) (return (member-type t
)))))
614 (when (or (equal elts
'(t nil
)) (equal elts
'(nil t
)))
615 ;; Semantically this is fine - XSETs
616 ;; are not order-preserving except by accident
617 ;; (when not represented as a hash-table).
618 (return (member-type t nil
))))))
619 (when (or unpaired
(not (xset-empty-p xset
)))
620 (let ((result (%make-member-type xset unpaired
)))
621 (setf (type-hash-value result
)
622 (logior (type-hash-value result
)
623 +type-admits-type
=-optimization
+))
625 ;; The actual member-type contains the XSET (with no FP zeroes),
626 ;; and a list of unpaired zeroes.
628 (make-union-type t
(if member-type
629 (cons member-type float-types
)
631 (or member-type
*empty-type
*)))))
633 (defun member-type-size (type)
634 (+ (length (member-type-fp-zeroes type
))
635 (xset-count (member-type-xset type
))))
637 (defun member-type-member-p (x type
)
639 (and (member x
(member-type-fp-zeroes type
)) t
)
640 (xset-member-p x
(member-type-xset type
))))
642 (defun mapcar-member-type-members (function type
)
643 (declare (function function
))
645 (map-xset (lambda (x)
646 (results (funcall function x
)))
647 (member-type-xset type
))
648 (dolist (zero (member-type-fp-zeroes type
))
649 (results (funcall function zero
)))
652 (defun mapc-member-type-members (function type
)
653 (declare (function function
))
654 (map-xset function
(member-type-xset type
))
655 (dolist (zero (member-type-fp-zeroes type
))
656 (funcall function zero
)))
658 (defun member-type-members (type)
659 (append (member-type-fp-zeroes type
)
660 (xset-members (member-type-xset type
))))
662 ;;; Return TYPE converted to canonical form for a situation where the
663 ;;; "type" '* (which SBCL still represents as a type even though ANSI
664 ;;; CL defines it as a related but different kind of placeholder) is
665 ;;; equivalent to type T.
666 (defun type-*-to-t
(type)
667 (if (type= type
*wild-type
*)
671 (!define-type-class cons
:enumerable nil
:might-contain-other-types nil
)
674 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
675 (defun make-cons-type (car-type cdr-type
)
676 (aver (not (or (eq car-type
*wild-type
*)
677 (eq cdr-type
*wild-type
*))))
678 (cond ((or (eq car-type
*empty-type
*)
679 (eq cdr-type
*empty-type
*))
681 ;; It's not a requirement that (CONS T T) be interned,
682 ;; but it improves the hit rate in the function caches.
683 ((and (type= car-type
*universal-type
*)
684 (type= cdr-type
*universal-type
*))
685 (literal-ctype (%make-cons-type
*universal-type
* *universal-type
*)
688 (%make-cons-type car-type cdr-type
))))
690 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
692 (defstruct (simd-pack-type
693 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
694 (:constructor %make-simd-pack-type
(element-type))
696 (element-type (missing-arg)
697 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
701 (defun make-simd-pack-type (element-type)
702 (aver (neq element-type
*wild-type
*))
703 (if (eq element-type
*empty-type
*)
705 (%make-simd-pack-type
706 (dolist (pack-type *simd-pack-element-types
*
707 (error "~S element type must be a subtype of ~
708 ~{~S~#[~;, or ~:;, ~]~}."
709 'simd-pack
*simd-pack-element-types
*))
710 (when (csubtypep element-type
(specifier-type pack-type
))
711 (return (list pack-type
)))))))
716 ;;; Return the type structure corresponding to a type specifier.
718 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
719 ;;; type is defined (or redefined).
721 ;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily
722 ;;; to the CLHS intent, which is to make the type known to the compiler.
723 ;;; If we compile in one file:
724 ;;; (DEFCLASS FRUITBAT () ())
725 ;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT))
726 ;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its
727 ;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF,
728 ;;; which (correctly) signals an error if the class were not defined by the
729 ;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier
730 ;;; at call time is wrong.
732 ;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton
733 ;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and
734 ;;; (CHARACTER) are not. It has to do with whether the primitive is actually
735 ;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal.
736 ;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis]
737 ;;; compound type specifier with no arguments supplied, (x)."
738 ;;; By that same reasonining, is (x) accepted if x names a class?
741 ;;; The xc host uses an ordinary hash table for memoization.
743 (let ((table (make-hash-table :test
'equal
)))
744 (defun !values-specifier-type-memo-wrapper
(thunk specifier
)
745 (multiple-value-bind (type yesp
) (gethash specifier table
)
748 (setf (gethash specifier table
) (funcall thunk
)))))
749 (defun values-specifier-type-cache-clear ()
751 ;;; This cache is sized extremely generously, which has payoff
752 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
753 ;;; since EQ types are an immediate win.
755 (sb!impl
::!define-hash-cache values-specifier-type
756 ((orig equal-but-no-car-recursion
)) ()
757 :hash-function
#'sxhash
:hash-bits
10)
759 (defvar *pending-defstruct-type
*)
760 (declaim (type classoid
*pending-defstruct-type
*))
762 ;;; The recursive ("-R" suffixed) entry point for this function
763 ;;; should be used for each nested parser invocation.
764 (defun values-specifier-type-r (context type-specifier
)
765 (declare (type cons context
))
766 (labels ((fail (spec) ; Q: Shouldn't this signal a TYPE-ERROR ?
767 (error "bad thing to be a type specifier: ~S" spec
))
768 (instance-to-ctype (x)
769 (flet ((translate (classoid)
770 ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE
771 ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ?
773 (or (and (built-in-classoid-p classoid
)
774 (built-in-classoid-translation classoid
))
776 (cond ((classoid-p x
) (translate x
))
777 ;; Avoid TYPEP on SB!MOP:EQL-SPECIALIZER and CLASS because
778 ;; the fake metaobjects do not allow type analysis, and
779 ;; would cause a compiler error as it tries to decide
780 ;; whether any clause of this COND subsumes another.
781 ;; Moreover, we don't require the host to support MOP.
783 ((sb!pcl
::classp x
) (translate (sb!pcl
::class-classoid x
)))
785 ((sb!pcl
::eql-specializer-p type-specifier
)
786 ;; FIXME: these aren't always cached. Should they be?
787 ;; It seems so, as "parsing" constructs a new object.
788 ;; Perhaps better, the EQL specializer itself could store
789 ;; (by memoizing, if not precomputing) a CTYPE
791 (sb!mop
:eql-specializer-object type-specifier
)))
793 (when (typep type-specifier
'instance
)
794 (return-from values-specifier-type-r
(instance-to-ctype type-specifier
)))
795 (when (atom type-specifier
)
796 ;; Try to bypass the cache, which avoids using a cache line for standard
797 ;; atomic specifiers. This is a trade-off- cache seek might be faster,
798 ;; but this solves the problem that a full call to (TYPEP #\A 'FIXNUM)
799 ;; consed a cache line every time the cache missed on FIXNUM (etc).
800 (awhen (info :type
:builtin type-specifier
)
801 (return-from values-specifier-type-r it
)))
802 (!values-specifier-type-memo-wrapper
806 (prog* ((head (if (listp spec
) (car spec
) spec
))
807 (builtin (if (symbolp head
)
808 (info :type
:builtin head
)
809 (return (fail spec
)))))
810 (when (deprecated-thing-p 'type head
)
811 (setf (cdr context
) nil
)
812 (signal 'parse-deprecated-type
:specifier spec
))
814 ;; If spec is non-atomic, the :BUILTIN value is inapplicable.
815 ;; There used to be compound builtins, but not any more.
816 (when builtin
(return builtin
))
817 ;; Any spec that apparently refers to a defstruct form
818 ;; that's being macroexpanded should refer to that type.
819 (when (boundp '*pending-defstruct-type
*)
820 (let ((classoid *pending-defstruct-type
*))
821 (when (eq (classoid-name classoid
) spec
)
822 (setf (cdr context
) nil
) ; don't cache
824 (case (info :type
:kind spec
)
825 (:instance
(return (find-classoid spec
)))
826 (:forthcoming-defclass-type
(go unknown
))))
827 ;; Expansion brings up an interesting question - should the cache
828 ;; contain entries for intermediary types? Say A -> B -> REAL.
829 ;; As it stands, we cache the ctype corresponding to A but not B.
830 (awhen (info :type
:expander head
)
831 (when (listp it
) ; The function translates directly to a CTYPE.
832 (return (or (funcall (car it
) context spec
) (fail spec
))))
833 ;; The function produces a type expression.
834 (let ((expansion (funcall it
(ensure-list spec
))))
835 (return (if (typep expansion
'instance
)
836 (instance-to-ctype expansion
)
837 (recurse expansion
)))))
838 ;; If the spec is (X ...) and X has neither a translator
839 ;; nor expander, and is a builtin, such as FIXNUM, fail now.
840 ;; But - see FIXME at top - it would be consistent with
841 ;; DEFTYPE to reject spec only if not a singleton.
842 (when builtin
(return (fail spec
)))
843 ;; SPEC has a legal form, so return an unknown type.
844 (signal 'parse-unknown-type
:specifier spec
)
846 (setf (cdr context
) nil
)
847 (return (make-unknown-type :specifier spec
)))))
848 (let ((result (recurse (uncross type-specifier
))))
849 (if (cdr context
) ; cacheable
851 ;; (The RETURN-FROM here inhibits caching; this makes sense
852 ;; not only from a compiler diagnostics point of view,
853 ;; but also for proper workingness of VALID-TYPE-SPECIFIER-P.
854 (return-from values-specifier-type-r result
)))))
856 (defun values-specifier-type (type-specifier)
857 (dx-let ((context (cons type-specifier t
)))
858 (values-specifier-type-r context type-specifier
)))
860 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
861 ;;; never return a VALUES type.
862 (defun specifier-type-r (context type-specifier
)
863 (let ((ctype (values-specifier-type-r context type-specifier
)))
864 (when (values-type-p ctype
)
865 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
867 (defun specifier-type (type-specifier)
868 (dx-let ((context (cons type-specifier t
)))
869 (specifier-type-r context type-specifier
)))
871 (defun single-value-specifier-type-r (context x
)
872 (if (eq x
'*) *universal-type
* (specifier-type-r context x
)))
873 (defun single-value-specifier-type (x)
878 (defun typexpand-1 (type-specifier &optional env
)
880 "Takes and expands a type specifier once like MACROEXPAND-1.
881 Returns two values: the expansion, and a boolean that is true when
883 (declare (type type-specifier type-specifier
))
884 (declare (type lexenv-designator env
) (ignore env
))
885 (let* ((spec type-specifier
)
886 (atom (if (listp spec
) (car spec
) spec
))
887 (expander (and (symbolp atom
) (info :type
:expander atom
))))
888 ;; We do not expand builtins even though it'd be
889 ;; possible to do so sometimes (e.g. STRING) for two
892 ;; a) From a user's point of view, CL types are opaque.
894 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
895 (if (and (functionp expander
) (not (info :type
:builtin atom
)))
896 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
897 (values type-specifier nil
))))
899 (defun typexpand (type-specifier &optional env
)
901 "Takes and expands a type specifier repeatedly like MACROEXPAND.
902 Returns two values: the expansion, and a boolean that is true when
904 ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
905 ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV.
906 (multiple-value-bind (expansion expanded
)
907 (typexpand-1 type-specifier env
)
909 (values (typexpand expansion env
) t
)
910 (values expansion expanded
))))
912 ;;; Note that the type NAME has been (re)defined, updating the
913 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
914 (defun %note-type-defined
(name)
915 (declare (symbol name
))
916 (note-name-defined name
:type
)
917 (values-specifier-type-cache-clear)
921 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)
923 ;;; When cross-compiling SPECIFIER-TYPE with a quoted argument,
924 ;;; it can be rendered as a literal object unless it:
925 ;;; - mentions a classoid or unknown type
926 ;;; - uses a floating-point literal (perhaps positive zero could be allowed?)
928 ;;; This is important for type system initialization, but it will also
929 ;;; apply to hand-written calls and make-load-form expressions.
931 ;;; After the target is built, we remove this transform, both because calls
932 ;;; to SPECIFIER-TYPE do not arise organically through user code,
933 ;;; and because it is possible that user changes to types could make parsing
934 ;;; return a different thing, e.g. changing a DEFTYPE to a DEFCLASS.
938 (sb!c
::define-source-transform specifier-type
(type-spec &environment env
)
939 (or (and (sb!xc
:constantp type-spec env
)
940 (let ((parse (specifier-type (constant-form-value type-spec env
))))
942 ((contains-unknown-type-p parse
)
943 (bug "SPECIFIER-TYPE transform parsed an unknown type"))
944 ((cold-dumpable-type-p parse
)
945 ;; Obtain a canonical form by unparsing so that TYPE= specs
946 ;; coalesce in presence of DEFTYPEs. LOAD-TIME-VALUE in the
947 ;; cross-compiler has a special-case to turn !SPECIFIER-TYPE
948 ;; into a fop-funcall, which is handled by genesis.
949 `(load-time-value (!specifier-type
',(type-specifier parse
))
953 (defun cold-dumpable-type-p (ctype)
954 (named-let recurse
((ctype ctype
))
957 (and (every #'recurse
(args-type-required ctype
))
958 (every #'recurse
(args-type-optional ctype
))
959 (acond ((args-type-rest ctype
) (recurse it
)) (t))
960 (every (lambda (x) (recurse (key-info-type x
)))
961 (args-type-keywords ctype
))
962 (if (fun-type-p ctype
) (recurse (fun-type-returns ctype
)) t
)))
963 (compound-type (every #'recurse
(compound-type-types ctype
)))
964 (negation-type (recurse (negation-type-type ctype
)))
965 (array-type (recurse (array-type-element-type ctype
)))
966 (cons-type (and (recurse (cons-type-car-type ctype
))
967 (recurse (cons-type-cdr-type ctype
))))
969 (and (listp (xset-data (member-type-xset ctype
))) ; can't dump hashtable
970 (not (member-type-fp-zeroes ctype
)))) ; nor floats
972 ;; Floating-point constants are not dumpable. (except maybe +0.0)
973 (if (or (typep (numeric-type-low ctype
) '(or float
(cons float
)))
974 (typep (numeric-type-high ctype
) '(or float
(cons float
))))
977 (built-in-classoid t
)
979 ;; HAIRY is just an s-expression, so it's dumpable. Same for simd-pack
980 ((or named-type character-set-type hairy-type
#!+sb-simd-pack simd-pack-type
)
983 (setf (get '!specifier-type
:sb-cold-funcall-handler
/for-value
)
986 (if (symbolp arg
) arg
(sb!fasl
::host-object-from-core arg
))))
987 (sb!fasl
::ctype-to-core specifier
(specifier-type specifier
)))))
989 (setf (info :function
:where-from
'!specifier-type
) :declared
) ; lie