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