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 (!begin-collecting-cold-init-forms
)
14 ;;;; representations of types
16 ;;; A HAIRY-TYPE represents anything too weird to be described
17 ;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
18 ;;; and unreasonably complicated types involving AND. We just remember
19 ;;; the original type spec.
20 ;;; A possible improvement would be for HAIRY-TYPE to have a subtype
21 ;;; named SATISFIES-TYPE for the hairy types which are specifically
22 ;;; of the form (SATISFIES pred) so that we don't have to examine
23 ;;; the sexpr repeatedly to decide whether it takes that form.
24 ;;; And as a further improvement, we might want a table that maps
25 ;;; predicates to their exactly recognized type when possible.
26 ;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES*
27 ;;; as a starting point. But something like PLUSP isn't in there.
28 ;;; On the other hand, either of these points may not be sources of
29 ;;; inefficiency, and the latter if implemented might have undesirable
30 ;;; user-visible ramifications, though it seems unlikely.
31 (defstruct (hairy-type (:include ctype
32 (class-info (type-class-or-lose 'hairy
)))
33 (:constructor %make-hairy-type
(specifier))
36 ;; the Common Lisp type-specifier of the type we represent
37 (specifier nil
:type t
:read-only t
))
39 ;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
40 ;; e.g. any SATISFIES with a predicate returning T over a finite domain.
41 ;; But in practice there's nothing that can be done with this information,
42 ;; because we don't call random predicates when performing operations on types
43 ;; as objects, only when checking for inclusion of something in the type.
44 (!define-type-class hairy
:enumerable t
:might-contain-other-types t
)
46 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
47 ;;; defined). We make this distinction since we don't want to complain
48 ;;; about types that are hairy but defined.
49 (defstruct (unknown-type (:include hairy-type
)
52 (defun maybe-reparse-specifier (type)
53 (when (unknown-type-p type
)
54 (let* ((spec (unknown-type-specifier type
))
55 (name (if (consp spec
)
58 (when (info :type
:kind name
)
59 (let ((new-type (specifier-type spec
)))
60 (unless (unknown-type-p new-type
)
64 (defmacro maybe-reparse-specifier
! (type)
65 (assert (symbolp type
))
66 (with-unique-names (new-type)
67 `(let ((,new-type
(maybe-reparse-specifier ,type
)))
69 (setf ,type
,new-type
)
72 (defstruct (negation-type (:include ctype
73 (class-info (type-class-or-lose 'negation
)))
75 (:constructor make-negation-type
(type))
77 (type (missing-arg) :type ctype
:read-only t
))
79 ;; Former comment was:
80 ;; FIXME: is this right? It's what they had before, anyway
81 ;; But I think the reason it's right is that "enumerable :t" is equivalent
82 ;; to "maybe" which is actually the conservative assumption, same as HAIRY.
83 (!define-type-class negation
:enumerable t
:might-contain-other-types t
)
85 (defun canonicalize-args-type-args (required optional rest
&optional keyp
)
86 (when (eq rest
*empty-type
*)
89 (loop with last-not-rest
= nil
92 do
(cond ((eq opt
*empty-type
*)
93 (return (values required
(subseq optional i
) rest
)))
94 ((and (not keyp
) (neq opt rest
))
95 (setq last-not-rest i
)))
96 finally
(return (values required
100 (subseq optional
0 (1+ last-not-rest
))))
103 ;; CONTEXT is the cookie passed down from the outermost surrounding call
104 ;; of VALUES-SPECIFIER-TYPE. INNER-CONTEXT-KIND is an indicator of whether
105 ;; we are currently parsing a FUNCTION or a VALUES compound type specifier.
106 (defun parse-args-types (context lambda-listy-thing inner-context-kind
)
107 (multiple-value-bind (llks required optional rest keys
)
110 :context inner-context-kind
111 :accept
(ecase inner-context-kind
112 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
113 (:function-type
(lambda-list-keyword-mask
114 '(&optional
&rest
&key
&allow-other-keys
))))
116 (flet ((parse-list (list)
117 (mapcar (lambda (x) (single-value-specifier-type-r context x
))
119 (let ((required (parse-list required
))
120 (optional (parse-list optional
))
121 (rest (when rest
(single-value-specifier-type-r context
(car rest
))))
123 (collect ((key-info))
125 (unless (proper-list-of-length-p key
2)
126 (error "Keyword type description is not a two-list: ~S." key
))
127 (let ((kwd (first key
)))
128 (when (find kwd
(key-info) :key
#'key-info-name
)
129 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
130 kwd lambda-listy-thing
))
133 ;; MAKE-KEY-INFO will complain if KWD is not a symbol.
134 ;; That's good enough - we don't need an extra check here.
136 :type
(single-value-specifier-type-r context
(second key
))))))
138 (multiple-value-bind (required optional rest
)
139 (canonicalize-args-type-args required optional rest
141 (values llks required optional rest keywords
))))))
143 (defstruct (values-type
145 (class-info (type-class-or-lose 'values
)))
146 (:constructor %make-values-type
)
147 (:predicate %values-type-p
)
150 (declaim (inline values-type-p
))
151 (defun values-type-p (x)
152 (or (eq x
*wild-type
*)
155 (defun-cached (make-values-type-cached
158 (lambda (req opt rest allowp
)
159 (logxor (type-list-cache-hash req
)
160 (type-list-cache-hash opt
)
162 (type-hash-value rest
)
164 ;; Results (logand #xFF (sxhash t/nil))
165 ;; hardcoded to avoid relying on the xc host.
166 ;; [but (logand (sxhash nil) #xff) => 2
167 ;; for me, so the code and comment disagree,
168 ;; but not in a way that matters.]
172 ((required equal-but-no-car-recursion
)
173 (optional equal-but-no-car-recursion
)
176 (%make-values-type
:required required
181 (defun make-values-type (&key required optional rest allowp
)
182 (multiple-value-bind (required optional rest
)
183 (canonicalize-args-type-args required optional rest
)
184 (cond ((and (null required
)
186 (eq rest
*universal-type
*))
188 ((memq *empty-type
* required
)
190 (t (make-values-type-cached required optional
193 (!define-type-class values
:enumerable nil
194 :might-contain-other-types nil
)
196 ;; Without this canonicalization step, I found >350 different
197 ;; (FUNCTION (T) *) representations in a sample build.
198 (declaim (type (simple-vector 4) *interned-fun-type-instances
*))
199 (defglobal *interned-fun-types
* (make-array 4))
200 (defun !intern-important-fun-type-instances
()
201 (setq *interned-fun-types
* (make-array 4))
205 (push *universal-type
* required
))
206 (setf (svref *interned-fun-types
* i
)
208 (%make-fun-type required nil nil nil nil nil nil
*wild-type
*))))))
210 (defun make-fun-type (&key required optional rest
213 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
214 (n (length required
)))
216 (not optional
) (not rest
) (not keyp
)
217 (not keywords
) (not allowp
) (not wild-args
)
218 (eq returns
*wild-type
*)
219 (every (lambda (x) (eq x
*universal-type
*)) required
))
220 (svref *interned-fun-types
* n
)
221 (%make-fun-type required optional rest keyp keywords
222 allowp wild-args returns
))))
224 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
225 ;;; "type specifier", which is only meaningful in function argument
226 ;;; type specifiers used within the compiler. (It represents something
227 ;;; that the compiler knows to be a constant.)
228 (defstruct (constant-type
230 (class-info (type-class-or-lose 'constant
)))
232 ;; The type which the argument must be a constant instance of for this type
234 (type (missing-arg) :type ctype
:read-only t
))
236 ;; For some numeric subtypes, uniqueness of the object representation
237 ;; is enforced. These encompass all array specializations and more.
238 (defglobal *unsigned-byte-type
* -
1)
239 (defglobal *integer-type
* -
1)
240 (defglobal *index-type
* -
1)
241 ;; BIGNUM is not an interned type because union types aren't interned,
242 ;; though some of the important ones probably ought to be.
243 (defglobal *positive-bignum-type
* -
1)
244 (defglobal *negative-bignum-type
* -
1)
245 (defglobal *rational-type
* -
1)
246 (defglobal *unsigned-byte-n-types
* -
1)
247 (defglobal *signed-byte-n-types
* -
1)
248 (defglobal *real-ffloat-type
* -
1)
249 (defglobal *real-dfloat-type
* -
1)
250 (defglobal *complex-ffloat-type
* -
1)
251 (defglobal *complex-dfloat-type
* -
1)
253 (declaim (type (simple-vector #.
(1+ sb
!vm
:n-word-bits
)) *unsigned-byte-n-types
*)
254 (type (simple-vector #.sb
!vm
:n-word-bits
) *signed-byte-n-types
*))
256 ;; Called after NUMBER-TYPE type-class has been made.
257 (defun !intern-important-numeric-type-instances
()
258 (flet ((float-type (format complexp
)
260 (%make-numeric-type
:class
'float
:complexp complexp
261 :format format
:enumerable nil
)))
264 (%make-numeric-type
:class
'integer
:complexp
:real
265 :enumerable
(if (and low high
) t nil
)
266 :low low
:high high
))))
267 (setq *real-ffloat-type
* (float-type 'single-float
:real
)
268 *real-dfloat-type
* (float-type 'double-float
:real
)
269 *complex-ffloat-type
* (float-type 'single-float
:complex
)
270 *complex-dfloat-type
* (float-type 'double-float
:complex
)
271 *rational-type
* (mark-ctype-interned
272 (%make-numeric-type
:class
'rational
))
273 *unsigned-byte-type
* (int-type 0 nil
)
274 *integer-type
* (int-type nil nil
)
275 *index-type
* (int-type 0 (1- sb
!xc
:array-dimension-limit
))
276 *negative-bignum-type
* (int-type nil
(1- sb
!xc
:most-negative-fixnum
))
277 *positive-bignum-type
* (int-type (1+ sb
!xc
:most-positive-fixnum
) nil
)
278 *unsigned-byte-n-types
* (make-array (1+ sb
!vm
:n-word-bits
))
279 *signed-byte-n-types
* (make-array sb
!vm
:n-word-bits
))
280 (dotimes (j (1+ sb
!vm
:n-word-bits
))
281 (setf (svref *unsigned-byte-n-types
* j
) (int-type 0 (1- (ash 1 j
)))))
282 (dotimes (j sb
!vm
:n-word-bits
)
283 (setf (svref *signed-byte-n-types
* j
)
284 (let ((high (1- (ash 1 j
)))) (int-type (- (1+ high
)) high
))))))
286 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
287 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
289 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
290 ;;; come from parsing MEMBER. But bounded integer ranges,
291 ;;; however large, are enumerable:
292 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
293 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
294 ;;; but, in contrast,
295 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
296 ;;; I can't figure out whether this is supposed to matter.
297 ;;; Moreover, it seems like this function should be responsible
298 ;;; for figuring out the right value so that callers don't have to.
299 (defun make-numeric-type (&key class format
(complexp :real
) low high
301 ;; if interval is empty
304 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
305 (>= (type-bound-number low
) (type-bound-number high
))
308 (multiple-value-bind (low high
)
311 ;; INTEGER types always have their LOW and HIGH bounds
312 ;; represented as inclusive, not exclusive values.
313 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
314 (if (consp high
) (1- (type-bound-number high
)) high
)))
316 ;; no canonicalization necessary
318 (when (and (eq class
'rational
) (integerp low
) (eql low high
))
319 (setf class
'integer
))
321 ;; Either lookup the canonical interned object for
322 ;; a point in the type lattice, or construct a new one.
323 (or (cond ((eq class
'float
)
324 (when (and (null low
) (null high
))
328 (:real
*real-ffloat-type
*)
329 (:complex
*complex-ffloat-type
*)))
332 (:real
*real-dfloat-type
*)
333 (:complex
*complex-dfloat-type
*))))))
334 ((and (eq class
'integer
) (eq complexp
:real
))
335 (flet ((n-bits () (integer-length (truly-the word high
))))
336 (declare (inline n-bits
))
338 (cond ((eql low
0) *unsigned-byte-type
*)
339 ((not low
) *integer-type
*)
340 ((eql low
(1+ sb
!xc
:most-positive-fixnum
))
341 *positive-bignum-type
*)))
342 ((or (= high most-positive-word
)
343 (and (typep high
'word
)
344 ;; is (1+ high) a power-of-2 ?
345 (zerop (logand (1+ high
) high
))))
347 (svref *unsigned-byte-n-types
* (n-bits)))
348 ((and (< high most-positive-word
)
349 (eql low
(lognot high
)))
350 (svref *signed-byte-n-types
* (n-bits)))))
352 (eql high
(1- sb
!xc
:array-dimension-limit
)))
355 (eql high
(1- sb
!xc
:most-negative-fixnum
)))
356 *negative-bignum-type
*))))
357 ((and (eq class
'rational
) (eq complexp
:real
)
358 (null low
) (eq high low
))
361 (%make-numeric-type
:class class
366 :enumerable enumerable
)))
367 (setf (type-hash-value result
)
368 (logior (type-hash-value result
)
369 +type-admits-type
=-optimization
+))
372 (defun modified-numeric-type (base
374 (class (numeric-type-class base
))
375 (format (numeric-type-format base
))
376 (complexp (numeric-type-complexp base
))
377 (low (numeric-type-low base
))
378 (high (numeric-type-high base
))
379 (enumerable (type-enumerable base
)))
380 (make-numeric-type :class class
385 :enumerable enumerable
))
387 ;; Interned character-set types.
388 (defglobal *character-type
* -
1)
390 (progn (defglobal *base-char-type
* -
1)
391 (defglobal *extended-char-type
* -
1))
392 #+sb-xc
(declaim (type ctype
*character-type
*
393 #!+sb-unicode
*base-char-type
*
394 #!+sb-unicode
*extended-char-type
*))
396 (defun !intern-important-character-set-type-instances
()
397 (flet ((range (low high
)
399 (%make-character-set-type
(list (cons low high
))))))
400 (setq *character-type
* (range 0 (1- sb
!xc
:char-code-limit
)))
402 (setq *base-char-type
* (range 0 (1- base-char-code-limit
))
403 *extended-char-type
* (range base-char-code-limit
(1- sb
!xc
:char-code-limit
)))))
405 (defun make-character-set-type (pairs)
406 ; (aver (equal (mapcar #'car pairs)
407 ; (sort (mapcar #'car pairs) #'<)))
408 ;; aver that the cars of the list elements are sorted into increasing order
409 (aver (or (null pairs
)
410 (do ((p pairs
(cdr p
)))
412 (when (> (caar p
) (caadr p
)) (return nil
)))))
413 (let ((pairs (let (result)
414 (do ((pairs pairs
(cdr pairs
)))
415 ((null pairs
) (nreverse result
))
416 (destructuring-bind (low . high
) (car pairs
)
417 (loop for
(low1 . high1
) in
(cdr pairs
)
418 if
(<= low1
(1+ high
))
419 do
(progn (setf high
(max high high1
))
420 (setf pairs
(cdr pairs
)))
421 else do
(return nil
))
423 ((>= low sb
!xc
:char-code-limit
))
425 (t (push (cons (max 0 low
)
426 (min high
(1- sb
!xc
:char-code-limit
)))
430 (or (and (singleton-p pairs
)
431 (let* ((pair (car pairs
))
435 (#.
(1- sb
!xc
:char-code-limit
)
439 (#.base-char-code-limit
*extended-char-type
*)))
441 (#.
(1- base-char-code-limit
)
443 *base-char-type
*)))))
444 (%make-character-set-type pairs
)))))
446 ;; For all ctypes which are the element types of specialized arrays,
447 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
448 ;; one for each of simple, maybe-simple, and non-simple (in that order),
449 ;; and 2 ctype objects for unknown-rank arrays, one each for simple
450 ;; and maybe-simple. (Unknown rank, known-non-simple isn't important)
451 (defglobal *canonical-array-ctypes
* -
1)
452 (defun !intern-important-array-type-instances
()
453 ;; Having made the canonical numeric and character ctypes
454 ;; representing the points in the type lattice for which there
455 ;; are array specializations, we can make the canonical array types.
456 (setq *canonical-array-ctypes
* (make-array (* 32 5)))
457 (labels ((make-1 (type-index dims complexp type
)
458 (setf (!ctype-saetp-index type
) type-index
)
459 (mark-ctype-interned (%make-array-type dims complexp type type
)))
460 (make-all (element-type type-index
)
461 (replace *canonical-array-ctypes
*
462 (list (make-1 type-index
'(*) nil element-type
)
463 (make-1 type-index
'(*) :maybe element-type
)
464 (make-1 type-index
'(*) t element-type
)
465 (make-1 type-index
'* nil element-type
)
466 (make-1 type-index
'* :maybe element-type
))
467 :start1
(* type-index
5)))
468 (integer-range (low high
)
469 (make-numeric-type :class
'integer
:complexp
:real
470 :enumerable t
:low low
:high high
)))
472 ;; Index 31 is available to store *WILD-TYPE*
473 ;; because there are fewer than 32 array widetags.
474 (make-all *wild-type
* 31)
475 (dolist (x '#.
*specialized-array-element-types
*
478 ;; Produce element-type representation without parsing a spec.
479 ;; (SPECIFIER-TYPE doesn't work when bootstrapping.)
480 ;; The MAKE- constructors return an interned object as appropriate.
482 ((cons (eql unsigned-byte
))
483 (integer-range 0 (1- (ash 1 (second x
)))))
484 ((cons (eql signed-byte
))
485 (let ((lim (ash 1 (1- (second x
)))))
486 (integer-range (- lim
) (1- lim
))))
487 ((eql bit
) (integer-range 0 1))
488 ;; FIXNUM is its own thing, why? See comment in vm-array
489 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
490 ((eql fixnum
) ; One good kludge deserves another.
491 (integer-range sb
!xc
:most-negative-fixnum
492 sb
!xc
:most-positive-fixnum
))
493 ((member single-float double-float
)
494 (make-numeric-type :class
'float
:format x
:complexp
:real
))
495 ((cons (eql complex
))
496 (make-numeric-type :class
'float
:format
(cadr x
)
499 (make-character-set-type `((0 .
,(1- sb
!xc
:char-code-limit
)))))
502 (make-character-set-type `((0 .
,(1- base-char-code-limit
)))))
503 ((eql t
) *universal-type
*)
504 ((eql nil
) *empty-type
*))
508 (declaim (ftype (sfunction (t &key
(:complexp t
)
510 (:specialized-element-type t
))
511 ctype
) make-array-type
))
512 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
513 (specialized-element-type *wild-type
*))
514 (if (and (eq element-type specialized-element-type
)
515 (or (and (eq dimensions
'*) (neq complexp t
))
516 (typep dimensions
'(cons (eql *) null
))))
517 (let ((res (svref *canonical-array-ctypes
*
518 (+ (* (!ctype-saetp-index element-type
) 5)
519 (if (listp dimensions
) 0 3)
520 (ecase complexp
((nil) 0) ((:maybe
) 1) ((t) 2))))))
521 (aver (eq (array-type-element-type res
) element-type
))
523 (%make-array-type dimensions
524 complexp element-type specialized-element-type
)))
526 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
527 ;;; bother with this at this level because MEMBER types are fairly
528 ;;; important and union and intersection are well defined.
529 (defstruct (member-type (:include ctype
530 (class-info (type-class-or-lose 'member
)))
532 (:constructor %make-member-type
(xset fp-zeroes
))
533 #-sb-xc-host
(:pure nil
))
534 (xset (missing-arg) :type xset
:read-only t
)
535 (fp-zeroes (missing-arg) :type list
:read-only t
))
537 (defglobal *null-type
* -
1) ; = (MEMBER NIL)
538 (defglobal *eql-t-type
* -
1) ; = (MEMBER T)
539 (defglobal *boolean-type
* -
1) ; = (MEMBER T NIL)
540 #+sb-xc
(declaim (type ctype
*null-type
*))
542 (defun !intern-important-member-type-instances
()
543 (flet ((make-it (list)
545 (%make-member-type
(xset-from-list list
) nil
))))
546 (setf *null-type
* (make-it '(nil))
547 *eql-t-type
* (make-it '(t))
548 *boolean-type
* (make-it '(t nil
)))))
550 (declaim (ftype (sfunction (xset list
) ctype
) make-member-type
))
551 (defun member-type-from-list (members)
552 (let ((xset (alloc-xset))
554 (dolist (elt members
(make-member-type xset fp-zeroes
))
556 (pushnew elt fp-zeroes
)
557 (add-to-xset elt xset
)))))
558 (defun make-eql-type (elt) (member-type-from-list (list elt
)))
559 ;; Return possibly a union of a MEMBER type and a NUMERIC type,
560 ;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET
561 ;; and the FP-ZEROES. XSET should not contains characters or real numbers.
562 (defun make-member-type (xset fp-zeroes
)
563 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
564 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
565 ;; ranges are compared by arithmetic operators (while MEMBERship is
566 ;; compared by EQL). -- CSR, 2003-04-23
570 (when fp-zeroes
; avoid doing two passes of nothing
572 (dolist (z fp-zeroes
)
573 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
578 #!+long-float
(long-float 4)))))
580 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
581 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
583 (push (ctype-of z
) float-types
))
584 (push z unpaired
)))))))
588 (when (singleton-p (xset-data xset
))
589 (case (first (xset-data xset
))
590 ((nil) (return *null-type
*))
591 ((t) (return *eql-t-type
*))))
592 ;; Semantically this is fine - XSETs
593 ;; are not order-preserving except by accident
594 ;; (when not represented as a hash-table).
595 (when (or (equal (xset-data xset
) '(t nil
))
596 (equal (xset-data xset
) '(nil t
)))
597 (return *boolean-type
*)))
598 (when (or unpaired
(not (xset-empty-p xset
)))
599 (let ((result (%make-member-type xset unpaired
)))
600 (setf (type-hash-value result
)
601 (logior (type-hash-value result
)
602 +type-admits-type
=-optimization
+))
604 ;; The actual member-type contains the XSET (with no FP zeroes),
605 ;; and a list of unpaired zeroes.
607 (make-union-type t
(if member-type
608 (cons member-type float-types
)
610 (or member-type
*empty-type
*)))))
612 (defun member-type-size (type)
613 (+ (length (member-type-fp-zeroes type
))
614 (xset-count (member-type-xset type
))))
616 (defun member-type-member-p (x type
)
618 (and (member x
(member-type-fp-zeroes type
)) t
)
619 (xset-member-p x
(member-type-xset type
))))
621 (defun mapcar-member-type-members (function type
)
622 (declare (function function
))
624 (map-xset (lambda (x)
625 (results (funcall function x
)))
626 (member-type-xset type
))
627 (dolist (zero (member-type-fp-zeroes type
))
628 (results (funcall function zero
)))
631 (defun mapc-member-type-members (function type
)
632 (declare (function function
))
633 (map-xset function
(member-type-xset type
))
634 (dolist (zero (member-type-fp-zeroes type
))
635 (funcall function zero
)))
637 (defun member-type-members (type)
638 (append (member-type-fp-zeroes type
)
639 (xset-members (member-type-xset type
))))
641 ;;; Return TYPE converted to canonical form for a situation where the
642 ;;; "type" '* (which SBCL still represents as a type even though ANSI
643 ;;; CL defines it as a related but different kind of placeholder) is
644 ;;; equivalent to type T.
645 (defun type-*-to-t
(type)
646 (if (type= type
*wild-type
*)
650 ;; The function caches work significantly better when there
651 ;; is a unique object that stands for the specifier (CONS T T).
652 (defglobal *cons-t-t-type
* -
1)
653 #+sb-xc
(declaim (type ctype
*cons-t-t-type
*))
655 (defun !intern-important-cons-type-instances
()
656 (setf *cons-t-t-type
*
658 (%make-cons-type
*universal-type
* *universal-type
*))))
661 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
662 (defun make-cons-type (car-type cdr-type
)
663 (aver (not (or (eq car-type
*wild-type
*)
664 (eq cdr-type
*wild-type
*))))
665 (cond ((or (eq car-type
*empty-type
*)
666 (eq cdr-type
*empty-type
*))
668 ;; It's not a requirement that (CONS T T) be interned,
669 ;; but it improves the hit rate in the function caches.
670 ((and (type= car-type
*universal-type
*)
671 (type= cdr-type
*universal-type
*))
674 (%make-cons-type car-type cdr-type
))))
676 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
678 (defstruct (simd-pack-type
679 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
680 (:constructor %make-simd-pack-type
(element-type))
682 (element-type (missing-arg)
683 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
687 (defun make-simd-pack-type (element-type)
688 (aver (neq element-type
*wild-type
*))
689 (if (eq element-type
*empty-type
*)
691 (%make-simd-pack-type
692 (dolist (pack-type *simd-pack-element-types
*
693 (error "~S element type must be a subtype of ~
694 ~{~S~#[~;, or ~:;, ~]~}."
695 'simd-pack
*simd-pack-element-types
*))
696 (when (csubtypep element-type
(specifier-type pack-type
))
697 (return (list pack-type
)))))))
702 ;;; Return the type structure corresponding to a type specifier.
704 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
705 ;;; type is defined (or redefined).
707 ;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily
708 ;;; to the CLHS intent, which is to make the type known to the compiler.
709 ;;; If we compile in one file:
710 ;;; (DEFCLASS FRUITBAT () ())
711 ;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT))
712 ;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its
713 ;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF,
714 ;;; which (correctly) signals an error if the class were not defined by the
715 ;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier
716 ;;; at call time is wrong.
718 ;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton
719 ;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and
720 ;;; (CHARACTER) are not. It has to do with whether the primitive is actually
721 ;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal.
722 ;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis]
723 ;;; compound type specifier with no arguments supplied, (x)."
724 ;;; By that same reasonining, is (x) accepted if x names a class?
727 ;;; The xc host uses an ordinary hash table for memoization.
729 (let ((table (make-hash-table :test
'equal
)))
730 (defun !values-specifier-type-memo-wrapper
(thunk specifier
)
731 (multiple-value-bind (type yesp
) (gethash specifier table
)
734 (setf (gethash specifier table
) (funcall thunk
)))))
735 (defun values-specifier-type-cache-clear ()
737 ;;; This cache is sized extremely generously, which has payoff
738 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
739 ;;; since EQ types are an immediate win.
741 (sb!impl
::!define-hash-cache values-specifier-type
742 ((orig equal-but-no-car-recursion
)) ()
743 :hash-function
#'sxhash
:hash-bits
10)
745 ;;; The recursive ("-R" suffixed) entry point for this function
746 ;;; should be used for each nested parser invocation.
747 (defun values-specifier-type-r (context type-specifier
)
748 (declare (type cons context
))
749 (labels ((fail (spec) ; Q: Shouldn't this signal a TYPE-ERROR ?
750 (error "bad thing to be a type specifier: ~S" spec
))
751 (instance-to-ctype (x)
752 (flet ((translate (classoid)
753 ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE
754 ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ?
756 (or (and (built-in-classoid-p classoid
)
757 (built-in-classoid-translation classoid
))
759 (cond ((classoid-p x
) (translate x
))
760 ;; Avoid TYPEP on SB!MOP:EQL-SPECIALIZER and CLASS because
761 ;; the fake metaobjects do not allow type analysis, and
762 ;; would cause a compiler error as it tries to decide
763 ;; whether any clause of this COND subsumes another.
764 ;; Moreover, we don't require the host to support MOP.
766 ((sb!pcl
::classp x
) (translate (sb!pcl
::class-classoid x
)))
768 ((sb!pcl
::eql-specializer-p type-specifier
)
769 ;; FIXME: these aren't always cached. Should they be?
770 ;; It seems so, as "parsing" constructs a new object.
771 ;; Perhaps better, the EQL specializer itself could store
772 ;; (by memoizing, if not precomputing) a CTYPE
774 (sb!mop
:eql-specializer-object type-specifier
)))
776 (when (typep type-specifier
'instance
)
777 (return-from values-specifier-type-r
(instance-to-ctype type-specifier
)))
778 (when (atom type-specifier
)
779 ;; Try to bypass the cache, which avoids using a cache line for standard
780 ;; atomic specifiers. This is a trade-off- cache seek might be faster,
781 ;; but this solves the problem that a full call to (TYPEP #\A 'FIXNUM)
782 ;; consed a cache line every time the cache missed on FIXNUM (etc).
783 (awhen (info :type
:builtin type-specifier
)
784 (return-from values-specifier-type-r it
)))
785 (!values-specifier-type-memo-wrapper
789 (prog* ((head (if (listp spec
) (car spec
) spec
))
790 (builtin (if (symbolp head
)
791 (info :type
:builtin head
)
792 (return (fail spec
)))))
793 (when (deprecated-thing-p 'type head
)
794 (setf (cdr context
) nil
)
795 (signal 'parse-deprecated-type
:specifier spec
))
797 ;; If spec is non-atomic, the :BUILTIN value is inapplicable.
798 ;; There used to be compound builtins, but not any more.
799 (when builtin
(return builtin
))
800 (case (info :type
:kind spec
)
801 (:instance
(return (find-classoid spec
)))
802 (:forthcoming-defclass-type
(go unknown
))))
803 ;; Expansion brings up an interesting question - should the cache
804 ;; contain entries for intermediary types? Say A -> B -> REAL.
805 ;; As it stands, we cache the ctype corresponding to A but not B.
806 (awhen (info :type
:expander head
)
807 (when (listp it
) ; The function translates directly to a CTYPE.
808 (return (or (funcall (car it
) context spec
) (fail spec
))))
809 ;; The function produces a type expression.
810 (let ((expansion (funcall it
(ensure-list spec
))))
811 (return (if (typep expansion
'instance
)
812 (instance-to-ctype expansion
)
813 (recurse expansion
)))))
814 ;; If the spec is (X ...) and X has neither a translator
815 ;; nor expander, and is a builtin, such as FIXNUM, fail now.
816 ;; But - see FIXME at top - it would be consistent with
817 ;; DEFTYPE to reject spec only if not a singleton.
818 (when builtin
(return (fail spec
)))
819 ;; SPEC has a legal form, so return an unknown type.
820 (signal 'parse-unknown-type
:specifier spec
)
822 (setf (cdr context
) nil
)
823 (return (make-unknown-type :specifier spec
)))))
824 (let ((result (recurse (uncross type-specifier
))))
825 (if (cdr context
) ; cacheable
827 ;; (The RETURN-FROM here inhibits caching; this makes sense
828 ;; not only from a compiler diagnostics point of view,
829 ;; but also for proper workingness of VALID-TYPE-SPECIFIER-P.
830 (return-from values-specifier-type-r result
)))))
832 (defun values-specifier-type (type-specifier)
833 (dx-let ((context (cons type-specifier t
)))
834 (values-specifier-type-r context type-specifier
)))
836 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
837 ;;; never return a VALUES type.
838 (defun specifier-type-r (context type-specifier
)
839 (let ((ctype (values-specifier-type-r context type-specifier
)))
840 (when (values-type-p ctype
)
841 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
843 (defun specifier-type (type-specifier)
844 (dx-let ((context (cons type-specifier t
)))
845 (specifier-type-r context type-specifier
)))
847 (defun single-value-specifier-type-r (context x
)
848 (if (eq x
'*) *universal-type
* (specifier-type-r context x
)))
849 (defun single-value-specifier-type (x)
854 (defun typexpand-1 (type-specifier &optional env
)
856 "Takes and expands a type specifier once like MACROEXPAND-1.
857 Returns two values: the expansion, and a boolean that is true when
859 (declare (type type-specifier type-specifier
))
860 (declare (type lexenv-designator env
) (ignore env
))
861 (let* ((spec type-specifier
)
862 (atom (if (listp spec
) (car spec
) spec
))
863 (expander (and (symbolp atom
) (info :type
:expander atom
))))
864 ;; We do not expand builtins even though it'd be
865 ;; possible to do so sometimes (e.g. STRING) for two
868 ;; a) From a user's point of view, CL types are opaque.
870 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
871 (if (and (functionp expander
) (not (info :type
:builtin atom
)))
872 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
873 (values type-specifier nil
))))
875 (defun typexpand (type-specifier &optional env
)
877 "Takes and expands a type specifier repeatedly like MACROEXPAND.
878 Returns two values: the expansion, and a boolean that is true when
880 ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
881 ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV.
882 (multiple-value-bind (expansion expanded
)
883 (typexpand-1 type-specifier env
)
885 (values (typexpand expansion env
) t
)
886 (values expansion expanded
))))
888 ;;; Note that the type NAME has been (re)defined, updating the
889 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
890 (defun %note-type-defined
(name)
891 (declare (symbol name
))
892 (note-name-defined name
:type
)
893 (values-specifier-type-cache-clear)
897 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)