X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=8e860f4ebbb9edcc9c1dd179e56b448906ab558b;hb=4cf50b1896b25f5337e7c258b0b560da00d47993;hp=1c720756828fe37c63a3cf72684f7735f53611f2;hpb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 1c72075..8e860f4 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -71,7 +71,7 @@
 (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)
@@ -94,7 +94,7 @@
 			  (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
@@ -264,7 +264,7 @@
   (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))
@@ -397,8 +397,8 @@
 ;;; 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))
@@ -407,14 +407,11 @@
 		   (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)))
@@ -422,6 +419,9 @@
 			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
@@ -431,27 +431,24 @@
 	      (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)