1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!KERNEL")
12 (!begin-collecting-cold-init-forms
)
14 ;;; the description of a &KEY argument
15 (defstruct (key-info #-sb-xc-host
(:pure t
)
17 ;; the key (not necessarily a keyword in ANSI Common Lisp)
18 (name (missing-arg) :type symbol
:read-only t
)
19 ;; the type of the argument value
20 (type (missing-arg) :type ctype
:read-only t
))
22 ;;;; representations of types
24 ;;; A HAIRY-TYPE represents anything too weird to be described
25 ;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
26 ;;; and unreasonably complicated types involving AND. We just remember
27 ;;; the original type spec.
28 (defstruct (hairy-type (:include ctype
29 (class-info (type-class-or-lose 'hairy
)))
30 (:constructor %make-hairy-type
(specifier))
33 ;; the Common Lisp type-specifier of the type we represent
34 (specifier nil
:type t
:read-only t
))
36 ;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
37 ;; e.g. any SATISFIES with a predicate returning T over a finite domain.
38 ;; But in practice there's nothing that can be done with this information,
39 ;; because we don't call random predicates when performing operations on types
40 ;; as objects, only when checking for inclusion of something in the type.
41 (!define-type-class hairy
:enumerable t
:might-contain-other-types t
)
43 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
44 ;;; defined). We make this distinction since we don't want to complain
45 ;;; about types that are hairy but defined.
46 (defstruct (unknown-type (:include hairy-type
)
49 (defun maybe-reparse-specifier (type)
50 (when (unknown-type-p type
)
51 (let* ((spec (unknown-type-specifier type
))
52 (name (if (consp spec
)
55 (when (info :type
:kind name
)
56 (let ((new-type (specifier-type spec
)))
57 (unless (unknown-type-p new-type
)
61 (defmacro maybe-reparse-specifier
! (type)
62 (assert (symbolp type
))
63 (with-unique-names (new-type)
64 `(let ((,new-type
(maybe-reparse-specifier ,type
)))
66 (setf ,type
,new-type
)
69 (defstruct (negation-type (:include ctype
70 (class-info (type-class-or-lose 'negation
)))
73 (type (missing-arg) :type ctype
:read-only t
))
75 ;; Former comment was:
76 ;; FIXME: is this right? It's what they had before, anyway
77 ;; But I think the reason it's right is that "enumerable :t" is equivalent
78 ;; to "maybe" which is actually the conservative assumption, same as HAIRY.
79 (!define-type-class negation
:enumerable t
:might-contain-other-types t
)
81 ;;; ARGS-TYPE objects are used both to represent VALUES types and
82 ;;; to represent FUNCTION types.
83 (defstruct (args-type (:include ctype
)
86 ;; Lists of the type for each required and optional argument.
87 (required nil
:type list
:read-only t
)
88 (optional nil
:type list
:read-only t
)
89 ;; The type for the rest arg. NIL if there is no &REST arg.
90 (rest nil
:type
(or ctype null
) :read-only t
)
91 ;; true if &KEY arguments are specified
92 (keyp nil
:type boolean
:read-only t
)
93 ;; list of KEY-INFO structures describing the &KEY arguments
94 (keywords nil
:type list
:read-only t
)
95 ;; true if other &KEY arguments are allowed
96 (allowp nil
:type boolean
:read-only t
))
98 (defun canonicalize-args-type-args (required optional rest
&optional keyp
)
99 (when (eq rest
*empty-type
*)
102 (loop with last-not-rest
= nil
105 do
(cond ((eq opt
*empty-type
*)
106 (return (values required
(subseq optional i
) rest
)))
107 ((and (not keyp
) (neq opt rest
))
108 (setq last-not-rest i
)))
109 finally
(return (values required
113 (subseq optional
0 (1+ last-not-rest
))))
116 (defun parse-args-types (lambda-listy-thing context
)
117 (multiple-value-bind (llks required optional rest keys
)
121 :accept
(ecase context
122 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
123 (:function-type
(lambda-list-keyword-mask
124 '(&optional
&rest
&key
&allow-other-keys
))))
126 (let ((required (mapcar #'single-value-specifier-type required
))
127 (optional (mapcar #'single-value-specifier-type optional
))
128 (rest (when rest
(single-value-specifier-type (car rest
))))
130 (collect ((key-info))
132 (unless (proper-list-of-length-p key
2)
133 (error "Keyword type description is not a two-list: ~S." key
))
134 (let ((kwd (first key
)))
135 (when (find kwd
(key-info) :key
#'key-info-name
)
136 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
137 kwd lambda-listy-thing
))
141 :type
(single-value-specifier-type (second key
))))))
143 (multiple-value-bind (required optional rest
)
144 (canonicalize-args-type-args required optional rest
146 (values llks required optional rest keywords
)))))
148 (defstruct (values-type
150 (class-info (type-class-or-lose 'values
)))
151 (:constructor %make-values-type
)
152 (:predicate %values-type-p
)
155 (declaim (inline values-type-p
))
156 (defun values-type-p (x)
157 (or (eq x
*wild-type
*)
160 (defun-cached (make-values-type-cached
163 (lambda (req opt rest allowp
)
164 (logxor (type-list-cache-hash req
)
165 (type-list-cache-hash opt
)
167 (type-hash-value rest
)
169 ;; Results (logand #xFF (sxhash t/nil))
170 ;; hardcoded to avoid relying on the xc host.
171 ;; [but (logand (sxhash nil) #xff) => 2
172 ;; for me, so the code and comment disagree,
173 ;; but not in a way that matters.]
177 ((required equal-but-no-car-recursion
)
178 (optional equal-but-no-car-recursion
)
181 (%make-values-type
:required required
186 (defun make-values-type (&key required optional rest allowp
)
187 (multiple-value-bind (required optional rest
)
188 (canonicalize-args-type-args required optional rest
)
189 (cond ((and (null required
)
191 (eq rest
*universal-type
*))
193 ((memq *empty-type
* required
)
195 (t (make-values-type-cached required optional
198 (!define-type-class values
:enumerable nil
199 :might-contain-other-types nil
)
201 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
202 (defstruct (fun-type (:include args-type
203 (class-info (type-class-or-lose 'function
)))
205 %make-fun-type
(required optional rest
206 keyp keywords allowp wild-args returns
)))
207 ;; true if the arguments are unrestrictive, i.e. *
208 (wild-args nil
:type boolean
:read-only t
)
209 ;; type describing the return values. This is a values type
210 ;; when multiple values were specified for the return.
211 (returns (missing-arg) :type ctype
:read-only t
))
213 ;; Without this canonicalization step, I found >350 different
214 ;; (FUNCTION (T) *) representations in a sample build.
215 (declaim (type (simple-vector 4) *interned-fun-type-instances
*))
216 (defglobal *interned-fun-types
* (make-array 4))
217 (defun !intern-important-fun-type-instances
()
218 (setq *interned-fun-types
* (make-array 4))
222 (push *universal-type
* required
))
223 (setf (svref *interned-fun-types
* i
)
225 (%make-fun-type required nil nil nil nil nil nil
*wild-type
*))))))
227 (defun make-fun-type (&key required optional rest
230 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
231 (n (length required
)))
233 (not optional
) (not rest
) (not keyp
)
234 (not keywords
) (not allowp
) (not wild-args
)
235 (eq returns
*wild-type
*)
236 (every (lambda (x) (eq x
*universal-type
*)) required
))
237 (svref *interned-fun-types
* n
)
238 (%make-fun-type required optional rest keyp keywords
239 allowp wild-args returns
))))
241 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
242 ;;; "type specifier", which is only meaningful in function argument
243 ;;; type specifiers used within the compiler. (It represents something
244 ;;; that the compiler knows to be a constant.)
245 (defstruct (constant-type
247 (class-info (type-class-or-lose 'constant
)))
249 ;; The type which the argument must be a constant instance of for this type
251 (type (missing-arg) :type ctype
:read-only t
))
253 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
254 ;;; special cases, as well as other special cases needed to
255 ;;; interpolate between regions of the type hierarchy, such as
256 ;;; INSTANCE (which corresponds to all those classes with slots which
257 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
258 ;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
259 ;;; non-VECTOR classes which are also sequences). These special cases
260 ;;; are the ones that aren't really discussed by Baker in his
261 ;;; "Decision Procedure for SUBTYPEP" paper.
262 (defstruct (named-type (:include ctype
263 (class-info (type-class-or-lose 'named
)))
265 (name nil
:type symbol
:read-only t
))
267 ;;; a list of all the float "formats" (i.e. internal representations;
268 ;;; nothing to do with #'FORMAT), in order of decreasing precision
269 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
270 (defparameter *float-formats
*
271 '(long-float double-float single-float short-float
)))
273 ;;; The type of a float format.
274 (deftype float-format
() `(member ,@*float-formats
*))
276 ;;; A NUMERIC-TYPE represents any numeric type, including things
278 (defstruct (numeric-type (:include ctype
279 (class-info (type-class-or-lose 'number
)))
280 (:constructor %make-numeric-type
)
282 ;; Formerly defined in every CTYPE, but now just in the ones
283 ;; for which enumerability is variable.
284 (enumerable nil
:read-only t
)
285 ;; the kind of numeric type we have, or NIL if not specified (just
286 ;; NUMBER or COMPLEX)
288 ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
289 ;; Especially when a CLASS value *is* stored in another slot (called
290 ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
291 ;; weird that comment above says "Numeric-Type is used to represent
292 ;; all numeric types" but this slot doesn't allow COMPLEX as an
293 ;; option.. how does this fall into "not specified" NIL case above?
294 ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
295 ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
296 ;; whatnot be concrete subclasses..
297 (class nil
:type
(member integer rational float nil
) :read-only t
)
298 ;; "format" for a float type (i.e. type specifier for a CPU
299 ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
300 ;; to do with #'FORMAT), or NIL if not specified or not a float.
301 ;; Formats which don't exist in a given implementation don't appear
303 (format nil
:type
(or float-format null
) :read-only t
)
304 ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
306 ;; FIXME: I'm bewildered by FOO-P names for things not intended to
307 ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
308 (complexp :real
:type
(member :real
:complex nil
) :read-only t
)
309 ;; The upper and lower bounds on the value, or NIL if there is no
310 ;; bound. If a list of a number, the bound is exclusive. Integer
311 ;; types never have exclusive bounds, i.e. they may have them on
312 ;; input, but they're canonicalized to inclusive bounds before we
314 (low nil
:type
(or number cons null
) :read-only t
)
315 (high nil
:type
(or number cons null
) :read-only t
))
317 ;; For some numeric subtypes, uniqueness of the object representation
318 ;; is enforced. These encompass all array specializations and more.
319 (defglobal *unsigned-byte-type
* -
1)
320 (defglobal *integer-type
* -
1)
321 (defglobal *unsigned-byte-n-types
* -
1)
322 (defglobal *signed-byte-n-types
* -
1)
323 (defglobal *real-ffloat-type
* -
1)
324 (defglobal *real-dfloat-type
* -
1)
325 (defglobal *complex-ffloat-type
* -
1)
326 (defglobal *complex-dfloat-type
* -
1)
328 (declaim (type (simple-vector #.
(1+ sb
!vm
:n-word-bits
)) *unsigned-byte-n-types
*)
329 (type (simple-vector #.sb
!vm
:n-word-bits
) *signed-byte-n-types
*))
331 ;; Called after NUMBER-TYPE type-class has been made.
332 (defun !intern-important-numeric-type-instances
()
333 (flet ((float-type (format complexp
)
335 (%make-numeric-type
:class
'float
:complexp complexp
336 :format format
:enumerable nil
)))
337 (int-type (enumerable low high
)
339 (%make-numeric-type
:class
'integer
:complexp
:real
340 :enumerable enumerable
341 :low low
:high high
))))
342 (setq *real-ffloat-type
* (float-type 'single-float
:real
)
343 *real-dfloat-type
* (float-type 'double-float
:real
)
344 *complex-ffloat-type
* (float-type 'single-float
:complex
)
345 *complex-dfloat-type
* (float-type 'double-float
:complex
)
346 *unsigned-byte-type
* (int-type nil
0 nil
)
347 *integer-type
* (int-type nil nil nil
)
348 *unsigned-byte-n-types
* (make-array (1+ sb
!vm
:n-word-bits
))
349 *signed-byte-n-types
* (make-array sb
!vm
:n-word-bits
))
350 (dotimes (j (1+ sb
!vm
:n-word-bits
))
351 (setf (svref *unsigned-byte-n-types
* j
) (int-type t
0 (1- (ash 1 j
)))))
352 (dotimes (j sb
!vm
:n-word-bits
)
353 (setf (svref *signed-byte-n-types
* j
)
354 (let ((high (1- (ash 1 j
)))) (int-type t
(- (1+ high
)) high
))))))
356 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
357 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
359 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
360 ;;; come from parsing MEMBER. But bounded integer ranges,
361 ;;; however large, are enumerable:
362 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
363 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
364 ;;; but, in contrast,
365 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
366 ;;; I can't figure out whether this is supposed to matter.
367 ;;; Moreover, it seems like this function should be responsible
368 ;;; for figuring out the right value so that callers don't have to.
369 (defun make-numeric-type (&key class format
(complexp :real
) low high
371 ;; if interval is empty
374 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
375 (>= (type-bound-number low
) (type-bound-number high
))
378 (multiple-value-bind (low high
)
381 ;; INTEGER types always have their LOW and HIGH bounds
382 ;; represented as inclusive, not exclusive values.
383 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
384 (if (consp high
) (1- (type-bound-number high
)) high
)))
386 ;; no canonicalization necessary
388 (when (and (eq class
'rational
)
392 (setf class
'integer
))
394 ;; Either lookup the canonical interned object for
395 ;; a point in the type lattice, or construct a new one.
396 (or (cond ((eq class
'float
)
397 (when (and (null low
) (null high
))
401 (:real
*real-ffloat-type
*)
402 (:complex
*complex-ffloat-type
*)))
405 (:real
*real-dfloat-type
*)
406 (:complex
*complex-dfloat-type
*))))))
407 ((and (eq class
'integer
) (eq complexp
:real
))
408 (flet ((n-bits () (integer-length (truly-the word high
))))
409 (declare (inline n-bits
))
411 (cond ((eql low
0) *unsigned-byte-type
*)
412 ((not low
) *integer-type
*)))
413 ((or (= high most-positive-word
)
414 (and (typep high
'word
)
415 ;; is (1+ high) a power-of-2 ?
416 (zerop (logand (1+ high
) high
))))
418 (svref *unsigned-byte-n-types
* (n-bits)))
419 ((and (< high most-positive-word
)
420 (eql low
(lognot high
)))
421 (svref *signed-byte-n-types
* (n-bits)))))))))
423 (%make-numeric-type
:class class
428 :enumerable enumerable
)))
429 (setf (type-hash-value result
)
430 (logior (type-hash-value result
)
431 +type-admits-type
=-optimization
+))
434 (defun modified-numeric-type (base
436 (class (numeric-type-class base
))
437 (format (numeric-type-format base
))
438 (complexp (numeric-type-complexp base
))
439 (low (numeric-type-low base
))
440 (high (numeric-type-high base
))
441 (enumerable (type-enumerable base
)))
442 (make-numeric-type :class class
447 :enumerable enumerable
))
449 (defstruct (character-set-type
451 (class-info (type-class-or-lose 'character-set
)))
452 (:constructor %make-character-set-type
(pairs))
454 (pairs (missing-arg) :type list
:read-only t
))
456 ;; Interned character-set types.
457 (defglobal *character-type
* -
1)
459 (progn (defglobal *base-char-type
* -
1)
460 (defglobal *extended-char-type
* -
1))
461 #+sb-xc
(declaim (type ctype
*character-type
*
462 #!+sb-unicode
*base-char-type
*
463 #!+sb-unicode
*extended-char-type
*))
465 (defun !intern-important-character-set-type-instances
()
466 (flet ((range (low high
)
468 (%make-character-set-type
(list (cons low high
))))))
469 (setq *character-type
* (range 0 (1- sb
!xc
:char-code-limit
)))
471 (setq *base-char-type
* (range 0 127)
472 *extended-char-type
* (range 128 (1- sb
!xc
:char-code-limit
)))))
474 (defun make-character-set-type (&key pairs
)
475 ; (aver (equal (mapcar #'car pairs)
476 ; (sort (mapcar #'car pairs) #'<)))
477 ;; aver that the cars of the list elements are sorted into increasing order
478 (aver (or (null pairs
)
479 (do ((p pairs
(cdr p
)))
481 (when (> (caar p
) (caadr p
)) (return nil
)))))
482 (let ((pairs (let (result)
483 (do ((pairs pairs
(cdr pairs
)))
484 ((null pairs
) (nreverse result
))
485 (destructuring-bind (low . high
) (car pairs
)
486 (loop for
(low1 . high1
) in
(cdr pairs
)
487 if
(<= low1
(1+ high
))
488 do
(progn (setf high
(max high high1
))
489 (setf pairs
(cdr pairs
)))
490 else do
(return nil
))
492 ((>= low sb
!xc
:char-code-limit
))
494 (t (push (cons (max 0 low
)
495 (min high
(1- sb
!xc
:char-code-limit
)))
499 (or (and (singleton-p pairs
)
500 (let* ((pair (car pairs
))
502 (case (cdr pair
) ; high
503 (#.
(1- sb
!xc
:char-code-limit
)
506 #!+sb-unicode
(128 *extended-char-type
*)))
508 (127 (if (eql low
0) *base-char-type
*)))))
509 (%make-character-set-type pairs
)))))
511 ;;; An ARRAY-TYPE is used to represent any array type, including
512 ;;; things such as SIMPLE-BASE-STRING.
513 (defstruct (array-type (:include ctype
514 (class-info (type-class-or-lose 'array
)))
515 (:constructor %make-array-type
516 (dimensions complexp element-type
517 specialized-element-type
))
519 ;; the dimensions of the array, or * if unspecified. If a dimension
520 ;; is unspecified, it is *.
521 (dimensions '* :type
(or list
(member *)) :read-only t
)
522 ;; Is this not a simple array type? (:MAYBE means that we don't know.)
523 (complexp :maybe
:type
(member t nil
:maybe
) :read-only t
)
524 ;; the element type as originally specified
525 (element-type (missing-arg) :type ctype
:read-only t
)
526 ;; the element type as it is specialized in this implementation
527 (specialized-element-type *wild-type
* :type ctype
:read-only t
))
529 ;; For all ctypes which are the element types of specialized arrays,
530 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
531 ;; one for each of simple, maybe simple, and not simple.
532 ;; It would also be reasonable to intern (ARRAY <type> *).
533 (defglobal *rank-1-array-ctypes
* -
1)
534 (defconstant +canon-array-ctype-hash-divisor
+ 37) ; arbitrary-ish
535 (defun !intern-important-array-type-instances
()
536 ;; Having made the canonical numeric and character ctypes
537 ;; representing the points in the type lattice for which there
538 ;; are array specializations, we can make the canonical array types.
539 (let* ((element-types
541 *universal-type
* *wild-type
* *empty-type
*
543 #!+sb-unicode
*base-char-type
* #!+sb-unicode
*extended-char-type
*
544 *real-ffloat-type
* *complex-ffloat-type
*
545 *real-dfloat-type
* *complex-dfloat-type
*
548 ;; Possibly could use the SAETP-IMPORTANCE as sort criterion
549 ;; so that collisions in a bucket place the more important
553 (cond ((typep x
'(cons (eql unsigned-byte
)))
554 (aref *unsigned-byte-n-types
* (cadr x
)))
556 (aref *unsigned-byte-n-types
* 1))
557 ((typep x
'(cons (eql signed-byte
)))
558 ;; 1- because there is no such thing as (signed-byte 0)
559 (aref *signed-byte-n-types
* (1- (cadr x
))))
560 ;; FIXNUM is its own thing, why? See comment in vm-array
561 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
562 ((eq x
'fixnum
) ; One good kludge deserves another.
563 (aref *signed-byte-n-types
* (1- sb
!vm
:n-fixnum-bits
)))))
564 '#.
*specialized-array-element-types
*))))
565 (n (length element-types
))
566 (data-vector (make-array (* 3 n
)))
568 (hashtable (make-array +canon-array-ctype-hash-divisor
+
569 :initial-element nil
)))
570 ;; This is a compact binned table. A full-blown hashtable is unneeded.
571 #-sb-xc
(aver (< (/ n
(length hashtable
)) 80/100)) ; assert reasonable load
572 (flet ((make-it (complexp type
)
573 (mark-ctype-interned (%make-array-type
'(*) complexp type type
))))
574 (dolist (element-type element-types
)
575 (let ((bin (mod (type-hash-value element-type
)
576 +canon-array-ctype-hash-divisor
+)))
577 (setf (aref hashtable bin
)
578 (nconc (aref hashtable bin
) (list (cons element-type index
))))
579 (setf (aref data-vector
(+ index
0)) (make-it nil element-type
)
580 (aref data-vector
(+ index
1)) (make-it :maybe element-type
)
581 (aref data-vector
(+ index
2)) (make-it t element-type
))
583 (setq *rank-1-array-ctypes
* (cons data-vector hashtable
))))
585 (declaim (ftype (sfunction (t &key
(:complexp t
)
587 (:specialized-element-type t
))
588 ctype
) make-array-type
))
589 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
590 (specialized-element-type *wild-type
*))
591 (or (and (eq element-type specialized-element-type
)
592 (singleton-p dimensions
)
593 (eq (first dimensions
) '*)
594 (let ((table *rank-1-array-ctypes
*))
595 (dolist (cell (svref (cdr table
)
596 (mod (type-hash-value element-type
)
597 +canon-array-ctype-hash-divisor
+)))
598 (when (eq (car cell
) element-type
)
599 (return (truly-the ctype
603 ((nil) 0) ((:maybe
) 1) ((t) 2))))))))))
604 (%make-array-type dimensions
605 complexp element-type specialized-element-type
)))
607 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
608 ;;; bother with this at this level because MEMBER types are fairly
609 ;;; important and union and intersection are well defined.
610 (defstruct (member-type (:include ctype
611 (class-info (type-class-or-lose 'member
)))
613 (:constructor %make-member-type
(xset fp-zeroes
))
614 #-sb-xc-host
(:pure nil
))
615 (xset (missing-arg) :type xset
:read-only t
)
616 (fp-zeroes (missing-arg) :type list
:read-only t
))
618 (defglobal *null-type
* -
1) ; = (MEMBER NIL)
619 (defglobal *eql-t-type
* -
1) ; = (MEMBER T)
620 (defglobal *boolean-type
* -
1) ; = (MEMBER T NIL)
621 #+sb-xc
(declaim (type ctype
*null-type
*))
623 (defun !intern-important-member-type-instances
()
624 (flet ((make-it (list)
626 (%make-member-type
(xset-from-list list
) nil
))))
627 (setf *null-type
* (make-it '(nil))
628 *eql-t-type
* (make-it '(t))
629 *boolean-type
* (make-it '(t nil
)))))
631 (declaim (ftype (sfunction (&key
(:xset t
) (:fp-zeroes t
) (:members t
)) ctype
)
633 (defun make-member-type (&key xset fp-zeroes members
)
635 (aver (not fp-zeroes
))
636 (setf xset
(alloc-xset))
637 (dolist (elt members
)
639 (pushnew elt fp-zeroes
)
640 (add-to-xset elt xset
))))
641 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
642 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
643 ;; ranges are compared by arithmetic operators (while MEMBERship is
644 ;; compared by EQL). -- CSR, 2003-04-23
648 (when fp-zeroes
; avoid doing two passes of nothing
650 (dolist (z fp-zeroes
)
651 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
656 #!+long-float
(long-float 4)))))
658 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
659 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
661 (push (ctype-of z
) float-types
))
662 (push z unpaired
)))))))
666 (when (singleton-p (xset-data xset
))
667 (case (first (xset-data xset
))
668 ((nil) (return *null-type
*))
669 ((t) (return *eql-t-type
*))))
670 ;; Semantically this is fine - XSETs
671 ;; are not order-preserving except by accident
672 ;; (when not represented as a hash-table).
673 (when (or (equal (xset-data xset
) '(t nil
))
674 (equal (xset-data xset
) '(nil t
)))
675 (return *boolean-type
*)))
676 (when (or unpaired
(not (xset-empty-p xset
)))
677 (let ((result (%make-member-type xset unpaired
)))
678 (setf (type-hash-value result
)
679 (logior (type-hash-value result
)
680 +type-admits-type
=-optimization
+))
682 ;; The actual member-type contains the XSET (with no FP zeroes),
683 ;; and a list of unpaired zeroes.
685 (make-union-type t
(if member-type
686 (cons member-type float-types
)
688 (or member-type
*empty-type
*)))))
690 (defun member-type-size (type)
691 (+ (length (member-type-fp-zeroes type
))
692 (xset-count (member-type-xset type
))))
694 (defun member-type-member-p (x type
)
696 (and (member x
(member-type-fp-zeroes type
)) t
)
697 (xset-member-p x
(member-type-xset type
))))
699 (defun mapcar-member-type-members (function type
)
700 (declare (function function
))
702 (map-xset (lambda (x)
703 (results (funcall function x
)))
704 (member-type-xset type
))
705 (dolist (zero (member-type-fp-zeroes type
))
706 (results (funcall function zero
)))
709 (defun mapc-member-type-members (function type
)
710 (declare (function function
))
711 (map-xset function
(member-type-xset type
))
712 (dolist (zero (member-type-fp-zeroes type
))
713 (funcall function zero
)))
715 (defun member-type-members (type)
716 (append (member-type-fp-zeroes type
)
717 (xset-members (member-type-xset type
))))
719 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
720 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
721 (defstruct (compound-type (:include ctype
)
724 ;; Formerly defined in every CTYPE, but now just in the ones
725 ;; for which enumerability is variable.
726 (enumerable nil
:read-only t
)
727 (types nil
:type list
:read-only t
))
729 ;;; A UNION-TYPE represents a use of the OR type specifier which we
730 ;;; couldn't canonicalize to something simpler. Canonical form:
731 ;;; 1. All possible pairwise simplifications (using the UNION2 type
732 ;;; methods) have been performed. Thus e.g. there is never more
733 ;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
734 ;;; this hadn't been fully implemented yet.
735 ;;; 2. There are never any UNION-TYPE components.
737 ;;; TODO: As STRING is an especially important union type,
738 ;;; it could be interned by canonicalizing its subparts into
739 ;;; ARRAY of {CHARACTER,BASE-CHAR,NIL} in that exact order always.
740 ;;; It will therefore admit quick TYPE=, but not quick failure, since
741 ;;; (type= (specifier-type '(or (simple-array (member #\a) (*))
742 ;;; (simple-array character (*))
743 ;;; (simple-array nil (*))))
744 ;;; (specifier-type 'simple-string)) => T and T
745 ;;; even though (MEMBER #\A) is not TYPE= to BASE-CHAR.
747 (defstruct (union-type (:include compound-type
748 (class-info (type-class-or-lose 'union
)))
749 (:constructor make-union-type
(enumerable types
))
752 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
753 ;;; which we couldn't canonicalize to something simpler. Canonical form:
754 ;;; 1. All possible pairwise simplifications (using the INTERSECTION2
755 ;;; type methods) have been performed. Thus e.g. there is never more
756 ;;; than one MEMBER-TYPE component.
757 ;;; 2. There are never any INTERSECTION-TYPE components: we've
758 ;;; flattened everything into a single INTERSECTION-TYPE object.
759 ;;; 3. There are never any UNION-TYPE components. Either we should
760 ;;; use the distributive rule to rearrange things so that
761 ;;; unions contain intersections and not vice versa, or we
762 ;;; should just punt to using a HAIRY-TYPE.
763 (defstruct (intersection-type (:include compound-type
764 (class-info (type-class-or-lose
766 (:constructor %make-intersection-type
770 ;;; Return TYPE converted to canonical form for a situation where the
771 ;;; "type" '* (which SBCL still represents as a type even though ANSI
772 ;;; CL defines it as a related but different kind of placeholder) is
773 ;;; equivalent to type T.
774 (defun type-*-to-t
(type)
775 (if (type= type
*wild-type
*)
779 ;;; A CONS-TYPE is used to represent a CONS type.
780 (defstruct (cons-type (:include ctype
(class-info (type-class-or-lose 'cons
)))
782 %make-cons-type
(car-type
785 ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
786 (car-type (missing-arg) :type ctype
:read-only t
)
787 (cdr-type (missing-arg) :type ctype
:read-only t
))
789 ;; The function caches work significantly better when there
790 ;; is a unique object that stands for the specifier (CONS T T).
791 (defglobal *cons-t-t-type
* -
1)
792 #+sb-xc
(declaim (type ctype
*cons-t-t-type
*))
794 (defun !intern-important-cons-type-instances
()
795 (setf *cons-t-t-type
*
797 (%make-cons-type
*universal-type
* *universal-type
*))))
800 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
801 (defun make-cons-type (car-type cdr-type
)
802 (aver (not (or (eq car-type
*wild-type
*)
803 (eq cdr-type
*wild-type
*))))
804 (cond ((or (eq car-type
*empty-type
*)
805 (eq cdr-type
*empty-type
*))
807 ;; It's not a requirement that (CONS T T) be interned,
808 ;; but it improves the hit rate in the function caches.
809 ((and (type= car-type
*universal-type
*)
810 (type= cdr-type
*universal-type
*))
813 (%make-cons-type car-type cdr-type
))))
815 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
817 (defstruct (simd-pack-type
818 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
819 (:constructor %make-simd-pack-type
(element-type))
821 (element-type (missing-arg)
822 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
826 (defun make-simd-pack-type (element-type)
827 (aver (neq element-type
*wild-type
*))
828 (if (eq element-type
*empty-type
*)
830 (%make-simd-pack-type
831 (dolist (pack-type *simd-pack-element-types
*
832 (error "~S element type must be a subtype of ~
833 ~{~S~#[~;, or ~:;, ~]~}."
834 'simd-pack
*simd-pack-element-types
*))
835 (when (csubtypep element-type
(specifier-type pack-type
))
836 (return (list pack-type
)))))))
841 ;;; Return the type structure corresponding to a type specifier. We
842 ;;; pick off structure types as a special case.
844 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
845 ;;; type is defined (or redefined).
846 ;;; This cache is sized extremely generously, which has payoff
847 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
848 ;;; since EQ types are an immediate win.
850 ;;; KLUDGE: why isn't this a MACROLET? "lexical environment too
852 (defmacro !values-specifier-type-body
(arg)
853 `(let* ((u (uncross ,arg
))
855 (result (or (info :type
:builtin u
)
856 (let ((spec (typexpand u
)))
857 (when (and (symbolp u
) (deprecated-thing-p 'type u
))
859 (signal 'parse-deprecated-type
:specifier u
))
861 ((and (not (eq spec u
))
862 (info :type
:builtin spec
)))
863 ((and (consp spec
) (symbolp (car spec
))
864 (info :type
:builtin
(car spec
))
865 (let ((expander (info :type
:expander
(car spec
))))
866 (and expander
(values-specifier-type (funcall expander spec
))))))
867 ((eq (info :type
:kind spec
) :instance
)
868 (find-classoid spec
))
869 ((typep spec
'classoid
)
870 (if (typep spec
'built-in-classoid
)
871 (or (built-in-classoid-translation spec
) spec
)
874 (when (and (atom spec
)
875 (member spec
'(and or not member eql satisfies values
)))
876 (error "The symbol ~S is not valid as a type specifier." spec
))
878 (info :type
:translator
(if (consp spec
) (car spec
) spec
))))
879 (cond ((functionp fun-or-ctype
)
880 (funcall fun-or-ctype
(ensure-list spec
)))
882 ((or (and (consp spec
) (symbolp (car spec
))
883 (not (info :type
:builtin
(car spec
))))
884 (and (symbolp spec
) (not (info :type
:builtin spec
))))
885 (when (and *type-system-initialized
*
886 (not (eq (info :type
:kind spec
)
887 :forthcoming-defclass-type
)))
888 (signal 'parse-unknown-type
:specifier spec
))
890 (make-unknown-type :specifier spec
))
892 (error "bad thing to be a type specifier: ~S"
896 ;; (The RETURN-FROM here inhibits caching; this does not only
897 ;; make sense from a compiler diagnostics point of view but
898 ;; is also indispensable for proper workingness of
899 ;; VALID-TYPE-SPECIFIER-P.)
900 (return-from values-specifier-type
903 (let ((table (make-hash-table :test
'equal
)))
904 (defun values-specifier-type (specifier)
905 (multiple-value-bind (type yesp
) (gethash specifier table
)
908 (setf (gethash specifier table
)
909 (!values-specifier-type-body specifier
)))))
910 (defun values-specifier-type-cache-clear ()
913 (defun-cached (values-specifier-type
914 :hash-function
#'sxhash
:hash-bits
10)
915 ((orig equal-but-no-car-recursion
))
916 (!values-specifier-type-body orig
))
918 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
919 ;;; never return a VALUES type.
920 (defun specifier-type (type-specifier)
921 (let ((ctype (values-specifier-type type-specifier
)))
922 (when (or (values-type-p ctype
)
923 ;; bootstrap magic :-(
924 (and (named-type-p ctype
)
925 (eq (named-type-name ctype
) '*)))
926 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
929 (defun single-value-specifier-type (x)
934 (defun typexpand-1 (type-specifier &optional env
)
936 "Takes and expands a type specifier once like MACROEXPAND-1.
937 Returns two values: the expansion, and a boolean that is true when
939 (declare (type type-specifier type-specifier
))
940 (declare (ignore env
))
941 (let* ((spec type-specifier
)
942 (atom (if (listp spec
) (car spec
) spec
))
943 (expander (and (symbolp atom
) (info :type
:expander atom
))))
944 ;; We do not expand builtins even though it'd be
945 ;; possible to do so sometimes (e.g. STRING) for two
948 ;; a) From a user's point of view, CL types are opaque.
950 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
951 (if (and expander
(not (info :type
:builtin atom
)))
952 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
953 (values type-specifier nil
))))
955 (defun typexpand (type-specifier &optional env
)
957 "Takes and expands a type specifier repeatedly like MACROEXPAND.
958 Returns two values: the expansion, and a boolean that is true when
960 (declare (type type-specifier type-specifier
))
961 (multiple-value-bind (expansion flag
)
962 (typexpand-1 type-specifier env
)
964 (values (typexpand expansion env
) t
)
965 (values expansion flag
))))
967 ;;; Note that the type NAME has been (re)defined, updating the
968 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
969 (defun %note-type-defined
(name)
970 (declare (symbol name
))
971 (note-name-defined name
:type
)
972 (values-specifier-type-cache-clear)
976 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)