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 SEQUENCE) are best tested by letting
28 ;;;; the 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 (defmacro define-type-predicate (name type)
39 "Define-Type-Predicate Name Type
40 Establish an association between the type predicate Name and the
41 corresponding Type. This causes the type predicate to be recognized for
42 purposes of optimization."
43 `(%define-type-predicate ',name ',type))
44 (defun %define-type-predicate (name specifier)
45 (let ((type (specifier-type specifier)))
46 (setf (gethash name *backend-predicate-types*) type)
47 (setf *backend-type-predicates*
48 (cons (cons type name)
49 (remove name *backend-type-predicates*
51 (%deftransform name '(function (t) *) #'fold-type-predicate)
56 ;;; If we discover the type argument is constant during IR1
57 ;;; optimization, then give the source transform another chance. The
58 ;;; source transform can't pass, since we give it an explicit
59 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
60 ;;; spurious attempts at transformation (and possible repeated
62 (deftransform typep ((object type))
63 (unless (constant-continuation-p type)
64 (give-up-ir1-transform "can't open-code test of non-constant type"))
65 `(typep object ',(continuation-value type)))
67 ;;; If the continuation OBJECT definitely is or isn't of the specified
68 ;;; type, then return T or NIL as appropriate. Otherwise quietly
69 ;;; GIVE-UP-IR1-TRANSFORM.
70 (defun ir1-transform-type-predicate (object type)
71 (declare (type continuation object) (type ctype type))
72 (let ((otype (continuation-type object)))
73 (cond ((not (types-intersect otype type))
75 ((csubtypep otype type)
78 (give-up-ir1-transform)))))
80 ;;; Flush %TYPEP tests whose result is known at compile time.
81 (deftransform %typep ((object type))
82 (unless (constant-continuation-p type) (give-up-ir1-transform))
83 (ir1-transform-type-predicate
85 (specifier-type (continuation-value type))))
87 ;;; This is the IR1 transform for simple type predicates. It checks
88 ;;; whether the single argument is known to (not) be of the
89 ;;; appropriate type, expanding to T or NIL as appropriate.
90 (deftransform fold-type-predicate ((object) * * :node node :defun-only t)
91 (let ((ctype (gethash (leaf-name
94 (basic-combination-fun node))))
95 *backend-predicate-types*)))
97 (ir1-transform-type-predicate object ctype)))
99 ;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
101 (deftransform find-class ((name) ((constant-argument symbol)) *
103 (let* ((name (continuation-value name))
104 (cell (find-class-cell name)))
105 `(or (class-cell-class ',cell)
106 (error "class not yet defined: ~S" name))))
108 ;;;; standard type predicates
110 ;;; FIXME: needed only at cold load time, can be uninterned afterwards;
111 ;;; or perhaps could just be done at toplevel
112 (defun define-standard-type-predicates ()
113 (define-type-predicate arrayp array)
114 ; (The ATOM predicate is handled separately as (NOT CONS).)
115 (define-type-predicate bit-vector-p bit-vector)
116 (define-type-predicate characterp character)
117 (define-type-predicate compiled-function-p compiled-function)
118 (define-type-predicate complexp complex)
119 (define-type-predicate complex-rational-p (complex rational))
120 (define-type-predicate complex-float-p (complex float))
121 (define-type-predicate consp cons)
122 (define-type-predicate floatp float)
123 (define-type-predicate functionp function)
124 (define-type-predicate integerp integer)
125 (define-type-predicate keywordp keyword)
126 (define-type-predicate listp list)
127 (define-type-predicate null null)
128 (define-type-predicate numberp number)
129 (define-type-predicate rationalp rational)
130 (define-type-predicate realp real)
131 (define-type-predicate simple-bit-vector-p simple-bit-vector)
132 (define-type-predicate simple-string-p simple-string)
133 (define-type-predicate simple-vector-p simple-vector)
134 (define-type-predicate stringp string)
135 (define-type-predicate %instancep instance)
136 (define-type-predicate funcallable-instance-p funcallable-instance)
137 (define-type-predicate symbolp symbol)
138 (define-type-predicate vectorp vector))
140 (define-standard-type-predicates)
142 ;;;; transforms for type predicates not implemented primitively
144 ;;;; See also VM dependent transforms.
146 (def-source-transform atom (x)
149 ;;;; TYPEP source transform
151 ;;; Return a form that tests the variable N-Object for being in the binds
152 ;;; specified by Type. Base is the name of the base type, for declaration. We
153 ;;; make safety locally 0 to inhibit any checking of this assertion.
154 #!-negative-zero-is-not-zero
155 (defun transform-numeric-bound-test (n-object type base)
156 (declare (type numeric-type type))
157 (let ((low (numeric-type-low type))
158 (high (numeric-type-high type)))
160 (declare (optimize (safety 0)))
163 `((> (the ,base ,n-object) ,(car low)))
164 `((>= (the ,base ,n-object) ,low))))
167 `((< (the ,base ,n-object) ,(car high)))
168 `((<= (the ,base ,n-object) ,high))))))))
170 #!+negative-zero-is-not-zero
171 (defun transform-numeric-bound-test (n-object type base)
172 (declare (type numeric-type type))
173 (let ((low (numeric-type-low type))
174 (high (numeric-type-high type))
175 (float-type-p (csubtypep type (specifier-type 'float)))
179 (declare (optimize (safety 0)))
182 `((let ((,x (the ,base ,n-object))
184 ,(if (not float-type-p)
186 `(if (and (zerop ,x) (zerop ,y))
187 (> (float-sign ,x) (float-sign ,y))
189 `((let ((,x (the ,base ,n-object))
191 ,(if (not float-type-p)
193 `(if (and (zerop ,x) (zerop ,y))
194 (>= (float-sign ,x) (float-sign ,y))
198 `((let ((,x (the ,base ,n-object))
200 ,(if (not float-type-p)
202 `(if (and (zerop ,x) (zerop ,y))
203 (< (float-sign ,x) (float-sign ,y))
205 `((let ((,x (the ,base ,n-object))
207 ,(if (not float-type-p)
209 `(if (and (zerop ,x) (zerop ,y))
210 (<= (float-sign ,x) (float-sign ,y))
213 ;;; Do source transformation of a test of a known numeric type. We can
214 ;;; assume that the type doesn't have a corresponding predicate, since
215 ;;; those types have already been picked off. In particular, CLASS
216 ;;; must be specified, since it is unspecified only in NUMBER and
217 ;;; COMPLEX. Similarly, we assume that COMPLEXP is always specified.
219 ;;; For non-complex types, we just test that the number belongs to the
220 ;;; base type, and then test that it is in bounds. When CLASS is
221 ;;; INTEGER, we check to see whether the range is no bigger than
222 ;;; FIXNUM. If so, we check for FIXNUM instead of INTEGER. This allows
223 ;;; us to use fixnum comparison to test the bounds.
225 ;;; For complex types, we must test for complex, then do the above on
226 ;;; both the real and imaginary parts. When CLASS is float, we need
227 ;;; only check the type of the realpart, since the format of the
228 ;;; realpart and the imagpart must be the same.
229 (defun source-transform-numeric-typep (object type)
230 (let* ((class (numeric-type-class type))
232 (integer (containing-integer-type type))
234 (float (or (numeric-type-format type) 'float))
236 (once-only ((n-object object))
237 (ecase (numeric-type-complexp type)
239 `(and (typep ,n-object ',base)
240 ,(transform-numeric-bound-test n-object type base)))
242 `(and (complexp ,n-object)
243 ,(once-only ((n-real `(realpart (the complex ,n-object)))
244 (n-imag `(imagpart (the complex ,n-object))))
247 (and (typep ,n-real ',base)
248 ,@(when (eq class 'integer)
249 `((typep ,n-imag ',base)))
250 ,(transform-numeric-bound-test n-real type base)
251 ,(transform-numeric-bound-test n-imag type
254 ;;; Do the source transformation for a test of a hairy type. AND,
255 ;;; SATISFIES and NOT are converted into the obvious code. We convert
256 ;;; unknown types to %TYPEP, emitting an efficiency note if
258 (defun source-transform-hairy-typep (object type)
259 (declare (type hairy-type type))
260 (let ((spec (hairy-type-specifier type)))
261 (cond ((unknown-type-p type)
262 (when (policy nil (> speed brevity))
263 (compiler-note "can't open-code test of unknown type ~S"
264 (type-specifier type)))
265 `(%typep ,object ',spec))
268 (satisfies `(if (funcall #',(second spec) ,object) t nil))
270 (once-only ((n-obj object))
271 `(,(first spec) ,@(mapcar #'(lambda (x)
275 ;;; Do source transformation for Typep of a known union type. If a
276 ;;; union type contains LIST, then we pull that out and make it into a
277 ;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
278 ;;; will be a subtype even without there being any (member NIL). We
279 ;;; just drop through to the general code in this case, rather than
280 ;;; trying to optimize it.
281 (defun source-transform-union-typep (object type)
282 (let* ((types (union-type-types type))
283 (ltype (specifier-type 'list))
284 (mtype (find-if #'member-type-p types)))
285 (cond ((and mtype (csubtypep ltype type))
286 (let ((members (member-type-members mtype)))
287 (once-only ((n-obj object))
291 '(or ,@(mapcar #'type-specifier
292 (remove (specifier-type 'cons)
293 (remove mtype types)))
294 (member ,@(remove nil members))))))))
296 (once-only ((n-obj object))
297 `(or ,@(mapcar #'(lambda (x)
298 `(typep ,n-obj ',(type-specifier x)))
301 ;;; If necessary recurse to check the cons type.
302 (defun source-transform-cons-typep (object type)
303 (let* ((car-type (cons-type-car-type type))
304 (cdr-type (cons-type-cdr-type type)))
305 (let ((car-test-p (not (or (type= car-type *wild-type*)
306 (type= car-type (specifier-type t)))))
307 (cdr-test-p (not (or (type= cdr-type *wild-type*)
308 (type= cdr-type (specifier-type t))))))
309 (if (and (not car-test-p) (not cdr-test-p))
311 (once-only ((n-obj object))
314 `((typep (car ,n-obj)
315 ',(type-specifier car-type))))
317 `((typep (cdr ,n-obj)
318 ',(type-specifier cdr-type))))))))))
320 ;;; Return the predicate and type from the most specific entry in
321 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
322 (defun find-supertype-predicate (type)
323 (declare (type ctype type))
326 (dolist (x *backend-type-predicates*)
327 (let ((stype (car x)))
328 (when (and (csubtypep type stype)
330 (csubtypep stype res-type)))
331 (setq res-type stype)
332 (setq res (cdr x)))))
333 (values res res-type)))
335 ;;; Return forms to test that OBJ has the rank and dimensions
336 ;;; specified by TYPE, where STYPE is the type we have checked against
337 ;;; (which is the same but for dimensions.)
338 (defun test-array-dimensions (obj type stype)
339 (declare (type array-type type stype))
340 (let ((obj `(truly-the ,(type-specifier stype) ,obj))
341 (dims (array-type-dimensions type)))
344 (when (eq (array-type-dimensions stype) '*)
345 (res `(= (array-rank ,obj) ,(length dims))))
347 (dim dims (cdr dim)))
349 (let ((dim (car dim)))
351 (res `(= (array-dimension ,obj ,i) ,dim)))))
354 ;;; If we can find a type predicate that tests for the type w/o
355 ;;; dimensions, then use that predicate and test for dimensions.
356 ;;; Otherwise, just do %TYPEP.
357 (defun source-transform-array-typep (obj type)
358 (multiple-value-bind (pred stype) (find-supertype-predicate type)
359 (if (and (array-type-p stype)
360 ;; (If the element type hasn't been defined yet, it's
361 ;; not safe to assume here that it will eventually
362 ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
363 (not (unknown-type-p (array-type-element-type type)))
364 (type= (array-type-specialized-element-type stype)
365 (array-type-specialized-element-type type))
366 (eq (array-type-complexp stype) (array-type-complexp type)))
367 (once-only ((n-obj obj))
369 ,@(test-array-dimensions n-obj type stype)))
370 `(%typep ,obj ',(type-specifier type)))))
372 ;;; Transform a type test against some instance type. The type test is
373 ;;; flushed if the result is known at compile time. If not properly
374 ;;; named, error. If sealed and has no subclasses, just test for
375 ;;; layout-EQ. If a structure then test for layout-EQ and then a
376 ;;; general test based on layout-inherits. If safety is important,
377 ;;; then we also check whether the layout for the object is invalid
378 ;;; and signal an error if so. Otherwise, look up the indirect
379 ;;; class-cell and call CLASS-CELL-TYPEP at runtime.
381 ;;; KLUDGE: The :WHEN :BOTH option here is probably a suboptimal
382 ;;; solution to the problem of %INSTANCE-TYPEP forms in byte compiled
383 ;;; code; it'd probably be better just to have %INSTANCE-TYPEP forms
384 ;;; never be generated in byte compiled code, or maybe to have a DEFUN
385 ;;; %INSTANCE-TYPEP somewhere to handle them if they are. But it's not
386 ;;; terribly important because mostly, %INSTANCE-TYPEP forms *aren't*
387 ;;; generated in byte compiled code. (As of sbcl-0.6.5, they could
388 ;;; sometimes be generated when byte compiling inline functions, but
389 ;;; it's quite uncommon.) -- WHN 20000523
390 (deftransform %instance-typep ((object spec) * * :when :both)
391 (assert (constant-continuation-p spec))
392 (let* ((spec (continuation-value spec))
393 (class (specifier-type spec))
394 (name (sb!xc:class-name class))
395 (otype (continuation-type object))
396 (layout (let ((res (info :type :compiler-layout name)))
397 (if (and res (not (layout-invalid res)))
400 (/noshow "entering DEFTRANSFORM %INSTANCE-TYPEP" otype spec class name layout)
402 ;; Flush tests whose result is known at compile time.
403 ((not (types-intersect otype class))
404 (/noshow "flushing constant NIL")
406 ((csubtypep otype class)
407 (/noshow "flushing constant T")
409 ;; If not properly named, error.
410 ((not (and name (eq (sb!xc:find-class name) class)))
411 (compiler-error "can't compile TYPEP of anonymous or undefined ~
415 ;; Otherwise transform the type test.
416 (multiple-value-bind (pred get-layout)
418 ((csubtypep class (specifier-type 'funcallable-instance))
419 (values 'funcallable-instance-p '%funcallable-instance-layout))
420 ((csubtypep class (specifier-type 'instance))
421 (values '%instancep '%instance-layout))
423 (values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
424 (/noshow pred get-layout)
426 ((and (eq (class-state class) :sealed) layout
427 (not (class-subclasses class)))
428 ;; Sealed and has no subclasses.
429 (/noshow "sealed and has no subclasses")
430 (let ((n-layout (gensym)))
432 (let ((,n-layout (,get-layout object)))
433 ,@(when (policy nil (>= safety speed))
434 `((when (layout-invalid ,n-layout)
435 (%layout-invalid-error object ',layout))))
436 (eq ,n-layout ',layout)))))
437 ((and (typep class 'basic-structure-class) layout)
438 (/noshow "structure type tests; hierarchical layout depths")
439 ;; structure type tests; hierarchical layout depths
440 (let ((depthoid (layout-depthoid layout))
443 (let ((,n-layout (,get-layout object)))
444 ,@(when (policy nil (>= safety speed))
445 `((when (layout-invalid ,n-layout)
446 (%layout-invalid-error object ',layout))))
447 (if (eq ,n-layout ',layout)
449 (and (> (layout-depthoid ,n-layout)
451 (locally (declare (optimize (safety 0)))
452 (eq (svref (layout-inherits ,n-layout)
456 (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
458 (class-cell-typep (,get-layout object)
459 ',(find-class-cell name)
463 ;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
464 ;;; which corresponds to the value returned by
465 ;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
466 ;;; result might change when we encounter a DEFTYPE.
467 (declaim (maybe-inline upgraded-array-element-ctype-2))
468 (defun upgraded-array-element-ctype-2 (spec)
469 (let ((ctype (specifier-type `(array ,spec))))
470 (values (array-type-specialized-element-type
471 (specifier-type `(array ,spec)))
472 (not (unknown-type-p (array-type-element-type ctype))))))
475 ;;; If the specifier argument is a quoted constant, then we consider
476 ;;; converting into a simple predicate or other stuff. If the type is
477 ;;; constant, but we can't transform the call, then we convert to
478 ;;; %TYPEP. We only pass when the type is non-constant. This allows us
479 ;;; to recognize between calls that might later be transformed
480 ;;; successfully when a constant type is discovered. We don't give an
481 ;;; efficiency note when we pass, since the IR1 transform will give
482 ;;; one if necessary and appropriate.
484 ;;; If the type is TYPE= to a type that has a predicate, then expand
485 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
486 ;;; These transformations can increase space, but it is hard to tell
487 ;;; when, so we ignore policy and always do them. When byte-compiling,
488 ;;; we only do transforms that have potential for control
489 ;;; simplification. Instance type tests are converted to
490 ;;; %INSTANCE-TYPEP to allow type propagation.
491 (def-source-transform typep (object spec)
492 (if (and (consp spec) (eq (car spec) 'quote))
493 (let ((type (specifier-type (cadr spec))))
494 (or (let ((pred (cdr (assoc type *backend-type-predicates*
496 (when pred `(,pred ,object)))
499 (source-transform-hairy-typep object type))
501 (source-transform-union-typep object type))
503 `(member ,object ',(member-type-members type)))
505 (compiler-warning "illegal type specifier for TYPEP: ~S"
507 `(%typep ,object ,spec))
509 (and (not (byte-compiling))
512 (source-transform-numeric-typep object type))
514 `(%instance-typep ,object ,spec))
516 (source-transform-array-typep object type))
518 (source-transform-cons-typep object type))
520 `(%typep ,object ,spec)))
525 ;;; old working version
526 (deftransform coerce ((x type) (* *) * :when :both)
527 (unless (constant-continuation-p type)
528 (give-up-ir1-transform))
529 (let ((tspec (specifier-type (continuation-value type))))
530 (if (csubtypep (continuation-type x) tspec)
532 `(the ,(continuation-value type)
533 ,(cond ((csubtypep tspec (specifier-type 'double-float))
535 ;; FIXME: If LONG-FLOAT is to be supported, we
536 ;; need to pick it off here before falling through
538 ((csubtypep tspec (specifier-type 'float))
541 (give-up-ir1-transform)))))))
543 ;;; KLUDGE: new broken version -- 20000504
544 ;;; FIXME: should be fixed or deleted
546 (deftransform coerce ((x type) (* *) * :when :both)
547 (unless (constant-continuation-p type)
548 (give-up-ir1-transform))
549 (let ((tspec (specifier-type (continuation-value type))))
550 (if (csubtypep (continuation-type x) tspec)
552 `(if #+nil (typep x type) #-nil nil
554 (the ,(continuation-value type)
555 ,(cond ((csubtypep tspec (specifier-type 'double-float))
557 ;; FIXME: If LONG-FLOAT is to be supported,
558 ;; we need to pick it off here before falling
559 ;; through to %SINGLE-FLOAT.
560 ((csubtypep tspec (specifier-type 'float))
563 ((csubtypep tspec (specifier-type 'list))
566 ((csubtypep tspec (specifier-type 'string))
567 '(coerce-to-simple-string x))
569 ((csubtypep tspec (specifier-type 'bit-vector))
570 '(coerce-to-bit-vector x))
572 ((csubtypep tspec (specifier-type 'vector))
573 '(coerce-to-vector x type))
575 (give-up-ir1-transform))))))))