(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))
+ (cond ((not (types-equal-or-intersect otype type))
nil)
((csubtypep otype type)
t)
(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
(declare (type hairy-type type))
(let ((spec (hairy-type-specifier type)))
(cond ((unknown-type-p type)
- (when (policy nil (> speed inhibit-warnings))
+ (when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note "can't open-code test of unknown type ~S"
(type-specifier type)))
`(%typep ,object ',spec))
;;; 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)