1 ;;;; This file contains stuff that implements the portable IR1
2 ;;;; semantics of type tests and coercion. The main thing we do is
3 ;;;; convert complex type operations into simpler code that can be
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
17 ;;;; type predicate translation
19 ;;;; We maintain a bidirectional association between type predicates
20 ;;;; and the tested type. The presence of a predicate in this
21 ;;;; association implies that it is desirable to implement tests of
22 ;;;; this type using the predicate. These are either predicates that
23 ;;;; the back end is likely to have special knowledge about, or
24 ;;;; predicates so complex that the only reasonable implentation is
25 ;;;; via function call.
27 ;;;; Some standard types (such as ATOM) are best tested by letting the
28 ;;;; TYPEP source transform do its thing with the expansion. These
29 ;;;; types (and corresponding predicates) are not maintained in this
30 ;;;; association. In this case, there need not be any predicate
31 ;;;; function unless it is required by the Common Lisp specification.
33 ;;;; The mapping between predicates and type structures is considered
34 ;;;; part of the backend; different backends can support different
35 ;;;; sets of predicates.
37 ;;; Establish an association between the type predicate NAME and the
38 ;;; corresponding TYPE. This causes the type predicate to be
39 ;;; recognized for purposes of optimization.
40 (defmacro define-type-predicate
(name type
)
41 `(%define-type-predicate
',name
',type
))
42 (defun %define-type-predicate
(name specifier
)
43 (let ((type (specifier-type specifier
)))
44 (setf (gethash name
*backend-predicate-types
*) type
)
45 (setf *backend-type-predicates
*
46 (cons (cons type name
)
47 (remove name
*backend-type-predicates
*
49 (%deftransform name nil
'(function (t) *) #'fold-type-predicate
)))
53 ;;; If we discover the type argument is constant during IR1
54 ;;; optimization, then give the source transform another chance. The
55 ;;; source transform can't pass, since we give it an explicit
56 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
57 ;;; spurious attempts at transformation (and possible repeated
59 (deftransform typep
((object type
&optional env
) * * :node node
)
60 (unless (constant-lvar-p type
)
61 (give-up-ir1-transform "can't open-code test of non-constant type"))
62 (unless (unsupplied-or-nil env
)
63 (give-up-ir1-transform "environment argument present and not null"))
64 (multiple-value-bind (expansion fail-p
)
65 (source-transform-typep 'object
(lvar-value type
))
70 (sb-xc:deftype other-pointer
()
72 (and number
(not (or fixnum
#+64-bit single-float
)))
73 fdefn
(and symbol
(not null
))
74 weak-pointer system-area-pointer code-component
))
76 (defun type-other-pointer-p (type)
77 (csubtypep type
(specifier-type 'other-pointer
)))
79 (defun type-not-other-pointer-p (type)
80 (csubtypep type
(specifier-type '(not other-pointer
))))
82 ;;; If the lvar OBJECT definitely is or isn't of the specified
83 ;;; type, then return T or NIL as appropriate. Otherwise quietly
84 ;;; GIVE-UP-IR1-TRANSFORM.
85 (defun ir1-transform-type-predicate (object type node
)
86 (declare (type lvar object
) (type ctype type
))
87 (let ((otype (lvar-type object
)))
88 (cond ((not (types-equal-or-intersect otype type
))
89 (return-from ir1-transform-type-predicate nil
))
90 ((csubtypep otype type
)
91 (return-from ir1-transform-type-predicate t
))
92 ((eq type
*empty-type
*)
93 (return-from ir1-transform-type-predicate nil
)))
94 (let ((intersect (type-intersection type otype
))
95 (current-predicate (combination-fun-source-name node
)))
96 ;; If the object type is known to be (OR NULL <type>),
97 ;; it is almost always cheaper to test for not EQ to NIL.
98 ;; There is one exception:
99 ;; - FIXNUMP is possibly cheaper than comparison to NIL, or definitely
100 ;; not worse. For x86, NIL is a 4-byte immediate operand,
101 ;; for lack of a null-tn register. FIXNUM-TAG-MASK is only 1 byte.
102 (when (type= otype
(type-union (specifier-type 'null
) type
))
103 (let ((difference (type-difference type
(specifier-type 'null
))))
104 (unless (type= difference
(specifier-type 'fixnum
))
105 (return-from ir1-transform-type-predicate
`(not (null object
))))))
106 (flet ((memory-type-test-p (type)
107 (and (types-equal-or-intersect
110 '(not (or fixnum
#+64-bit single-float
113 (not (type= type
(specifier-type 'instance
))))))
114 (cond ((typep type
'alien-type-type
)
115 ;; We don't transform alien type tests until here, because
116 ;; once we do that the rest of the type system can no longer
117 ;; reason about them properly -- so we'd miss out on type
119 (delay-ir1-transform node
:ir1-phases
)
120 (let ((alien-type (alien-type-type-alien-type type
)))
121 ;; If it's a lisp-rep-type, the CTYPE should be one already.
122 (aver (not (compute-lisp-rep-type alien-type
)))
123 `(sb-alien::alien-value-typep object
',alien-type
)))
124 ;; (typep (the (or list fixnum) x) 'integer) =>
126 ((let ((new-predicate
128 (backend-type-predicate intersect
)
129 ;; Remove bounds from numeric types
130 (and (csubtypep intersect
(specifier-type 'real
))
131 (macrolet ((up (&rest types
)
132 `(cond ,@(loop for
(type predicate
) on types by
#'cddr
134 `((and (csubtypep intersect
(specifier-type ',type
))
135 (csubtypep (specifier-type ',type
) type
))
140 single-float single-float-p
141 double-float double-float-p
144 (when (and new-predicate
145 (neq new-predicate current-predicate
)
146 ;; Some subtypes are more expensive to check
147 (not (and (eq current-predicate
'listp
)
148 (eq new-predicate
'consp
)))
149 (not (and (eq current-predicate
'functionp
)
150 (eq new-predicate
'compiled-function-p
)))
151 (not (eq current-predicate
'characterp
))
152 (not (and (eq current-predicate
'non-null-symbol-p
)
153 (eq new-predicate
'keywordp
)))
154 (not (eq new-predicate
#+64-bit
'signed-byte-64-p
155 #-
64-bit
'signed-byte-32-p
))
156 (not (eq new-predicate
#+64-bit
'unsigned-byte-64-p
157 #-
64-bit
'unsigned-byte-32-p
)))
158 `(,new-predicate object
))))
159 ;; (typep (the float x) 'double-float) =>
160 ;; (typep x 'single-float)
161 ((let* ((diff (type-difference otype type
))
162 (pred (and (or (eq current-predicate
'sequencep
) ;; always expensive
163 (not (memory-type-test-p diff
)))
164 (or (backend-type-predicate diff
)
165 ;; Remove bounds from numeric types
166 (and (csubtypep diff
(specifier-type 'real
))
167 (macrolet ((up (&rest types
)
168 `(cond ,@(loop for
(type predicate
) on types by
#'cddr
170 `((and (csubtypep diff
(specifier-type ',type
))
171 (not (types-equal-or-intersect type
(specifier-type ',type
))))
176 single-float single-float-p
177 double-float double-float-p
181 ;; Testing for fixnum is usually the cheapest
182 (or (eq pred
'fixnump
)
183 (memory-type-test-p type
)))
184 `(not (,pred object
)))
185 ((and (memory-type-test-p type
)
186 (cond ((and (type-not-other-pointer-p diff
)
187 (type-other-pointer-p type
))
188 `(%other-pointer-p object
))
189 ((and (type-other-pointer-p diff
)
190 (type-not-other-pointer-p type
))
191 `(not (%other-pointer-p object
)))))))))
193 (give-up-ir1-transform)))))))
195 ;;; Flush %TYPEP tests whose result is known at compile time.
196 (deftransform %typep
((object type
) * * :node node
)
197 (unless (constant-lvar-p type
)
198 (give-up-ir1-transform))
199 (ir1-transform-type-predicate
201 (ir1-transform-specifier-type (lvar-value type
))
204 ;;; This is the IR1 transform for simple type predicates. It checks
205 ;;; whether the single argument is known to (not) be of the
206 ;;; appropriate type, expanding to T or NIL as appropriate.
207 (deftransform fold-type-predicate
((object) * * :node node
:defun-only t
)
208 (let ((ctype (gethash (leaf-source-name
211 (basic-combination-fun node
))))
212 *backend-predicate-types
*)))
214 (ir1-transform-type-predicate object ctype node
)))
216 ;;; If FIND-CLASSOID is called on a constant class, locate the
217 ;;; CLASSOID-CELL at load time.
218 (deftransform find-classoid
((name) ((constant-arg symbol
)) *)
219 (let* ((name (lvar-value name
))
220 (cell (find-classoid-cell name
:create t
)))
221 `(or (classoid-cell-classoid ',cell
)
222 (error "Class not yet defined: ~S" name
))))
224 (defoptimizer (%typep-wrapper constraint-propagate-if
) ((test-value variable type
) node
)
225 (aver (constant-lvar-p type
))
226 (let* ((type (lvar-value type
))
227 (ctype (if (ctype-p type
)
229 (handler-case (careful-specifier-type type
)
231 (if (and ctype
(type-for-constraints-p ctype
))
232 (values variable ctype
))))
234 (deftransform %typep-wrapper
((test-value variable type
) * * :node node
)
235 (aver (constant-lvar-p type
))
236 (if (constant-lvar-p test-value
)
237 `',(lvar-value test-value
)
238 (let* ((type (lvar-value type
))
239 (type (if (ctype-p type
)
241 (handler-case (careful-specifier-type type
)
243 (value-type (lvar-type variable
)))
246 ((csubtypep value-type type
)
248 ((not (types-equal-or-intersect value-type type
))
251 (delay-ir1-transform node
:constraint
)
254 (deftransform %type-constraint
((x type
) * * :node node
)
255 (delay-ir1-transform node
:constraint
)
258 (defoptimizer (%type-constraint constraint-propagate
) ((x type
) node gen
)
259 (let ((var (ok-lvar-lambda-var x gen
)))
261 (let ((type (lvar-value type
)))
262 (list (list 'typep var
265 (handler-case (careful-specifier-type type
)
269 ;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
270 ;;;; plus at least one oddball (%INSTANCEP)
272 ;;;; Various other type predicates (e.g. low-level representation
273 ;;;; stuff like SIMPLE-ARRAY-SINGLE-FLOAT-P) are defined elsewhere.
275 ;;; FIXME: This function is only called once, at top level. Why not
276 ;;; just expand all its operations into toplevel code?
277 (defun !define-standard-type-predicates
()
278 (define-type-predicate arrayp array
)
279 ; (The ATOM predicate is handled separately as (NOT CONS).)
280 (define-type-predicate bit-vector-p bit-vector
)
281 (define-type-predicate characterp character
)
282 #+(and sb-unicode
(or x86-64 arm64
)) ;; others have a source-transform
283 (define-type-predicate base-char-p base-char
)
284 (define-type-predicate compiled-function-p compiled-function
)
285 (define-type-predicate complexp complex
)
286 (define-type-predicate complex-rational-p
(complex rational
))
287 (define-type-predicate complex-float-p
(complex float
))
288 (define-type-predicate consp cons
)
289 (define-type-predicate floatp float
)
290 (define-type-predicate functionp function
)
291 (define-type-predicate integerp integer
)
292 (define-type-predicate keywordp keyword
)
293 (define-type-predicate listp list
)
294 (define-type-predicate null null
)
295 (define-type-predicate numberp number
)
296 (define-type-predicate rationalp rational
)
297 (define-type-predicate realp real
)
298 (define-type-predicate sequencep sequence
)
299 (define-type-predicate extended-sequence-p extended-sequence
)
300 (define-type-predicate simple-bit-vector-p simple-bit-vector
)
301 (define-type-predicate simple-string-p simple-string
)
302 (define-type-predicate simple-vector-p simple-vector
)
303 (define-type-predicate stringp string
)
304 (define-type-predicate %instancep instance
)
305 (define-type-predicate simple-fun-p simple-fun
)
306 (define-type-predicate closurep closure
)
307 (define-type-predicate funcallable-instance-p funcallable-instance
)
308 (define-type-predicate symbolp symbol
)
309 (define-type-predicate vectorp vector
))
310 (!define-standard-type-predicates
)
312 ;;;; transforms for type predicates not implemented primitively
314 ;;;; See also VM dependent transforms.
316 (define-source-transform atom
(x)
319 #+(and sb-unicode
(not (or x86-64 arm64
)))
320 (define-source-transform base-char-p
(x)
321 `(typep ,x
'base-char
))
322 ;; CONS is implemented as (and list (not (eql nil))) where the 'and' is
323 ;; built-in to the consp vop. Reduce to just LISTP if possible.
324 (deftransform consp
((x) ((not null
)) * :important nil
)
327 ;;; If X is known non-nil, then testing SYMBOLP can skip the "= NIL" part.
328 (deftransform symbolp
((x) ((not null
)) * :important nil
)
329 '(non-null-symbol-p x
))
330 (deftransform non-null-symbol-p
((object) (symbol) * :important nil
)
331 `(not (eq object nil
)))
332 ;;; CLHS: http://www.lispworks.com/documentation/HyperSpec/Body/t_symbol.htm#symbol
333 ;;; "The consequences are undefined if an attempt is made to alter the home package
334 ;;; of a symbol external in the COMMON-LISP package or the KEYWORD package."
335 ;;; Therefore, we can constant-fold if the symbol-package is one of those two.
336 ;;; Interestingly, we don't need any transform for (NOT SYMBOL)
337 ;;; because IR1-TRANSFORM-TYPE-PREDICATE knows that the intersection of the type
338 ;;; implied by KEYWORDP with any type that does not intersect SYMBOL is NIL.
339 (deftransform keywordp
((x) ((constant-arg symbol
)))
340 (let ((pkg (sb-xc:symbol-package
(lvar-value x
))))
341 (cond ((eq pkg
*cl-package
*) 'nil
)
342 ((eq pkg
*keyword-package
*) 't
)
343 (t (give-up-ir1-transform)))))
345 ;;;; TYPEP source transform
347 ;;; Return a form that tests the variable N-OBJECT for being in the
348 ;;; binds specified by TYPE. BASE is the name of the base type, for
350 (defun transform-numeric-bound-test (n-object type base
)
351 (declare (type numeric-type type
))
352 (let ((low (numeric-type-low type
))
353 (high (numeric-type-high type
)))
356 `((> (truly-the ,base
,n-object
) ,(car low
)))
357 `((>= (truly-the ,base
,n-object
) ,low
))))
360 `((< (truly-the ,base
,n-object
) ,(car high
)))
361 `((<= (truly-the ,base
,n-object
) ,high
)))))))
363 ;;; Do source transformation of a test of a known numeric type. We can
364 ;;; assume that the type doesn't have a corresponding predicate, since
365 ;;; those types have already been picked off. In particular, CLASS
366 ;;; must be specified, since it is unspecified only in NUMBER and
367 ;;; COMPLEX. Similarly, we assume that COMPLEXP is always specified.
369 ;;; For non-complex types, we just test that the number belongs to the
370 ;;; base type, and then test that it is in bounds. When CLASS is
371 ;;; INTEGER, we check to see whether the range is no bigger than
372 ;;; FIXNUM. If so, we check for FIXNUM instead of INTEGER. This allows
373 ;;; us to use fixnum comparison to test the bounds.
375 ;;; For complex types, we must test for complex, then do the above on
376 ;;; both the real and imaginary parts. When CLASS is float, we need
377 ;;; only check the type of the realpart, since the format of the
378 ;;; realpart and the imagpart must be the same.
379 (defun source-transform-numeric-typep (object type
)
380 (let* ((class (numeric-type-class type
))
382 (integer (containing-integer-type
383 (if (numeric-type-complexp type
)
384 (modified-numeric-type type
388 (float (or (numeric-type-format type
) 'float
))
390 (low (numeric-type-low type
))
391 (high (numeric-type-high type
)))
392 (ecase (numeric-type-complexp type
)
394 (cond ((and (vop-existsp :translate check-range
<=)
395 (eql (numeric-type-class type
) 'integer
)
398 `(check-range<= ,low
,object
,high
))
399 ((type= type
(specifier-type '(or word sb-vm
:signed-word
)))
400 `(or (typep ,object
'sb-vm
:signed-word
)
401 (typep ,object
'word
)))
402 ((and (vop-existsp :translate unsigned-byte-x-p
)
403 (eql (numeric-type-class type
) 'integer
)
406 (= (logcount (1+ high
)) 1)
407 (zerop (rem (integer-length high
) sb-vm
:n-word-bits
)))
408 `(unsigned-byte-x-p ,object
,(integer-length high
)))
410 `(and (typep ,object
',base
)
411 ,(transform-numeric-bound-test object type base
)))))
413 (let ((part-type (second (type-specifier type
))))
414 `(and (typep ,object
'(complex ,(case base
415 ((double-float single-float rational
) base
)
416 (t (if (eq class
'integer
)
419 (typep (realpart ,object
) ',part-type
)
420 (typep (imagpart ,object
) ',part-type
)))))))
422 ;;; Do the source transformation for a test of a hairy type.
423 ;;; SATISFIES is converted into the obvious. Otherwise, we convert
424 ;;; to CACHED-TYPEP an possibly print an efficiency note.
425 (defun source-transform-hairy-typep (object type
)
426 (declare (type hairy-type type
))
427 (let ((spec (hairy-type-specifier type
)))
428 (cond ((and (unknown-type-p type
)
430 (eq (info :type
:kind spec
) :forthcoming-defclass-type
))
431 ;; Knowing that it was DEFCLASSed is enough to emit a CLASSOID-CELL-TYPEP test.
432 ;; Combinators involving this - e.g. (OR A-NEW-CLASS OTHER-CLASS) -
433 ;; are handled correctly, because we don't punt on everything in the expression
434 ;; as soon as any unknown is present.
435 `(classoid-cell-typep ,(find-classoid-cell spec
:create t
) ,object
))
436 ((unknown-type-p type
)
437 `(let ((object ,object
)
438 (cache (load-time-value (cons #'sb-kernel
::cached-typep
',spec
)
440 (truly-the (values t
&optional
)
441 (funcall (truly-the function
(car (truly-the cons cache
)))
446 (let* ((name (second spec
))
447 (expansion (fun-name-inline-expansion name
)))
448 ;; Lambda without lexenv can easily be handled here.
449 ;; This fixes the issue that LEGAL-FUN-NAME-P which is
450 ;; just a renaming of VALID-FUNCTION-NAME-P would not
451 ;; be inlined when testing the FUNCTION-NAME type.
452 `(if ,(if (and (typep expansion
'(cons (eql lambda
)))
453 (not (fun-lexically-notinline-p name
)))
454 `(,expansion
,object
)
455 `(funcall (global-function ,name
) ,object
))
458 (defun source-transform-negation-typep (object type
)
459 (declare (type negation-type type
))
460 (let ((spec (type-specifier (negation-type-type type
))))
461 `(not (typep ,object
',spec
))))
463 ;;; Check the type of a group of equally specialized but of
464 ;;; different length simple arrays once
465 (defun group-vector-type-length-tests (object types
)
468 (loop for type in types
470 (if (and (array-type-p type
)
471 (not (array-type-complexp type
))
472 (typep (array-type-dimensions type
) '(cons integer null
))
473 (or (eq (array-type-element-type type
) *wild-type
*)
474 (neq (array-type-specialized-element-type type
) *wild-type
*)))
477 (array-type-specialized-element-type type
)))
478 (push type
(getf groups
:other
))))
479 (loop for
(el-type types
) on groups by
#'cddr
481 (cond ((eq el-type
:other
))
482 ((> (length types
) 1)
483 (setf any-grouped t
))
486 (getf groups
:other
)))))
488 (let ((other (getf groups
:other
)))
490 ,@(loop for
(el-type types
) on groups by
#'cddr
491 when
(and (neq el-type
:other
)
492 (> (length types
) 1))
493 collect
`(and (typep ,object
494 '(simple-array ,(type-specifier el-type
) (*)))
495 (typep (vector-length
496 (truly-the (simple-array * (*)) ,object
))
497 '(member ,@(loop for type in types
498 collect
(car (array-type-dimensions type
)))))))
501 `((typep ,object
'(or ,@(mapcar #'type-specifier other
))))))))))
503 ;;; Test the length of multiple arrays types once
504 (defun group-vector-length-type-tests (object types
)
507 (loop for type in types
509 (if (and (array-type-p type
)
510 (typep (array-type-dimensions type
) '(cons integer null
)))
511 (push type
(getf groups
(car (array-type-dimensions type
))))
512 (push type
(getf groups
:other
))))
513 (loop for
(length types
) on groups by
#'cddr
515 (cond ((eq length
:other
))
516 ((> (length types
) 1)
517 (setf any-grouped t
))
520 (getf groups
:other
)))))
522 (let ((other (getf groups
:other
)))
524 ,@(loop for
(length types
) on groups by
#'cddr
525 for any-complex
= nil
527 when
(and (neq length
:other
)
528 (> (length types
) 1))
529 collect
`(and (typep ,object
531 ,@(loop for type in types
532 for complex
= (array-type-complexp type
)
535 (when (eq complex
:maybe
)
536 (setf any-simple t
)))
538 (setf any-simple t
)))
542 (make-array-type '(*)
545 (array-type-element-type type
)
546 :specialized-element-type
547 (array-type-specialized-element-type type
))))))
550 `(= (vector-length (truly-the (simple-array * (*)) ,object
))
553 `(= (%array-dimension
(truly-the vector
,object
) 0)
556 `(if (array-header-p (truly-the vector
,object
))
557 (= (%array-dimension
(truly-the vector
,object
) 0)
559 (= (vector-length (truly-the vector
,object
))
563 `((typep ,object
'(or ,@(mapcar #'type-specifier other
))))))))))
565 (defun source-transform-union-numeric-typep (object types
)
566 (cond ((and (= (length types
) 2)
567 ;; Transform (or (double-float * (0d0)) (eql -0d0))
568 (destructuring-bind (a b
) types
569 (multiple-value-bind (member numeric
) (cond ((member-type-p a
)
574 (and (numeric-type-p numeric
)
575 (= (member-type-size member
) 1)
576 (or (setf double
(sb-kernel::member-type-member-p -
0d0 member
))
577 (sb-kernel::member-type-member-p -
0f0 member
))
578 (let ((low (numeric-type-low numeric
))
579 (high (numeric-type-high numeric
))
583 (when (and (eq (numeric-type-class numeric
) 'float
)
584 (eq (numeric-type-complexp numeric
) :real
)
585 (equal high
(if double
589 `(double-float-p ,object
)
590 `(single-float-p ,object
))
592 `(and (float-sign-bit-set-p (truly-the ,type
,object
))
596 (truly-the ,type
,object
)))
597 `(float-sign-bit-set-p (truly-the ,type
,object
))))))))))))
598 ((not (every #'numeric-type-p types
))
600 ((and (= (length types
) 2)
601 ;; (and subtype-of-integer (not (eql x)))
602 ;; don't test a range.
603 ;; (and subtype-of-integer (not (integer x y)))
604 (destructuring-bind (b a
) types
605 (and (integer-type-p a
)
608 (let* ((a-hi (numeric-type-high a
))
609 (a-lo (numeric-type-low a
))
610 (b-hi (numeric-type-high b
))
611 (b-lo (numeric-type-low b
)))
613 (not (eql a-lo a-hi
))
614 (not (eql b-lo b-hi
))
618 (%source-transform-typep object
619 `(integer ,(or a-lo
'*) ,(or b-hi
'*))))
623 `(eql ,object
,(1+ a-hi
)))
626 (%source-transform-typep object
627 `(integer (,a-hi
) (,b-lo
))))))))
633 ((and (= (length types
) 2)
634 ;; (or (integer * fixnum-x) (integer fixnum-y))
635 ;; only check for bignump and not its value.
636 (destructuring-bind (b a
) types
637 (and (integer-type-p a
)
640 (let* ((a-hi (numeric-type-high a
))
641 (a-lo (numeric-type-low a
))
642 (b-hi (numeric-type-high b
))
643 (b-lo (numeric-type-low b
)))
644 (when (and (fixnump a-hi
)
648 `(or (and (fixnump ,object
)
649 (or (>= ,object
,b-lo
)
651 (bignump ,object
))))))
655 ;;; Do source transformation for TYPEP of a known union type. If a
656 ;;; union type contains LIST, then we pull that out and make it into a
657 ;;; single LISTP call.
658 (defun source-transform-union-typep (object type
)
659 (let* ((types (union-type-types type
))
660 (type-cons (specifier-type 'cons
))
661 (type-symbol (specifier-type 'symbol
))
662 (mtype (find-if #'member-type-p types
))
663 (members (when mtype
(member-type-members mtype
))))
666 (memq type-cons types
))
669 '(or ,@(mapcar #'type-specifier
671 (remove mtype types
)))
672 (member ,@(remove nil members
))))))
673 ((and (memq type-cons types
)
674 (memq type-symbol types
))
676 (non-null-symbol-p ,object
)
678 '(or ,@(mapcar #'type-specifier
680 (remove type-symbol types
)))))))
681 ((group-vector-type-length-tests object types
))
682 ((group-vector-length-type-tests object types
))
683 ((source-transform-union-numeric-typep object types
))
685 (multiple-value-bind (widetags more-types
)
686 (sb-kernel::widetags-from-union-type types
)
687 (multiple-value-bind (predicate more-union-types
)
688 (split-union-type-tests type
)
689 (cond ((and predicate
690 (< (length more-union-types
)
691 (length more-types
)))
692 `(or (,predicate
,object
)
693 (typep ,object
'(or ,@(mapcar #'type-specifier more-union-types
)))))
695 `(or (%other-pointer-subtype-p
,object
',widetags
)
696 (typep ,object
'(or ,@(mapcar #'type-specifier more-types
)))))
697 ((and (cdr more-types
)
698 (every #'intersection-type-p more-types
)
699 (let ((common (intersection-type-types (car more-types
))))
700 (loop for type in
(cdr more-types
)
701 for types
= (intersection-type-types type
)
702 for int
= (intersection common types
:test
#'type
=)
707 (typep ,object
'(and ,@(mapcar #'type-specifier common
)))
708 (or ,@(loop for type in more-types
709 for types
= (intersection-type-types type
)
711 `(typep ,object
'(and ,@(mapcar #'type-specifier
712 (set-difference types common
))))))))))))
715 ,@(mapcar (lambda (x)
716 `(typep ,object
',(type-specifier x
)))
719 (defun source-transform-intersection-typep (object type
)
722 ;; Group negated types into a union type which might be better
723 ;; handled by source-transform-union-typep above.
724 (loop for type in
(intersection-type-types type
)
726 (cond ((hairy-type-p type
)
727 ;; These might impose some sort of an order.
730 ((typep type
'negation-type
)
731 (push (negation-type-type type
) negated
))
737 '(and ,@(mapcar #'type-specifier types
)))))
740 '(or ,@(mapcar #'type-specifier negated
))))))
742 `(and ,@(mapcar (lambda (x)
743 `(typep ,object
',(type-specifier x
)))
744 (intersection-type-types type
)))))))
746 ;;; If necessary recurse to check the cons type.
747 (defun source-transform-cons-typep
748 (object type
&aux
(car-type (cons-type-car-type type
))
749 (cdr-type (cons-type-cdr-type type
))
750 (car-test-p (not (type= car-type
*universal-type
*)))
751 (cdr-test-p (not (type= cdr-type
*universal-type
*))))
752 ;; CONSP can be safely weakened to LISTP if either of the CAR
753 ;; or CDR test (or both) can distinguish LIST from CONS
754 ;; by never returning T when given an input of NIL.
755 (labels ((safely-weakened (ctype)
758 (not (member nil
(member-type-members ctype
))))
760 ;; can't weaken if the specifier is (CONS SYMBOL)
761 (not (ctypep nil ctype
)))
762 ;; these are disjoint from NIL
763 ((or cons-type numeric-type array-type character-set-type
)
766 ;; at least one of them must not spuriously return T
767 (some #'safely-weakened
(compound-type-types ctype
)))
769 ;; require that none spuriously return T
770 (every #'safely-weakened
(compound-type-types ctype
)))
772 ;; hack - (CONS KEYWORD) is weakenable
773 ;; because NIL is not a keyword.
774 (equal (hairy-type-specifier ctype
)
775 '(satisfies keywordp
))))))
777 ((and (not car-test-p
) (not cdr-test-p
))
779 ((and (not cdr-test-p
)
780 (member-type-p car-type
)
781 (vop-existsp :translate car-eq-if-listp
)
782 (type-singleton-p car-type
)
783 (typep (first (member-type-members car-type
)) '(and symbol
(not null
))))
784 `(car-eq-if-listp ,object
',(first (member-type-members car-type
))))
788 `((typep (car ,object
) ',(type-specifier car-type
)))))
791 `((typep (cdr ,object
) ',(type-specifier cdr-type
))))))
792 ;; Being paranoid, perform the safely weakenable test first
793 ;; so that the other part doesn't execute on an object that
794 ;; it would not have gotten, were the CONSP test not weakened.
795 (cond ((and car-test-p
(safely-weakened car-type
))
796 `(and (listp ,object
) ,@car-test
,@cdr-test
))
797 ((and cdr-test-p
(safely-weakened cdr-type
))
798 `(and (listp ,object
) ,@cdr-test
,@car-test
))
800 `(and (consp ,object
) ,@car-test
,@cdr-test
))))))))
802 (defun source-transform-character-set-typep (object type
)
803 (let ((pairs (character-set-type-pairs type
)))
804 (or (and (= (length pairs
) 1)
807 #+(and sb-unicode
(or x86-64 arm64
))
808 ((= (cdar pairs
) (1- base-char-code-limit
))
809 `(base-char-p ,object
))
810 ((= (cdar pairs
) (1- char-code-limit
))
811 `(characterp ,object
))))
812 (let ((n-code (gensym "CODE")))
813 `(and (characterp ,object
)
814 (let ((,n-code
(char-code ,object
)))
816 ,@(loop for pair in pairs
818 `(<= ,(car pair
) ,n-code
,(cdr pair
))))))))))
821 (defun source-transform-simd-pack-typep (object type
)
822 (let ((mask (simd-pack-type-tag-mask type
)))
823 (if (= mask sb-kernel
::+simd-pack-wild
+)
824 `(simd-pack-p ,object
)
825 `(and (simd-pack-p ,object
)
826 ,(if (= (logcount mask
) 1)
827 `(eql (%simd-pack-tag
,object
) ,(sb-vm::simd-pack-mask-
>tag mask
))
828 `(logbitp (%simd-pack-tag
,object
) ,mask
))))))
831 (defun source-transform-simd-pack-256-typep (object type
)
832 (let ((mask (simd-pack-256-type-tag-mask type
)))
833 (if (= mask sb-kernel
::+simd-pack-wild
+)
834 `(simd-pack-256-p ,object
)
835 `(and (simd-pack-256-p ,object
)
836 ,(if (= (logcount mask
) 1)
837 `(eql (%simd-pack-256-tag
,object
) ,(sb-vm::simd-pack-mask-
>tag mask
))
838 `(logbitp (%simd-pack-256-tag
,object
) ,mask
))))))
840 ;;; Return the predicate and type from the most specific entry in
841 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
842 (defun find-supertype-predicate (type)
843 (declare (type ctype type
))
846 (dolist (x *backend-type-predicates
*)
847 (let ((stype (car x
)))
848 (when (and (csubtypep type stype
)
850 (csubtypep stype res-type
)))
851 (setq res-type stype
)
852 (setq res
(cdr x
)))))
853 (values res res-type
)))
855 ;;; Return forms to test that OBJ has the rank and dimensions
856 ;;; specified by TYPE, where STYPE is the type we have checked against
857 ;;; (which is the same but for dimensions and element type).
859 ;;; Secondary return value is true if passing the generated tests implies that
860 ;;; the array has a header.
861 (defun test-array-dimensions (original-obj type stype
862 simple-array-header-p
)
863 (declare (type array-type type stype
))
864 (let ((obj `(truly-the ,(type-specifier stype
) ,original-obj
))
865 (dims (array-type-dimensions type
))
866 (header-test (if simple-array-header-p
867 `(simple-array-header-p ,original-obj
)
868 `(array-header-p ,original-obj
))))
869 (unless (or (eq dims
'*)
870 (equal dims
(array-type-dimensions stype
)))
872 (values `(,@(if (and simple-array-header-p
873 (vop-existsp :translate simple-array-header-of-rank-p
)
874 (eq (array-type-dimensions stype
) '*))
875 `((simple-array-header-of-rank-p ,original-obj
,(length dims
)))
877 ,@(when (eq (array-type-dimensions stype
) '*)
878 (if (vop-existsp :translate %array-rank
=)
879 `((%array-rank
= ,obj
,(length dims
)))
880 `((= (%array-rank
,obj
) ,(length dims
)))))))
881 ,@(loop for d in dims
884 collect
`(= (%array-dimension
,obj
,i
) ,d
)))
887 (values `(,header-test
888 (= (%array-rank
,obj
) 0))
890 ((not (array-type-complexp type
))
891 (if (csubtypep stype
(specifier-type 'vector
))
892 (values (unless (eq '* (car dims
))
893 `((= (vector-length ,obj
) ,@dims
)))
895 (values (if (eq '* (car dims
))
896 `((not ,header-test
))
898 (= (vector-length ,obj
) ,@dims
)))
901 (values (unless (eq '* (car dims
))
903 (= (%array-dimension
,obj
0) ,@dims
)
904 (= (vector-length ,obj
) ,@dims
))))
908 ;;; Return forms to test that OBJ has the element-type specified by type
909 ;;; specified by TYPE, where STYPE is the type we have checked against (which
910 ;;; is the same but for dimensions and element type). If HEADERP is true, OBJ
911 ;;; is guaranteed to be an array-header.
912 (defun test-array-element-type (obj type stype headerp pred length
)
913 (declare (type array-type type stype
))
914 (let ((eltype (array-type-specialized-element-type type
)))
915 (unless (or (type= eltype
(array-type-specialized-element-type stype
))
916 (eq eltype
*wild-type
*))
917 (let* ((typecode (sb-vm:saetp-typecode
(find-saetp-by-ctype eltype
))))
918 (cond ((and headerp
(not (array-type-complexp stype
)))
919 (let ((obj `(truly-the ,(type-specifier stype
) ,obj
)))
920 ;; If we know OBJ is an array header, and that the array is
921 ;; simple, we also know there is exactly one indirection to
924 (eq (%other-pointer-widetag
(%array-data
,obj
)) ,typecode
)
926 (widetag= (%array-data
,obj
) ,typecode
))))
927 ((not (array-type-complexp stype
))
929 `((and (%other-pointer-p
,obj
)
930 (let ((widetag (%other-pointer-widetag
,obj
)))
931 (or (eq widetag
,typecode
)
932 (and (eq widetag sb-vm
:simple-array-widetag
)
933 (eq (%other-pointer-widetag
(%array-data
,obj
)) ,typecode
))))))
934 ;; skip checking for array.
939 (values `((and (%other-pointer-p
,obj
)
942 (let ((widetag (%other-pointer-widetag data
)))
943 (if (eq widetag
,typecode
)
945 (if (or (eq widetag sb-vm
:simple-array-widetag
)
946 (>= widetag sb-vm
:complex-base-string-widetag
))
947 (setf data
(%array-data data
))
952 (values `((and (%other-pointer-p
,obj
)
953 (let ((widetag (%other-pointer-widetag
,obj
)))
954 (if (eq widetag
,typecode
)
955 (= (vector-length (truly-the (simple-array * (*)) ,obj
)) ,length
)
956 (and (= widetag sb-vm
:complex-vector-widetag
)
957 (= (%array-dimension
(truly-the (and (array * (*))
958 (not simple-array
)) ,obj
) 0)
962 (setf data
(%array-data data
))
963 (let ((widetag (%other-pointer-widetag data
)))
964 (if (eq widetag
,typecode
)
966 (unless (or (eq widetag sb-vm
:simple-array-widetag
)
967 (>= widetag sb-vm
:complex-vector-widetag
))
968 (return nil
)))))))))))
971 (values `((and (%other-pointer-p
,obj
)
972 (let ((widetag (%other-pointer-widetag
,obj
)))
973 (if (eq widetag
,typecode
)
975 (and (= widetag sb-vm
:complex-vector-widetag
)
978 (setf data
(%array-data data
))
979 (let ((widetag (%other-pointer-widetag data
)))
980 (if (eq widetag
,typecode
)
983 (eq widetag sb-vm
:simple-array-widetag
)
984 (>= widetag sb-vm
:complex-vector-widetag
))
985 (return nil
)))))))))))
988 ;;; If we can find a type predicate that tests for the type without
989 ;;; dimensions, then use that predicate and test for dimensions.
990 ;;; Otherwise, just do %TYPEP.
991 (defun source-transform-array-typep (object type
)
992 ;; Intercept (SIMPLE-ARRAY * (*)) because otherwise it tests
993 ;; (AND SIMPLE-ARRAY (NOT ARRAY-HEADER)) to weed out rank 0 and >1.
994 ;; By design the simple arrays of of rank 1 occupy a contiguous
995 ;; range of widetags, and unlike the arbitrary-widetags code for unions,
996 ;; this nonstandard predicate can be generically defined for all backends.
997 (let ((dims (array-type-dimensions type
))
998 (et (array-type-element-type type
)))
999 (if (and (not (array-type-complexp type
))
1002 `(simple-rank-1-array-*-p
,object
)
1003 (multiple-value-bind (pred stype
) (find-supertype-predicate type
)
1004 (if (and (array-type-p stype
)
1005 ;; (If the element type hasn't been defined yet, it's
1006 ;; not safe to assume here that it will eventually
1007 ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
1008 (not (unknown-type-p (array-type-element-type type
)))
1009 (or (eq (array-type-complexp stype
) (array-type-complexp type
))
1010 (and (eql (array-type-complexp stype
) :maybe
)
1011 (eql (array-type-complexp type
) t
))))
1012 (let ((complex-tag (and
1013 (eql (array-type-complexp type
) t
)
1015 (and (neq et
*wild-type
*)
1016 (sb-vm:saetp-complex-typecode
1017 (find-saetp-by-ctype (array-type-element-type type
))))))
1018 (simple-array-header-p
1019 (and (null (array-type-complexp stype
))
1022 (complexp (and (eql (array-type-complexp stype
) :maybe
)
1023 (eql (array-type-complexp type
) t
))))
1025 `(and (%other-pointer-p
,object
)
1026 (eq (%other-pointer-widetag
,object
) ,complex-tag
)
1027 ,@(unless (eq (car dims
) '*)
1028 `((= (%array-dimension
,object
0) ,(car dims
)))))
1029 (multiple-value-bind (dim-tests headerp length
)
1030 (test-array-dimensions object type stype
1031 simple-array-header-p
)
1032 (multiple-value-bind (type-test no-check-for-array length-checked
)
1033 (test-array-element-type object type stype headerp pred length
)
1034 (if no-check-for-array
1036 ,@(unless length-checked
1039 ,@(cond ((and (eql pred
'vectorp
)
1041 `((%other-pointer-subtype-p
,object
1042 ',(list sb-vm
:complex-base-string-widetag
1043 #+sb-unicode sb-vm
:complex-character-string-widetag
1044 sb-vm
:complex-bit-vector-widetag
1045 sb-vm
:complex-vector-widetag
))))
1046 ((and (eql pred
'arrayp
)
1048 `((%other-pointer-subtype-p
,object
1049 ',(list sb-vm
:complex-base-string-widetag
1050 #+sb-unicode sb-vm
:complex-character-string-widetag
1051 sb-vm
:complex-bit-vector-widetag
1052 sb-vm
:complex-vector-widetag
1053 sb-vm
:complex-array-widetag
))))
1055 `(,@(unless (or (and headerp
(eql pred
'arrayp
))
1056 simple-array-header-p
)
1057 ;; ARRAY-HEADER-P from DIM-TESTS will test for that
1060 `((typep ,object
'(not simple-array
)))))))
1063 `(%typep
,object
',(type-specifier type
)))))))
1065 ;;; Transform a type test against some instance type. The type test is
1066 ;;; flushed if the result is known at compile time. If not properly
1067 ;;; named, error. If sealed and has no subclasses, just test for
1068 ;;; layout-EQ. If a structure then test for layout-EQ and then a
1069 ;;; general test based on layout-inherits. Otherwise, look up the indirect
1070 ;;; class-cell and call CLASS-CELL-TYPEP at runtime.
1071 (deftransform %instance-typep
((object spec
) * * :node node
)
1072 (aver (constant-lvar-p spec
))
1073 (let* ((spec (lvar-value spec
))
1074 (class (specifier-type spec
))
1075 (name (classoid-name class
))
1076 (otype (lvar-type object
)))
1078 ;; Flush tests whose result is known at compile time.
1079 ((not (types-equal-or-intersect otype class
))
1081 ((csubtypep otype class
)
1083 ;; If not properly named, error.
1084 ((not (and name
(eq (find-classoid name
) class
)))
1085 (compiler-error "can't compile TYPEP of anonymous or undefined ~
1089 ;; Delay the type transform to give type propagation a chance.
1090 (delay-ir1-transform node
:constraint
)
1091 (transform-instance-typep class
)))))
1093 ;;; Notice that there are some instance types for which it is almost impossible
1094 ;;; to create. One such is SEQUENCE, viz: (make-instance 'sequence) =>
1095 ;;; "Cannot allocate an instance of #<BUILT-IN-CLASS SEQUENCE>."
1096 ;;; We should not need to check for that, just the 'inherits' vector.
1097 ;;; However, bootstrap code does a sleazy thing, making an instance of
1098 ;;; the abstract base type which is impossible for user code to do.
1100 ;;; Preferably the prototype instance for SEQUENCE would be one that could
1101 ;;; exist, so it would be a STANDARD-OBJECT and SEQUENCE. But it's not.
1102 ;;; Hence we would have to check for a layout that no code using the documented
1103 ;;; sequence API would ever see, just to get the boundary case right.
1104 ;;; The for STREAM and FILE-STREAM.
1105 ;;; But there was precedent for builtin class prototype instances
1106 ;;; failing their type predicate, i.e. (TYPEP (CLASS-PROTOTYPE X) X) => NIL
1107 ;;; which was fixed in git rev d60a6d30.
1108 ;;; Also for what it's worth, some builtins use a prototype object that is strictly
1109 ;;; deeper than layout of the named class because it is indeed the case that no
1110 ;;; object's layout can ever be EQ to that of the ancestor.
1111 ;;; e.g. a fixnum as representative of class REAL.
1112 ;;; So in actual practice, you can't make something that is a pure STREAM, etc.
1115 ;;; 1. There is an additional tweak that can potentially return false in one fewer
1116 ;;; conditional branch if the layout being tested has depthoid 8 (or 9 if #+64-bit).
1117 ;;; In that scenario, if the ID word of the candidate structure's layout does not
1118 ;;; exist, then it's the 0th bitmap word and safe to read always. Therefore
1119 ;;; STRUCTURE-IS-A and depthoid can be tested in that order. If there is no ID match,
1120 ;;; there's no depthoid test. If there is an ID match, it's the same as before.
1121 ;;; 2. Since all backends implement STRUCTURE-IS-A, is there any reason that the
1122 ;;; depthoid test is in the transform's expansion and not baked into that vop?
1123 ;;; Putting it in the vop could be better for some backends,
1124 ;;; and would eliminate the ad-hoc LAYOUT-DEPTHOID-GE vop.
1126 #-
(or x86 x86-64
) ; vop-translated for these 2
1127 (defmacro layout-depthoid-ge
(layout depthoid
)
1128 `(>= (layout-depthoid ,layout
) ,depthoid
))
1129 (symbol-macrolet ((get-hash 'layout-clos-hash
)
1130 (get-flags 'layout-flags
))
1131 (defun transform-instance-typep (classoid)
1133 ((name (classoid-name classoid
))
1134 (layout (let ((res (info :type
:compiler-layout name
)))
1135 (when (and res
(not (layout-invalid res
))) res
)))
1136 ((lowtag lowtag-test slot-reader
)
1137 (cond ((csubtypep classoid
(specifier-type 'funcallable-instance
))
1138 (values sb-vm
:fun-pointer-lowtag
1139 '(function-with-layout-p object
) '(%fun-layout object
)))
1140 ((csubtypep classoid
(specifier-type 'instance
))
1141 (values sb-vm
:instance-pointer-lowtag
1142 '(%instancep object
) '(%instance-layout object
)))))
1143 (depthoid (if layout
(layout-depthoid layout
) -
1))
1144 (type (make-symbol "TYPE")))
1145 (declare (ignorable layout
))
1147 ;; Easiest case first: single bit test.
1148 (cond ((member name
'(condition pathname structure-object
))
1149 (let ((flag (case name
1150 (condition +condition-layout-flag
+)
1151 (pathname +pathname-layout-flag
+)
1152 (t +structure-layout-flag
+))))
1153 (if (vop-existsp :translate structure-typep
)
1154 `(structure-typep object
,flag
)
1155 `(and (%instancep object
)
1156 (logtest (,get-flags
(%instance-layout object
)) ,flag
)))))
1158 ;; Next easiest: Sealed and no subtypes. Typically for DEFSTRUCT only.
1159 ;; Even if you don't seal a DEFCLASS, we're allowed to assume that things
1160 ;; won't change, as per CLHS 3.2.2.3 on Semantic Constraints:
1161 ;; "Classes defined by defclass in the compilation environment must be defined
1162 ;; at run time to have the same superclasses and same metaclass."
1163 ;; I think that means we should know the lowtag always. Nonetheless, this isn't
1164 ;; an important scenario, and only if you _do_ seal a class could this case be
1165 ;; reached; users rarely seal their classes since the standard doesn't say how.
1167 (eq (classoid-state classoid
) :sealed
)
1168 (not (classoid-subclasses classoid
)))
1169 (cond ((and (eq lowtag sb-vm
:instance-pointer-lowtag
)
1170 (vop-existsp :translate structure-typep
))
1171 `(structure-typep object
,layout
))
1174 ,(if (vop-existsp :translate layout-eq
)
1175 `(layout-eq object
,layout
,lowtag
)
1176 `(eq ,slot-reader
,layout
))))
1179 ;; (if-vop-existsp (:translate %instanceoid-layout)
1180 ;; (%instanceoid-layout object)
1181 ;; ;; Slightly quicker than LAYOUT-OF. See also %PCL-INSTANCE-P
1182 ;; (cond ((%instancep object) (%instance-layout object))
1183 ;; ((funcallable-instance-p object) (%fun-layout object))
1184 ;; (t ,(find-layout 't)))))
1185 (bug "Unexpected metatype for ~S" layout
))))
1187 ;; All other structure types
1188 ((and (typep classoid
'structure-classoid
) layout
)
1189 ;; structure type tests; hierarchical layout depths
1190 (aver (eql lowtag sb-vm
:instance-pointer-lowtag
))
1191 ;; we used to check for invalid layouts here, but in fact that's both unnecessary and
1192 ;; wrong; it's unnecessary because structure classes can't be redefined, and it's wrong
1193 ;; because it is quite legitimate to pass an object with an invalid layout
1194 ;; to a structure type test.
1195 (if (vop-existsp :translate structure-typep
)
1196 ;; A single VOP is easier to optimize later
1197 `(structure-typep object
,layout
)
1198 `(and (%instancep object
)
1199 ,(if (<= depthoid sb-kernel
::layout-id-vector-fixed-capacity
)
1200 `(%structure-is-a
(%instance-layout object
) ,layout
)
1201 `(let ((,type
(%instance-layout object
)))
1202 (and (layout-depthoid-ge ,type
,depthoid
)
1203 (%structure-is-a
,type
,layout
)))))))
1206 ;; fixed-depth ancestors of non-structure types:
1207 ;; STREAM, FILE-STREAM, STRING-STREAM, and SEQUENCE.
1208 #+sb-xc-host
(when (typep classoid
'static-classoid
)
1209 ;; should have use :SEALED code above
1210 (bug "Non-frozen static classoids ~S" name
))
1211 (let ((guts `((when (zerop (,get-hash
,type
))
1212 (setq ,type
(update-object-layout object
)))
1215 `(logtest (,get-flags
,type
) ,+stream-layout-flag
+))
1217 `(logtest (,get-flags
,type
) ,+file-stream-layout-flag
+))
1219 `(logtest (,get-flags
,type
) ,+string-stream-layout-flag
+))
1220 ;; Testing the type EXTENDED-SEQUENCE tests for #<LAYOUT of SEQUENCE>.
1221 ;; It can only arise from a direct invocation of TRANSFORM-INSTANCE-TYPEP,
1222 ;; because the lisp type is not a classoid. It's done this way to define
1223 ;; the logic once only, instead of both here and src/code/pred.lisp.
1225 `(logtest (,get-flags
,type
) ,+sequence-layout-flag
+))))))
1227 `(and ,lowtag-test
(let ((,type
,slot-reader
)) ,@guts
))
1228 (if-vop-existsp (:translate %instanceoid-layout
)
1229 `(let ((,type
(%instanceoid-layout object
))) ,@guts
)
1231 (let ((,type
(cond ((%instancep object
) (%instance-layout object
))
1232 ((funcallable-instance-p object
) (%fun-layout object
))
1233 (t (return-from typep nil
)))))
1237 `(classoid-cell-typep ',(find-classoid-cell name
:create t
)
1240 ;;; If the specifier argument is a quoted constant, then we consider
1241 ;;; converting into a simple predicate or other stuff. If the type is
1242 ;;; constant, but we can't transform the call, then we convert to
1243 ;;; %TYPEP. We only pass when the type is non-constant. This allows us
1244 ;;; to recognize between calls that might later be transformed
1245 ;;; successfully when a constant type is discovered. We don't give an
1246 ;;; efficiency note when we pass, since the IR1 transform will give
1247 ;;; one if necessary and appropriate.
1249 ;;; If the type is TYPE= to a type that has a predicate, then expand
1250 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
1251 ;;; These transformations can increase space, but it is hard to tell
1252 ;;; when, so we ignore policy and always do them.
1253 (defun %source-transform-typep
(object type
)
1254 (let ((ctype (careful-specifier-type type
)))
1257 ;; It's purely a waste of compiler resources to wait for IR1 to
1258 ;; see these 2 edge cases that can be decided right now.
1259 (cond ((eq ctype
*universal-type
*) t
)
1260 ((eq ctype
*empty-type
*) nil
))
1261 (and (not (intersection-type-p ctype
))
1262 (multiple-value-bind (constantp value
) (type-singleton-p ctype
)
1264 `(eql ,object
',value
))))
1267 (let ((pred (backend-type-predicate ctype
)))
1268 (when pred
`(,pred
,object
)))
1269 (let* ((negated (type-negation ctype
))
1270 (pred (backend-type-predicate negated
)))
1272 `(not (,pred
,object
)))
1273 ((numeric-type-p negated
)
1274 `(not ,(%source-transform-typep object
(type-specifier negated
)))))))
1276 (sb-kernel::cross-type-warning
1280 (source-transform-hairy-typep object ctype
))
1282 (source-transform-negation-typep object ctype
))
1284 (source-transform-union-typep object ctype
))
1286 (source-transform-intersection-typep object ctype
))
1288 `(if (member ,object
',(member-type-members ctype
)) t
))
1290 (compiler-warn "illegal type specifier for TYPEP: ~S" type
)
1291 (return-from %source-transform-typep
(values nil t
)))
1293 (source-transform-numeric-typep object ctype
))
1295 `(%instance-typep
,object
',type
))
1297 (source-transform-array-typep object ctype
))
1299 (source-transform-cons-typep object ctype
))
1301 (source-transform-character-set-typep object ctype
))
1304 (source-transform-simd-pack-typep object ctype
))
1307 (source-transform-simd-pack-256-typep object ctype
))
1309 `(%typep
,object
',type
))
1312 (defun source-transform-typep (object type
)
1313 (when (typep type
'type-specifier
)
1314 (check-deprecated-type type
))
1315 (let ((name (gensym "OBJECT")))
1316 (multiple-value-bind (transform error
)
1317 (%source-transform-typep name type
)
1320 (values `(let ((,name
,object
))
1321 (%typep-wrapper
,transform
,name
',type
)))))))
1323 ;;; These things will be removed by the tree shaker, so no #+ needed.
1324 (defvar *interesting-types
* nil
)
1325 (defun involves-alien-p (ctype)
1326 (sb-kernel::map-type
1328 (when (alien-type-type-p type
) (return-from involves-alien-p t
)))
1330 (defun dump/restore-interesting-types
(op)
1331 (declare (ignorable op
))
1332 #+collect-typep-regression-dataset
1335 (when *interesting-types
*
1336 (let ((list (sort (loop for k being each hash-key of
*interesting-types
* collect k
)
1337 #'string
< :key
#'write-to-string
)))
1338 (with-open-file (f "interesting-types.lisp-expr" :direction
:output
1339 :if-exists
:supersede
:if-does-not-exist
:create
)
1340 (let ((*package
* #+sb-xc-host
(find-package "XC-STRICT-CL")
1341 #-sb-xc-host
#.
(find-package "SB-KERNEL"))
1342 (*print-pretty
* nil
)
1343 (*print-length
* nil
)
1345 (*print-readably
* t
))
1347 (write (uncross item
) :stream f
)
1350 (unless (hash-table-p *interesting-types
*)
1351 (setq *interesting-types
* (make-hash-table :test
'equal
:synchronized t
)))
1352 (with-open-file (f "interesting-types.lisp-expr" :if-does-not-exist nil
)
1354 (let ((*package
* (find-package "SB-KERNEL")))
1355 (loop (let ((expr (read f nil f
)))
1356 (when (eq expr f
) (return))
1357 (format t
"Read ~a~%" expr
)
1358 (setf (gethash expr
*interesting-types
*) t
))))))
1359 *interesting-types
*)))
1361 (define-source-transform typep
(object spec
&optional env
)
1362 ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
1363 ;; since that would overlook other kinds of constants. But it turns
1364 ;; out that the DEFTRANSFORM for TYPEP detects any constant
1365 ;; lvar, transforms it into a quoted form, and gives this
1366 ;; source transform another chance, so it all works out OK, in a
1367 ;; weird roundabout way. -- WHN 2001-03-18
1369 (typep spec
'(cons (eql quote
) (cons t null
))))
1370 (with-current-source-form (spec)
1371 ;; Decline to do the source transform when seeing an unknown
1372 ;; type immediately while block converting, since it may be
1373 ;; defined later. By waiting for the deftransform to fire
1374 ;; during block compilation, we give ourselves a better chance
1375 ;; at open-coding the type test.
1376 (let ((type (cadr spec
)))
1378 #+collect-typep-regression-dataset
1379 (let ((parse (specifier-type type
)))
1380 ;; alien types aren't externalizable as trees of symbols,
1381 ;; and some classoid types aren't defined at the start of warm build,
1382 ;; making it impossible to re-parse a dump produced late in the build.
1383 ;; Luckily there are no cases involving compund types and classoids.
1384 (unless (or (involves-alien-p parse
)
1385 (or (classoid-p parse
)
1386 (and (cons-type-p parse
)
1387 (classoid-p (cons-type-car-type parse
)))))
1388 (let ((table *interesting-types
*))
1389 (unless (hash-table-p table
)
1390 (setq table
(dump/restore-interesting-types
'read
)))
1391 (setf (gethash type table
) t
))))
1393 (if (and (block-compile *compilation
*)
1394 (contains-unknown-type-p (careful-specifier-type type
)))
1396 (source-transform-typep object type
))))
1401 ;;; Constant-folding.
1404 (defoptimizer (coerce optimizer
) ((x type
) node
)
1405 (when (and (constant-lvar-p x
) (constant-lvar-p type
))
1406 (let ((value (lvar-value x
)))
1407 (when (or (numberp value
) (characterp value
))
1408 (constant-fold-call node
)
1411 ;;; Drops dimension information from vector types.
1412 ;;; Returns four values
1414 ;;; * upgraded-element ctype or requsted element
1415 ;;; * T if the upgraded-element is upgraded, i.e. it
1416 ;;; does not contain any unknown types.
1417 ;;; * T if there were any dimensions
1418 (defun simplify-vector-type (type)
1419 (labels ((process-compound-type (types)
1424 (dolist (type types
)
1425 (unless (or (hairy-type-p type
)
1426 (sb-kernel::negation-type-p type
))
1427 (multiple-value-bind (type et upgraded dimensions
) (simplify type
)
1428 (push type array-types
)
1429 (push et element-types
)
1431 (setf dimensions-removed t
))
1433 (setf upgraded nil
)))))
1434 (values (apply #'type-union array-types
)
1435 (if (member *wild-type
* element-types
)
1437 (apply #'type-union element-types
))
1439 dimensions-removed
)))
1441 (cond ((and (array-type-p type
)
1442 (singleton-p (array-type-dimensions type
)))
1444 (et (array-type-specialized-element-type type
))
1445 (et (cond ((neq et
*wild-type
*)
1447 ((eq (array-type-element-type type
) *wild-type
*)
1451 (array-type-element-type type
)))))
1452 (values (specifier-type
1453 (list (if (array-type-complexp type
)
1460 (not (eq (car (array-type-dimensions type
)) '*)))))
1461 ((union-type-p type
)
1462 (process-compound-type (union-type-types type
)))
1463 ((intersection-type-p type
)
1464 (process-compound-type (intersection-type-types type
)))
1465 ((member-type-p type
)
1466 (process-compound-type
1467 (mapcar #'ctype-of
(member-type-members type
))))
1469 (error "~a is not a subtype of VECTOR." type
)))))
1472 (defun strip-array-dimensions-and-complexity (type &optional simple
)
1473 (labels ((process-compound-type (types)
1475 (dolist (type types
)
1476 (unless (or (hairy-type-p type
)
1477 (sb-kernel::negation-type-p type
))
1478 (push (strip type
) array-types
)))
1479 (apply #'type-union array-types
)))
1481 (cond ((array-type-p type
)
1482 (let ((dim (array-type-dimensions type
)))
1486 (make-list (length dim
)
1487 :initial-element
'*))
1488 :complexp
(if simple
1491 :element-type
(array-type-element-type type
)
1492 :specialized-element-type
(array-type-specialized-element-type type
))))
1493 ((union-type-p type
)
1494 (process-compound-type (union-type-types type
)))
1495 ((intersection-type-p type
)
1496 (process-compound-type (intersection-type-types type
)))
1497 ((member-type-p type
)
1498 (process-compound-type
1499 (mapcar #'ctype-of
(member-type-members type
))))
1501 (error "~a is not a subtype of ARRAY." type
)))))
1504 (defun check-coerce (value-type to-type type-specifier node
)
1506 (compiler-warn "Cannot coerce ~s to ~s"
1507 (type-specifier value-type
)
1508 (type-specifier to-type
))
1509 (setf (combination-kind node
) :error
)
1510 (give-up-ir1-transform)))
1511 (cond ((eq to-type
*empty-type
*)
1513 ((types-equal-or-intersect value-type to-type
))
1514 ((csubtypep to-type
(specifier-type 'sequence
))
1515 (unless (csubtypep to-type
(specifier-type 'sequence
))
1517 ((eql type-specifier
'character
)
1518 (unless (types-equal-or-intersect value-type
1519 (specifier-type 'string
))
1521 ((csubtypep to-type
(specifier-type 'complex
))
1522 (unless (types-equal-or-intersect value-type
1523 (specifier-type 'number
))
1526 ((csubtypep to-type
(specifier-type 'float
))
1527 (unless (types-equal-or-intersect value-type
1528 (specifier-type 'real
))
1530 ((eq type-specifier
'function
)
1531 (unless (types-equal-or-intersect value-type
1532 (specifier-type '(or symbol cons
)))
1537 (deftransform coerce
((x type
) * * :node node
)
1538 (unless (constant-lvar-p type
)
1539 (give-up-ir1-transform))
1540 (let* ((tval (lvar-value type
))
1541 (tspec (ir1-transform-specifier-type tval
))
1542 (value-type (lvar-type x
)))
1543 (check-coerce value-type tspec tval node
)
1544 ;; Note: The THE forms we use to wrap the results make sure that
1545 ;; specifiers like (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
1547 ((csubtypep value-type tspec
)
1549 ((csubtypep tspec
(specifier-type 'double-float
))
1550 `(the ,tval
(%double-float x
)))
1551 ((csubtypep tspec
(specifier-type 'single-float
))
1552 `(the ,tval
(%single-float x
)))
1553 ;; FIXME: #+long-float (t ,(error "LONG-FLOAT case needed"))
1554 ((csubtypep tspec
(specifier-type 'float
))
1555 (if (types-equal-or-intersect value-type
(specifier-type 'float
))
1556 `(the ,tval
(if (floatp x
)
1558 (let ((r (the* (real :silent-conflict t
) x
)))
1559 (declare (muffle-conditions code-deletion-note
))
1560 (sb-kernel:%single-float r
))))
1561 `(the ,tval
(%single-float x
))))
1562 ((csubtypep tspec
(specifier-type 'complex
))
1563 (multiple-value-bind (part-type result-type
)
1564 (cond ((and (numeric-type-p tspec
)
1565 (numeric-type-format tspec
))) ; specific FLOAT type
1566 ((csubtypep tspec
(specifier-type '(complex float
)))
1567 ;; unspecific FLOAT type
1569 ((csubtypep tspec
(specifier-type '(complex rational
)))
1570 (values 'rational
`(or ,tval rational
)))
1572 (values t
`(or ,tval rational
))))
1573 (let ((result-type (or result-type tval
)))
1575 ((not (typep x
'complex
))
1576 (the ,result-type
(complex (coerce x
',part-type
))))
1579 (t ; X is COMPLEX, but not of the requested type
1580 ,(if (eq part-type
'rational
)
1581 ;; Can't coerce non-rational to a rational and
1582 ;; CHECK-COERCE will warn, so just full call
1583 ;; COERCE and let it signal an error.
1584 `(locally (declare (notinline coerce
))
1587 (complex (coerce (realpart x
) ',part-type
)
1588 (coerce (imagpart x
) ',part-type
)))))))))
1589 ((eq tval
'character
)
1591 ;; Handle specialized element types for 1D arrays.
1592 ((multiple-value-bind (result already-type-p dimension specialization
)
1593 (cond ((and (array-type-p tspec
)
1594 (neq (array-type-complexp tspec
) t
) ; :MAYBE and NIL are good
1595 (not (contains-unknown-type-p (array-type-element-type tspec
)))
1596 ;; just for requesting (array nil (*)), you lose
1597 (neq (array-type-specialized-element-type tspec
) *empty-type
*)
1598 (consp (array-type-dimensions tspec
)))
1600 (source-transform-array-typep 'x tspec
)
1601 (car (array-type-dimensions tspec
))
1602 (let ((et (array-type-specialized-element-type tspec
)))
1603 (unless (or (eq et
*universal-type
*) ; don't need
1604 ;; * is illegal as :element-type; in this context
1605 ;; it means to produce a SIMPLE-VECTOR
1606 (eq et
*wild-type
*))
1607 `(:element-type
',(type-specifier et
))))))
1608 ;; Check for string types. This loses on (STRING 1) and such.
1610 ((type= tspec
(specifier-type 'simple-string
))
1611 (values 'simple-string
'(simple-string-p x
) '* '(:element-type
'character
)))
1613 ((type= tspec
(specifier-type 'string
))
1614 (values 'string
'(stringp x
) '* '(:element-type
'character
))))
1616 ;; If the dimension is in the type, we check the input length if safety > 0,
1617 ;; though technically CLHS would allow not checking in safety < 3.
1618 ;; And if mismatch occurs in unsafe code, the results accords with the
1619 ;; specifier, NOT the dimension of the input. This is a rational choice
1620 ;; because one could not argue that incorrect code should have taken the
1621 ;; bad input's length when COERCE was asked for an exact type of output.
1625 ,(cond ((eq dimension
'*)
1627 ;; Passing :INITIAL-CONTENTS avoids allocating ubsan shadow bits,
1628 ;; but redundantly checks the length of the input in MAKE-ARRAY's
1629 ;; transform because we don't or can't infer that LENGTH gives the
1630 ;; same answer each time it is called on X. There may be a way to
1631 ;; extract more efficiency - at least eliminate the unreachable
1632 ;; error-signaling code on mismatch - but I don't care to try.
1633 `(make-array (length x
) ,@specialization
:initial-contents x
)
1634 #-ubsan
; better: do not generate a redundant LENGTH check
1635 `(replace (make-array (length x
) ,@specialization
) x
))
1636 ((policy node
(= safety
0)) ; Disregard the input length
1637 `(replace (make-array ,dimension
,@specialization
) x
))
1639 `(make-array ,dimension
,@specialization
:initial-contents x
))))))))
1640 ((type= tspec
(specifier-type 'list
))
1641 `(coerce-to-list x
))
1642 ((csubtypep tspec
(specifier-type 'extended-sequence
))
1643 (let ((class (and (symbolp tval
) (find-class tval nil
))))
1645 (give-up-ir1-transform)
1646 `(coerce-to-extended-sequence x
(load-time-value (find-class ',tval
) t
)))))
1647 ((type= tspec
(specifier-type 'function
))
1648 (if (csubtypep (lvar-type x
) (specifier-type 'symbol
))
1649 `(coerce-symbol-to-fun x
)
1650 ;; if X can later be derived as FUNCTION then we don't want
1651 ;; to call COERCE-TO-FUN, because there's no smartness
1652 ;; that can undo that and see that it's really (IDENTITY X).
1653 (progn (delay-ir1-transform node
:constraint
)
1654 `(coerce-to-fun x
))))
1655 ((multiple-value-bind (p really
)
1657 (specifier-type '(or sequence character complex float function
)))
1660 `(the* (,tspec
:context coerce-context
) x
))
1662 (give-up-ir1-transform
1663 "~@<open coding coercion to ~S not implemented.~:@>"
1666 (deftransform #+64-bit unsigned-byte-64-p
#-
64-bit unsigned-byte-32-p
1667 ((value) (sb-vm:signed-word
) * :important nil
)
1670 (when-vop-existsp (:translate unsigned-byte-x-p
)
1671 (deftransform unsigned-byte-x-p
1672 ((value x
) (t t
) * :important nil
:node node
)
1673 (ir1-transform-type-predicate value
(specifier-type `(unsigned-byte ,(lvar-value x
))) node
))
1675 (deftransform unsigned-byte-x-p
1676 ((value x
) ((integer * #.most-positive-word
) t
) * :important nil
)
1677 `(#+64-bit unsigned-byte-64-p
#-
64-bit unsigned-byte-32-p x
)))
1679 (deftransform %other-pointer-p
((object))
1680 (let ((type (lvar-type object
)))
1681 (cond ((not (types-equal-or-intersect type
(specifier-type 'other-pointer
)))
1683 ((or (csubtypep type
(specifier-type 'other-pointer
))
1684 ;; It doesn't negate to this type, so check both
1685 (csubtypep type
(specifier-type '(not (or fixnum
#+64-bit single-float
1686 list function instance character
)))))
1688 ((give-up-ir1-transform)))))
1690 ;;; BIGNUMP is simpler than INTEGERP, so if we can rule out FIXNUM then ...
1691 (deftransform integerp
((x) ((not fixnum
)) * :important nil
) '(bignump x
))
1693 (deftransform structure-typep
((object type
) (t t
) * :node node
)
1694 (if (types-equal-or-intersect (lvar-type object
) (specifier-type 'instance
))
1695 (give-up-ir1-transform)
1698 (deftransform structure-typep
((object type
) (t (constant-arg t
)))
1699 (let* ((layout (lvar-value type
))
1701 (#.
+condition-layout-flag
+ (specifier-type 'condition
))
1702 (#.
+pathname-layout-flag
+ (specifier-type 'pathname
))
1703 (#.
+structure-layout-flag
+ (specifier-type 'structure-object
))
1705 (layout-classoid layout
))))
1706 (diff (type-difference (lvar-type object
) type
))
1707 (pred (backend-type-predicate diff
)))
1708 (cond ((not (types-equal-or-intersect (lvar-type object
) type
))
1710 ((csubtypep (lvar-type object
) type
)
1713 `(not (,pred object
)))
1715 (give-up-ir1-transform)))))
1717 (deftransform classoid-cell-typep
((cell object
) ((constant-arg t
) t
))
1718 (let* ((type (specifier-type (classoid-cell-name (lvar-value cell
))))
1719 (diff (type-difference (lvar-type object
) type
))
1720 (pred (backend-type-predicate diff
)))
1722 `(not (,pred object
))
1723 (give-up-ir1-transform))))
1725 (when-vop-existsp (:translate signed-byte-8-p
)
1726 (macrolet ((def (bits)
1727 `(deftransform ,(symbolicate "SIGNED-BYTE-" (princ-to-string bits
) "-P")
1728 ((x) (unsigned-byte) * :important nil
)
1729 '(typep x
'(unsigned-byte ,(1- bits
))))))