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
'(function (t) *) #'fold-type-predicate
)
54 ;;; If we discover the type argument is constant during IR1
55 ;;; optimization, then give the source transform another chance. The
56 ;;; source transform can't pass, since we give it an explicit
57 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
58 ;;; spurious attempts at transformation (and possible repeated
60 (deftransform typep
((object type
&optional env
) * * :node node
)
61 (unless (constant-lvar-p type
)
62 (give-up-ir1-transform "can't open-code test of non-constant type"))
63 (unless (or (null env
)
64 (and (constant-lvar-p env
) (null (lvar-value env
))))
65 (give-up-ir1-transform "environment argument present and not null"))
66 (multiple-value-bind (expansion fail-p
)
67 (source-transform-typep 'object
(lvar-value type
))
72 ;;; If the lvar OBJECT definitely is or isn't of the specified
73 ;;; type, then return T or NIL as appropriate. Otherwise quietly
74 ;;; GIVE-UP-IR1-TRANSFORM.
75 (defun ir1-transform-type-predicate (object type node
)
76 (declare (type lvar object
) (type ctype type
))
77 (let ((otype (lvar-type object
)))
79 (cond ((typep type
'alien-type-type
)
80 ;; We don't transform alien type tests until here, because
81 ;; once we do that the rest of the type system can no longer
82 ;; reason about them properly -- so we'd miss out on type
84 (delay-ir1-transform node
:optimize
)
85 (let ((alien-type (alien-type-type-alien-type type
)))
86 ;; If it's a lisp-rep-type, the CTYPE should be one already.
87 (aver (not (compute-lisp-rep-type alien-type
)))
88 `(sb!alien
::alien-value-typep object
',alien-type
)))
90 (give-up-ir1-transform)))))
91 (cond ((not (types-equal-or-intersect otype type
))
93 ((csubtypep otype type
)
95 ((eq type
*empty-type
*)
98 (let ((intersect (type-intersection2 type otype
)))
101 (multiple-value-bind (constantp value
)
102 (type-singleton-p intersect
)
104 `(eql object
',value
)
107 ;;; Flush %TYPEP tests whose result is known at compile time.
108 (deftransform %typep
((object type
) * * :node node
)
109 (unless (constant-lvar-p type
)
110 (give-up-ir1-transform))
111 (ir1-transform-type-predicate
113 (ir1-transform-specifier-type (lvar-value type
))
116 ;;; This is the IR1 transform for simple type predicates. It checks
117 ;;; whether the single argument is known to (not) be of the
118 ;;; appropriate type, expanding to T or NIL as appropriate.
119 (deftransform fold-type-predicate
((object) * * :node node
:defun-only t
)
120 (let ((ctype (gethash (leaf-source-name
123 (basic-combination-fun node
))))
124 *backend-predicate-types
*)))
126 (ir1-transform-type-predicate object ctype node
)))
128 ;;; If FIND-CLASSOID is called on a constant class, locate the
129 ;;; CLASSOID-CELL at load time.
130 (deftransform find-classoid
((name) ((constant-arg symbol
)) *)
131 (let* ((name (lvar-value name
))
132 (cell (find-classoid-cell name
:create t
)))
133 `(or (classoid-cell-classoid ',cell
)
134 (error "Class not yet defined: ~S" name
))))
136 (defoptimizer (%typep-wrapper constraint-propagate-if
)
137 ((test-value variable type
) node gen
)
138 (declare (ignore test-value gen
))
139 (aver (constant-lvar-p type
))
140 (let ((type (lvar-value type
)))
141 (values variable
(if (ctype-p type
)
143 (handler-case (careful-specifier-type type
)
146 (deftransform %typep-wrapper
((test-value variable type
) * * :node node
)
147 (aver (constant-lvar-p type
))
148 (if (constant-lvar-p test-value
)
149 `',(lvar-value test-value
)
150 (let* ((type (lvar-value type
))
151 (type (if (ctype-p type
)
153 (handler-case (careful-specifier-type type
)
155 (value-type (lvar-type variable
)))
158 ((csubtypep value-type type
)
160 ((not (types-equal-or-intersect value-type type
))
163 (delay-ir1-transform node
:constraint
)
166 ;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
167 ;;;; plus at least one oddball (%INSTANCEP)
169 ;;;; Various other type predicates (e.g. low-level representation
170 ;;;; stuff like SIMPLE-ARRAY-SINGLE-FLOAT-P) are defined elsewhere.
172 ;;; FIXME: This function is only called once, at top level. Why not
173 ;;; just expand all its operations into toplevel code?
174 (defun !define-standard-type-predicates
()
175 (define-type-predicate arrayp array
)
176 ; (The ATOM predicate is handled separately as (NOT CONS).)
177 (define-type-predicate bit-vector-p bit-vector
)
178 (define-type-predicate characterp character
)
179 (define-type-predicate compiled-function-p compiled-function
)
180 (define-type-predicate complexp complex
)
181 (define-type-predicate complex-rational-p
(complex rational
))
182 (define-type-predicate complex-float-p
(complex float
))
183 (define-type-predicate consp cons
)
184 (define-type-predicate floatp float
)
185 (define-type-predicate functionp function
)
186 (define-type-predicate integerp integer
)
187 (define-type-predicate keywordp keyword
)
188 (define-type-predicate listp list
)
189 (define-type-predicate null null
)
190 (define-type-predicate numberp number
)
191 (define-type-predicate rationalp rational
)
192 (define-type-predicate realp real
)
193 (define-type-predicate sequencep sequence
)
194 (define-type-predicate extended-sequence-p extended-sequence
)
195 (define-type-predicate simple-bit-vector-p simple-bit-vector
)
196 (define-type-predicate simple-string-p simple-string
)
197 (define-type-predicate simple-vector-p simple-vector
)
198 (define-type-predicate stringp string
)
199 (define-type-predicate %instancep instance
)
200 (define-type-predicate simple-fun-p simple-fun
)
201 (define-type-predicate closurep closure
)
202 (define-type-predicate funcallable-instance-p funcallable-instance
)
203 (define-type-predicate symbolp symbol
)
204 (define-type-predicate vectorp vector
))
205 (!define-standard-type-predicates
)
207 ;;;; transforms for type predicates not implemented primitively
209 ;;;; See also VM dependent transforms.
211 (define-source-transform atom
(x)
214 (define-source-transform base-char-p
(x)
215 `(typep ,x
'base-char
))
216 ;; CONS is implemented as (and list (not (eql nil))) where the 'and' is
217 ;; built-in to the consp vop. Reduce to just LISTP if possible.
218 (deftransform consp
((x) ((not null
)) * :important nil
) '(listp x
))
220 ;;;; TYPEP source transform
222 ;;; Return a form that tests the variable N-OBJECT for being in the
223 ;;; binds specified by TYPE. BASE is the name of the base type, for
224 ;;; declaration. We make SAFETY locally 0 to inhibit any checking of
226 (defun transform-numeric-bound-test (n-object type base
)
227 (declare (type numeric-type type
))
228 (let ((low (numeric-type-low type
))
229 (high (numeric-type-high type
)))
231 (declare (optimize (safety 0)))
234 `((> (truly-the ,base
,n-object
) ,(car low
)))
235 `((>= (truly-the ,base
,n-object
) ,low
))))
238 `((< (truly-the ,base
,n-object
) ,(car high
)))
239 `((<= (truly-the ,base
,n-object
) ,high
))))))))
241 ;;; Do source transformation of a test of a known numeric type. We can
242 ;;; assume that the type doesn't have a corresponding predicate, since
243 ;;; those types have already been picked off. In particular, CLASS
244 ;;; must be specified, since it is unspecified only in NUMBER and
245 ;;; COMPLEX. Similarly, we assume that COMPLEXP is always specified.
247 ;;; For non-complex types, we just test that the number belongs to the
248 ;;; base type, and then test that it is in bounds. When CLASS is
249 ;;; INTEGER, we check to see whether the range is no bigger than
250 ;;; FIXNUM. If so, we check for FIXNUM instead of INTEGER. This allows
251 ;;; us to use fixnum comparison to test the bounds.
253 ;;; For complex types, we must test for complex, then do the above on
254 ;;; both the real and imaginary parts. When CLASS is float, we need
255 ;;; only check the type of the realpart, since the format of the
256 ;;; realpart and the imagpart must be the same.
257 (defun source-transform-numeric-typep (object type
)
258 (let* ((class (numeric-type-class type
))
260 (integer (containing-integer-type
261 (if (numeric-type-complexp type
)
262 (modified-numeric-type type
266 (float (or (numeric-type-format type
) 'float
))
268 (once-only ((n-object object
))
269 (ecase (numeric-type-complexp type
)
271 (cond #!+(or x86 x86-64 arm arm64
) ;; Not implemented elsewhere yet
273 (eql (numeric-type-class type
) 'integer
)
274 (eql (numeric-type-low type
) 0)
275 (fixnump (numeric-type-high type
)))
276 `(fixnum-mod-p ,n-object
,(numeric-type-high type
)))
278 `(and (typep ,n-object
',base
)
279 ,(transform-numeric-bound-test n-object type base
)))))
281 `(and (complexp ,n-object
)
282 ,(once-only ((n-real `(realpart (truly-the complex
,n-object
)))
283 (n-imag `(imagpart (truly-the complex
,n-object
))))
286 (and (typep ,n-real
',base
)
287 ,@(when (eq class
'integer
)
288 `((typep ,n-imag
',base
)))
289 ,(transform-numeric-bound-test n-real type base
)
290 ,(transform-numeric-bound-test n-imag type
293 ;;; Do the source transformation for a test of a hairy type. AND,
294 ;;; SATISFIES and NOT are converted into the obvious code. We convert
295 ;;; unknown types to %TYPEP, emitting an efficiency note if
297 (defun source-transform-hairy-typep (object type
)
298 (declare (type hairy-type type
))
299 (let ((spec (hairy-type-specifier type
)))
300 (cond ((unknown-type-p type
)
302 (warn "can't open-code test of unknown type ~S"
303 (type-specifier type
))
305 (when (policy *lexenv
* (> speed inhibit-warnings
))
306 (compiler-notify "can't open-code test of unknown type ~S"
307 (type-specifier type
)))
308 `(let ((object ,object
)
309 (cache (load-time-value (cons #'sb
!kernel
::cached-typep
',spec
)
311 (truly-the (values t
&optional
)
312 (funcall (truly-the function
(car (truly-the cons cache
)))
317 (let* ((name (second spec
))
318 (expansion (fun-name-inline-expansion name
)))
319 ;; Lambda without lexenv can easily be handled here.
320 ;; This fixes the issue that LEGAL-FUN-NAME-P which is
321 ;; just a renaming of VALID-FUNCTION-NAME-P would not
322 ;; be inlined when testing the FUNCTION-NAME type.
323 `(if ,(if (and (typep expansion
'(cons (eql lambda
)))
324 (not (fun-lexically-notinline-p name
)))
325 `(,expansion
,object
)
326 `(funcall (global-function ,name
) ,object
))
329 (once-only ((n-obj object
))
330 `(,(first spec
) ,@(mapcar (lambda (x)
334 (defun source-transform-negation-typep (object type
)
335 (declare (type negation-type type
))
336 (let ((spec (type-specifier (negation-type-type type
))))
337 `(not (typep ,object
',spec
))))
339 ;;; Do source transformation for TYPEP of a known union type. If a
340 ;;; union type contains LIST, then we pull that out and make it into a
341 ;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
342 ;;; will be a subtype even without there being any (member NIL). We
343 ;;; currently just drop through to the general code in this case,
344 ;;; rather than trying to optimize it (but FIXME CSR 2004-04-05: it
345 ;;; wouldn't be hard to optimize it after all).
346 ;;; FIXME: if the CONSP|NIL -> LISTP optimization kicks in,
347 ;;; we forgo the array optimizations.
348 (defun source-transform-union-typep (object type
)
349 (let* ((types (union-type-types type
))
350 (type-cons (specifier-type 'cons
))
351 (mtype (find-if #'member-type-p types
))
352 (members (when mtype
(member-type-members mtype
))))
353 (once-only ((n-obj object
))
356 (memq type-cons types
))
359 '(or ,@(mapcar #'type-specifier
361 (remove mtype types
)))
362 (member ,@(remove nil members
)))))
363 (multiple-value-bind (widetags more-types
)
364 (sb!kernel
::widetags-from-union-type types
)
366 `((%other-pointer-subtype-p
,n-obj
',widetags
)))
367 ,@(mapcar (lambda (x)
368 `(typep ,n-obj
',(type-specifier x
)))
371 ;;; Do source transformation for TYPEP of a known intersection type.
372 (defun source-transform-intersection-typep (object type
)
373 (once-only ((n-obj object
))
374 `(and ,@(mapcar (lambda (x)
375 `(typep ,n-obj
',(type-specifier x
)))
376 (intersection-type-types type
)))))
378 ;;; If necessary recurse to check the cons type.
379 (defun source-transform-cons-typep (object type
)
380 (let* ((car-type (cons-type-car-type type
))
381 (cdr-type (cons-type-cdr-type type
))
382 (car-test-p (not (type= car-type
*universal-type
*)))
383 (cdr-test-p (not (type= cdr-type
*universal-type
*))))
384 (if (and (not car-test-p
) (not cdr-test-p
))
386 ;; CONSP can be safely weakened to LISTP if either of the CAR
387 ;; or CDR test (or both) can distinguish LIST from CONS
388 ;; by never returning T when given an input of NIL.
389 (labels ((safely-weakened (ctype)
392 (not (member nil
(member-type-members ctype
))))
394 ;; can't weaken if the specifier is (CONS SYMBOL)
395 (not (ctypep nil ctype
)))
396 ;; these are disjoint from NIL
397 ((or cons-type numeric-type array-type character-set-type
)
400 ;; at least one of them must not spuriously return T
401 (some #'safely-weakened
(compound-type-types ctype
)))
403 ;; require that none spuriously return T
404 (every #'safely-weakened
(compound-type-types ctype
)))
406 ;; hack - (CONS KEYWORD) is weakenable
407 ;; because NIL is not a keyword.
408 (equal (hairy-type-specifier ctype
)
409 '(satisfies keywordp
))))))
410 (let* ((n-obj (sb!xc
:gensym
))
413 `((typep (car ,n-obj
) ',(type-specifier car-type
)))))
416 `((typep (cdr ,n-obj
) ',(type-specifier cdr-type
))))))
417 `(let ((,n-obj
,object
))
418 ;; Being paranoid, perform the safely weakenable test first
419 ;; so that the other part doesn't execute on an object that
420 ;; it would not have gotten, were the CONSP test not weakened.
421 ,(cond ((and car-test-p
(safely-weakened car-type
))
422 `(and (listp ,n-obj
) ,@car-test
,@cdr-test
))
423 ((and cdr-test-p
(safely-weakened cdr-type
))
424 `(and (listp ,n-obj
) ,@cdr-test
,@car-test
))
426 `(and (consp ,n-obj
) ,@car-test
,@cdr-test
)))))))))
428 (defun source-transform-character-set-typep (object type
)
429 (let ((pairs (character-set-type-pairs type
)))
430 (if (and (= (length pairs
) 1)
432 (= (cdar pairs
) (1- sb
!xc
:char-code-limit
)))
433 `(characterp ,object
)
434 (once-only ((n-obj object
))
435 (let ((n-code (gensym "CODE")))
436 `(and (characterp ,n-obj
)
437 (let ((,n-code
(sb!xc
:char-code
,n-obj
)))
439 ,@(loop for pair in pairs
441 `(<= ,(car pair
) ,n-code
,(cdr pair
)))))))))))
444 (defun source-transform-simd-pack-typep (object type
)
445 (if (type= type
(specifier-type 'simd-pack
))
446 `(simd-pack-p ,object
)
447 (once-only ((n-obj object
))
448 (let ((n-tag (gensym "TAG")))
451 (let ((,n-tag
(%simd-pack-tag
,n-obj
)))
453 for type in
(simd-pack-type-element-type type
)
454 for index
= (position type
*simd-pack-element-types
*)
455 collect
`(eql ,n-tag
,index
)))))))))
457 ;;; Return the predicate and type from the most specific entry in
458 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
459 (defun find-supertype-predicate (type)
460 (declare (type ctype type
))
463 (dolist (x *backend-type-predicates
*)
464 (let ((stype (car x
)))
465 (when (and (csubtypep type stype
)
467 (csubtypep stype res-type
)))
468 (setq res-type stype
)
469 (setq res
(cdr x
)))))
470 (values res res-type
)))
472 ;;; Return forms to test that OBJ has the rank and dimensions
473 ;;; specified by TYPE, where STYPE is the type we have checked against
474 ;;; (which is the same but for dimensions and element type).
476 ;;; Secondary return value is true if passing the generated tests implies that
477 ;;; the array has a header.
478 (defun test-array-dimensions (obj type stype
)
479 (declare (type array-type type stype
))
480 (let ((obj `(truly-the ,(type-specifier stype
) ,obj
))
481 (dims (array-type-dimensions type
)))
482 (unless (or (eq dims
'*)
483 (equal dims
(array-type-dimensions stype
)))
485 (values `((array-header-p ,obj
)
486 ,@(when (eq (array-type-dimensions stype
) '*)
487 `((= (%array-rank
,obj
) ,(length dims
))))
488 ,@(loop for d in dims
491 collect
`(= (%array-dimension
,obj
,i
) ,d
)))
494 (values `((array-header-p ,obj
)
495 (= (%array-rank
,obj
) 0))
497 ((not (array-type-complexp type
))
498 (if (csubtypep stype
(specifier-type 'vector
))
499 (values (unless (eq '* (car dims
))
500 `((= (vector-length ,obj
) ,@dims
)))
502 (values (if (eq '* (car dims
))
503 `((not (array-header-p ,obj
)))
504 `((not (array-header-p ,obj
))
505 (= (vector-length ,obj
) ,@dims
)))
508 (values (unless (eq '* (car dims
))
509 `((if (array-header-p ,obj
)
510 (= (%array-dimension
,obj
0) ,@dims
)
511 (= (vector-length ,obj
) ,@dims
))))
514 ;;; Return forms to test that OBJ has the element-type specified by type
515 ;;; specified by TYPE, where STYPE is the type we have checked against (which
516 ;;; is the same but for dimensions and element type). If HEADERP is true, OBJ
517 ;;; is guaranteed to be an array-header.
518 (defun test-array-element-type (obj type stype headerp
)
519 (declare (type array-type type stype
))
520 (let ((obj `(truly-the ,(type-specifier stype
) ,obj
))
521 (eltype (array-type-specialized-element-type type
)))
522 (unless (or (type= eltype
(array-type-specialized-element-type stype
))
523 (eq eltype
*wild-type
*))
524 (let ((typecode (sb!vm
:saetp-typecode
(find-saetp-by-ctype eltype
))))
525 (with-unique-names (data)
526 (if (and headerp
(not (array-type-complexp stype
)))
527 ;; If we know OBJ is an array header, and that the array is
528 ;; simple, we also know there is exactly one indirection to
530 `((eq (%other-pointer-widetag
(%array-data
,obj
)) ,typecode
))
531 `((do ((,data
,(if headerp
`(%array-data
,obj
) obj
)
532 (%array-data
,data
)))
533 ((not (array-header-p ,data
))
534 (eq (%other-pointer-widetag
,data
) ,typecode
))))))))))
536 ;;; If we can find a type predicate that tests for the type without
537 ;;; dimensions, then use that predicate and test for dimensions.
538 ;;; Otherwise, just do %TYPEP.
539 (defun source-transform-array-typep (obj type
)
540 ;; Intercept (SIMPLE-ARRAY * (*)) because otherwise it tests
541 ;; (AND SIMPLE-ARRAY (NOT ARRAY-HEADER)) to weed out rank 0 and >1.
542 ;; By design the simple arrays of of rank 1 occupy a contiguous
543 ;; range of widetags, and unlike the arbitrary-widetags code for unions,
544 ;; this nonstandard predicate can be generically defined for all backends.
545 (let ((dims (array-type-dimensions type
))
546 (et (array-type-element-type type
)))
547 (if (and (not (array-type-complexp type
))
550 (return-from source-transform-array-typep
551 `(simple-rank-1-array-*-p
,obj
)))
552 (multiple-value-bind (pred stype
) (find-supertype-predicate type
)
553 (if (and (array-type-p stype
)
554 ;; (If the element type hasn't been defined yet, it's
555 ;; not safe to assume here that it will eventually
556 ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
557 (not (unknown-type-p (array-type-element-type type
)))
558 (or (eq (array-type-complexp stype
) (array-type-complexp type
))
559 (and (eql (array-type-complexp stype
) :maybe
)
560 (eql (array-type-complexp type
) t
))))
561 (let ((complex-tag (and
562 (eql (array-type-complexp type
) t
)
564 (and (neq et
*wild-type
*)
565 (sb!vm
:saetp-complex-typecode
566 (find-saetp-by-ctype (array-type-element-type type
)))))))
567 (once-only ((n-obj obj
))
569 `(and (eq (%other-pointer-widetag
,n-obj
) ,complex-tag
)
570 ,@(unless (eq (car dims
) '*)
571 `((= (%array-dimension
,n-obj
0) ,(car dims
)))))
572 (multiple-value-bind (tests headerp
)
573 (test-array-dimensions n-obj type stype
)
574 `(and ,@(unless (and headerp
(eql pred
'arrayp
))
575 ;; ARRAY-HEADER-P from TESTS will test for that
577 ,@(when (and (eql (array-type-complexp stype
) :maybe
)
578 (eql (array-type-complexp type
) t
))
579 ;; KLUDGE: this is a bit lame; if we get here,
580 ;; we already know that N-OBJ is an array, but
581 ;; (NOT SIMPLE-ARRAY) doesn't know that. On the
582 ;; other hand, this should get compiled down to
583 ;; two widetag tests, so it's only a bit lame.
584 `((typep ,n-obj
'(not simple-array
))))
586 ,@(test-array-element-type n-obj type stype headerp
))))))
587 `(%typep
,obj
',(type-specifier type
))))))
589 ;;; Transform a type test against some instance type. The type test is
590 ;;; flushed if the result is known at compile time. If not properly
591 ;;; named, error. If sealed and has no subclasses, just test for
592 ;;; layout-EQ. If a structure then test for layout-EQ and then a
593 ;;; general test based on layout-inherits. If safety is important,
594 ;;; then we also check whether the layout for the object is invalid
595 ;;; and signal an error if so. Otherwise, look up the indirect
596 ;;; class-cell and call CLASS-CELL-TYPEP at runtime.
597 (deftransform %instance-typep
((object spec
) (* *) * :node node
)
598 (aver (constant-lvar-p spec
))
599 (let* ((spec (lvar-value spec
))
600 (class (specifier-type spec
))
601 (name (classoid-name class
))
602 (otype (lvar-type object
))
603 (layout (let ((res (info :type
:compiler-layout name
)))
604 (if (and res
(not (layout-invalid res
)))
608 ;; Flush tests whose result is known at compile time.
609 ((not (types-equal-or-intersect otype class
))
611 ((csubtypep otype class
)
613 ;; If not properly named, error.
614 ((not (and name
(eq (find-classoid name
) class
)))
615 (compiler-error "can't compile TYPEP of anonymous or undefined ~
619 ;; Delay the type transform to give type propagation a chance.
620 (delay-ir1-transform node
:constraint
)
622 ;; FIXME: (TYPEP X 'ERROR) - or any condition - checks whether X
623 ;; has the lowtag of either an ordinary or funcallable instance.
624 ;; But you can not define a class that is both CONDITION and FUNCTION
625 ;; because CONDITION-CLASS and FUNCALLABLE-STANDARD-CLASS are
626 ;; incompatible metaclasses. Thus the type test is less efficient than
627 ;; could be, since fun-pointer-lowtag can not occur in the "true" case.
629 ;; Otherwise transform the type test.
630 (binding* (((pred get-layout
)
631 (cond ((csubtypep class
(specifier-type 'funcallable-instance
))
632 (values '(funcallable-instance-p object
)
633 '(%funcallable-instance-layout object
)))
634 ((csubtypep class
(specifier-type 'instance
))
635 (values '(%instancep object
)
636 '(%instance-layout object
)))))
637 (get-layout-or-return-false
639 ;; Test just one of %INSTANCEP or %FUNCALLABLE-INSTANCE-P
640 `(if ,pred
,get-layout
(return-from typep nil
))
641 ;; But if we don't know which is will be, try both.
642 ;; This is less general than LAYOUT-OF,and therefore
643 ;; a little quicker to fail, because objects with
644 ;; {LIST|OTHER}-POINTER-LOWTAG can't possibly pass.
645 `(cond ((%instancep object
)
646 (%instance-layout object
))
647 ((funcallable-instance-p object
)
648 (%funcallable-instance-layout object
))
649 (t (return-from typep nil
)))))
652 ;; It's possible to seal a STANDARD-CLASS, not just a STRUCTURE-CLASS,
653 ;; though probably extremely weird. Also the PRED should be set in
654 ;; that event, but it isn't.
655 ((and (eq (classoid-state class
) :sealed
) layout
656 (not (classoid-subclasses class
)))
657 ;; Sealed and has no subclasses.
658 ;; The crummy dual expressions for the same result are because
659 ;; (BLOCK (RETURN ...)) seems to emit a forward branch in the
660 ;; passing case, but AND emits a forward branch in the failing
661 ;; case which I believe is the better choice.
663 `(and ,pred
(eq ,get-layout
',layout
))
664 `(block typep
(eq ,get-layout-or-return-false
',layout
))))
666 ((and (typep class
'structure-classoid
) layout
)
667 ;; structure type tests; hierarchical layout depths
668 (let* ((depthoid (layout-depthoid layout
))
669 ;; If a structure is apparently an abstract base type,
670 ;; having no constructor, then no instance layout should
671 ;; be EQ to the classoid's layout. It is a slight win
672 ;; to use the depth-based check first, then do the EQ check.
673 ;; There is no loss in the case where both fail, and there
674 ;; is a benefit in a passing case. Always try both though,
675 ;; because (MAKE-INSTANCE 'x) works on any structure class.
676 (abstract-base-p (awhen (layout-info layout
)
677 (not (dd-constructors it
))))
679 ;; Use DATA-VECTOR-REF directly, since that's what SVREF in
680 ;; a SAFETY 0 lexenv will eventually be transformed to.
681 ;; This can give a large compilation speedup, since
682 ;; %INSTANCE-TYPEPs are frequently created during
683 ;; GENERATE-TYPE-CHECKS, and the normal aref transformation
684 ;; path is pretty heavy.
685 `(locally (declare (optimize (safety 0)))
686 (data-vector-ref (layout-inherits ,n-layout
) ,depthoid
)))
688 ;; Layouts are immediate constants in immobile space.
689 ;; It would be far nicer if we had a pattern-matching pass
690 ;; wherein the backend would recognize that
691 ;; (eq (data-vector-ref ...) k) has a single instruction form,
692 ;; but lacking that, force it into a single call
693 ;; that a vop can translate.
695 `(sb!vm
::layout-inherits-ref-eq
696 (layout-inherits ,n-layout
) ,depthoid
,layout
)
697 #!-immobile-space
`(eq ,get-ancestor
,layout
))
698 (deeper-p `(> (layout-depthoid ,n-layout
) ,depthoid
)))
699 (aver (equal pred
'(%instancep object
)))
701 (let ((,n-layout
,get-layout
))
702 ;; we used to check for invalid layouts here,
703 ;; but in fact that's both unnecessary and
704 ;; wrong; it's unnecessary because structure
705 ;; classes can't be redefined, and it's wrong
706 ;; because it is quite legitimate to pass an
707 ;; object with an invalid layout to a structure
710 `(eq (if ,deeper-p
,get-ancestor
,n-layout
) ,layout
)
711 `(cond ((eq ,n-layout
,layout
) t
)
712 (,deeper-p
,ancestor-layout-eq
)))))))
713 ((and layout
(>= (layout-depthoid layout
) 0))
714 ;; hierarchical layout depths for other things (e.g.
715 ;; CONDITION, STREAM)
716 ;; The quasi-hierarchical types are abstract base types,
717 ;; so perform inheritance check first, and EQ second.
718 ;; Actually, since you can't make an abstract STREAM,
719 ;; maybe we should skip the EQ test? But you *can* make
720 ;; an instance of CONDITION for what it's worth.
721 ;; SEQUENCE is special-cased, but could be handled here.
722 (let* ((depthoid (layout-depthoid layout
))
723 (n-inherits (gensym))
725 `((when (layout-invalid ,n-layout
)
726 (setq ,n-layout
(update-object-layout-or-invalid
728 (let ((,n-inherits
(layout-inherits
729 (truly-the layout
,n-layout
))))
730 (declare (optimize (safety 0)))
731 (eq (if (> (vector-length ,n-inherits
) ,depthoid
)
732 (data-vector-ref ,n-inherits
,depthoid
)
736 `(and ,pred
(let ((,n-layout
,get-layout
)) ,@guts
))
738 (let ((,n-layout
,get-layout-or-return-false
)) ,@guts
)))))
741 (/noshow
"default case -- ,PRED and CLASS-CELL-TYPEP")
742 `(classoid-cell-typep ',(find-classoid-cell name
:create t
)
745 ;;; If the specifier argument is a quoted constant, then we consider
746 ;;; converting into a simple predicate or other stuff. If the type is
747 ;;; constant, but we can't transform the call, then we convert to
748 ;;; %TYPEP. We only pass when the type is non-constant. This allows us
749 ;;; to recognize between calls that might later be transformed
750 ;;; successfully when a constant type is discovered. We don't give an
751 ;;; efficiency note when we pass, since the IR1 transform will give
752 ;;; one if necessary and appropriate.
754 ;;; If the type is TYPE= to a type that has a predicate, then expand
755 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
756 ;;; These transformations can increase space, but it is hard to tell
757 ;;; when, so we ignore policy and always do them.
758 (defun %source-transform-typep
(object type
)
759 (let ((ctype (careful-specifier-type type
)))
760 (or (when (not ctype
)
761 (compiler-warn "illegal type specifier for TYPEP: ~S" type
)
762 (return-from %source-transform-typep
(values nil t
)))
763 (multiple-value-bind (constantp value
) (type-singleton-p ctype
)
765 `(eql ,object
',value
)))
766 (let ((pred (cdr (assoc ctype
*backend-type-predicates
*
768 (when pred
`(,pred
,object
)))
771 (source-transform-hairy-typep object ctype
))
773 (source-transform-negation-typep object ctype
))
775 (source-transform-union-typep object ctype
))
777 (source-transform-intersection-typep object ctype
))
779 `(if (member ,object
',(member-type-members ctype
)) t
))
781 (compiler-warn "illegal type specifier for TYPEP: ~S" type
)
782 (return-from %source-transform-typep
(values nil t
)))
786 (source-transform-numeric-typep object ctype
))
788 `(%instance-typep
,object
',type
))
790 (source-transform-array-typep object ctype
))
792 (source-transform-cons-typep object ctype
))
794 (source-transform-character-set-typep object ctype
))
797 (source-transform-simd-pack-typep object ctype
))
799 `(%typep
,object
',type
))))
801 (defun source-transform-typep (object type
)
802 (when (typep type
'type-specifier
)
803 (check-deprecated-type type
))
804 (let ((name (gensym "OBJECT")))
805 (multiple-value-bind (transform error
)
806 (%source-transform-typep name type
)
809 (values `(let ((,name
,object
))
810 (%typep-wrapper
,transform
,name
',type
)))))))
812 (define-source-transform typep
(object spec
&optional env
)
813 ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
814 ;; since that would overlook other kinds of constants. But it turns
815 ;; out that the DEFTRANSFORM for TYPEP detects any constant
816 ;; lvar, transforms it into a quoted form, and gives this
817 ;; source transform another chance, so it all works out OK, in a
818 ;; weird roundabout way. -- WHN 2001-03-18
821 (eq (car spec
) 'quote
))
822 (source-transform-typep object
(cadr spec
))
827 ;;; Constant-folding.
830 (defoptimizer (coerce optimizer
) ((x type
) node
)
831 (when (and (constant-lvar-p x
) (constant-lvar-p type
))
832 (let ((value (lvar-value x
)))
833 (when (or (numberp value
) (characterp value
))
834 (constant-fold-call node
)
837 ;;; Drops dimension information from vector types.
838 ;;; Returns four values
840 ;;; * upgraded-element ctype or requsted element
841 ;;; * T if the upgraded-element is upgraded, i.e. it
842 ;;; does not contain any unknown types.
843 ;;; * T if there were any dimensions
844 (defun simplify-vector-type (type)
845 (labels ((process-compound-type (types)
851 (unless (or (hairy-type-p type
)
852 (sb!kernel
::negation-type-p type
))
853 (multiple-value-bind (type et upgraded dimensions
) (simplify type
)
854 (push type array-types
)
855 (push et element-types
)
857 (setf dimensions-removed t
))
859 (setf upgraded nil
)))))
860 (values (apply #'type-union array-types
)
861 (if (member *wild-type
* element-types
)
863 (apply #'type-union element-types
))
865 dimensions-removed
)))
867 (cond ((and (array-type-p type
)
868 (singleton-p (array-type-dimensions type
)))
870 (et (array-type-specialized-element-type type
))
871 (et (cond ((neq et
*wild-type
*)
873 ((eq (array-type-element-type type
) *wild-type
*)
877 (array-type-element-type type
)))))
878 (values (specifier-type
879 (list (if (array-type-complexp type
)
886 (not (eq (car (array-type-dimensions type
)) '*)))))
888 (process-compound-type (union-type-types type
)))
889 ((intersection-type-p type
)
890 (process-compound-type (intersection-type-types type
)))
891 ((member-type-p type
)
892 (process-compound-type
893 (mapcar #'ctype-of
(member-type-members type
))))
895 (error "~a is not a subtype of VECTOR." type
)))))
898 (deftransform coerce
((x type
) (* *) * :node node
)
899 (unless (constant-lvar-p type
)
900 (give-up-ir1-transform))
901 (let* ((tval (lvar-value type
))
902 (tspec (ir1-transform-specifier-type tval
)))
903 (if (csubtypep (lvar-type x
) tspec
)
905 ;; Note: The THE forms we use to wrap the results make sure that
906 ;; specifiers like (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
908 ((csubtypep tspec
(specifier-type 'double-float
))
909 `(the ,tval
(%double-float x
)))
910 ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
911 ((csubtypep tspec
(specifier-type 'float
))
912 `(the ,tval
(%single-float x
)))
913 ((csubtypep tspec
(specifier-type 'complex
))
914 (multiple-value-bind (part-type result-type
)
915 (cond ((and (numeric-type-p tspec
)
916 (numeric-type-format tspec
))) ; specific FLOAT type
917 ((csubtypep tspec
(specifier-type '(complex float
)))
918 ;; unspecific FLOAT type
920 ((csubtypep tspec
(specifier-type '(complex rational
)))
921 (values 'rational
`(or ,tval rational
)))
923 (values t
`(or ,tval rational
))))
924 (let ((result-type (or result-type tval
)))
926 ((not (typep x
'complex
))
927 (the ,result-type
(complex (coerce x
',part-type
))))
930 (t ; X is COMPLEX, but not of the requested type
932 (complex (coerce (realpart x
) ',part-type
)
933 (coerce (imagpart x
) ',part-type
))))))))
934 ;; Special case STRING and SIMPLE-STRING as they are union types
936 ((member tval
'(string simple-string
))
940 (replace (make-array (length x
) :element-type
'character
) x
))))
941 ((eq tval
'character
)
943 ;; Special case VECTOR
948 (replace (make-array (length x
)) x
))))
949 ;; Handle specialized element types for 1D arrays.
950 ((csubtypep tspec
(specifier-type '(array * (*))))
951 ;; Can we avoid checking for dimension issues like (COERCE FOO
952 ;; '(SIMPLE-VECTOR 5)) returning a vector of length 6?
954 ;; CLHS actually allows this for all code with SAFETY < 3,
955 ;; but we're a conservative bunch.
956 (if (or (policy node
(zerop safety
)) ; no need in unsafe code
957 (and (array-type-p tspec
) ; no need when no dimensions
958 (equal (array-type-dimensions tspec
) '(*))))
960 (multiple-value-bind (vtype etype upgraded
) (simplify-vector-type tspec
)
962 (give-up-ir1-transform))
963 (let ((vtype (type-specifier vtype
)))
965 (if (typep x
',vtype
)
968 (make-array (length x
)
969 ,@(and (not (eq etype
*universal-type
*))
970 (not (eq etype
*wild-type
*))
971 `(:element-type
',(type-specifier etype
))))
973 ;; No, duh. Dimension checking required.
974 (give-up-ir1-transform
975 "~@<~S specifies dimensions other than (*) in safe code.~:@>"
977 ((type= tspec
(specifier-type 'list
))
979 ((csubtypep tspec
(specifier-type 'function
))
980 (if (csubtypep (lvar-type x
) (specifier-type 'symbol
))
981 `(coerce-symbol-to-fun x
)
982 ;; if X can later be derived as FUNCTION then we don't want
983 ;; to call COERCE-TO-FUN, because there's no smartness
984 ;; that can undo that and see that it's really (IDENTITY X).
985 (progn (delay-ir1-transform node
:constraint
)
986 `(coerce-to-fun x
))))
988 (give-up-ir1-transform
989 "~@<open coding coercion to ~S not implemented.~:@>"