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 ;;; A possible improvement would be for HAIRY-TYPE to have a subtype
29 ;;; named SATISFIES-TYPE for the hairy types which are specifically
30 ;;; of the form (SATISFIES pred) so that we don't have to examine
31 ;;; the sexpr repeatedly to decide whether it takes that form.
32 ;;; And as a further improvement, we might want a table that maps
33 ;;; predicates to their exactly recognized type when possible.
34 ;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES*
35 ;;; as a starting point. But something like PLUSP isn't in there.
36 ;;; On the other hand, either of these points may not be sources of
37 ;;; inefficiency, and the latter if implemented might have undesirable
38 ;;; user-visible ramifications, though it seems unlikely.
39 (defstruct (hairy-type (:include ctype
40 (class-info (type-class-or-lose 'hairy
)))
41 (:constructor %make-hairy-type
(specifier))
44 ;; the Common Lisp type-specifier of the type we represent
45 (specifier nil
:type t
:read-only t
))
47 ;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
48 ;; e.g. any SATISFIES with a predicate returning T over a finite domain.
49 ;; But in practice there's nothing that can be done with this information,
50 ;; because we don't call random predicates when performing operations on types
51 ;; as objects, only when checking for inclusion of something in the type.
52 (!define-type-class hairy
:enumerable t
:might-contain-other-types t
)
54 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
55 ;;; defined). We make this distinction since we don't want to complain
56 ;;; about types that are hairy but defined.
57 (defstruct (unknown-type (:include hairy-type
)
60 (defun maybe-reparse-specifier (type)
61 (when (unknown-type-p type
)
62 (let* ((spec (unknown-type-specifier type
))
63 (name (if (consp spec
)
66 (when (info :type
:kind name
)
67 (let ((new-type (specifier-type spec
)))
68 (unless (unknown-type-p new-type
)
72 (defmacro maybe-reparse-specifier
! (type)
73 (assert (symbolp type
))
74 (with-unique-names (new-type)
75 `(let ((,new-type
(maybe-reparse-specifier ,type
)))
77 (setf ,type
,new-type
)
80 (defstruct (negation-type (:include ctype
81 (class-info (type-class-or-lose 'negation
)))
84 (type (missing-arg) :type ctype
:read-only t
))
86 ;; Former comment was:
87 ;; FIXME: is this right? It's what they had before, anyway
88 ;; But I think the reason it's right is that "enumerable :t" is equivalent
89 ;; to "maybe" which is actually the conservative assumption, same as HAIRY.
90 (!define-type-class negation
:enumerable t
:might-contain-other-types t
)
92 ;;; ARGS-TYPE objects are used both to represent VALUES types and
93 ;;; to represent FUNCTION types.
94 (defstruct (args-type (:include ctype
)
97 ;; Lists of the type for each required and optional argument.
98 (required nil
:type list
:read-only t
)
99 (optional nil
:type list
:read-only t
)
100 ;; The type for the rest arg. NIL if there is no &REST arg.
101 (rest nil
:type
(or ctype null
) :read-only t
)
102 ;; true if &KEY arguments are specified
103 (keyp nil
:type boolean
:read-only t
)
104 ;; list of KEY-INFO structures describing the &KEY arguments
105 (keywords nil
:type list
:read-only t
)
106 ;; true if other &KEY arguments are allowed
107 (allowp nil
:type boolean
:read-only t
))
109 (defun canonicalize-args-type-args (required optional rest
&optional keyp
)
110 (when (eq rest
*empty-type
*)
113 (loop with last-not-rest
= nil
116 do
(cond ((eq opt
*empty-type
*)
117 (return (values required
(subseq optional i
) rest
)))
118 ((and (not keyp
) (neq opt rest
))
119 (setq last-not-rest i
)))
120 finally
(return (values required
124 (subseq optional
0 (1+ last-not-rest
))))
127 (defun parse-args-types (lambda-listy-thing context
)
128 (multiple-value-bind (llks required optional rest keys
)
132 :accept
(ecase context
133 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
134 (:function-type
(lambda-list-keyword-mask
135 '(&optional
&rest
&key
&allow-other-keys
))))
137 (let ((required (mapcar #'single-value-specifier-type required
))
138 (optional (mapcar #'single-value-specifier-type optional
))
139 (rest (when rest
(single-value-specifier-type (car rest
))))
141 (collect ((key-info))
143 (unless (proper-list-of-length-p key
2)
144 (error "Keyword type description is not a two-list: ~S." key
))
145 (let ((kwd (first key
)))
146 (when (find kwd
(key-info) :key
#'key-info-name
)
147 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
148 kwd lambda-listy-thing
))
152 :type
(single-value-specifier-type (second key
))))))
154 (multiple-value-bind (required optional rest
)
155 (canonicalize-args-type-args required optional rest
157 (values llks required optional rest keywords
)))))
159 (defstruct (values-type
161 (class-info (type-class-or-lose 'values
)))
162 (:constructor %make-values-type
)
163 (:predicate %values-type-p
)
166 (declaim (inline values-type-p
))
167 (defun values-type-p (x)
168 (or (eq x
*wild-type
*)
171 (defun-cached (make-values-type-cached
174 (lambda (req opt rest allowp
)
175 (logxor (type-list-cache-hash req
)
176 (type-list-cache-hash opt
)
178 (type-hash-value rest
)
180 ;; Results (logand #xFF (sxhash t/nil))
181 ;; hardcoded to avoid relying on the xc host.
182 ;; [but (logand (sxhash nil) #xff) => 2
183 ;; for me, so the code and comment disagree,
184 ;; but not in a way that matters.]
188 ((required equal-but-no-car-recursion
)
189 (optional equal-but-no-car-recursion
)
192 (%make-values-type
:required required
197 (defun make-values-type (&key required optional rest allowp
)
198 (multiple-value-bind (required optional rest
)
199 (canonicalize-args-type-args required optional rest
)
200 (cond ((and (null required
)
202 (eq rest
*universal-type
*))
204 ((memq *empty-type
* required
)
206 (t (make-values-type-cached required optional
209 (!define-type-class values
:enumerable nil
210 :might-contain-other-types nil
)
212 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
213 (defstruct (fun-type (:include args-type
214 (class-info (type-class-or-lose 'function
)))
216 %make-fun-type
(required optional rest
217 keyp keywords allowp wild-args returns
)))
218 ;; true if the arguments are unrestrictive, i.e. *
219 (wild-args nil
:type boolean
:read-only t
)
220 ;; type describing the return values. This is a values type
221 ;; when multiple values were specified for the return.
222 (returns (missing-arg) :type ctype
:read-only t
))
224 ;; Without this canonicalization step, I found >350 different
225 ;; (FUNCTION (T) *) representations in a sample build.
226 (declaim (type (simple-vector 4) *interned-fun-type-instances
*))
227 (defglobal *interned-fun-types
* (make-array 4))
228 (defun !intern-important-fun-type-instances
()
229 (setq *interned-fun-types
* (make-array 4))
233 (push *universal-type
* required
))
234 (setf (svref *interned-fun-types
* i
)
236 (%make-fun-type required nil nil nil nil nil nil
*wild-type
*))))))
238 (defun make-fun-type (&key required optional rest
241 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
242 (n (length required
)))
244 (not optional
) (not rest
) (not keyp
)
245 (not keywords
) (not allowp
) (not wild-args
)
246 (eq returns
*wild-type
*)
247 (every (lambda (x) (eq x
*universal-type
*)) required
))
248 (svref *interned-fun-types
* n
)
249 (%make-fun-type required optional rest keyp keywords
250 allowp wild-args returns
))))
252 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
253 ;;; "type specifier", which is only meaningful in function argument
254 ;;; type specifiers used within the compiler. (It represents something
255 ;;; that the compiler knows to be a constant.)
256 (defstruct (constant-type
258 (class-info (type-class-or-lose 'constant
)))
260 ;; The type which the argument must be a constant instance of for this type
262 (type (missing-arg) :type ctype
:read-only t
))
264 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
265 ;;; special cases, as well as other special cases needed to
266 ;;; interpolate between regions of the type hierarchy, such as
267 ;;; INSTANCE (which corresponds to all those classes with slots which
268 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
269 ;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
270 ;;; non-VECTOR classes which are also sequences). These special cases
271 ;;; are the ones that aren't really discussed by Baker in his
272 ;;; "Decision Procedure for SUBTYPEP" paper.
273 (defstruct (named-type (:include ctype
274 (class-info (type-class-or-lose 'named
)))
276 (name nil
:type symbol
:read-only t
))
278 ;;; a list of all the float "formats" (i.e. internal representations;
279 ;;; nothing to do with #'FORMAT), in order of decreasing precision
280 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
281 (defparameter *float-formats
*
282 '(long-float double-float single-float short-float
)))
284 ;;; The type of a float format.
285 (deftype float-format
() `(member ,@*float-formats
*))
287 ;;; A NUMERIC-TYPE represents any numeric type, including things
289 (defstruct (numeric-type (:include ctype
290 (class-info (type-class-or-lose 'number
)))
291 (:constructor %make-numeric-type
)
293 ;; Formerly defined in every CTYPE, but now just in the ones
294 ;; for which enumerability is variable.
295 (enumerable nil
:read-only t
)
296 ;; the kind of numeric type we have, or NIL if not specified (just
297 ;; NUMBER or COMPLEX)
299 ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
300 ;; Especially when a CLASS value *is* stored in another slot (called
301 ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
302 ;; weird that comment above says "Numeric-Type is used to represent
303 ;; all numeric types" but this slot doesn't allow COMPLEX as an
304 ;; option.. how does this fall into "not specified" NIL case above?
305 ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
306 ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
307 ;; whatnot be concrete subclasses..
308 (class nil
:type
(member integer rational float nil
) :read-only t
)
309 ;; "format" for a float type (i.e. type specifier for a CPU
310 ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
311 ;; to do with #'FORMAT), or NIL if not specified or not a float.
312 ;; Formats which don't exist in a given implementation don't appear
314 (format nil
:type
(or float-format null
) :read-only t
)
315 ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
317 ;; FIXME: I'm bewildered by FOO-P names for things not intended to
318 ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
319 (complexp :real
:type
(member :real
:complex nil
) :read-only t
)
320 ;; The upper and lower bounds on the value, or NIL if there is no
321 ;; bound. If a list of a number, the bound is exclusive. Integer
322 ;; types never have exclusive bounds, i.e. they may have them on
323 ;; input, but they're canonicalized to inclusive bounds before we
325 (low nil
:type
(or number cons null
) :read-only t
)
326 (high nil
:type
(or number cons null
) :read-only t
))
328 ;; For some numeric subtypes, uniqueness of the object representation
329 ;; is enforced. These encompass all array specializations and more.
330 (defglobal *unsigned-byte-type
* -
1)
331 (defglobal *integer-type
* -
1)
332 (defglobal *index-type
* -
1)
333 ;; BIGNUM is not an interned type because union types aren't interned,
334 ;; though some of the important ones probably ought to be.
335 (defglobal *positive-bignum-type
* -
1)
336 (defglobal *negative-bignum-type
* -
1)
337 (defglobal *rational-type
* -
1)
338 (defglobal *unsigned-byte-n-types
* -
1)
339 (defglobal *signed-byte-n-types
* -
1)
340 (defglobal *real-ffloat-type
* -
1)
341 (defglobal *real-dfloat-type
* -
1)
342 (defglobal *complex-ffloat-type
* -
1)
343 (defglobal *complex-dfloat-type
* -
1)
345 (declaim (type (simple-vector #.
(1+ sb
!vm
:n-word-bits
)) *unsigned-byte-n-types
*)
346 (type (simple-vector #.sb
!vm
:n-word-bits
) *signed-byte-n-types
*))
348 ;; Called after NUMBER-TYPE type-class has been made.
349 (defun !intern-important-numeric-type-instances
()
350 (flet ((float-type (format complexp
)
352 (%make-numeric-type
:class
'float
:complexp complexp
353 :format format
:enumerable nil
)))
354 (int-type (enumerable low high
)
356 (%make-numeric-type
:class
'integer
:complexp
:real
357 :enumerable enumerable
358 :low low
:high high
))))
359 (setq *real-ffloat-type
* (float-type 'single-float
:real
)
360 *real-dfloat-type
* (float-type 'double-float
:real
)
361 *complex-ffloat-type
* (float-type 'single-float
:complex
)
362 *complex-dfloat-type
* (float-type 'double-float
:complex
)
363 *rational-type
* (mark-ctype-interned
364 (%make-numeric-type
:class
'rational
))
365 *unsigned-byte-type
* (int-type nil
0 nil
)
366 *integer-type
* (int-type nil nil nil
)
367 *index-type
* (int-type nil
0 (1- sb
!xc
:array-dimension-limit
))
368 *negative-bignum-type
* (int-type nil nil
(1- sb
!xc
:most-negative-fixnum
))
369 *positive-bignum-type
* (int-type nil
(1+ sb
!xc
:most-positive-fixnum
) nil
)
370 *unsigned-byte-n-types
* (make-array (1+ sb
!vm
:n-word-bits
))
371 *signed-byte-n-types
* (make-array sb
!vm
:n-word-bits
))
372 (dotimes (j (1+ sb
!vm
:n-word-bits
))
373 (setf (svref *unsigned-byte-n-types
* j
) (int-type t
0 (1- (ash 1 j
)))))
374 (dotimes (j sb
!vm
:n-word-bits
)
375 (setf (svref *signed-byte-n-types
* j
)
376 (let ((high (1- (ash 1 j
)))) (int-type t
(- (1+ high
)) high
))))))
378 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
379 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
381 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
382 ;;; come from parsing MEMBER. But bounded integer ranges,
383 ;;; however large, are enumerable:
384 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
385 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
386 ;;; but, in contrast,
387 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
388 ;;; I can't figure out whether this is supposed to matter.
389 ;;; Moreover, it seems like this function should be responsible
390 ;;; for figuring out the right value so that callers don't have to.
391 (defun make-numeric-type (&key class format
(complexp :real
) low high
393 ;; if interval is empty
396 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
397 (>= (type-bound-number low
) (type-bound-number high
))
400 (multiple-value-bind (low high
)
403 ;; INTEGER types always have their LOW and HIGH bounds
404 ;; represented as inclusive, not exclusive values.
405 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
406 (if (consp high
) (1- (type-bound-number high
)) high
)))
408 ;; no canonicalization necessary
410 (when (and (eq class
'rational
)
414 (setf class
'integer
))
416 ;; Either lookup the canonical interned object for
417 ;; a point in the type lattice, or construct a new one.
418 (or (cond ((eq class
'float
)
419 (when (and (null low
) (null high
))
423 (:real
*real-ffloat-type
*)
424 (:complex
*complex-ffloat-type
*)))
427 (:real
*real-dfloat-type
*)
428 (:complex
*complex-dfloat-type
*))))))
429 ((and (eq class
'integer
) (eq complexp
:real
))
430 (flet ((n-bits () (integer-length (truly-the word high
))))
431 (declare (inline n-bits
))
433 (cond ((eql low
0) *unsigned-byte-type
*)
434 ((not low
) *integer-type
*)
435 ((eql low
(1+ sb
!xc
:most-positive-fixnum
))
436 *positive-bignum-type
*)))
437 ((or (= high most-positive-word
)
438 (and (typep high
'word
)
439 ;; is (1+ high) a power-of-2 ?
440 (zerop (logand (1+ high
) high
))))
442 (svref *unsigned-byte-n-types
* (n-bits)))
443 ((and (< high most-positive-word
)
444 (eql low
(lognot high
)))
445 (svref *signed-byte-n-types
* (n-bits)))))
447 (eql high
(1- sb
!xc
:array-dimension-limit
)))
450 (eql high
(1- sb
!xc
:most-negative-fixnum
)))
451 *negative-bignum-type
*))))
452 ((and (eq class
'rational
) (eq complexp
:real
)
453 (null low
) (eq high low
))
456 (%make-numeric-type
:class class
461 :enumerable enumerable
)))
462 (setf (type-hash-value result
)
463 (logior (type-hash-value result
)
464 +type-admits-type
=-optimization
+))
467 (defun modified-numeric-type (base
469 (class (numeric-type-class base
))
470 (format (numeric-type-format base
))
471 (complexp (numeric-type-complexp base
))
472 (low (numeric-type-low base
))
473 (high (numeric-type-high base
))
474 (enumerable (type-enumerable base
)))
475 (make-numeric-type :class class
480 :enumerable enumerable
))
482 (defstruct (character-set-type
484 (class-info (type-class-or-lose 'character-set
)))
485 (:constructor %make-character-set-type
(pairs))
487 (pairs (missing-arg) :type list
:read-only t
))
489 ;; Interned character-set types.
490 (defglobal *character-type
* -
1)
492 (progn (defglobal *base-char-type
* -
1)
493 (defglobal *extended-char-type
* -
1))
494 #+sb-xc
(declaim (type ctype
*character-type
*
495 #!+sb-unicode
*base-char-type
*
496 #!+sb-unicode
*extended-char-type
*))
498 (defun !intern-important-character-set-type-instances
()
499 (flet ((range (low high
)
501 (%make-character-set-type
(list (cons low high
))))))
502 (setq *character-type
* (range 0 (1- sb
!xc
:char-code-limit
)))
504 (setq *base-char-type
* (range 0 127)
505 *extended-char-type
* (range 128 (1- sb
!xc
:char-code-limit
)))))
507 (defun make-character-set-type (&key pairs
)
508 ; (aver (equal (mapcar #'car pairs)
509 ; (sort (mapcar #'car pairs) #'<)))
510 ;; aver that the cars of the list elements are sorted into increasing order
511 (aver (or (null pairs
)
512 (do ((p pairs
(cdr p
)))
514 (when (> (caar p
) (caadr p
)) (return nil
)))))
515 (let ((pairs (let (result)
516 (do ((pairs pairs
(cdr pairs
)))
517 ((null pairs
) (nreverse result
))
518 (destructuring-bind (low . high
) (car pairs
)
519 (loop for
(low1 . high1
) in
(cdr pairs
)
520 if
(<= low1
(1+ high
))
521 do
(progn (setf high
(max high high1
))
522 (setf pairs
(cdr pairs
)))
523 else do
(return nil
))
525 ((>= low sb
!xc
:char-code-limit
))
527 (t (push (cons (max 0 low
)
528 (min high
(1- sb
!xc
:char-code-limit
)))
532 (or (and (singleton-p pairs
)
533 (let* ((pair (car pairs
))
535 (case (cdr pair
) ; high
536 (#.
(1- sb
!xc
:char-code-limit
)
539 #!+sb-unicode
(128 *extended-char-type
*)))
541 (127 (if (eql low
0) *base-char-type
*)))))
542 (%make-character-set-type pairs
)))))
544 ;;; An ARRAY-TYPE is used to represent any array type, including
545 ;;; things such as SIMPLE-BASE-STRING.
546 (defstruct (array-type (:include ctype
547 (class-info (type-class-or-lose 'array
)))
548 (:constructor %make-array-type
549 (dimensions complexp element-type
550 specialized-element-type
))
552 ;; the dimensions of the array, or * if unspecified. If a dimension
553 ;; is unspecified, it is *.
554 (dimensions '* :type
(or list
(member *)) :read-only t
)
555 ;; Is this not a simple array type? (:MAYBE means that we don't know.)
556 (complexp :maybe
:type
(member t nil
:maybe
) :read-only t
)
557 ;; the element type as originally specified
558 (element-type (missing-arg) :type ctype
:read-only t
)
559 ;; the element type as it is specialized in this implementation
560 (specialized-element-type *wild-type
* :type ctype
:read-only t
))
562 ;; For all ctypes which are the element types of specialized arrays,
563 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
564 ;; one for each of simple, maybe-simple, and non-simple (in that order),
565 ;; and 2 ctype objects for unknown-rank arrays, one each for simple
566 ;; and maybe-simple. (Unknown rank, known-non-simple isn't important)
567 (defglobal *canonical-array-ctypes
* -
1)
568 (defconstant +canon-array-ctype-hash-divisor
+ 37) ; arbitrary-ish
569 (defun !intern-important-array-type-instances
()
570 ;; Having made the canonical numeric and character ctypes
571 ;; representing the points in the type lattice for which there
572 ;; are array specializations, we can make the canonical array types.
573 (let* ((element-types
575 *universal-type
* *wild-type
* *empty-type
*
577 #!+sb-unicode
*base-char-type
*
578 ;; FIXME: This one is can't be used by MAKE-ARRAY-TYPE?
579 #!+sb-unicode
*extended-char-type
*
580 *real-ffloat-type
* *complex-ffloat-type
*
581 *real-dfloat-type
* *complex-dfloat-type
*
584 ;; Possibly could use the SAETP-IMPORTANCE as sort criterion
585 ;; so that collisions in a bucket place the more important
589 (cond ((typep x
'(cons (eql unsigned-byte
)))
590 (aref *unsigned-byte-n-types
* (cadr x
)))
592 (aref *unsigned-byte-n-types
* 1))
593 ((typep x
'(cons (eql signed-byte
)))
594 ;; 1- because there is no such thing as (signed-byte 0)
595 (aref *signed-byte-n-types
* (1- (cadr x
))))
596 ;; FIXNUM is its own thing, why? See comment in vm-array
597 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
598 ((eq x
'fixnum
) ; One good kludge deserves another.
599 (aref *signed-byte-n-types
* (1- sb
!vm
:n-fixnum-bits
)))))
600 '#.
*specialized-array-element-types
*))))
601 (n (length element-types
))
602 (data-vector (make-array (* 5 n
)))
604 (hashtable (make-array +canon-array-ctype-hash-divisor
+
605 :initial-element nil
)))
606 ;; This is a compact binned table. A full-blown hashtable is unneeded.
607 #-sb-xc
(aver (< (/ n
(length hashtable
)) 80/100)) ; assert reasonable load
608 (flet ((make-it (dims complexp type
)
609 (setf (aref data-vector
(prog1 index
(incf index
)))
611 (%make-array-type dims complexp type type
)))))
612 (dolist (element-type element-types
)
613 (let ((bin (mod (type-hash-value element-type
)
614 +canon-array-ctype-hash-divisor
+)))
615 (setf (aref hashtable bin
)
616 (nconc (aref hashtable bin
) (list (cons element-type index
))))
617 (make-it '(*) nil element-type
)
618 (make-it '(*) :maybe element-type
)
619 (make-it '(*) t element-type
)
620 (make-it '* nil element-type
)
621 (make-it '* :maybe element-type
))))
622 (setq *canonical-array-ctypes
* (cons data-vector hashtable
))))
624 (declaim (ftype (sfunction (t &key
(:complexp t
)
626 (:specialized-element-type t
))
627 ctype
) make-array-type
))
628 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
629 (specialized-element-type *wild-type
*))
630 (or (and (eq element-type specialized-element-type
)
631 (or (and (eq dimensions
'*) (neq complexp t
))
632 (typep dimensions
'(cons (eql *) null
)))
633 (let ((table *canonical-array-ctypes
*))
634 (dolist (cell (svref (cdr table
)
635 (mod (type-hash-value element-type
)
636 +canon-array-ctype-hash-divisor
+)))
637 (when (eq (car cell
) element-type
)
642 (if (listp dimensions
) 0 3)
644 ((nil) 0) ((:maybe
) 1) ((t) 2))))))))))
645 (%make-array-type dimensions
646 complexp element-type specialized-element-type
)))
648 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
649 ;;; bother with this at this level because MEMBER types are fairly
650 ;;; important and union and intersection are well defined.
651 (defstruct (member-type (:include ctype
652 (class-info (type-class-or-lose 'member
)))
654 (:constructor %make-member-type
(xset fp-zeroes
))
655 #-sb-xc-host
(:pure nil
))
656 (xset (missing-arg) :type xset
:read-only t
)
657 (fp-zeroes (missing-arg) :type list
:read-only t
))
659 (defglobal *null-type
* -
1) ; = (MEMBER NIL)
660 (defglobal *eql-t-type
* -
1) ; = (MEMBER T)
661 (defglobal *boolean-type
* -
1) ; = (MEMBER T NIL)
662 #+sb-xc
(declaim (type ctype
*null-type
*))
664 (defun !intern-important-member-type-instances
()
665 (flet ((make-it (list)
667 (%make-member-type
(xset-from-list list
) nil
))))
668 (setf *null-type
* (make-it '(nil))
669 *eql-t-type
* (make-it '(t))
670 *boolean-type
* (make-it '(t nil
)))))
672 (declaim (ftype (sfunction (xset list
) ctype
) make-member-type
))
673 (defun member-type-from-list (members)
674 (let ((xset (alloc-xset))
676 (dolist (elt members
(make-member-type xset fp-zeroes
))
678 (pushnew elt fp-zeroes
)
679 (add-to-xset elt xset
)))))
680 (defun make-eql-type (elt) (member-type-from-list (list elt
)))
681 ;; Return possibly a union of a MEMBER type and a NUMERIC type,
682 ;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET
683 ;; and the FP-ZEROES. XSET should not contains characters or real numbers.
684 (defun make-member-type (xset fp-zeroes
)
685 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
686 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
687 ;; ranges are compared by arithmetic operators (while MEMBERship is
688 ;; compared by EQL). -- CSR, 2003-04-23
692 (when fp-zeroes
; avoid doing two passes of nothing
694 (dolist (z fp-zeroes
)
695 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
700 #!+long-float
(long-float 4)))))
702 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
703 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
705 (push (ctype-of z
) float-types
))
706 (push z unpaired
)))))))
710 (when (singleton-p (xset-data xset
))
711 (case (first (xset-data xset
))
712 ((nil) (return *null-type
*))
713 ((t) (return *eql-t-type
*))))
714 ;; Semantically this is fine - XSETs
715 ;; are not order-preserving except by accident
716 ;; (when not represented as a hash-table).
717 (when (or (equal (xset-data xset
) '(t nil
))
718 (equal (xset-data xset
) '(nil t
)))
719 (return *boolean-type
*)))
720 (when (or unpaired
(not (xset-empty-p xset
)))
721 (let ((result (%make-member-type xset unpaired
)))
722 (setf (type-hash-value result
)
723 (logior (type-hash-value result
)
724 +type-admits-type
=-optimization
+))
726 ;; The actual member-type contains the XSET (with no FP zeroes),
727 ;; and a list of unpaired zeroes.
729 (make-union-type t
(if member-type
730 (cons member-type float-types
)
732 (or member-type
*empty-type
*)))))
734 (defun member-type-size (type)
735 (+ (length (member-type-fp-zeroes type
))
736 (xset-count (member-type-xset type
))))
738 (defun member-type-member-p (x type
)
740 (and (member x
(member-type-fp-zeroes type
)) t
)
741 (xset-member-p x
(member-type-xset type
))))
743 (defun mapcar-member-type-members (function type
)
744 (declare (function function
))
746 (map-xset (lambda (x)
747 (results (funcall function x
)))
748 (member-type-xset type
))
749 (dolist (zero (member-type-fp-zeroes type
))
750 (results (funcall function zero
)))
753 (defun mapc-member-type-members (function type
)
754 (declare (function function
))
755 (map-xset function
(member-type-xset type
))
756 (dolist (zero (member-type-fp-zeroes type
))
757 (funcall function zero
)))
759 (defun member-type-members (type)
760 (append (member-type-fp-zeroes type
)
761 (xset-members (member-type-xset type
))))
763 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
764 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
765 (defstruct (compound-type (:include ctype
)
768 ;; Formerly defined in every CTYPE, but now just in the ones
769 ;; for which enumerability is variable.
770 (enumerable nil
:read-only t
)
771 (types nil
:type list
:read-only t
))
773 ;;; A UNION-TYPE represents a use of the OR type specifier which we
774 ;;; couldn't canonicalize to something simpler. Canonical form:
775 ;;; 1. All possible pairwise simplifications (using the UNION2 type
776 ;;; methods) have been performed. Thus e.g. there is never more
777 ;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
778 ;;; this hadn't been fully implemented yet.
779 ;;; 2. There are never any UNION-TYPE components.
781 ;;; TODO: As STRING is an especially important union type,
782 ;;; it could be interned by canonicalizing its subparts into
783 ;;; ARRAY of {CHARACTER,BASE-CHAR,NIL} in that exact order always.
784 ;;; It will therefore admit quick TYPE=, but not quick failure, since
785 ;;; (type= (specifier-type '(or (simple-array (member #\a) (*))
786 ;;; (simple-array character (*))
787 ;;; (simple-array nil (*))))
788 ;;; (specifier-type 'simple-string)) => T and T
789 ;;; even though (MEMBER #\A) is not TYPE= to BASE-CHAR.
791 (defstruct (union-type (:include compound-type
792 (class-info (type-class-or-lose 'union
)))
793 (:constructor make-union-type
(enumerable types
))
796 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
797 ;;; which we couldn't canonicalize to something simpler. Canonical form:
798 ;;; 1. All possible pairwise simplifications (using the INTERSECTION2
799 ;;; type methods) have been performed. Thus e.g. there is never more
800 ;;; than one MEMBER-TYPE component.
801 ;;; 2. There are never any INTERSECTION-TYPE components: we've
802 ;;; flattened everything into a single INTERSECTION-TYPE object.
803 ;;; 3. There are never any UNION-TYPE components. Either we should
804 ;;; use the distributive rule to rearrange things so that
805 ;;; unions contain intersections and not vice versa, or we
806 ;;; should just punt to using a HAIRY-TYPE.
807 (defstruct (intersection-type (:include compound-type
808 (class-info (type-class-or-lose
810 (:constructor %make-intersection-type
814 ;;; Return TYPE converted to canonical form for a situation where the
815 ;;; "type" '* (which SBCL still represents as a type even though ANSI
816 ;;; CL defines it as a related but different kind of placeholder) is
817 ;;; equivalent to type T.
818 (defun type-*-to-t
(type)
819 (if (type= type
*wild-type
*)
823 ;;; A CONS-TYPE is used to represent a CONS type.
824 (defstruct (cons-type (:include ctype
(class-info (type-class-or-lose 'cons
)))
826 %make-cons-type
(car-type
829 ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
830 (car-type (missing-arg) :type ctype
:read-only t
)
831 (cdr-type (missing-arg) :type ctype
:read-only t
))
833 ;; The function caches work significantly better when there
834 ;; is a unique object that stands for the specifier (CONS T T).
835 (defglobal *cons-t-t-type
* -
1)
836 #+sb-xc
(declaim (type ctype
*cons-t-t-type
*))
838 (defun !intern-important-cons-type-instances
()
839 (setf *cons-t-t-type
*
841 (%make-cons-type
*universal-type
* *universal-type
*))))
844 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
845 (defun make-cons-type (car-type cdr-type
)
846 (aver (not (or (eq car-type
*wild-type
*)
847 (eq cdr-type
*wild-type
*))))
848 (cond ((or (eq car-type
*empty-type
*)
849 (eq cdr-type
*empty-type
*))
851 ;; It's not a requirement that (CONS T T) be interned,
852 ;; but it improves the hit rate in the function caches.
853 ((and (type= car-type
*universal-type
*)
854 (type= cdr-type
*universal-type
*))
857 (%make-cons-type car-type cdr-type
))))
859 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
861 (defstruct (simd-pack-type
862 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
863 (:constructor %make-simd-pack-type
(element-type))
865 (element-type (missing-arg)
866 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
870 (defun make-simd-pack-type (element-type)
871 (aver (neq element-type
*wild-type
*))
872 (if (eq element-type
*empty-type
*)
874 (%make-simd-pack-type
875 (dolist (pack-type *simd-pack-element-types
*
876 (error "~S element type must be a subtype of ~
877 ~{~S~#[~;, or ~:;, ~]~}."
878 'simd-pack
*simd-pack-element-types
*))
879 (when (csubtypep element-type
(specifier-type pack-type
))
880 (return (list pack-type
)))))))
885 ;;; Return the type structure corresponding to a type specifier.
887 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
888 ;;; type is defined (or redefined).
890 ;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily
891 ;;; to the CLHS intent, which is to make the type known to the compiler.
892 ;;; If we compile in one file:
893 ;;; (DEFCLASS FRUITBAT () ())
894 ;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT))
895 ;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its
896 ;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF,
897 ;;; which (correctly) signals an error if the class were not defined by the
898 ;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier
899 ;;; at call time is wrong.
901 ;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton
902 ;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and
903 ;;; (CHARACTER) are not. It has to do with whether the primitive is actually
904 ;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal.
905 ;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis]
906 ;;; compound type specifier with no arguments supplied, (x)."
907 ;;; By that same reasonining, is (x) accepted if x names a class?
909 ;;; KLUDGE: why isn't this a MACROLET? "lexical environment too
911 (defmacro !values-specifier-type-body
(arg)
915 (or (and (built-in-classoid-p x
)
916 (built-in-classoid-translation x
))
918 ;; Q: Shouldn't this signal a TYPE-ERROR ?
919 (fail (spec) (error "bad thing to be a type specifier: ~S" spec
))
921 (when (typep spec
'instance
)
923 (cond ((classoid-p spec
) (translate spec
))
924 ((sb!pcl
::classp spec
)
925 (translate (sb!pcl
::class-classoid spec
)))
926 ;; We don't try to know how to map a generalized
927 ;; PCL specializer to its ctype other than by lookup.
928 (t (or (info :type
:translator spec
) (fail spec
))))))
929 (prog* ((head (if (listp spec
) (car spec
) spec
))
930 (builtin (if (symbolp head
)
931 (info :type
:builtin head
)
932 (return (fail spec
)))))
933 (when (deprecated-thing-p 'type head
)
935 (signal 'parse-deprecated-type
:specifier spec
))
937 ;; If spec is non-atomic, the :BUILTIN value is inapplicable.
938 ;; There used to be compound builtins, but not any more.
939 (when builtin
(return builtin
))
940 (case (info :type
:kind spec
)
941 (:instance
(return (find-classoid spec
)))
942 (:forthcoming-defclass-type
(go unknown
))))
943 (awhen (info :type
:translator head
)
944 (return (or (funcall it spec
) (fail spec
))))
945 (awhen (info :type
:expander head
)
946 (return (recurse (funcall it
(ensure-list spec
)))))
947 ;; If the spec is (X ...) and X has neither a translator
948 ;; nor expander, and is a builtin, such as FIXNUM, fail now.
949 ;; But - see FIXME at top - it would be consistent with
950 ;; DEFTYPE to reject spec only if not a singleton.
951 (when builtin
(return (fail spec
)))
952 ;; SPEC has a legal form, so return an unknown type.
953 (signal 'parse-unknown-type
:specifier spec
)
956 (return (make-unknown-type :specifier spec
)))))
957 (let ((result (recurse (uncross ,arg
))))
960 ;; (The RETURN-FROM here inhibits caching; this makes sense
961 ;; not only from a compiler diagnostics point of view,
962 ;; but also for proper workingness of VALID-TYPE-SPECIFIER-P.
963 ;; FIXME: cache bypass for (OR DEPRECATED GOOD)
964 ;; or (OR UNKNOWN KNOWN) doesn't actually work.
965 (return-from values-specifier-type result
))))))
967 (let ((table (make-hash-table :test
'equal
)))
968 (defun values-specifier-type (specifier)
969 (multiple-value-bind (type yesp
) (gethash specifier table
)
972 (setf (gethash specifier table
)
973 (!values-specifier-type-body specifier
)))))
974 (defun values-specifier-type-cache-clear ()
976 ;;; This cache is sized extremely generously, which has payoff
977 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
978 ;;; since EQ types are an immediate win.
980 (defun-cached (values-specifier-type
981 :hash-function
#'sxhash
:hash-bits
10)
982 ((orig equal-but-no-car-recursion
))
983 (!values-specifier-type-body orig
))
985 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
986 ;;; never return a VALUES type.
987 (defun specifier-type (type-specifier)
988 (let ((ctype (values-specifier-type type-specifier
)))
989 (when (or (values-type-p ctype
)
990 ;; bootstrap magic :-(
991 (and (named-type-p ctype
)
992 (eq (named-type-name ctype
) '*)))
993 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
996 (defun single-value-specifier-type (x)
1001 (defun typexpand-1 (type-specifier &optional env
)
1003 "Takes and expands a type specifier once like MACROEXPAND-1.
1004 Returns two values: the expansion, and a boolean that is true when
1005 expansion happened."
1006 (declare (type type-specifier type-specifier
))
1007 (declare (ignore env
))
1008 (let* ((spec type-specifier
)
1009 (atom (if (listp spec
) (car spec
) spec
))
1010 (expander (and (symbolp atom
) (info :type
:expander atom
))))
1011 ;; We do not expand builtins even though it'd be
1012 ;; possible to do so sometimes (e.g. STRING) for two
1015 ;; a) From a user's point of view, CL types are opaque.
1017 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
1018 (if (and expander
(not (info :type
:builtin atom
)))
1019 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
1020 (values type-specifier nil
))))
1022 (defun typexpand (type-specifier &optional env
)
1024 "Takes and expands a type specifier repeatedly like MACROEXPAND.
1025 Returns two values: the expansion, and a boolean that is true when
1026 expansion happened."
1027 (declare (type type-specifier type-specifier
))
1028 (multiple-value-bind (expansion flag
)
1029 (typexpand-1 type-specifier env
)
1031 (values (typexpand expansion env
) t
)
1032 (values expansion flag
))))
1034 ;;; Note that the type NAME has been (re)defined, updating the
1035 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
1036 (defun %note-type-defined
(name)
1037 (declare (symbol name
))
1038 (note-name-defined name
:type
)
1039 (values-specifier-type-cache-clear)
1043 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)