diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp
index 367cb31941515da45799d66716c5fa1dba1d8fa5..7b9466886240d42200dd31a86eacbfedcffbbc26 100644
--- a/compiler/checkgen.lisp
+++ b/compiler/checkgen.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.31 2003/04/13 11:57:16 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.32 2003/04/29 11:58:17 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -290,7 +290,7 @@
 ;;; destination receives only a single value, a :hairy type check is
 ;;; generated for the single-values-type of the asserted type.
 ;;;
-(defun continuation-check-types (cont)
+(defun continuation-check-types (cont &optional force-hairy)
   (declare (type continuation cont))
   (let ((atype (continuation-asserted-type cont))
 	(dest (continuation-dest cont)))
@@ -307,12 +307,12 @@
 			      (declare (ignore ignore))
 			      (eq count :unknown))))
 		   (maybe-negate-check cont types t)
-		   (maybe-negate-check cont types nil))))
+		   (maybe-negate-check cont types force-hairy))))
 	    ((and (mv-combination-p dest)
 		  (eq (basic-combination-kind dest) :local))
 	     (assert (values-type-p atype))
 	     (assert (null (args-type-required atype)))
-	     (maybe-negate-check cont (args-type-optional atype) nil))
+	     (maybe-negate-check cont (args-type-optional atype) force-hairy))
 	    ((or (exit-p dest) (return-p dest) (mv-combination-p dest))
 	     (values :too-hairy nil))
 	    (t
@@ -350,7 +350,7 @@
   (let ((dest (continuation-dest cont)))
     (cond ((eq (continuation-type-check cont) :error)
 	   (if (and (combination-p dest) (eq (combination-kind dest) :error))
-	       nil
+	       (policy dest (= safety 3))
 	       t))
 	  ((or (not dest)
 	       (policy dest (zerop safety)))
@@ -589,7 +589,10 @@
 
     (dolist (cont (conts))
       (multiple-value-bind (check types)
-	  (continuation-check-types cont)
+	  (continuation-check-types
+	   cont
+	   (and (eq (continuation-%type-check cont) :error)
+		(policy (continuation-dest cont) (= safety 3))))
 	(ecase check
 	  (:simple)
 	  (:hairy
diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp
index 09d4bd95bb46ea173cc7340a1f63540ba211f353..050eeaa0a17d68daca0cdf10b4aa96c8a3299084 100644
--- a/compiler/ir1opt.lisp
+++ b/compiler/ir1opt.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.76 2003/04/26 18:39:30 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.77 2003/04/29 11:58:16 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -304,8 +304,14 @@
 	(let ((last (block-last block)))
 	  (typecase last
 	    (cif
-	     (flush-dest (if-test last))
-	     (when (unlink-node last) (return)))
+	     ;;
+	     ;; Don't flush an if-test if it requires a type check.
+	     (cond ((memq (continuation-type-check (if-test last))
+			  '(nil :deleted))
+		    (flush-dest (if-test last))
+		    (when (unlink-node last) (return)))
+		   (t
+		    (return))))
 	    (exit
 	     (when (maybe-delete-exit last) (return)))))
 	
@@ -628,23 +634,25 @@
 	(when (immediately-used-p test use)
 	  (convert-if-if use node)
 	  (when (continuation-use test) (return)))))
-
-    (let* ((type (continuation-type test))
-	   (victim
-	    (cond ((constant-continuation-p test)
-		   (if (continuation-value test)
-		       (if-alternative node)
-		       (if-consequent node)))
-		  ((not (types-intersect type *null-type*))
-		   (if-alternative node))
-		  ((type= type *null-type*)
-		   (if-consequent node)))))
-      (when victim
-	(flush-dest test)
-	(when (rest (block-succ block))
-	  (unlink-blocks block victim))
-	(setf (component-reanalyze (block-component (node-block node))) t)
-	(unlink-node node))))
+    ;;
+    ;; Don't flush if-tests when they require a type check.
+    (when (memq (continuation-type-check test) '(nil :deleted))
+      (let* ((type (continuation-type test))
+	     (victim
+	      (cond ((constant-continuation-p test)
+		     (if (continuation-value test)
+			 (if-alternative node)
+			 (if-consequent node)))
+		    ((not (types-intersect type *null-type*))
+		     (if-alternative node))
+		    ((type= type *null-type*)
+		     (if-consequent node)))))
+	(when victim
+	  (flush-dest test)
+	  (when (rest (block-succ block))
+	    (unlink-blocks block victim))
+	  (setf (component-reanalyze (block-component (node-block node))) t)
+	  (unlink-node node)))))
   (undefined-value))
 
 
@@ -1178,44 +1186,23 @@
 	 (fun (leaf-name (ref-leaf ref))))
     
     (multiple-value-bind (values win)
-			 (careful-call fun args call "constant folding")
-      (cond
-       ((not win)
-	(setf (combination-kind call) :error))
-       ;; X Always transform the call below so that non-flushable
-       ;; functions get flushed if the constant folding works.
-       #+nil
-       ((= (length values) 1)
-	(with-ir1-environment call
-	  (when (producing-fasl-file)
-	    (maybe-emit-make-load-forms (first values)))
-	  (let* ((leaf (find-constant (first values)))
-		 (node (make-ref (leaf-type leaf) leaf))
-		 (dummy (make-continuation))
-		 (cont (node-cont call))
-		 (block (node-block call))
-		 (next (continuation-next cont)))
-	    (push node (leaf-refs leaf))
-	    (setf (leaf-ever-used leaf) t)
-	    
-	    (delete-continuation-use call)
-	    (add-continuation-use call dummy)
-	    (prev-link node dummy)
-	    (add-continuation-use node cont)
-	    (setf (continuation-next cont) next)
-	    (when (eq call (block-last block))
-	      (setf (block-last block) node))
-	    (reoptimize-continuation cont))))
-       (t
-	(let ((dummies (loop repeat (length args)
-			     collect (gensym))))
-	  (transform-call
-	   call
-	   `(lambda ,dummies
-	      (declare (ignore ,@dummies))
-	      (values ,@(mapcar #'(lambda (x) `',x) values)))))))))
-  
-  (undefined-value))
+	(careful-call fun args call "constant folding")
+      (cond ((not win)
+	     (setf (combination-kind call) :error))
+	    ;;
+	    ;; Don't constand-fold a call if one of its arguments
+	    ;; requires a type check.
+	    ((or (policy call (< safety 3))
+		 (loop for arg in (basic-combination-args call)
+		       as check = (continuation-type-check arg)
+		       always (member check '(nil :deleted))))
+	     (let ((dummies (loop repeat (length args) collect (gensym))))
+	       (transform-call
+		call
+		`(lambda ,dummies
+		   (declare (ignore ,@dummies))
+		   (values ,@(mapcar (lambda (x) `',x) values)))))))))
+  (values))
 
 
 ;;;; Local call optimization: