diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp
index a34302dfe9022a0bcbb2abd4a2dae7366ac0aed7..54327c34369ce5e20426382f9b53cf3e3140573d 100644
--- a/compiler/checkgen.lisp
+++ b/compiler/checkgen.lisp
@@ -84,6 +84,38 @@
 ;;;; Checking strategy determination:
 
 
+;;; MAYBE-WEAKEN-CHECK  --  Internal
+;;;
+;;;    Return the type we should test for when we really want to check for
+;;; Type.   If speed, space or compilation speed is more important than safety,
+;;; then we return a weaker type if it is easier to check.  First we try the
+;;; defined type weakenings, then look for any predicate that is cheaper.
+;;;
+;;;    If the supertype is equal in cost to the type, we prefer the supertype.
+;;; This produces a closer approximation of the right thing in the presence of
+;;; poor cost info.
+;;;
+(defun maybe-weaken-check (type cont)
+  (declare (type ctype type) (type continuation cont))
+  (cond ((policy (continuation-dest cont)
+		 (<= speed safety) (<= space safety) (<= cspeed safety))
+	 type)
+	(t
+	 (let ((min-cost (type-test-cost type))
+	       (min-type type)
+	       (found-super nil))
+	   (dolist (x *type-predicates*)
+	     (let ((stype (car x)))
+	       (when (csubtypep type stype)
+		 (setq found-super t)
+		 (let ((stype-cost (type-test-cost stype)))
+		   (when (< stype-cost min-cost)
+		     (setq min-type stype  min-cost stype-cost))))))
+	   (if found-super
+	       min-type
+	       *universal-type*)))))
+
+
 ;;; MAYBE-NEGATE-CHECK  --  Internal
 ;;;
 ;;;    Cont is a continuation we are doing a type check on and Types is a list
@@ -101,14 +133,17 @@
     (if (eq count :unknown)
 	(if (every #'type-check-template types)
 	    (values :simple types)
-	    (values :hairy (mapcar #'(lambda (x) (list nil x x)) types)))
+	    (values :hairy
+		    (mapcar #'(lambda (x)
+				(list nil (maybe-weaken-check x cont) x))
+			    types)))
 	(let ((res (mapcar #'(lambda (p c)
 			       (let ((diff (type-difference p c)))
 				 (if (and diff
 					  (< (type-test-cost diff)
 					     (type-test-cost c)))
-				     (list t diff c)
-				     (list nil c c))))
+				     (list t (maybe-weaken-check diff cont) c)
+				     (list nil (maybe-weaken-check c cont) c))))
 			   ptypes types)))
 	  (if (and (not (find-if #'first res))
 		   (every #'type-check-template types))
@@ -167,7 +202,7 @@
 ;;; to choose to implement the continuation's DEST, we use a heuristic.  We
 ;;; always return T unless:
 ;;;  -- Nobody uses the value, or
-;;;  -- Speed or space is more important that safety, or
+;;;  -- Safety is totally unimportant, or
 ;;;  -- the continuation is an argument to an unknown function, or
 ;;;  -- the continuation is an argument to a known function that has no
 ;;;     IR2-Convert method or :fast-safe templates that are compatible with the
@@ -185,7 +220,7 @@
   (let ((dest (continuation-dest cont)))
     (cond ((eq (continuation-type-check cont) :error))
 	  ((or (not dest)
-	       (policy dest (or (> speed safety) (> space safety))))
+	       (policy dest (zerop safety)))
 	   nil)
 	  ((basic-combination-p dest)
 	   (let ((kind (basic-combination-kind dest)))
@@ -355,9 +390,13 @@
 		  (setf (basic-combination-kind dest) :full)))
 	      (when (policy node (>= safety brevity))
 		(let ((*compiler-error-context* node))
-		  (compiler-warning "Result is a ~S, not a ~S."
-				    (type-specifier dtype)
-				    (type-specifier atype))))))
+		  (if (and (ref-p node) (constant-p (ref-leaf node)))
+		      (compiler-warning "This is not a ~S:~%  ~S"
+					(type-specifier atype)
+					(constant-value (ref-leaf node)))
+		      (compiler-warning "Result is a ~S, not a ~S."
+					(type-specifier dtype)
+					(type-specifier atype)))))))
 	  
 	  (let ((check-p (probable-type-check-p cont)))
 	    (multiple-value-bind (check types)