1 ;;;; type-related stuff which exists only in the target SBCL runtime
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
14 (!begin-collecting-cold-init-forms
)
16 ;;; If TYPE is a type that we can do a compile-time test on, then
17 ;;; return whether the object is of that type as the first value and
18 ;;; second value true. Otherwise return NIL, NIL.
20 ;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
21 ;;; types. For STRUCTURE- types, we require that the type be defined
22 ;;; in both the current and compiler environments, and that the
23 ;;; INCLUDES be the same.
25 ;;; KLUDGE: This should probably be a type method instead of a big
26 ;;; ETYPECASE. But then the type method system should probably be CLOS
27 ;;; too, and until that happens wedging more stuff into it might be
28 ;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
29 (defun ctypep (obj type
)
30 (declare (type ctype type
))
39 #!+sb-simd-pack simd-pack-type
)
40 (values (%%typep obj type
) t
))
42 (if (if (csubtypep type
(specifier-type 'function
))
43 (funcallable-instance-p obj
)
45 (if (eq (classoid-layout type
)
46 (info :type
:compiler-layout
(classoid-name type
)))
47 (values (sb!xc
:typep obj type
) t
)
51 (funcall (etypecase type
52 (intersection-type #'every
/type
)
53 (union-type #'any
/type
))
56 (compound-type-types type
)))
58 (values (functionp obj
) t
))
62 (values (alien-typep obj
(alien-type-type-alien-type type
)) t
))
64 (multiple-value-bind (res win
)
65 (ctypep obj
(negation-type-type type
))
70 ;; Now the tricky stuff.
71 (let* ((hairy-spec (hairy-type-specifier type
))
72 (symbol (if (consp hairy-spec
) (car hairy-spec
) hairy-spec
)))
77 (dolist (spec (cdr hairy-spec
) (values t t
))
78 (multiple-value-bind (res win
)
79 (ctypep obj
(specifier-type spec
))
80 (unless win
(return (values nil nil
)))
81 (unless res
(return (values nil t
)))))))
83 (multiple-value-bind (res win
)
84 (ctypep obj
(specifier-type (cadr hairy-spec
)))
89 ;; If the SATISFIES function is not foldable, we cannot answer!
90 (let* ((form `(,(second hairy-spec
) ',obj
)))
91 (multiple-value-bind (ok result
)
92 (sb!c
::constant-function-call-p form nil nil
)
93 (values (not (null result
)) ok
)))))))))
95 ;;; Return the layout for an object. This is the basic operation for
96 ;;; finding out the "type" of an object, and is used for generic
97 ;;; function dispatch. The standard doesn't seem to say as much as it
98 ;;; should about what this returns for built-in objects. For example,
99 ;;; it seems that we must return NULL rather than LIST when X is NIL
100 ;;; so that GF's can specialize on NULL.
101 #!-sb-fluid
(declaim (inline layout-of
))
103 (declare (optimize (speed 3) (safety 0)))
104 (cond ((%instancep x
) (%instance-layout x
))
105 ((funcallable-instance-p x
) (%funcallable-instance-layout x
))
106 ;; Compiler can dump literal layouts, which handily sidesteps
107 ;; the question of when cold-init runs L-T-V forms.
108 ((null x
) #.
(find-layout 'null
))
110 ;; Note that WIDETAG-OF is slightly suboptimal here and could be
111 ;; improved - we've already ruled out some of the lowtags.
112 (svref (load-time-value **built-in-class-codes
** t
) (widetag-of x
)))))
114 #!-sb-fluid
(declaim (inline classoid-of
))
115 (defun classoid-of (object)
117 "Return the class of the supplied object, which may be any Lisp object, not
118 just a CLOS STANDARD-OBJECT."
119 (layout-classoid (layout-of object
)))
121 ;;;; miscellaneous interfaces
123 ;;; Clear memoization of all type system operations that can be
124 ;;; altered by type definition/redefinition.
126 (defun clear-type-caches ()
127 ;; FIXME: We would like to differentiate between different cache
128 ;; kinds, but at the moment all our caches pretty much are type
130 (drop-all-hash-caches)
133 ;;; This is like TYPE-OF, only we return a CTYPE structure instead of
134 ;;; a type specifier, and we try to return the type most useful for
135 ;;; type checking, rather than trying to come up with the one that the
136 ;;; user might find most informative.
138 ;;; To avoid inadvertent memory retention we avoid using arrays
139 ;;; and functions as keys.
140 ;;; During cross-compilation, the CTYPE-OF function is not memoized.
141 ;;; Constants get their type stored in their LEAF, so it's ok.
143 (defun-cached (ctype-of :hash-bits
7 :hash-function
#'sxhash
145 ;; an unfortunate aspect of using EQ is that several appearances
146 ;; of the = double-float can be in the cache, but it's
147 ;; probably more efficient overall to use object identity.
149 (flet ((try-cache (x)
151 ;; For functions, the input is a type specifier
152 ;; of the form (FUNCTION (...) ...)
153 (cond ((listp x
) (specifier-type x
)) ; NIL can't occur
154 ((symbolp x
) (make-eql-type x
))
155 (t (ctype-of-number x
))))))
158 (if (funcallable-instance-p x
)
160 (let ((type (sb!impl
::%fun-type x
)))
161 (if (typep type
'(cons (eql function
))) ; sanity test
164 (symbol (if x
(try-cache x
) *null-type
*))
165 (number (try-cache x
))
166 (array (ctype-of-array x
))
167 (cons *cons-t-t-type
*)
168 ;; This makes no distinction for BASE/EXTENDED-CHAR. Should it?
169 (character *character-type
*)
172 (let ((tag (%simd-pack-tag x
)))
173 (svref (load-time-value
174 (coerce (cons (specifier-type 'simd-pack
)
175 (mapcar (lambda (x) (specifier-type `(simd-pack ,x
)))
176 *simd-pack-element-types
*))
179 (if (<= 0 tag
#.
(1- (length *simd-pack-element-types
*)))
185 ;; Helper function that implements (CTYPE-OF x) when X is an array.
186 (defun-cached (ctype-of-array
187 :values
(ctype) ; Bind putative output to this when probing.
189 :hash-function
(lambda (a &aux
(hash cookie
))
191 (dotimes (axis rank hash
)
192 (mixf hash
(%array-dimension a axis
)))
193 (mixf hash
(length a
)))))
194 ;; "type-key" is a perfect hash of rank + widetag + simple-p.
195 ;; If it matches, then compare dims, which are read from the output.
196 ;; The hash of the type-key + dims can have collisions.
197 ((array (lambda (array type-key
)
198 (and (eq type-key cookie
)
199 (let ((dims (array-type-dimensions ctype
)))
201 (dotimes (axis rank t
)
202 (unless (eq (pop (truly-the list dims
))
203 (%array-dimension array axis
))
205 (eq (length array
) (car dims
))))))
206 cookie
) ; Store COOKIE as the single key.
207 &aux
(rank (array-rank array
))
208 (simple-p (if (simple-array-p array
) 1 0))
209 (header-p (array-header-p array
)) ; non-simple or rank <> 1 or both
210 (cookie (the fixnum
(logior (ash (logior (ash rank
1) simple-p
)
211 sb
!vm
:n-widetag-bits
)
212 (array-underlying-widetag array
)))))
213 ;; The value computed on cache miss.
214 (let ((etype (specifier-type (array-element-type array
))))
215 (make-array-type (array-dimensions array
)
216 :complexp
(not (simple-array-p array
))
218 :specialized-element-type etype
)))
220 (!defun-from-collected-cold-init-forms
!target-type-cold-init
)
222 ;;;; Some functions for examining the type system
223 ;;;; which are not needed during self-build.
225 (defun typexpand-all (type-specifier &optional env
)
227 "Takes and expands a type specifier recursively like MACROEXPAND-ALL."
228 (declare (type type-specifier type-specifier
))
229 (declare (ignore env
))
230 ;; I first thought this would not be a good implementation because
231 ;; it signals an error on e.g. (CONS 1 2) until I realized that
232 ;; walking and calling TYPEXPAND would also result in errors, and
233 ;; it actually makes sense.
235 ;; There's still a small problem in that
236 ;; (TYPEXPAND-ALL '(CONS * FIXNUM)) => (CONS T FIXNUM)
237 ;; whereas walking+typexpand would result in (CONS * FIXNUM).
239 ;; Similiarly, (TYPEXPAND-ALL '(FUNCTION (&REST T) *)) => FUNCTION.
240 (type-specifier (values-specifier-type type-specifier
)))
242 (defun defined-type-name-p (name &optional env
)
244 "Returns T if NAME is known to name a type specifier, otherwise NIL."
245 (declare (symbol name
))
246 (declare (ignore env
))
247 (and (info :type
:kind name
) t
))
249 (defun valid-type-specifier-p (type-specifier &optional env
)
251 "Returns T if TYPE-SPECIFIER is a valid type specifier, otherwise NIL.
253 There may be different metrics on what constitutes a \"valid type
254 specifier\" depending on context. If this function does not suit your
255 exact need, you may be able to craft a particular solution using a
256 combination of DEFINED-TYPE-NAME-P and the TYPEXPAND functions.
258 The definition of \"valid type specifier\" employed by this function
259 is based on the following mnemonic:
261 \"Would TYPEP accept it as second argument?\"
263 Except that unlike TYPEP, this function fully supports compound
264 FUNCTION type specifiers, and the VALUES type specifier, too.
266 In particular, VALID-TYPE-SPECIFIER-P will return NIL if
267 TYPE-SPECIFIER is not a class, not a symbol that is known to name a
268 type specifier, and not a cons that represents a known compound type
269 specifier in a syntactically and recursively correct way.
273 (valid-type-specifier-p '(cons * *)) => T
274 (valid-type-specifier-p '#:foo) => NIL
275 (valid-type-specifier-p '(cons * #:foo)) => NIL
276 (valid-type-specifier-p '(cons 1 *) => NIL
279 (declare (ignore env
))
280 (handler-case (prog1 t
(values-specifier-type type-specifier
))
281 (parse-unknown-type () nil
)