;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
+;;; FIXME: Many of the functions in this file could probably be
+;;; byte-compiled, since they're one-pass, cons-heavy code.
+
(in-package "SB!C")
\f
;;;; type predicate translation
;;;; part of the backend; different backends can support different
;;;; sets of predicates.
+;;; Establish an association between the type predicate NAME and the
+;;; corresponding TYPE. This causes the type predicate to be
+;;; recognized for purposes of optimization.
(defmacro define-type-predicate (name type)
- #!+sb-doc
- "Define-Type-Predicate Name Type
- Establish an association between the type predicate Name and the
- corresponding Type. This causes the type predicate to be recognized for
- purposes of optimization."
`(%define-type-predicate ',name ',type))
(defun %define-type-predicate (name specifier)
(let ((type (specifier-type specifier)))
(defun ir1-transform-type-predicate (object type)
(declare (type continuation object) (type ctype type))
(let ((otype (continuation-type object)))
- (cond ((not (types-intersect otype type))
- 'nil)
+ (cond ((not (types-equal-or-intersect otype type))
+ nil)
((csubtypep otype type)
- 't)
+ t)
(t
(give-up-ir1-transform)))))
(continuation-use
(basic-combination-fun node))))
*backend-predicate-types*)))
- (assert ctype)
+ (aver ctype)
(ir1-transform-type-predicate object ctype)))
;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
`(or (class-cell-class ',cell)
(error "class not yet defined: ~S" name))))
\f
-;;;; standard type predicates
+;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
+;;;; plus at least one oddball (%INSTANCEP)
+;;;;
+;;;; Various other type predicates (e.g. low-level representation
+;;;; stuff like SIMPLE-ARRAY-SINGLE-FLOAT-P) are defined elsewhere.
-;;; FIXME: needed only at cold load time, can be uninterned afterwards;
-;;; or perhaps could just be done at toplevel
-(defun define-standard-type-predicates ()
+;;; FIXME: This function is only called once, at top level. Why not
+;;; just expand all its operations into toplevel code?
+(defun !define-standard-type-predicates ()
(define-type-predicate arrayp array)
; (The ATOM predicate is handled separately as (NOT CONS).)
(define-type-predicate bit-vector-p bit-vector)
(define-type-predicate funcallable-instance-p funcallable-instance)
(define-type-predicate symbolp symbol)
(define-type-predicate vectorp vector))
-
-(define-standard-type-predicates)
+(!define-standard-type-predicates)
\f
;;;; transforms for type predicates not implemented primitively
;;;;
\f
;;;; TYPEP source transform
-;;; Return a form that tests the variable N-Object for being in the binds
-;;; specified by Type. Base is the name of the base type, for declaration. We
-;;; make safety locally 0 to inhibit any checking of this assertion.
+;;; Return a form that tests the variable N-OBJECT for being in the
+;;; binds specified by TYPE. BASE is the name of the base type, for
+;;; declaration. We make SAFETY locally 0 to inhibit any checking of
+;;; this assertion.
#!-negative-zero-is-not-zero
(defun transform-numeric-bound-test (n-object type base)
(declare (type numeric-type type))
(declare (type hairy-type type))
(let ((spec (hairy-type-specifier type)))
(cond ((unknown-type-p type)
- (when (policy nil (> speed brevity))
+ (when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note "can't open-code test of unknown type ~S"
(type-specifier type)))
`(%typep ,object ',spec))
`(typep ,n-obj ',x))
(rest spec))))))))))
-;;; Do source transformation for Typep of a known union type. If a
+;;; Do source transformation for TYPEP of a known union type. If a
;;; union type contains LIST, then we pull that out and make it into a
;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
;;; will be a subtype even without there being any (member NIL). We
(let* ((types (union-type-types type))
(ltype (specifier-type 'list))
(mtype (find-if #'member-type-p types)))
- (cond ((and mtype (csubtypep ltype type))
- (let ((members (member-type-members mtype)))
- (once-only ((n-obj object))
- `(if (listp ,n-obj)
- t
- (typep ,n-obj
- '(or ,@(mapcar #'type-specifier
- (remove (specifier-type 'cons)
- (remove mtype types)))
- (member ,@(remove nil members))))))))
- (t
- (once-only ((n-obj object))
- `(or ,@(mapcar #'(lambda (x)
- `(typep ,n-obj ',(type-specifier x)))
- types)))))))
+ (if (and mtype (csubtypep ltype type))
+ (let ((members (member-type-members mtype)))
+ (once-only ((n-obj object))
+ `(or (listp ,n-obj)
+ (typep ,n-obj
+ '(or ,@(mapcar #'type-specifier
+ (remove (specifier-type 'cons)
+ (remove mtype types)))
+ (member ,@(remove nil members)))))))
+ (once-only ((n-obj object))
+ `(or ,@(mapcar (lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
+ types))))))
+
+;;; Do source transformation for TYPEP of a known intersection type.
+(defun source-transform-intersection-typep (object type)
+ (once-only ((n-obj object))
+ `(and ,@(mapcar (lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
+ (intersection-type-types type)))))
;;; If necessary recurse to check the cons type.
(defun source-transform-cons-typep (object type)
;;; generated in byte compiled code. (As of sbcl-0.6.5, they could
;;; sometimes be generated when byte compiling inline functions, but
;;; it's quite uncommon.) -- WHN 20000523
-(deftransform %instance-typep ((object spec) * * :when :both)
- (assert (constant-continuation-p spec))
+(deftransform %instance-typep ((object spec) (* *) * :node node :when :both)
+ (aver (constant-continuation-p spec))
(let* ((spec (continuation-value spec))
(class (specifier-type spec))
(name (sb!xc:class-name class))
(if (and res (not (layout-invalid res)))
res
nil))))
- (/noshow "entering DEFTRANSFORM %INSTANCE-TYPEP" otype spec class name layout)
(cond
;; Flush tests whose result is known at compile time.
- ((not (types-intersect otype class))
- (/noshow "flushing constant NIL")
+ ((not (types-equal-or-intersect otype class))
nil)
((csubtypep otype class)
- (/noshow "flushing constant T")
t)
;; If not properly named, error.
((not (and name (eq (sb!xc:find-class name) class)))
class:~% ~S"
class))
(t
+ ;; Delay the type transform to give type propagation a chance.
+ (delay-ir1-transform node :constraint)
+
;; Otherwise transform the type test.
(multiple-value-bind (pred get-layout)
(cond
(values '%instancep '%instance-layout))
(t
(values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
- (/noshow pred get-layout)
(cond
((and (eq (class-state class) :sealed) layout
(not (class-subclasses class)))
;; Sealed and has no subclasses.
- (/noshow "sealed and has no subclasses")
(let ((n-layout (gensym)))
`(and (,pred object)
(let ((,n-layout (,get-layout object)))
- ,@(when (policy nil (>= safety speed))
+ ,@(when (policy *lexenv* (>= safety speed))
`((when (layout-invalid ,n-layout)
(%layout-invalid-error object ',layout))))
(eq ,n-layout ',layout)))))
((and (typep class 'basic-structure-class) layout)
- (/noshow "structure type tests; hierarchical layout depths")
;; structure type tests; hierarchical layout depths
(let ((depthoid (layout-depthoid layout))
(n-layout (gensym)))
`(and (,pred object)
(let ((,n-layout (,get-layout object)))
- ,@(when (policy nil (>= safety speed))
+ ,@(when (policy *lexenv* (>= safety speed))
`((when (layout-invalid ,n-layout)
(%layout-invalid-error object ',layout))))
(if (eq ,n-layout ',layout)
',(find-class-cell name)
object)))))))))
-#|
-;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
-;;; which corresponds to the value returned by
-;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
-;;; result might change when we encounter a DEFTYPE.
-(declaim (maybe-inline upgraded-array-element-ctype-2))
-(defun upgraded-array-element-ctype-2 (spec)
- (let ((ctype (specifier-type `(array ,spec))))
- (values (array-type-specialized-element-type
- (specifier-type `(array ,spec)))
- (not (unknown-type-p (array-type-element-type ctype))))))
-|#
-
;;; If the specifier argument is a quoted constant, then we consider
;;; converting into a simple predicate or other stuff. If the type is
;;; constant, but we can't transform the call, then we convert to
;;; simplification. Instance type tests are converted to
;;; %INSTANCE-TYPEP to allow type propagation.
(def-source-transform typep (object spec)
+ ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
+ ;; since that would overlook other kinds of constants. But it turns
+ ;; out that the DEFTRANSFORM for TYPEP detects any constant
+ ;; continuation, transforms it into a quoted form, and gives this
+ ;; source transform another chance, so it all works out OK, in a
+ ;; weird roundabout way. -- WHN 2001-03-18
(if (and (consp spec) (eq (car spec) 'quote))
(let ((type (specifier-type (cadr spec))))
(or (let ((pred (cdr (assoc type *backend-type-predicates*
(source-transform-hairy-typep object type))
(union-type
(source-transform-union-typep object type))
+ (intersection-type
+ (source-transform-intersection-typep object type))
(member-type
`(member ,object ',(member-type-members type)))
(args-type
projects / sbcl.git / blobdiff