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 specifier
)
19 (declare (ignorable 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 (sb!xc
:defmacro literal-ctype
(constructor specifier
)
30 (declare (ignorable constructor
))
31 ;; The source-transform for SPECIFIER-TYPE turn this call into
32 ;; (LOAD-TIME-VALUE (!SPECIFIER-TYPE ',specifier)).
33 ;; It's best to go through the transform rather than expand directly
34 ;; into that, because the transform canonicalizes the spec,
35 ;; ensuring correctness of the hash lookups performed during genesis.
36 `(specifier-type ',specifier
))
38 (sb!xc
:defmacro literal-ctype-vector
(var)
39 (let ((vector (symbol-value var
)))
40 `(truly-the (simple-vector ,(length vector
))
45 `(!specifier-type
',(type-specifier x
))
46 x
)) ; allow NIL or 0 in the vector
49 (!begin-collecting-cold-init-forms
)
51 ;;;; representations of types
53 ;;; A HAIRY-TYPE represents anything too weird to be described
54 ;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
55 ;;; and unreasonably complicated types involving AND. We just remember
56 ;;; the original type spec.
57 ;;; A possible improvement would be for HAIRY-TYPE to have a subtype
58 ;;; named SATISFIES-TYPE for the hairy types which are specifically
59 ;;; of the form (SATISFIES pred) so that we don't have to examine
60 ;;; the sexpr repeatedly to decide whether it takes that form.
61 ;;; And as a further improvement, we might want a table that maps
62 ;;; predicates to their exactly recognized type when possible.
63 ;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES*
64 ;;; as a starting point. But something like PLUSP isn't in there.
65 ;;; On the other hand, either of these points may not be sources of
66 ;;; inefficiency, and the latter if implemented might have undesirable
67 ;;; user-visible ramifications, though it seems unlikely.
68 (defstruct (hairy-type (:include ctype
69 (class-info (type-class-or-lose 'hairy
)))
70 (:constructor %make-hairy-type
(specifier))
73 ;; the Common Lisp type-specifier of the type we represent
74 (specifier nil
:type t
:read-only t
))
76 ;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
77 ;; e.g. any SATISFIES with a predicate returning T over a finite domain.
78 ;; But in practice there's nothing that can be done with this information,
79 ;; because we don't call random predicates when performing operations on types
80 ;; as objects, only when checking for inclusion of something in the type.
81 (!define-type-class hairy
:enumerable t
:might-contain-other-types t
)
83 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
84 ;;; defined). We make this distinction since we don't want to complain
85 ;;; about types that are hairy but defined.
86 (defstruct (unknown-type (:include hairy-type
)
89 (defun maybe-reparse-specifier (type)
90 (when (unknown-type-p type
)
91 (let* ((spec (unknown-type-specifier type
))
92 (name (if (consp spec
)
95 (when (info :type
:kind name
)
96 (let ((new-type (specifier-type spec
)))
97 (unless (unknown-type-p new-type
)
101 (defmacro maybe-reparse-specifier
! (type)
102 (assert (symbolp type
))
103 (with-unique-names (new-type)
104 `(let ((,new-type
(maybe-reparse-specifier ,type
)))
106 (setf ,type
,new-type
)
109 (defstruct (negation-type (:include ctype
110 (class-info (type-class-or-lose 'negation
)))
112 (:constructor make-negation-type
(type))
114 (type (missing-arg) :type ctype
:read-only t
))
116 ;; Former comment was:
117 ;; FIXME: is this right? It's what they had before, anyway
118 ;; But I think the reason it's right is that "enumerable :t" is equivalent
119 ;; to "maybe" which is actually the conservative assumption, same as HAIRY.
120 (!define-type-class negation
:enumerable t
:might-contain-other-types t
)
122 (defun canonicalize-args-type-args (required optional rest
&optional keyp
)
123 (when (eq rest
*empty-type
*)
126 (loop with last-not-rest
= nil
129 do
(cond ((eq opt
*empty-type
*)
130 (return (values required
(subseq optional i
) rest
)))
131 ((and (not keyp
) (neq opt rest
))
132 (setq last-not-rest i
)))
133 finally
(return (values required
137 (subseq optional
0 (1+ last-not-rest
))))
140 ;; CONTEXT is the cookie passed down from the outermost surrounding call
141 ;; of VALUES-SPECIFIER-TYPE. INNER-CONTEXT-KIND is an indicator of whether
142 ;; we are currently parsing a FUNCTION or a VALUES compound type specifier.
143 (defun parse-args-types (context lambda-listy-thing inner-context-kind
)
144 (multiple-value-bind (llks required optional rest keys
)
147 :context inner-context-kind
148 :accept
(ecase inner-context-kind
149 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
150 (:function-type
(lambda-list-keyword-mask
151 '(&optional
&rest
&key
&allow-other-keys
))))
153 (flet ((parse-list (list)
154 (mapcar (lambda (x) (single-value-specifier-type-r context x
))
156 (let ((required (parse-list required
))
157 (optional (parse-list optional
))
158 (rest (when rest
(single-value-specifier-type-r context
(car rest
))))
160 (collect ((key-info))
162 (unless (proper-list-of-length-p key
2)
163 (error "Keyword type description is not a two-list: ~S." key
))
164 (let ((kwd (first key
)))
165 (when (find kwd
(key-info) :key
#'key-info-name
)
166 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
167 kwd lambda-listy-thing
))
170 ;; MAKE-KEY-INFO will complain if KWD is not a symbol.
171 ;; That's good enough - we don't need an extra check here.
173 :type
(single-value-specifier-type-r context
(second key
))))))
175 (multiple-value-bind (required optional rest
)
176 (canonicalize-args-type-args required optional rest
178 (values llks required optional rest keywords
))))))
180 (defstruct (values-type
182 (class-info (type-class-or-lose 'values
)))
183 (:constructor %make-values-type
)
184 (:predicate %values-type-p
)
187 (declaim (inline values-type-p
))
188 (defun values-type-p (x)
189 (or (eq x
*wild-type
*)
192 (defun-cached (make-values-type-cached
195 (lambda (req opt rest allowp
)
196 (logxor (type-list-cache-hash req
)
197 (type-list-cache-hash opt
)
199 (type-hash-value rest
)
201 ;; Results (logand #xFF (sxhash t/nil))
202 ;; hardcoded to avoid relying on the xc host.
203 ;; [but (logand (sxhash nil) #xff) => 2
204 ;; for me, so the code and comment disagree,
205 ;; but not in a way that matters.]
209 ((required equal-but-no-car-recursion
)
210 (optional equal-but-no-car-recursion
)
213 (%make-values-type
:required required
218 (defun make-values-type (&key required optional rest allowp
)
219 (multiple-value-bind (required optional rest
)
220 (canonicalize-args-type-args required optional rest
)
221 (cond ((and (null required
)
223 (eq rest
*universal-type
*))
225 ((memq *empty-type
* required
)
227 (t (make-values-type-cached required optional
230 (!define-type-class values
:enumerable nil
231 :might-contain-other-types nil
)
233 (!define-type-class function
:enumerable nil
234 :might-contain-other-types nil
)
237 (defvar *interned-fun-types
*
240 (%make-fun-type
(make-list n
:initial-element
*universal-type
*)
241 nil nil nil nil nil nil
*wild-type
*))))
242 (vector (fun-type 0) (fun-type 1) (fun-type 2) (fun-type 3))))
244 (defun make-fun-type (&key required optional rest
247 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
248 (n (length required
)))
250 (not optional
) (not rest
) (not keyp
)
251 (not keywords
) (not allowp
) (not wild-args
)
252 (eq returns
*wild-type
*)
253 (not (find *universal-type
* required
:test
#'neq
)))
254 (svref (literal-ctype-vector *interned-fun-types
*) n
)
255 (%make-fun-type required optional rest keyp keywords
256 allowp wild-args returns
))))
258 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
259 ;;; "type specifier", which is only meaningful in function argument
260 ;;; type specifiers used within the compiler. (It represents something
261 ;;; that the compiler knows to be a constant.)
262 (defstruct (constant-type
264 (class-info (type-class-or-lose 'constant
)))
266 ;; The type which the argument must be a constant instance of for this type
268 (type (missing-arg) :type ctype
:read-only t
))
270 (!define-type-class number
:enumerable
#'numeric-type-enumerable
271 :might-contain-other-types nil
)
275 ;; Work around an ABCL bug. This fails to load:
276 ;; (macrolet ((foo-it (x) `(- ,x))) (defvar *var* (foo-it 3)))
277 (defvar *interned-signed-byte-types
*)
278 (defvar *interned-unsigned-byte-types
*)
279 (macrolet ((int-type (low high
)
280 `(mark-ctype-interned
281 (%make-numeric-type
:class
'integer
:enumerable t
282 :low
,low
:high
,high
))))
283 (setq *interned-signed-byte-types
*
284 (let ((v (make-array sb
!vm
:n-word-bits
))
286 (dotimes (i sb
!vm
:n-word-bits v
)
287 (setf (svref v i
) (int-type j
(lognot j
)) j
(ash j
1)))))
288 (setq *interned-unsigned-byte-types
*
289 (let ((v (make-array (1+ sb
!vm
:n-word-bits
))))
290 (dotimes (i (length v
) v
)
291 (setf (svref v i
) (int-type 0 (1- (ash 1 i
)))))))))
293 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
294 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
296 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
297 ;;; come from parsing MEMBER. But bounded integer ranges,
298 ;;; however large, are enumerable:
299 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
300 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
301 ;;; but, in contrast,
302 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
303 ;;; I can't figure out whether this is supposed to matter.
304 ;;; Moreover, it seems like this function should be responsible
305 ;;; for figuring out the right value so that callers don't have to.
306 (defun make-numeric-type (&key class format
(complexp :real
) low high
308 ;; if interval is empty
311 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
312 (>= (type-bound-number low
) (type-bound-number high
))
314 (return-from make-numeric-type
*empty-type
*))
315 (multiple-value-bind (low high
)
318 ;; INTEGER types always have their LOW and HIGH bounds
319 ;; represented as inclusive, not exclusive values.
320 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
321 (if (consp high
) (1- (type-bound-number high
)) high
)))
323 ;; no canonicalization necessary
325 (when (and (eq class
'rational
) (integerp low
) (eql low high
))
326 (setf class
'integer
))
327 ;; Either lookup the canonical interned object for
328 ;; a point in the type lattice, or construct a new one.
331 (macrolet ((float-type (fmt complexp
)
333 (%make-numeric-type
:class
'float
:complexp
,complexp
334 :format
',fmt
:enumerable nil
)
335 ,(if (eq complexp
:complex
) `(complex ,fmt
) fmt
))))
336 (when (and (null low
) (null high
))
340 (:real
(float-type single-float
:real
))
341 (:complex
(float-type single-float
:complex
))))
344 (:real
(float-type double-float
:real
))
345 (:complex
(float-type double-float
:complex
))))))))
347 (macrolet ((int-type (low high
)
350 :class
'integer
:low
,low
:high
,high
351 :enumerable
(if (and ,low
,high
) t nil
))
352 (integer ,(or low
'*) ,(or high
'*)))))
353 (cond ((neq complexp
:real
) nil
)
354 ((and (eql low
0) (eql high
(1- sb
!xc
:array-dimension-limit
)))
355 (int-type 0 #.
(1- sb
!xc
:array-dimension-limit
))) ; INDEX type
357 (cond ((not low
) (int-type nil nil
))
358 ((eql low
0) (int-type 0 nil
))
359 ((eql low
(1+ sb
!xc
:most-positive-fixnum
))
361 (int-type #.
(1+ sb
!xc
:most-positive-fixnum
) nil
))))
362 ((or (eql high most-positive-word
)
363 ;; is (1+ high) a power-of-2 ?
364 (and (typep high
'word
) (zerop (logand (1+ high
) high
))))
366 (svref (literal-ctype-vector *interned-unsigned-byte-types
*)
367 (integer-length (truly-the word high
))))
368 ((and (< high most-positive-word
) (eql low
(lognot high
)))
369 (svref (literal-ctype-vector *interned-signed-byte-types
*)
370 (integer-length (truly-the word high
))))))
371 ((and (not low
) (eql high
(1- sb
!xc
:most-negative-fixnum
)))
373 (int-type nil
#.
(1- sb
!xc
:most-negative-fixnum
))))))
375 (when (and (eq complexp
:real
) (null low
) (eq high low
))
376 (literal-ctype (%make-numeric-type
:class
'rational
) rational
))))
377 (let ((result (%make-numeric-type
:class class
:format format
380 :enumerable enumerable
)))
381 (setf (type-hash-value result
)
382 (logior (type-hash-value result
) +type-admits-type
=-optimization
+))
385 (defun modified-numeric-type (base
387 (class (numeric-type-class base
))
388 (format (numeric-type-format base
))
389 (complexp (numeric-type-complexp base
))
390 (low (numeric-type-low base
))
391 (high (numeric-type-high base
))
392 (enumerable (type-enumerable base
)))
393 (make-numeric-type :class class
398 :enumerable enumerable
))
400 ;; all character-set types are enumerable, but it's not possible
401 ;; for one to be TYPE= to a MEMBER type because (MEMBER #\x)
402 ;; is not internally represented as a MEMBER type.
403 ;; So in case it wasn't clear already ENUMERABLE-P does not mean
404 ;; "possibly a MEMBER type in the Lisp-theoretic sense",
405 ;; but means "could be implemented in SBCL as a MEMBER type".
406 (!define-type-class character-set
:enumerable nil
407 :might-contain-other-types nil
)
409 (defun make-character-set-type (pairs)
410 ; (aver (equal (mapcar #'car pairs)
411 ; (sort (mapcar #'car pairs) #'<)))
412 ;; aver that the cars of the list elements are sorted into increasing order
414 (do ((p pairs
(cdr p
)))
416 (aver (<= (caar p
) (caadr p
)))))
417 (let ((pairs (let (result)
418 (do ((pairs pairs
(cdr pairs
)))
419 ((null pairs
) (nreverse result
))
420 (destructuring-bind (low . high
) (car pairs
)
421 (loop for
(low1 . high1
) in
(cdr pairs
)
422 if
(<= low1
(1+ high
))
423 do
(progn (setf high
(max high high1
))
424 (setf pairs
(cdr pairs
)))
425 else do
(return nil
))
427 ((>= low sb
!xc
:char-code-limit
))
429 (t (push (cons (max 0 low
)
430 (min high
(1- sb
!xc
:char-code-limit
)))
433 (return-from make-character-set-type
*empty-type
*))
435 (macrolet ((range (low high
)
436 `(return-from make-character-set-type
437 (literal-ctype (%make-character-set-type
'((,low .
,high
)))
438 (character-set ((,low .
,high
)))))))
439 (let* ((pair (car pairs
))
442 (cond ((eql high
(1- sb
!xc
:char-code-limit
))
443 (cond ((eql low
0) (range 0 #.
(1- sb
!xc
:char-code-limit
)))
445 ((eql low base-char-code-limit
)
446 (range #.base-char-code-limit
447 #.
(1- sb
!xc
:char-code-limit
)))))
449 ((and (eql low
0) (eql high
(1- base-char-code-limit
)))
450 (range 0 #.
(1- base-char-code-limit
)))))))
451 (%make-character-set-type pairs
)))
453 (!define-type-class array
:enumerable nil
454 :might-contain-other-types nil
)
456 ;; For all ctypes which are the element types of specialized arrays,
457 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
458 ;; one for each of simple, maybe-simple, and non-simple (in that order),
459 ;; and 2 ctype objects for unknown-rank arrays, one each for simple
460 ;; and maybe-simple. (Unknown rank, known-non-simple isn't important)
462 (defvar *interned-array-types
*
463 (labels ((make-1 (type-index dims complexp type
)
464 (setf (!ctype-saetp-index type
) type-index
)
465 (mark-ctype-interned (%make-array-type dims complexp type type
)))
466 (make-all (element-type type-index array
)
468 (list (make-1 type-index
'(*) nil element-type
)
469 (make-1 type-index
'(*) :maybe element-type
)
470 (make-1 type-index
'(*) t element-type
)
471 (make-1 type-index
'* nil element-type
)
472 (make-1 type-index
'* :maybe element-type
))
473 :start1
(* type-index
5)))
474 (integer-range (low high
)
475 (make-numeric-type :class
'integer
:complexp
:real
476 :enumerable t
:low low
:high high
)))
477 (let ((array (make-array (* 32 5)))
479 ;; Index 31 is available to store *WILD-TYPE*
480 ;; because there are fewer than 32 array widetags.
481 (make-all *wild-type
* 31 array
)
482 (dolist (x *specialized-array-element-types
*
483 (progn (aver (< index
31)) array
))
485 ;; Produce element-type representation without parsing a spec.
486 ;; (SPECIFIER-TYPE doesn't work when bootstrapping.)
487 ;; The MAKE- constructors return an interned object as appropriate.
489 ((cons (eql unsigned-byte
))
490 (integer-range 0 (1- (ash 1 (second x
)))))
491 ((cons (eql signed-byte
))
492 (let ((lim (ash 1 (1- (second x
)))))
493 (integer-range (- lim
) (1- lim
))))
494 ((eql bit
) (integer-range 0 1))
495 ;; FIXNUM is its own thing, why? See comment in vm-array
496 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
497 ((eql fixnum
) ; One good kludge deserves another.
498 (integer-range sb
!xc
:most-negative-fixnum
499 sb
!xc
:most-positive-fixnum
))
500 ((member single-float double-float
)
501 (make-numeric-type :class
'float
:format x
:complexp
:real
))
502 ((cons (eql complex
))
503 (make-numeric-type :class
'float
:format
(cadr x
)
506 (make-character-set-type `((0 .
,(1- sb
!xc
:char-code-limit
)))))
509 (make-character-set-type `((0 .
,(1- base-char-code-limit
)))))
510 ((eql t
) *universal-type
*)
511 ((eql nil
) *empty-type
*))
515 (declaim (ftype (sfunction (t &key
(:complexp t
)
517 (:specialized-element-type t
))
518 ctype
) make-array-type
))
519 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
520 (specialized-element-type *wild-type
*))
521 (if (and (eq element-type specialized-element-type
)
522 (or (and (eq dimensions
'*) (neq complexp t
))
523 (typep dimensions
'(cons (eql *) null
))))
524 (let ((res (svref (literal-ctype-vector *interned-array-types
*)
525 (+ (* (!ctype-saetp-index element-type
) 5)
526 (if (listp dimensions
) 0 3)
527 (ecase complexp
((nil) 0) ((:maybe
) 1) ((t) 2))))))
528 (aver (eq (array-type-element-type res
) element-type
))
530 (%make-array-type dimensions
531 complexp element-type specialized-element-type
)))
533 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
534 ;;; bother with this at this level because MEMBER types are fairly
535 ;;; important and union and intersection are well defined.
536 (defstruct (member-type (:include ctype
537 (class-info (type-class-or-lose 'member
)))
539 (:constructor %make-member-type
(xset fp-zeroes
))
540 #-sb-xc-host
(:pure nil
))
541 (xset (missing-arg) :type xset
:read-only t
)
542 (fp-zeroes (missing-arg) :type list
:read-only t
))
544 (defglobal *null-type
* -
1) ; = (MEMBER NIL)
545 (defglobal *eql-t-type
* -
1) ; = (MEMBER T)
546 (defglobal *boolean-type
* -
1) ; = (MEMBER T NIL)
547 #+sb-xc
(declaim (type ctype
*null-type
*))
549 (defun !intern-important-member-type-instances
()
550 (flet ((make-it (list)
552 (%make-member-type
(xset-from-list list
) nil
))))
553 (setf *null-type
* (make-it '(nil))
554 *eql-t-type
* (make-it '(t))
555 *boolean-type
* (make-it '(t nil
)))))
557 (declaim (ftype (sfunction (xset list
) ctype
) make-member-type
))
558 (defun member-type-from-list (members)
559 (let ((xset (alloc-xset))
561 (dolist (elt members
(make-member-type xset fp-zeroes
))
563 (pushnew elt fp-zeroes
)
564 (add-to-xset elt xset
)))))
565 (defun make-eql-type (elt) (member-type-from-list (list elt
)))
566 ;; Return possibly a union of a MEMBER type and a NUMERIC type,
567 ;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET
568 ;; and the FP-ZEROES. XSET should not contains characters or real numbers.
569 (defun make-member-type (xset fp-zeroes
)
570 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
571 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
572 ;; ranges are compared by arithmetic operators (while MEMBERship is
573 ;; compared by EQL). -- CSR, 2003-04-23
577 (when fp-zeroes
; avoid doing two passes of nothing
579 (dolist (z fp-zeroes
)
580 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
585 #!+long-float
(long-float 4)))))
587 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
588 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
590 (push (ctype-of z
) float-types
))
591 (push z unpaired
)))))))
595 (when (singleton-p (xset-data xset
))
596 (case (first (xset-data xset
))
597 ((nil) (return *null-type
*))
598 ((t) (return *eql-t-type
*))))
599 ;; Semantically this is fine - XSETs
600 ;; are not order-preserving except by accident
601 ;; (when not represented as a hash-table).
602 (when (or (equal (xset-data xset
) '(t nil
))
603 (equal (xset-data xset
) '(nil t
)))
604 (return *boolean-type
*)))
605 (when (or unpaired
(not (xset-empty-p xset
)))
606 (let ((result (%make-member-type xset unpaired
)))
607 (setf (type-hash-value result
)
608 (logior (type-hash-value result
)
609 +type-admits-type
=-optimization
+))
611 ;; The actual member-type contains the XSET (with no FP zeroes),
612 ;; and a list of unpaired zeroes.
614 (make-union-type t
(if member-type
615 (cons member-type float-types
)
617 (or member-type
*empty-type
*)))))
619 (defun member-type-size (type)
620 (+ (length (member-type-fp-zeroes type
))
621 (xset-count (member-type-xset type
))))
623 (defun member-type-member-p (x type
)
625 (and (member x
(member-type-fp-zeroes type
)) t
)
626 (xset-member-p x
(member-type-xset type
))))
628 (defun mapcar-member-type-members (function type
)
629 (declare (function function
))
631 (map-xset (lambda (x)
632 (results (funcall function x
)))
633 (member-type-xset type
))
634 (dolist (zero (member-type-fp-zeroes type
))
635 (results (funcall function zero
)))
638 (defun mapc-member-type-members (function type
)
639 (declare (function function
))
640 (map-xset function
(member-type-xset type
))
641 (dolist (zero (member-type-fp-zeroes type
))
642 (funcall function zero
)))
644 (defun member-type-members (type)
645 (append (member-type-fp-zeroes type
)
646 (xset-members (member-type-xset type
))))
648 ;;; Return TYPE converted to canonical form for a situation where the
649 ;;; "type" '* (which SBCL still represents as a type even though ANSI
650 ;;; CL defines it as a related but different kind of placeholder) is
651 ;;; equivalent to type T.
652 (defun type-*-to-t
(type)
653 (if (type= type
*wild-type
*)
657 ;; The function caches work significantly better when there
658 ;; is a unique object that stands for the specifier (CONS T T).
659 (defglobal *cons-t-t-type
* -
1)
660 #+sb-xc
(declaim (type ctype
*cons-t-t-type
*))
662 (defun !intern-important-cons-type-instances
()
663 (setf *cons-t-t-type
*
665 (%make-cons-type
*universal-type
* *universal-type
*))))
668 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
669 (defun make-cons-type (car-type cdr-type
)
670 (aver (not (or (eq car-type
*wild-type
*)
671 (eq cdr-type
*wild-type
*))))
672 (cond ((or (eq car-type
*empty-type
*)
673 (eq cdr-type
*empty-type
*))
675 ;; It's not a requirement that (CONS T T) be interned,
676 ;; but it improves the hit rate in the function caches.
677 ((and (type= car-type
*universal-type
*)
678 (type= cdr-type
*universal-type
*))
681 (%make-cons-type car-type cdr-type
))))
683 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
685 (defstruct (simd-pack-type
686 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
687 (:constructor %make-simd-pack-type
(element-type))
689 (element-type (missing-arg)
690 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
694 (defun make-simd-pack-type (element-type)
695 (aver (neq element-type
*wild-type
*))
696 (if (eq element-type
*empty-type
*)
698 (%make-simd-pack-type
699 (dolist (pack-type *simd-pack-element-types
*
700 (error "~S element type must be a subtype of ~
701 ~{~S~#[~;, or ~:;, ~]~}."
702 'simd-pack
*simd-pack-element-types
*))
703 (when (csubtypep element-type
(specifier-type pack-type
))
704 (return (list pack-type
)))))))
709 ;;; Return the type structure corresponding to a type specifier.
711 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
712 ;;; type is defined (or redefined).
714 ;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily
715 ;;; to the CLHS intent, which is to make the type known to the compiler.
716 ;;; If we compile in one file:
717 ;;; (DEFCLASS FRUITBAT () ())
718 ;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT))
719 ;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its
720 ;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF,
721 ;;; which (correctly) signals an error if the class were not defined by the
722 ;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier
723 ;;; at call time is wrong.
725 ;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton
726 ;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and
727 ;;; (CHARACTER) are not. It has to do with whether the primitive is actually
728 ;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal.
729 ;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis]
730 ;;; compound type specifier with no arguments supplied, (x)."
731 ;;; By that same reasonining, is (x) accepted if x names a class?
734 ;;; The xc host uses an ordinary hash table for memoization.
736 (let ((table (make-hash-table :test
'equal
)))
737 (defun !values-specifier-type-memo-wrapper
(thunk specifier
)
738 (multiple-value-bind (type yesp
) (gethash specifier table
)
741 (setf (gethash specifier table
) (funcall thunk
)))))
742 (defun values-specifier-type-cache-clear ()
744 ;;; This cache is sized extremely generously, which has payoff
745 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
746 ;;; since EQ types are an immediate win.
748 (sb!impl
::!define-hash-cache values-specifier-type
749 ((orig equal-but-no-car-recursion
)) ()
750 :hash-function
#'sxhash
:hash-bits
10)
752 ;;; The recursive ("-R" suffixed) entry point for this function
753 ;;; should be used for each nested parser invocation.
754 (defun values-specifier-type-r (context type-specifier
)
755 (declare (type cons context
))
756 (labels ((fail (spec) ; Q: Shouldn't this signal a TYPE-ERROR ?
757 (error "bad thing to be a type specifier: ~S" spec
))
758 (instance-to-ctype (x)
759 (flet ((translate (classoid)
760 ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE
761 ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ?
763 (or (and (built-in-classoid-p classoid
)
764 (built-in-classoid-translation classoid
))
766 (cond ((classoid-p x
) (translate x
))
767 ;; Avoid TYPEP on SB!MOP:EQL-SPECIALIZER and CLASS because
768 ;; the fake metaobjects do not allow type analysis, and
769 ;; would cause a compiler error as it tries to decide
770 ;; whether any clause of this COND subsumes another.
771 ;; Moreover, we don't require the host to support MOP.
773 ((sb!pcl
::classp x
) (translate (sb!pcl
::class-classoid x
)))
775 ((sb!pcl
::eql-specializer-p type-specifier
)
776 ;; FIXME: these aren't always cached. Should they be?
777 ;; It seems so, as "parsing" constructs a new object.
778 ;; Perhaps better, the EQL specializer itself could store
779 ;; (by memoizing, if not precomputing) a CTYPE
781 (sb!mop
:eql-specializer-object type-specifier
)))
783 (when (typep type-specifier
'instance
)
784 (return-from values-specifier-type-r
(instance-to-ctype type-specifier
)))
785 (when (atom type-specifier
)
786 ;; Try to bypass the cache, which avoids using a cache line for standard
787 ;; atomic specifiers. This is a trade-off- cache seek might be faster,
788 ;; but this solves the problem that a full call to (TYPEP #\A 'FIXNUM)
789 ;; consed a cache line every time the cache missed on FIXNUM (etc).
790 (awhen (info :type
:builtin type-specifier
)
791 (return-from values-specifier-type-r it
)))
792 (!values-specifier-type-memo-wrapper
796 (prog* ((head (if (listp spec
) (car spec
) spec
))
797 (builtin (if (symbolp head
)
798 (info :type
:builtin head
)
799 (return (fail spec
)))))
800 (when (deprecated-thing-p 'type head
)
801 (setf (cdr context
) nil
)
802 (signal 'parse-deprecated-type
:specifier spec
))
804 ;; If spec is non-atomic, the :BUILTIN value is inapplicable.
805 ;; There used to be compound builtins, but not any more.
806 (when builtin
(return builtin
))
807 (case (info :type
:kind spec
)
808 (:instance
(return (find-classoid spec
)))
809 (:forthcoming-defclass-type
(go unknown
))))
810 ;; Expansion brings up an interesting question - should the cache
811 ;; contain entries for intermediary types? Say A -> B -> REAL.
812 ;; As it stands, we cache the ctype corresponding to A but not B.
813 (awhen (info :type
:expander head
)
814 (when (listp it
) ; The function translates directly to a CTYPE.
815 (return (or (funcall (car it
) context spec
) (fail spec
))))
816 ;; The function produces a type expression.
817 (let ((expansion (funcall it
(ensure-list spec
))))
818 (return (if (typep expansion
'instance
)
819 (instance-to-ctype expansion
)
820 (recurse expansion
)))))
821 ;; If the spec is (X ...) and X has neither a translator
822 ;; nor expander, and is a builtin, such as FIXNUM, fail now.
823 ;; But - see FIXME at top - it would be consistent with
824 ;; DEFTYPE to reject spec only if not a singleton.
825 (when builtin
(return (fail spec
)))
826 ;; SPEC has a legal form, so return an unknown type.
827 (signal 'parse-unknown-type
:specifier spec
)
829 (setf (cdr context
) nil
)
830 (return (make-unknown-type :specifier spec
)))))
831 (let ((result (recurse (uncross type-specifier
))))
832 (if (cdr context
) ; cacheable
834 ;; (The RETURN-FROM here inhibits caching; this makes sense
835 ;; not only from a compiler diagnostics point of view,
836 ;; but also for proper workingness of VALID-TYPE-SPECIFIER-P.
837 (return-from values-specifier-type-r result
)))))
839 (defun values-specifier-type (type-specifier)
840 (dx-let ((context (cons type-specifier t
)))
841 (values-specifier-type-r context type-specifier
)))
843 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
844 ;;; never return a VALUES type.
845 (defun specifier-type-r (context type-specifier
)
846 (let ((ctype (values-specifier-type-r context type-specifier
)))
847 (when (values-type-p ctype
)
848 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
850 (defun specifier-type (type-specifier)
851 (dx-let ((context (cons type-specifier t
)))
852 (specifier-type-r context type-specifier
)))
854 (defun single-value-specifier-type-r (context x
)
855 (if (eq x
'*) *universal-type
* (specifier-type-r context x
)))
856 (defun single-value-specifier-type (x)
861 (defun typexpand-1 (type-specifier &optional env
)
863 "Takes and expands a type specifier once like MACROEXPAND-1.
864 Returns two values: the expansion, and a boolean that is true when
866 (declare (type type-specifier type-specifier
))
867 (declare (type lexenv-designator env
) (ignore env
))
868 (let* ((spec type-specifier
)
869 (atom (if (listp spec
) (car spec
) spec
))
870 (expander (and (symbolp atom
) (info :type
:expander atom
))))
871 ;; We do not expand builtins even though it'd be
872 ;; possible to do so sometimes (e.g. STRING) for two
875 ;; a) From a user's point of view, CL types are opaque.
877 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
878 (if (and (functionp expander
) (not (info :type
:builtin atom
)))
879 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
880 (values type-specifier nil
))))
882 (defun typexpand (type-specifier &optional env
)
884 "Takes and expands a type specifier repeatedly like MACROEXPAND.
885 Returns two values: the expansion, and a boolean that is true when
887 ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
888 ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV.
889 (multiple-value-bind (expansion expanded
)
890 (typexpand-1 type-specifier env
)
892 (values (typexpand expansion env
) t
)
893 (values expansion expanded
))))
895 ;;; Note that the type NAME has been (re)defined, updating the
896 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
897 (defun %note-type-defined
(name)
898 (declare (symbol name
))
899 (note-name-defined name
:type
)
900 (values-specifier-type-cache-clear)
904 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)
906 ;;; When cross-compiling SPECIFIER-TYPE with a quoted argument,
907 ;;; it can be rendered as a literal object unless it:
908 ;;; - mentions a classoid or unknown type
909 ;;; - uses a floating-point literal (perhaps positive zero could be allowed?)
911 ;;; This is important for type system initialization, but it will also
912 ;;; apply to hand-written calls and make-load-form expressions.
914 ;;; After the target is built, we remove this transform, both because calls
915 ;;; to SPECIFIER-TYPE do not arise organically through user code,
916 ;;; and because it is possible that user changes to types could make parsing
917 ;;; return a different thing, e.g. changing a DEFTYPE to a DEFCLASS.
921 (sb!c
::define-source-transform specifier-type
(type-spec &environment env
)
922 (or (and (sb!xc
:constantp type-spec env
)
923 (let ((parse (specifier-type (constant-form-value type-spec env
))))
925 ((contains-unknown-type-p parse
)
926 (bug "SPECIFIER-TYPE transform parsed an unknown type"))
927 ((cold-dumpable-type-p parse
)
928 ;; Obtain a canonical form by unparsing so that TYPE= specs
929 ;; coalesce in presence of DEFTYPEs. LOAD-TIME-VALUE in the
930 ;; cross-compiler has a special-case to turn !SPECIFIER-TYPE
931 ;; into a fop-funcall, which is handled by genesis.
932 `(load-time-value (!specifier-type
',(type-specifier parse
))
936 (defun cold-dumpable-type-p (ctype)
937 (named-let recurse
((ctype ctype
))
940 (and (every #'recurse
(args-type-required ctype
))
941 (every #'recurse
(args-type-optional ctype
))
942 (acond ((args-type-rest ctype
) (recurse it
)) (t))
943 (every (lambda (x) (recurse (key-info-type x
)))
944 (args-type-keywords ctype
))
945 (if (fun-type-p ctype
) (recurse (fun-type-returns ctype
)) t
)))
947 ;; Floating-point constants are not dumpable. (except maybe +0.0)
948 (if (or (typep (numeric-type-low ctype
) '(or float
(cons float
)))
949 (typep (numeric-type-high ctype
) '(or float
(cons float
))))
952 ;; HAIRY is just an s-expression, so it's dumpable
953 ((or named-type character-set-type hairy-type
) t
))))
955 (setf (get '!specifier-type
:sb-cold-funcall-handler
/for-value
)
958 (if (symbolp arg
) arg
(sb!fasl
::host-object-from-core arg
))))
959 (sb!fasl
::ctype-to-core specifier
(specifier-type specifier
)))))
961 (setf (info :function
:where-from
'!specifier-type
) :declared
) ; lie