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 (aver (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
0 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
272 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
273 (n (length required
)))
275 (make-fun-designator-type required optional rest keyp keywords
276 allowp wild-args returns
))
279 (not optional
) (not rest
) (not keyp
)
280 (not keywords
) (not allowp
) (not wild-args
)
281 (eq returns
*wild-type
*)
282 (not (find *universal-type
* required
:test
#'neq
)))
283 (svref (literal-ctype-vector *interned-fun-types
*) n
))
285 (%make-fun-type required optional rest keyp keywords
286 allowp wild-args returns
)))))
288 ;; This seems to be used only by cltl2, and within 'cross-type',
289 ;; where it is never used, which makes sense, since pretty much we
290 ;; never want this object, but instead the classoid FUNCTION
291 ;; if we know nothing about a function's signature.
292 ;; Maybe this should not exist unless cltl2 is loaded???
293 (defvar *universal-fun-type
*
294 (make-fun-type :wild-args t
:returns
*wild-type
*))
296 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
297 ;;; "type specifier", which is only meaningful in function argument
298 ;;; type specifiers used within the compiler. (It represents something
299 ;;; that the compiler knows to be a constant.)
300 (defstruct (constant-type
302 (class-info (type-class-or-lose 'constant
)))
304 ;; The type which the argument must be a constant instance of for this type
306 (type (missing-arg) :type ctype
:read-only t
))
308 (!define-type-class number
:enumerable
#'numeric-type-enumerable
309 :might-contain-other-types nil
)
313 ;; Work around an ABCL bug. This fails to load:
314 ;; (macrolet ((foo-it (x) `(- ,x))) (defvar *var* (foo-it 3)))
315 (defvar *interned-signed-byte-types
*)
316 (defvar *interned-unsigned-byte-types
*)
317 (macrolet ((int-type (low high
)
318 `(mark-ctype-interned
319 (%make-numeric-type
:class
'integer
:enumerable t
320 :low
,low
:high
,high
))))
321 (setq *interned-signed-byte-types
*
322 (let ((v (make-array sb
!vm
:n-word-bits
))
324 (dotimes (i sb
!vm
:n-word-bits v
)
325 (setf (svref v i
) (int-type j
(lognot j
)) j
(ash j
1)))))
326 (setq *interned-unsigned-byte-types
*
327 (let ((v (make-array (1+ sb
!vm
:n-word-bits
))))
328 (dotimes (i (length v
) v
)
329 (setf (svref v i
) (int-type 0 (1- (ash 1 i
)))))))))
331 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
332 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
334 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
335 ;;; come from parsing MEMBER. But bounded integer ranges,
336 ;;; however large, are enumerable:
337 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
338 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
339 ;;; but, in contrast,
340 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
341 ;;; I can't figure out whether this is supposed to matter.
342 ;;; Moreover, it seems like this function should be responsible
343 ;;; for figuring out the right value so that callers don't have to.
344 (defun make-numeric-type (&key class format
(complexp :real
) low high
346 (multiple-value-bind (low high
)
349 ;; INTEGER types always have their LOW and HIGH bounds
350 ;; represented as inclusive, not exclusive values.
351 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
352 (if (consp high
) (1- (type-bound-number high
)) high
)))
354 ;; no canonicalization necessary
356 ;; if interval is empty
358 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
359 (>= (type-bound-number low
) (type-bound-number high
))
361 (return-from make-numeric-type
*empty-type
*))
362 (when (and (eq class
'rational
) (integerp low
) (eql low high
))
363 (setf class
'integer
))
364 ;; Either lookup the canonical interned object for
365 ;; a point in the type lattice, or construct a new one.
368 (macrolet ((float-type (fmt complexp
)
370 (%make-numeric-type
:class
'float
:complexp
,complexp
371 :format
',fmt
:enumerable nil
)
372 ,(if (eq complexp
:complex
) `(complex ,fmt
) fmt
))))
373 (when (and (null low
) (null high
))
377 (:real
(float-type single-float
:real
))
378 (:complex
(float-type single-float
:complex
))))
381 (:real
(float-type double-float
:real
))
382 (:complex
(float-type double-float
:complex
))))))))
384 (macrolet ((int-type (low high
)
387 :class
'integer
:low
,low
:high
,high
388 :enumerable
(if (and ,low
,high
) t nil
))
389 (integer ,(or low
'*) ,(or high
'*)))))
390 (cond ((neq complexp
:real
) nil
)
391 ((and (eql low
0) (eql high
(1- sb
!xc
:array-dimension-limit
)))
392 (int-type 0 #.
(1- sb
!xc
:array-dimension-limit
))) ; INDEX type
394 (cond ((not low
) (int-type nil nil
))
395 ((eql low
0) (int-type 0 nil
))
396 ((eql low
(1+ sb
!xc
:most-positive-fixnum
))
398 (int-type #.
(1+ sb
!xc
:most-positive-fixnum
) nil
))))
399 ((or (eql high most-positive-word
)
400 ;; is (1+ high) a power-of-2 ?
401 (and (typep high
'word
) (zerop (logand (1+ high
) high
))))
403 (svref (literal-ctype-vector *interned-unsigned-byte-types
*)
404 (integer-length (truly-the word high
))))
405 ((and (< high most-positive-word
) (eql low
(lognot high
)))
406 (svref (literal-ctype-vector *interned-signed-byte-types
*)
407 (integer-length (truly-the word high
))))))
408 ((and (not low
) (eql high
(1- sb
!xc
:most-negative-fixnum
)))
410 (int-type nil
#.
(1- sb
!xc
:most-negative-fixnum
))))))
412 (when (and (eq complexp
:real
) (null low
) (eq high low
))
413 (literal-ctype (%make-numeric-type
:class
'rational
) rational
))))
414 (let ((result (%make-numeric-type
:class class
:format format
417 :enumerable enumerable
)))
418 (setf (type-hash-value result
)
419 (logior (type-hash-value result
) +type-admits-type
=-optimization
+))
422 (defun modified-numeric-type (base
424 (class (numeric-type-class base
))
425 (format (numeric-type-format base
))
426 (complexp (numeric-type-complexp base
))
427 (low (numeric-type-low base
))
428 (high (numeric-type-high base
))
429 (enumerable (type-enumerable base
)))
430 (make-numeric-type :class class
435 :enumerable enumerable
))
437 (defun make-character-set-type (pairs)
438 ; (aver (equal (mapcar #'car pairs)
439 ; (sort (mapcar #'car pairs) #'<)))
440 ;; aver that the cars of the list elements are sorted into increasing order
442 (do ((p pairs
(cdr p
)))
444 (aver (<= (caar p
) (caadr p
)))))
445 (let ((pairs (let (result)
446 (do ((pairs pairs
(cdr pairs
)))
447 ((null pairs
) (nreverse result
))
448 (destructuring-bind (low . high
) (car pairs
)
449 (loop for
(low1 . high1
) in
(cdr pairs
)
450 if
(<= low1
(1+ high
))
451 do
(progn (setf high
(max high high1
))
452 (setf pairs
(cdr pairs
)))
453 else do
(return nil
))
455 ((>= low sb
!xc
:char-code-limit
))
457 (t (push (cons (max 0 low
)
458 (min high
(1- sb
!xc
:char-code-limit
)))
461 (return-from make-character-set-type
*empty-type
*))
463 (macrolet ((range (low high
)
464 `(return-from make-character-set-type
465 (literal-ctype (%make-character-set-type
'((,low .
,high
)))
466 (character-set ((,low .
,high
)))))))
467 (let* ((pair (car pairs
))
470 (cond ((eql high
(1- sb
!xc
:char-code-limit
))
471 (cond ((eql low
0) (range 0 #.
(1- sb
!xc
:char-code-limit
)))
473 ((eql low base-char-code-limit
)
474 (range #.base-char-code-limit
475 #.
(1- sb
!xc
:char-code-limit
)))))
477 ((and (eql low
0) (eql high
(1- base-char-code-limit
)))
478 (range 0 #.
(1- base-char-code-limit
)))))))
479 (%make-character-set-type pairs
)))
481 (!define-type-class array
:enumerable nil
482 :might-contain-other-types nil
)
484 ;; For all ctypes which are the element types of specialized arrays,
485 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
486 ;; one for each of simple, maybe-simple, and non-simple (in that order),
487 ;; and 2 ctype objects for unknown-rank arrays, one each for simple
488 ;; and maybe-simple. (Unknown rank, known-non-simple isn't important)
491 (defvar *interned-array-types
*
492 (labels ((make-1 (type-index dims complexp type
)
493 (setf (!ctype-saetp-index type
) type-index
)
494 (mark-ctype-interned (%make-array-type dims complexp type type
)))
495 (make-all (element-type type-index array
)
497 (list (make-1 type-index
'(*) nil element-type
)
498 (make-1 type-index
'(*) :maybe element-type
)
499 (make-1 type-index
'(*) t element-type
)
500 (make-1 type-index
'* nil element-type
)
501 (make-1 type-index
'* :maybe element-type
))
502 :start1
(* type-index
5)))
503 (integer-range (low high
)
504 (make-numeric-type :class
'integer
:complexp
:real
505 :enumerable t
:low low
:high high
)))
506 (let ((array (make-array (* 32 5)))
508 ;; Index 31 is available to store *WILD-TYPE*
509 ;; because there are fewer than 32 array widetags.
510 (make-all *wild-type
* 31 array
)
511 (dolist (x *specialized-array-element-types
*
512 (progn (aver (< index
31)) array
))
514 ;; Produce element-type representation without parsing a spec.
515 ;; (SPECIFIER-TYPE doesn't work when bootstrapping.)
516 ;; The MAKE- constructors return an interned object as appropriate.
518 ((cons (eql unsigned-byte
))
519 (integer-range 0 (1- (ash 1 (second x
)))))
520 ((cons (eql signed-byte
))
521 (let ((lim (ash 1 (1- (second x
)))))
522 (integer-range (- lim
) (1- lim
))))
523 ((eql bit
) (integer-range 0 1))
524 ;; FIXNUM is its own thing, why? See comment in vm-array
525 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
526 ((eql fixnum
) ; One good kludge deserves another.
527 (integer-range sb
!xc
:most-negative-fixnum
528 sb
!xc
:most-positive-fixnum
))
529 ((member single-float double-float
)
530 (make-numeric-type :class
'float
:format x
:complexp
:real
))
531 ((cons (eql complex
))
532 (make-numeric-type :class
'float
:format
(cadr x
)
535 (make-character-set-type `((0 .
,(1- sb
!xc
:char-code-limit
)))))
538 (make-character-set-type `((0 .
,(1- base-char-code-limit
)))))
539 ((eql t
) *universal-type
*)
540 ((eql nil
) *empty-type
*))
543 (defvar *parsed-specialized-array-element-types
*
544 (let ((a (make-array (length *specialized-array-element-types
*))))
545 (loop for i below
(length a
)
546 do
(setf (aref a i
) (array-type-specialized-element-type
547 (aref *interned-array-types
* (* i
5)))))
550 (declaim (ftype (sfunction (t &key
(:complexp t
)
552 (:specialized-element-type t
))
553 ctype
) make-array-type
))
554 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
555 (specialized-element-type *wild-type
*))
556 (if (and (eq element-type specialized-element-type
)
557 (or (and (eq dimensions
'*) (neq complexp t
))
558 (typep dimensions
'(cons (eql *) null
))))
559 (let ((res (svref (literal-ctype-vector *interned-array-types
*)
560 (+ (* (!ctype-saetp-index element-type
) 5)
561 (if (listp dimensions
) 0 3)
562 (ecase complexp
((nil) 0) ((:maybe
) 1) ((t) 2))))))
563 (aver (eq (array-type-element-type res
) element-type
))
565 (%make-array-type dimensions
566 complexp element-type specialized-element-type
)))
568 (!define-type-class member
:enumerable t
569 :might-contain-other-types nil
)
571 (declaim (ftype (sfunction (xset list
) ctype
) make-member-type
))
572 (defun member-type-from-list (members)
573 (let ((xset (alloc-xset))
575 (dolist (elt members
(make-member-type xset fp-zeroes
))
577 (pushnew elt fp-zeroes
)
578 (add-to-xset elt xset
)))))
579 (defun make-eql-type (elt) (member-type-from-list (list elt
)))
580 ;; Return possibly a union of a MEMBER type and a NUMERIC type,
581 ;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET
582 ;; and the FP-ZEROES. XSET should not contains characters or real numbers.
583 (defun make-member-type (xset fp-zeroes
)
584 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
585 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
586 ;; ranges are compared by arithmetic operators (while MEMBERship is
587 ;; compared by EQL). -- CSR, 2003-04-23
591 (when fp-zeroes
; avoid doing two passes of nothing
593 (dolist (z fp-zeroes
)
594 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
599 #!+long-float
(long-float 4)))))
601 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
602 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
604 (push (ctype-of z
) float-types
))
605 (push z unpaired
)))))))
609 (macrolet ((member-type (&rest elts
)
611 (%make-member-type
(xset-from-list ',elts
) nil
)
613 (let ((elts (xset-data xset
)))
614 (when (singleton-p elts
)
616 ((nil) (return (member-type nil
)))
617 ((t) (return (member-type t
)))))
618 (when (or (equal elts
'(t nil
)) (equal elts
'(nil t
)))
619 ;; Semantically this is fine - XSETs
620 ;; are not order-preserving except by accident
621 ;; (when not represented as a hash-table).
622 (return (member-type t nil
))))))
623 (when (or unpaired
(not (xset-empty-p xset
)))
624 (let ((result (%make-member-type xset unpaired
)))
625 (setf (type-hash-value result
)
626 (logior (type-hash-value result
)
627 +type-admits-type
=-optimization
+))
629 ;; The actual member-type contains the XSET (with no FP zeroes),
630 ;; and a list of unpaired zeroes.
632 (make-union-type t
(if member-type
633 (cons member-type float-types
)
635 (or member-type
*empty-type
*)))))
637 (defun member-type-size (type)
638 (+ (length (member-type-fp-zeroes type
))
639 (xset-count (member-type-xset type
))))
641 (defun member-type-member-p (x type
)
643 (and (member x
(member-type-fp-zeroes type
)) t
)
644 (xset-member-p x
(member-type-xset type
))))
646 (defun mapcar-member-type-members (function type
)
647 (declare (function function
))
649 (map-xset (lambda (x)
650 (results (funcall function x
)))
651 (member-type-xset type
))
652 (dolist (zero (member-type-fp-zeroes type
))
653 (results (funcall function zero
)))
656 (defun mapc-member-type-members (function type
)
657 (declare (function function
))
658 (map-xset function
(member-type-xset type
))
659 (dolist (zero (member-type-fp-zeroes type
))
660 (funcall function zero
)))
662 (defun member-type-members (type)
663 (append (member-type-fp-zeroes type
)
664 (xset-members (member-type-xset type
))))
666 ;;; Return TYPE converted to canonical form for a situation where the
667 ;;; "type" '* (which SBCL still represents as a type even though ANSI
668 ;;; CL defines it as a related but different kind of placeholder) is
669 ;;; equivalent to type T.
670 (defun type-*-to-t
(type)
671 (if (type= type
*wild-type
*)
675 (!define-type-class cons
:enumerable nil
:might-contain-other-types nil
)
678 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
679 (defun make-cons-type (car-type cdr-type
)
680 (aver (not (or (eq car-type
*wild-type
*)
681 (eq cdr-type
*wild-type
*))))
682 (cond ((or (eq car-type
*empty-type
*)
683 (eq cdr-type
*empty-type
*))
685 ;; It's not a requirement that (CONS T T) be interned,
686 ;; but it improves the hit rate in the function caches.
687 ((and (type= car-type
*universal-type
*)
688 (type= cdr-type
*universal-type
*))
689 (literal-ctype (%make-cons-type
*universal-type
* *universal-type
*)
692 (%make-cons-type car-type cdr-type
))))
694 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
696 (defstruct (simd-pack-type
697 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
698 (:constructor %make-simd-pack-type
(element-type))
700 (element-type (missing-arg)
701 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
705 (defun make-simd-pack-type (element-type)
706 (aver (neq element-type
*wild-type
*))
707 (if (eq element-type
*empty-type
*)
709 (%make-simd-pack-type
710 (dolist (pack-type *simd-pack-element-types
*
711 (error "~S element type must be a subtype of ~
712 ~{~/sb!impl:print-type-specifier/~#[~;, or ~
714 'simd-pack
*simd-pack-element-types
*))
715 (when (csubtypep element-type
(specifier-type pack-type
))
716 (return (list pack-type
)))))))
721 ;;; Return the type structure corresponding to a type specifier.
723 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
724 ;;; type is defined (or redefined).
726 ;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily
727 ;;; to the CLHS intent, which is to make the type known to the compiler.
728 ;;; If we compile in one file:
729 ;;; (DEFCLASS FRUITBAT () ())
730 ;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT))
731 ;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its
732 ;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF,
733 ;;; which (correctly) signals an error if the class were not defined by the
734 ;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier
735 ;;; at call time is wrong.
737 ;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton
738 ;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and
739 ;;; (CHARACTER) are not. It has to do with whether the primitive is actually
740 ;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal.
741 ;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis]
742 ;;; compound type specifier with no arguments supplied, (x)."
743 ;;; By that same reasonining, is (x) accepted if x names a class?
746 ;;; The xc host uses an ordinary hash table for memoization.
748 (let ((table (make-hash-table :test
'equal
)))
749 (defun !values-specifier-type-memo-wrapper
(thunk specifier
)
750 (multiple-value-bind (type yesp
) (gethash specifier table
)
753 (setf (gethash specifier table
) (funcall thunk
)))))
754 (defun values-specifier-type-cache-clear ()
756 ;;; This cache is sized extremely generously, which has payoff
757 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
758 ;;; since EQ types are an immediate win.
760 (sb!impl
::!define-hash-cache values-specifier-type
761 ((orig equal-but-no-car-recursion
)) ()
762 :hash-function
#'sxhash
:hash-bits
10)
764 (defvar *pending-defstruct-type
*)
765 (declaim (type classoid
*pending-defstruct-type
*))
767 ;;; The recursive ("-R" suffixed) entry point for this function
768 ;;; should be used for each nested parser invocation.
769 (defun values-specifier-type-r (context type-specifier
)
770 (declare (type cons context
))
771 (labels ((fail (spec) ; Q: Shouldn't this signal a TYPE-ERROR ?
772 #-sb-xc-host
(declare (optimize allow-non-returning-tail-call
))
773 (error "bad thing to be a type specifier: ~
774 ~/sb!impl:print-type-specifier/"
776 (instance-to-ctype (x)
777 (flet ((translate (classoid)
778 ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE
779 ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ?
781 (or (and (built-in-classoid-p classoid
)
782 (built-in-classoid-translation classoid
))
784 (cond ((classoid-p x
) (translate x
))
785 ;; Avoid TYPEP on SB!MOP:EQL-SPECIALIZER and CLASS because
786 ;; the fake metaobjects do not allow type analysis, and
787 ;; would cause a compiler error as it tries to decide
788 ;; whether any clause of this COND subsumes another.
789 ;; Moreover, we don't require the host to support MOP.
791 ((sb!pcl
::classp x
) (translate (sb!pcl
::class-classoid x
)))
793 ((sb!pcl
::eql-specializer-p type-specifier
)
794 ;; FIXME: these aren't always cached. Should they be?
795 ;; It seems so, as "parsing" constructs a new object.
796 ;; Perhaps better, the EQL specializer itself could store
797 ;; (by memoizing, if not precomputing) a CTYPE
799 (sb!mop
:eql-specializer-object type-specifier
)))
801 (when (typep type-specifier
'instance
)
802 (return-from values-specifier-type-r
(instance-to-ctype type-specifier
)))
803 (when (atom type-specifier
)
804 ;; Try to bypass the cache, which avoids using a cache line for standard
805 ;; atomic specifiers. This is a trade-off- cache seek might be faster,
806 ;; but this solves the problem that a full call to (TYPEP #\A 'FIXNUM)
807 ;; consed a cache line every time the cache missed on FIXNUM (etc).
808 (awhen (info :type
:builtin type-specifier
)
809 (return-from values-specifier-type-r it
)))
810 (!values-specifier-type-memo-wrapper
814 (prog* ((head (if (listp spec
) (car spec
) spec
))
815 (builtin (if (symbolp head
)
816 (info :type
:builtin head
)
817 (return (fail spec
)))))
818 (when (deprecated-thing-p 'type head
)
819 (setf (cdr context
) nil
)
820 (signal 'parse-deprecated-type
:specifier spec
))
822 ;; If spec is non-atomic, the :BUILTIN value is inapplicable.
823 ;; There used to be compound builtins, but not any more.
824 (when builtin
(return builtin
))
825 ;; Any spec that apparently refers to a defstruct form
826 ;; that's being macroexpanded should refer to that type.
827 (when (boundp '*pending-defstruct-type
*)
828 (let ((classoid *pending-defstruct-type
*))
829 (when (eq (classoid-name classoid
) spec
)
830 (setf (cdr context
) nil
) ; don't cache
832 (case (info :type
:kind spec
)
833 (:instance
(return (find-classoid spec
)))
834 (:forthcoming-defclass-type
(go unknown
))))
835 ;; Expansion brings up an interesting question - should the cache
836 ;; contain entries for intermediary types? Say A -> B -> REAL.
837 ;; As it stands, we cache the ctype corresponding to A but not B.
838 (awhen (info :type
:expander head
)
839 (when (listp it
) ; The function translates directly to a CTYPE.
840 (return (or (funcall (car it
) context spec
) (fail spec
))))
841 ;; The function produces a type expression.
842 (let ((expansion (funcall it
(ensure-list spec
))))
843 (return (if (typep expansion
'instance
)
844 (instance-to-ctype expansion
)
845 (recurse expansion
)))))
846 ;; If the spec is (X ...) and X has neither a translator
847 ;; nor expander, and is a builtin, such as FIXNUM, fail now.
848 ;; But - see FIXME at top - it would be consistent with
849 ;; DEFTYPE to reject spec only if not a singleton.
850 (when builtin
(return (fail spec
)))
851 ;; SPEC has a legal form, so return an unknown type.
852 (signal 'parse-unknown-type
:specifier spec
)
854 (setf (cdr context
) nil
)
855 (return (make-unknown-type :specifier spec
)))))
856 (let ((result (recurse (uncross type-specifier
))))
857 (if (cdr context
) ; cacheable
859 ;; (The RETURN-FROM here inhibits caching; this makes sense
860 ;; not only from a compiler diagnostics point of view,
861 ;; but also for proper workingness of VALID-TYPE-SPECIFIER-P.
862 (return-from values-specifier-type-r result
)))))
864 (defun values-specifier-type (type-specifier)
865 (dx-let ((context (cons type-specifier t
)))
866 (values-specifier-type-r context type-specifier
)))
868 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
869 ;;; never return a VALUES type.
870 (defun specifier-type-r (context type-specifier
)
871 (let ((ctype (values-specifier-type-r context type-specifier
)))
872 (when (values-type-p ctype
)
873 (error "VALUES type illegal in this context:~% ~
874 ~/sb!impl:print-type-specifier/"
877 (defun specifier-type (type-specifier)
878 (dx-let ((context (cons type-specifier t
)))
879 (specifier-type-r context type-specifier
)))
881 ;;; Parse TYPE-SPECIFIER, returning NIL if any sub-part of it is unknown
882 (defun type-or-nil-if-unknown (type-specifier &optional allow-values
)
883 (dx-let ((context (cons type-specifier t
)))
884 (let ((result (values-specifier-type-r context type-specifier
)))
885 (when (and (not allow-values
) (values-type-p result
))
886 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
887 ;; If it was non-cacheable, either it contained a deprecated type
888 ;; or unknown type, or was a pending defstruct definition.
889 (if (and (not (cdr context
)) (contains-unknown-type-p result
))
893 (defun single-value-specifier-type-r (context x
)
894 (if (eq x
'*) *universal-type
* (specifier-type-r context x
)))
895 (defun single-value-specifier-type (x)
900 (defun typexpand-1 (type-specifier &optional env
)
901 "Takes and expands a type specifier once like MACROEXPAND-1.
902 Returns two values: the expansion, and a boolean that is true when
904 (declare (type type-specifier type-specifier
))
905 (declare (type lexenv-designator env
) (ignore env
))
906 (let* ((spec type-specifier
)
907 (atom (if (listp spec
) (car spec
) spec
))
908 (expander (and (symbolp atom
) (info :type
:expander atom
))))
909 ;; We do not expand builtins even though it'd be
910 ;; possible to do so sometimes (e.g. STRING) for two
913 ;; a) From a user's point of view, CL types are opaque.
915 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
916 (if (and (functionp expander
) (not (info :type
:builtin atom
)))
917 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
918 (values type-specifier nil
))))
920 (defun typexpand (type-specifier &optional env
)
921 "Takes and expands a type specifier repeatedly like MACROEXPAND.
922 Returns two values: the expansion, and a boolean that is true when
924 ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
925 ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV.
926 (multiple-value-bind (expansion expanded
)
927 (typexpand-1 type-specifier env
)
929 (values (typexpand expansion env
) t
)
930 (values expansion expanded
))))
932 ;;; Note that the type NAME has been (re)defined, updating the
933 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
934 (defun %note-type-defined
(name)
935 (declare (symbol name
))
936 (note-name-defined name
:type
)
937 (values-specifier-type-cache-clear)
941 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)
943 ;;; When cross-compiling SPECIFIER-TYPE with a quoted argument,
944 ;;; it can be rendered as a literal object unless it:
945 ;;; - mentions a classoid or unknown type
946 ;;; - uses a floating-point literal (perhaps positive zero could be allowed?)
948 ;;; This is important for type system initialization, but it will also
949 ;;; apply to hand-written calls and make-load-form expressions.
951 ;;; After the target is built, we remove this transform, both because calls
952 ;;; to SPECIFIER-TYPE do not arise organically through user code,
953 ;;; and because it is possible that user changes to types could make parsing
954 ;;; return a different thing, e.g. changing a DEFTYPE to a DEFCLASS.
958 (sb!c
::define-source-transform specifier-type
(type-spec &environment env
)
959 (or (and (sb!xc
:constantp type-spec env
)
960 (let ((parse (specifier-type (constant-form-value type-spec env
))))
962 ((contains-unknown-type-p parse
)
963 (bug "SPECIFIER-TYPE transform parsed an unknown type"))
964 ((cold-dumpable-type-p parse
)
965 ;; Obtain a canonical form by unparsing so that TYPE= specs
966 ;; coalesce in presence of DEFTYPEs. LOAD-TIME-VALUE in the
967 ;; cross-compiler has a special-case to turn !SPECIFIER-TYPE
968 ;; into a fop-funcall, which is handled by genesis.
969 `(load-time-value (!specifier-type
',(type-specifier parse
))
973 (defun cold-dumpable-type-p (ctype)
974 (named-let recurse
((ctype ctype
))
977 (and (every #'recurse
(args-type-required ctype
))
978 (every #'recurse
(args-type-optional ctype
))
979 (acond ((args-type-rest ctype
) (recurse it
)) (t))
980 (every (lambda (x) (recurse (key-info-type x
)))
981 (args-type-keywords ctype
))
982 (if (fun-type-p ctype
) (recurse (fun-type-returns ctype
)) t
)))
983 (compound-type (every #'recurse
(compound-type-types ctype
)))
984 (negation-type (recurse (negation-type-type ctype
)))
985 (array-type (recurse (array-type-element-type ctype
)))
986 (cons-type (and (recurse (cons-type-car-type ctype
))
987 (recurse (cons-type-cdr-type ctype
))))
989 (and (listp (xset-data (member-type-xset ctype
))) ; can't dump hashtable
990 (not (member-type-fp-zeroes ctype
)))) ; nor floats
992 ;; Floating-point constants are not dumpable. (except maybe +0.0)
993 (if (or (typep (numeric-type-low ctype
) '(or float
(cons float
)))
994 (typep (numeric-type-high ctype
) '(or float
(cons float
))))
997 (built-in-classoid t
)
999 ;; HAIRY is just an s-expression, so it's dumpable. Same for simd-pack
1000 ((or named-type character-set-type hairy-type
#!+sb-simd-pack simd-pack-type
)
1003 (setf (get '!specifier-type
:sb-cold-funcall-handler
/for-value
)
1006 (if (symbolp arg
) arg
(sb!fasl
::host-object-from-core arg
))))
1007 (sb!fasl
::ctype-to-core specifier
(specifier-type specifier
)))))
1009 (setf (info :function
:where-from
'!specifier-type
) :declared
) ; lie