X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f31fb9c4f853b77fb8c3014c03bd33c314b0c62a;hb=77af6d16968262049d6dadfb5521af7a8a7c6868;hp=0f0230270618d78e1b2fc5db0c6fdb604bed9f1d;hpb=913e06f191acb65c1d99d42234704bec38500ff4;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 0f02302..f31fb9c 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -22,48 +22,27 @@
 ;;; constant leaf.
 (defun constant-continuation-p (thing)
   (and (continuation-p thing)
-       (let ((use (continuation-use thing)))
-	 (and (ref-p use)
-	      (constant-p (ref-leaf use))))))
+       (let ((use (principal-continuation-use thing)))
+         (and (ref-p use) (constant-p (ref-leaf use))))))
 
 ;;; Return the constant value for a continuation whose only use is a
 ;;; constant node.
 (declaim (ftype (function (continuation) t) continuation-value))
 (defun continuation-value (cont)
-  (aver (constant-continuation-p cont))
-  (constant-value (ref-leaf (continuation-use cont))))
+  (let ((use (principal-continuation-use cont)))
+    (constant-value (ref-leaf use))))
 
 ;;;; interface for obtaining results of type inference
 
-;;; Return a (possibly values) type that describes what we have proven
-;;; about the type of Cont without taking any type assertions into
-;;; consideration. This is just the union of the NODE-DERIVED-TYPE of
-;;; all the uses. Most often people use CONTINUATION-DERIVED-TYPE or
-;;; CONTINUATION-TYPE instead of using this function directly.
-(defun continuation-proven-type (cont)
-  (declare (type continuation cont))
-  (ecase (continuation-kind cont)
-    ((:block-start :deleted-block-start)
-     (let ((uses (block-start-uses (continuation-block cont))))
-       (if uses
-	   (do ((res (node-derived-type (first uses))
-		     (values-type-union (node-derived-type (first current))
-					res))
-		(current (rest uses) (rest current)))
-	       ((null current) res))
-	   *empty-type*)))
-    (:inside-block
-     (node-derived-type (continuation-use cont)))))
-
 ;;; Our best guess for the type of this continuation's value. Note
-;;; that this may be Values or Function type, which cannot be passed
+;;; that this may be VALUES or FUNCTION type, which cannot be passed
 ;;; as an argument to the normal type operations. See
-;;; Continuation-Type. This may be called on deleted continuations,
+;;; CONTINUATION-TYPE. This may be called on deleted continuations,
 ;;; always returning *.
 ;;;
 ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the
 ;;; result is a subtype of the assertion. If so, return the proven
-;;; type and set TYPE-CHECK to nil. Otherwise, return the intersection
+;;; type and set TYPE-CHECK to NIL. Otherwise, return the intersection
 ;;; of the asserted and proven types, and set TYPE-CHECK T. If
 ;;; TYPE-CHECK already has a non-null value, then preserve it. Only in
 ;;; the somewhat unusual circumstance of a newly discovered assertion
@@ -76,41 +55,75 @@
 (defun continuation-derived-type (cont)
   (declare (type continuation cont))
   (or (continuation-%derived-type cont)
-      (%continuation-derived-type cont)))
+      (setf (continuation-%derived-type cont)
+            (%continuation-derived-type cont))))
 (defun %continuation-derived-type (cont)
   (declare (type continuation cont))
-  (let ((proven (continuation-proven-type cont))
-	(asserted (continuation-asserted-type cont)))
-    (cond ((values-subtypep proven asserted)
-	   (setf (continuation-%type-check cont) nil)
-	   (setf (continuation-%derived-type cont) proven))
-	  (t
-	   (unless (or (continuation-%type-check cont)
-		       (not (continuation-dest cont))
-		       (eq asserted *universal-type*))
-	     (setf (continuation-%type-check cont) t))
-
-	   (setf (continuation-%derived-type cont)
-		 (values-type-intersection asserted proven))))))
-
-;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to
-;;; date, then return it.
-#!-sb-fluid (declaim (inline continuation-type-check))
-(defun continuation-type-check (cont)
-  (declare (type continuation cont))
-  (continuation-derived-type cont)
-  (continuation-%type-check cont))
+  (ecase (continuation-kind cont)
+    ((:block-start :deleted-block-start)
+     (let ((uses (block-start-uses (continuation-block cont))))
+       (if uses
+	   (do ((res (node-derived-type (first uses))
+		     (values-type-union (node-derived-type (first current))
+					res))
+		(current (rest uses) (rest current)))
+	       ((null current) res))
+	   *empty-type*)))
+    (:inside-block
+     (node-derived-type (continuation-use cont)))))
 
 ;;; Return the derived type for CONT's first value. This is guaranteed
 ;;; not to be a VALUES or FUNCTION type.
-(declaim (ftype (function (continuation) ctype) continuation-type))
+(declaim (ftype (sfunction (continuation) ctype) continuation-type))
 (defun continuation-type (cont)
   (single-value-type (continuation-derived-type cont)))
+
+;;; If CONT is an argument of a function, return a type which the
+;;; function checks CONT for.
+#!-sb-fluid (declaim (inline continuation-externally-checkable-type))
+(defun continuation-externally-checkable-type (cont)
+  (or (continuation-%externally-checkable-type cont)
+      (%continuation-%externally-checkable-type cont)))
+(defun %continuation-%externally-checkable-type (cont)
+  (declare (type continuation cont))
+  (let ((dest (continuation-dest cont)))
+      (if (not (and dest (combination-p dest)))
+          ;; TODO: MV-COMBINATION
+          (setf (continuation-%externally-checkable-type cont) *wild-type*)
+          (let* ((fun (combination-fun dest))
+                 (args (combination-args dest))
+                 (fun-type (continuation-type fun)))
+            (setf (continuation-%externally-checkable-type fun) *wild-type*)
+            (if (or (not (fun-type-p fun-type))
+                    ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
+                    (fun-type-wild-args fun-type))
+                (progn (dolist (arg args)
+                         (when arg
+                           (setf (continuation-%externally-checkable-type arg)
+                                 *wild-type*)))
+                       *wild-type*)
+                (let* ((arg-types (append (fun-type-required fun-type)
+                                          (fun-type-optional fun-type)
+                                          (let ((rest (list (or (fun-type-rest fun-type)
+                                                                *wild-type*))))
+                                            (setf (cdr rest) rest)))))
+                  ;; TODO: &KEY
+                  (loop
+                     for arg of-type continuation in args
+                     and type of-type ctype in arg-types
+                     do (when arg
+                          (setf (continuation-%externally-checkable-type arg)
+                                (coerce-to-values type))))
+                  (continuation-%externally-checkable-type cont)))))))
+(declaim (inline flush-continuation-externally-checkable-type))
+(defun flush-continuation-externally-checkable-type (cont)
+  (declare (type continuation cont))
+  (setf (continuation-%externally-checkable-type cont) nil))
 
 ;;;; interface routines used by optimizers
 
 ;;; This function is called by optimizers to indicate that something
-;;; interesting has happened to the value of Cont. Optimizers must
+;;; interesting has happened to the value of CONT. Optimizers must
 ;;; make sure that they don't call for reoptimization when nothing has
 ;;; happened, since optimization will fail to terminate.
 ;;;
@@ -119,11 +132,11 @@
 ;;; is deleted (in which case we do nothing.)
 ;;;
 ;;; Since this can get called during IR1 conversion, we have to be
-;;; careful not to fly into space when the Dest's Prev is missing.
+;;; careful not to fly into space when the DEST's PREV is missing.
 (defun reoptimize-continuation (cont)
   (declare (type continuation cont))
+  (setf (continuation-%derived-type cont) nil)
   (unless (member (continuation-kind cont) '(:deleted :unused))
-    (setf (continuation-%derived-type cont) nil)
     (let ((dest (continuation-dest cont)))
       (when dest
 	(setf (continuation-reoptimize cont) t)
@@ -140,50 +153,72 @@
       (setf (block-type-check (node-block node)) t)))
   (values))
 
-;;; Annotate Node to indicate that its result has been proven to be
-;;; typep to RType. After IR1 conversion has happened, this is the
+(defun reoptimize-continuation-uses (cont)
+  (declare (type continuation cont))
+  (dolist (use (find-uses cont))
+    (setf (node-reoptimize use) t)
+    (setf (block-reoptimize (node-block use)) t)
+    (setf (component-reoptimize (node-component use)) t)))
+
+;;; Annotate NODE to indicate that its result has been proven to be
+;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the
 ;;; only correct way to supply information discovered about a node's
-;;; type. If you screw with the Node-Derived-Type directly, then
+;;; type. If you screw with the NODE-DERIVED-TYPE directly, then
 ;;; information may be lost and reoptimization may not happen.
 ;;;
-;;; What we do is intersect Rtype with Node's Derived-Type. If the
+;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
 ;;; intersection is different from the old type, then we do a
-;;; Reoptimize-Continuation on the Node-Cont.
+;;; REOPTIMIZE-CONTINUATION on the NODE-CONT.
 (defun derive-node-type (node rtype)
   (declare (type node node) (type ctype rtype))
   (let ((node-type (node-derived-type node)))
     (unless (eq node-type rtype)
-      (let ((int (values-type-intersection node-type rtype)))
+      (let ((int (values-type-intersection node-type rtype))
+            (cont (node-cont node)))
 	(when (type/= node-type int)
 	  (when (and *check-consistency*
 		     (eq int *empty-type*)
 		     (not (eq rtype *empty-type*)))
 	    (let ((*compiler-error-context* node))
-	      (compiler-warning
+	      (compiler-warn
 	       "New inferred type ~S conflicts with old type:~
-		~%  ~S~%*** Bug?"
+		~%  ~S~%*** possible internal error? Please report this."
 	       (type-specifier rtype) (type-specifier node-type))))
 	  (setf (node-derived-type node) int)
-	  (reoptimize-continuation (node-cont node))))))
+          (when (and (ref-p node)
+                     (lambda-var-p (ref-leaf node)))
+            (let ((type (single-value-type int)))
+              (when (and (member-type-p type)
+                         (null (rest (member-type-members type))))
+                (change-ref-leaf node (find-constant
+                                       (first (member-type-members type)))))))
+	  (reoptimize-continuation cont)))))
   (values))
 
 ;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
-;;; error for CONT's value not to be TYPEP to TYPE. If we improve the
-;;; assertion, we set TYPE-CHECK and TYPE-ASSERTED to guarantee that
-;;; the new assertion will be checked.
-(defun assert-continuation-type (cont type)
+;;; error for CONT's value not to be TYPEP to TYPE. We implement it
+;;; splitting off DEST a new CAST node. If we improve the assertion,
+;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
+;;; assertion will be checked. We return the new "argument"
+;;; continuation of DEST.
+(defun assert-continuation-type (cont type policy)
   (declare (type continuation cont) (type ctype type))
-  (let ((cont-type (continuation-asserted-type cont)))
-    (unless (eq cont-type type)
-      (let ((int (values-type-intersection cont-type type)))
-	(when (type/= cont-type int)
-	  (setf (continuation-asserted-type cont) int)
-	  (do-uses (node cont)
-	    (setf (block-attributep (block-flags (node-block node))
-				    type-check type-asserted)
-		  t))
-	  (reoptimize-continuation cont)))))
-  (values))
+  (if (values-subtypep (continuation-derived-type cont) type)
+      cont
+      (let* ((dest (continuation-dest cont))
+             (prev-cont (node-prev dest)))
+        (aver dest)
+        (with-ir1-environment-from-node dest
+          (let* ((cast (make-cast cont type policy))
+                 (checked-value (make-continuation)))
+            (setf (continuation-next prev-cont) cast
+                  (node-prev cast) prev-cont)
+            (use-continuation cast checked-value)
+            (link-node-to-previous-continuation dest checked-value)
+            (substitute-continuation checked-value cont)
+            (setf (continuation-dest cont) cast)
+            (reoptimize-continuation cont)
+            checked-value)))))
 
 ;;; Assert that CALL is to a function of the specified TYPE. It is
 ;;; assumed that the call is legal and has only constants in the
@@ -191,20 +226,21 @@
 (defun assert-call-type (call type)
   (declare (type combination call) (type fun-type type))
   (derive-node-type call (fun-type-returns type))
-  (let ((args (combination-args call)))
+  (let ((args (combination-args call))
+        (policy (lexenv-policy (node-lexenv call))))
     (dolist (req (fun-type-required type))
       (when (null args) (return-from assert-call-type))
       (let ((arg (pop args)))
-	(assert-continuation-type arg req)))
+	(assert-continuation-type arg req policy)))
     (dolist (opt (fun-type-optional type))
       (when (null args) (return-from assert-call-type))
       (let ((arg (pop args)))
-	(assert-continuation-type arg opt)))
+	(assert-continuation-type arg opt policy)))
 
     (let ((rest (fun-type-rest type)))
       (when rest
 	(dolist (arg args)
-	  (assert-continuation-type arg rest))))
+	  (assert-continuation-type arg rest policy))))
 
     (dolist (key (fun-type-keywords type))
       (let ((name (key-info-name key)))
@@ -212,7 +248,8 @@
 	    ((null arg))
 	  (when (eq (continuation-value (first arg)) name)
 	    (assert-continuation-type
-	     (second arg) (key-info-type key)))))))
+	     (second arg) (key-info-type key)
+             policy))))))
   (values))
 
 ;;;; IR1-OPTIMIZE
@@ -221,133 +258,151 @@
 ;;; and doing IR1 optimizations. We can ignore all blocks that don't
 ;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when
 ;;; we are done, then another iteration would be beneficial.
-;;;
-;;; We delete blocks when there is either no predecessor or the block
-;;; is in a lambda that has been deleted. These blocks would
-;;; eventually be deleted by DFO recomputation, but doing it here
-;;; immediately makes the effect available to IR1 optimization.
 (defun ir1-optimize (component)
   (declare (type component component))
   (setf (component-reoptimize component) nil)
   (do-blocks (block component)
     (cond
-     ((or (block-delete-p block)
-	  (null (block-pred block))
-	  (eq (functional-kind (block-home-lambda block)) :deleted))
-      (delete-block block))
-     (t
-      (loop
-	(let ((succ (block-succ block)))
-	  (unless (and succ (null (rest succ)))
-	    (return)))
-	
-	(let ((last (block-last block)))
-	  (typecase last
-	    (cif
-	     (flush-dest (if-test last))
-	     (when (unlink-node last)
-	       (return)))
-	    (exit
-	     (when (maybe-delete-exit last)
-	       (return)))))
-	
-	(unless (join-successor-if-possible block)
-	  (return)))
-
-      (when (and (block-reoptimize block) (block-component block))
-	(aver (not (block-delete-p block)))
-	(ir1-optimize-block block))
-
-      (when (and (block-flush-p block) (block-component block))
-	(aver (not (block-delete-p block)))
-	(flush-dead-code block)))))
+      ;; We delete blocks when there is either no predecessor or the
+      ;; block is in a lambda that has been deleted. These blocks
+      ;; would eventually be deleted by DFO recomputation, but doing
+      ;; it here immediately makes the effect available to IR1
+      ;; optimization.
+      ((or (block-delete-p block)
+           (null (block-pred block)))
+       (delete-block block))
+      ((eq (functional-kind (block-home-lambda block)) :deleted)
+       ;; Preserve the BLOCK-SUCC invariant that almost every block has
+       ;; one successor (and a block with DELETE-P set is an acceptable
+       ;; exception).
+       (mark-for-deletion block)
+       (delete-block block))
+      (t
+       (loop
+          (let ((succ (block-succ block)))
+            (unless (singleton-p succ)
+              (return)))
+
+          (let ((last (block-last block)))
+            (typecase last
+              (cif
+               (flush-dest (if-test last))
+               (when (unlink-node last)
+                 (return)))
+              (exit
+               (when (maybe-delete-exit last)
+                 (return)))))
+
+          (unless (join-successor-if-possible block)
+            (return)))
+
+       (when (and (block-reoptimize block) (block-component block))
+         (aver (not (block-delete-p block)))
+         (ir1-optimize-block block))
+
+       (cond ((and (block-delete-p block) (block-component block))
+              (delete-block block))
+             ((and (block-flush-p block) (block-component block))
+              (flush-dead-code block))))))
 
   (values))
 
-;;; Loop over the nodes in Block, looking for stuff that needs to be
-;;; optimized. We dispatch off of the type of each node with its
-;;; reoptimize flag set:
-
-;;; -- With a combination, we call Propagate-Function-Change whenever
-;;;    the function changes, and call IR1-Optimize-Combination if any
-;;;    argument changes.
-;;; -- With an Exit, we derive the node's type from the Value's type.
-;;;    We don't propagate Cont's assertion to the Value, since if we
-;;;    did, this would move the checking of Cont's assertion to the
-;;;    exit. This wouldn't work with Catch and UWP, where the Exit
-;;;    node is just a placeholder for the actual unknown exit.
+;;; Loop over the nodes in BLOCK, acting on (and clearing) REOPTIMIZE
+;;; flags.
 ;;;
-;;; Note that we clear the node & block reoptimize flags *before*
-;;; doing the optimization. This ensures that the node or block will
-;;; be reoptimized if necessary. We leave the NODE-OPTIMIZE flag set
-;;; going into IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
-;;; clear the flag itself.
+;;; Note that although they are cleared here, REOPTIMIZE flags might
+;;; still be set upon return from this function, meaning that further
+;;; optimization is wanted (as a consequence of optimizations we did).
 (defun ir1-optimize-block (block)
   (declare (type cblock block))
+  ;; We clear the node and block REOPTIMIZE flags before doing the
+  ;; optimization, not after. This ensures that the node or block will
+  ;; be reoptimized if necessary.
   (setf (block-reoptimize block) nil)
   (do-nodes (node cont block :restart-p t)
     (when (node-reoptimize node)
+      ;; As above, we clear the node REOPTIMIZE flag before optimizing.
       (setf (node-reoptimize node) nil)
       (typecase node
 	(ref)
 	(combination
+	 ;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever
+	 ;; the function changes, and call IR1-OPTIMIZE-COMBINATION if
+	 ;; any argument changes.
 	 (ir1-optimize-combination node))
 	(cif
 	 (ir1-optimize-if node))
 	(creturn
+	 ;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into
+	 ;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
+	 ;; clear the flag itself. -- WHN 2002-02-02, quoting original
+	 ;; CMU CL comments
 	 (setf (node-reoptimize node) t)
 	 (ir1-optimize-return node))
 	(mv-combination
 	 (ir1-optimize-mv-combination node))
 	(exit
+	 ;; With an EXIT, we derive the node's type from the VALUE's
+	 ;; type. We don't propagate CONT's assertion to the VALUE,
+	 ;; since if we did, this would move the checking of CONT's
+	 ;; assertion to the exit. This wouldn't work with CATCH and
+	 ;; UWP, where the EXIT node is just a placeholder for the
+	 ;; actual unknown exit.
 	 (let ((value (exit-value node)))
 	   (when value
 	     (derive-node-type node (continuation-derived-type value)))))
 	(cset
-	 (ir1-optimize-set node)))))
+	 (ir1-optimize-set node))
+        (cast
+         (ir1-optimize-cast node)))))
+
   (values))
 
-;;; We cannot combine with a successor block if:
-;;;  1. The successor has more than one predecessor.
-;;;  2. The last node's CONT is also used somewhere else.
-;;;  3. The successor is the current block (infinite loop).
-;;;  4. The next block has a different cleanup, and thus we may want 
-;;;     to insert cleanup code between the two blocks at some point.
-;;;  5. The next block has a different home lambda, and thus the
-;;;     control transfer is a non-local exit.
-;;;
-;;; If we succeed, we return true, otherwise false.
-;;;
-;;; Joining is easy when the successor's Start continuation is the
-;;; same from our Last's Cont. If they differ, then we can still join
-;;; when the last continuation has no next and the next continuation
-;;; has no uses. In this case, we replace the next continuation with
-;;; the last before joining the blocks.
+;;; Try to join with a successor block. If we succeed, we return true,
+;;; otherwise false.
 (defun join-successor-if-possible (block)
   (declare (type cblock block))
   (let ((next (first (block-succ block))))
-    (when (block-start next)
+    (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
       (let* ((last (block-last block))
 	     (last-cont (node-cont last))
 	     (next-cont (block-start next)))
-	(cond ((or (rest (block-pred next))
-		   (not (eq (continuation-use last-cont) last))
-		   (eq next block)
-		   (not (eq (block-end-cleanup block)
-			    (block-start-cleanup next)))
-		   (not (eq (block-home-lambda block)
-			    (block-home-lambda next))))
+	(cond (;; We cannot combine with a successor block if:
+	       (or
+		;; The successor has more than one predecessor.
+		(rest (block-pred next))
+		;; The last node's CONT is also used somewhere else.
+                ;; (as in (IF <cond> (M-V-PROG1 ...) (M-V-PROG1 ...)))
+		(not (eq (continuation-use last-cont) last))
+		;; The successor is the current block (infinite loop).
+		(eq next block)
+		;; The next block has a different cleanup, and thus
+		;; we may want to insert cleanup code between the
+		;; two blocks at some point.
+		(not (eq (block-end-cleanup block)
+			 (block-start-cleanup next)))
+		;; The next block has a different home lambda, and
+		;; thus the control transfer is a non-local exit.
+		(not (eq (block-home-lambda block)
+			 (block-home-lambda next))))
 	       nil)
+	      ;; Joining is easy when the successor's START
+	      ;; continuation is the same from our LAST's CONT.
 	      ((eq last-cont next-cont)
 	       (join-blocks block next)
 	       t)
+	      ;; If they differ, then we can still join when the last
+	      ;; continuation has no next and the next continuation
+	      ;; has no uses.
 	      ((and (null (block-start-uses next))
 		    (eq (continuation-kind last-cont) :inside-block))
+	       ;; In this case, we replace the next
+	       ;; continuation with the last before joining the blocks.
 	       (let ((next-node (continuation-next next-cont)))
-		 ;; If next-cont does have a dest, it must be
-		 ;; unreachable, since there are no uses.
+		 ;; If NEXT-CONT does have a dest, it must be
+		 ;; unreachable, since there are no USES.
 		 ;; DELETE-CONTINUATION will mark the dest block as
-		 ;; delete-p [and also this block, unless it is no
+		 ;; DELETE-P [and also this block, unless it is no
 		 ;; longer backward reachable from the dest block.]
 		 (delete-continuation next-cont)
 		 (setf (node-prev next-node) last-cont)
@@ -355,11 +410,23 @@
 		 (setf (block-start next) last-cont)
 		 (join-blocks block next))
 	       t)
+              ((and (null (block-start-uses next))
+                    (not (typep (continuation-dest last-cont)
+                                '(or exit creturn)))
+                    (null (continuation-lexenv-uses last-cont)))
+               (assert (null (find-uses next-cont)))
+               (when (continuation-dest last-cont)
+                 (substitute-continuation next-cont last-cont))
+               (delete-continuation-use last)
+               (add-continuation-use last next-cont)
+               (setf (continuation-%derived-type next-cont) nil)
+               (join-blocks block next)
+               t)
 	      (t
 	       nil))))))
 
 ;;; Join together two blocks which have the same ending/starting
-;;; continuation. The code in Block2 is moved into Block1 and Block2
+;;; continuation. The code in BLOCK2 is moved into BLOCK1 and BLOCK2
 ;;; is deleted from the DFO. We combine the optimize flags for the two
 ;;; blocks so that any indicated optimization gets done.
 (defun join-blocks (block1 block2)
@@ -394,13 +461,9 @@
 
   (values))
 
-;;; Delete any nodes in BLOCK whose value is unused and have no
-;;; side-effects. We can delete sets of lexical variables when the set
+;;; Delete any nodes in BLOCK whose value is unused and which have no
+;;; side effects. We can delete sets of lexical variables when the set
 ;;; variable has no references.
-;;;
-;;; [### For now, don't delete potentially flushable calls when they
-;;; have the CALL attribute. Someday we should look at the funcitonal
-;;; args to determine if they have any side-effects.]
 (defun flush-dead-code (block)
   (declare (type cblock block))
   (do-nodes-backwards (node cont block)
@@ -411,14 +474,18 @@
 	 (unlink-node node))
 	(combination
 	 (let ((info (combination-kind node)))
-	   (when (function-info-p info)
-	     (let ((attr (function-info-attributes info)))
-	       (when (and (ir1-attributep attr flushable)
-			  (not (ir1-attributep attr call)))
-		 (flush-dest (combination-fun node))
-		 (dolist (arg (combination-args node))
-		   (flush-dest arg))
-		 (unlink-node node))))))
+	   (when (fun-info-p info)
+	     (let ((attr (fun-info-attributes info)))
+	       (when (and (not (ir1-attributep attr call))
+			  ;; ### For now, don't delete potentially
+			  ;; flushable calls when they have the CALL
+			  ;; attribute. Someday we should look at the
+			  ;; functional args to determine if they have
+			  ;; any side effects.
+                          (if (policy node (= safety 3))
+                              (ir1-attributep attr flushable)
+                              (ir1-attributep attr unsafely-flushable)))
+                 (flush-combination node))))))
 	(mv-combination
 	 (when (eq (basic-combination-kind node) :local)
 	   (let ((fun (combination-lambda node)))
@@ -440,7 +507,11 @@
 	     (flush-dest (set-value node))
 	     (setf (basic-var-sets var)
 		   (delete node (basic-var-sets var)))
-	     (unlink-node node)))))))
+	     (unlink-node node))))
+        (cast
+         (unless (cast-type-check node)
+           (flush-dest (cast-value node))
+           (unlink-node node))))))
 
   (setf (block-flush-p block) nil)
   (values))
@@ -476,9 +547,12 @@
 		   (return-from find-result-type (values)))))
 	      (t
 	       (use-union (node-derived-type use)))))
-      (let ((int (values-type-intersection
-		  (continuation-asserted-type result)
-		  (use-union))))
+      (let ((int
+             ;; (values-type-intersection
+             ;; (continuation-asserted-type result) ; FIXME -- APD, 2002-01-26
+             (use-union)
+              ;; )
+            ))
 	(setf (return-result-type node) int))))
   (values))
 
@@ -487,7 +561,7 @@
 ;;; all functions in the tail set to be equivalent, this amounts to
 ;;; bringing the entire tail set up to date. We iterate over the
 ;;; returns for all the functions in the tail set, reanalyzing them
-;;; all (not treating Node specially.)
+;;; all (not treating NODE specially.)
 ;;;
 ;;; When we are done, we check whether the new type is different from
 ;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
@@ -497,7 +571,7 @@
 (defun ir1-optimize-return (node)
   (declare (type creturn node))
   (let* ((tails (lambda-tail-set (return-lambda node)))
-	 (funs (tail-set-functions tails)))
+	 (funs (tail-set-funs tails)))
     (collect ((res *empty-type* values-type-union))
       (dolist (fun funs)
 	(let ((return (lambda-return fun)))
@@ -509,7 +583,7 @@
 
       (when (type/= (res) (tail-set-type tails))
 	(setf (tail-set-type tails) (res))
-	(dolist (fun (tail-set-functions tails))
+	(dolist (fun (tail-set-funs tails))
 	  (dolist (ref (leaf-refs fun))
 	    (reoptimize-continuation (node-cont ref)))))))
 
@@ -535,26 +609,26 @@
 	  (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-equal-or-intersect type (specifier-type 'null)))
-		   (if-alternative node))
-		  ((type= type (specifier-type 'null))
-		   (if-consequent node)))))
+           (victim
+            (cond ((constant-continuation-p test)
+                   (if (continuation-value test)
+                       (if-alternative node)
+                       (if-consequent node)))
+                  ((not (types-equal-or-intersect type (specifier-type 'null)))
+                   (if-alternative node))
+                  ((type= type (specifier-type 'null))
+                   (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))))
+        (flush-dest test)
+        (when (rest (block-succ block))
+          (unlink-blocks block victim))
+        (setf (component-reanalyze (node-component node)) t)
+        (unlink-node node))))
   (values))
 
-;;; Create a new copy of an IF Node that tests the value of the node
-;;; Use. The test must have >1 use, and must be immediately used by
-;;; Use. Node must be the only node in its block (implying that
+;;; Create a new copy of an IF node that tests the value of the node
+;;; USE. The test must have >1 use, and must be immediately used by
+;;; USE. NODE must be the only node in its block (implying that
 ;;; block-start = if-test).
 ;;;
 ;;; This optimization has an effect semantically similar to the
@@ -568,7 +642,7 @@
 ;;; become unreachable, resulting in a spurious note.
 (defun convert-if-if (use node)
   (declare (type node use) (type cif node))
-  (with-ir1-environment node
+  (with-ir1-environment-from-node node
     (let* ((block (node-block node))
 	   (test (if-test node))
 	   (cblock (if-consequent node))
@@ -580,8 +654,9 @@
 			      :consequent cblock
 			      :alternative ablock))
 	   (new-block (continuation-starts-block new-cont)))
-      (prev-link new-node new-cont)
+      (link-node-to-previous-continuation new-node new-cont)
       (setf (continuation-dest new-cont) new-node)
+      (flush-continuation-externally-checkable-type new-cont)
       (add-continuation-use new-node dummy-cont)
       (setf (block-last new-block) new-node)
 
@@ -605,9 +680,9 @@
 
 ;;; This function attempts to delete an exit node, returning true if
 ;;; it deletes the block as a consequence:
-;;; -- If the exit is degenerate (has no Entry), then we don't do
+;;; -- If the exit is degenerate (has no ENTRY), then we don't do
 ;;;    anything, since there is nothing to be done.
-;;; -- If the exit node and its Entry have the same home lambda then
+;;; -- If the exit node and its ENTRY have the same home lambda then
 ;;;    we know the exit is local, and can delete the exit. We change
 ;;;    uses of the Exit-Value to be uses of the original continuation,
 ;;;    then unlink the node. If the exit is to a TR context, then we
@@ -623,22 +698,14 @@
   (declare (type exit node))
   (let ((value (exit-value node))
 	(entry (exit-entry node))
-	(cont (node-cont node)))
+        (cont (node-cont node)))
     (when (and entry
 	       (eq (node-home-lambda node) (node-home-lambda entry)))
       (setf (entry-exits entry) (delete node (entry-exits entry)))
-      (prog1
-	  (unlink-node node)
-	(when value
-	  (collect ((merges))
-	    (when (return-p (continuation-dest cont))
-	      (do-uses (use value)
-		(when (and (basic-combination-p use)
-			   (eq (basic-combination-kind use) :local))
-		  (merges use))))
-	    (substitute-continuation-uses cont value)
-	    (dolist (merge (merges))
-	      (merge-tail-sets merge))))))))
+      (if value
+          (delete-filter node cont value)
+          (unlink-node node)))))
+
 
 ;;;; combination IR1 optimization
 
@@ -650,7 +717,7 @@
 (declaim (ftype (function (combination) (values)) ir1-optimize-combination))
 (defun ir1-optimize-combination (node)
   (when (continuation-reoptimize (basic-combination-fun node))
-    (propagate-function-change node))
+    (propagate-fun-change node))
   (let ((args (basic-combination-args node))
 	(kind (basic-combination-kind node)))
     (case kind
@@ -668,7 +735,7 @@
 	 (when arg
 	   (setf (continuation-reoptimize arg) nil)))
 
-       (let ((attr (function-info-attributes kind)))
+       (let ((attr (fun-info-attributes kind)))
 	 (when (and (ir1-attributep attr foldable)
 		    ;; KLUDGE: The next test could be made more sensitive,
 		    ;; only suppressing constant-folding of functions with
@@ -686,23 +753,25 @@
 		    ;; cross-compiler can't fold it because the
 		    ;; cross-compiler doesn't know how to evaluate it.
 		    #+sb-xc-host
-		    (let* ((ref (continuation-use (combination-fun node)))
-			   (fun (leaf-name (ref-leaf ref))))
-		      (fboundp fun)))
+		    (or (fboundp (combination-fun-source-name node))
+                        (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
+                                       (combination-fun-source-name node)
+                                       (mapcar #'continuation-value args))
+                               nil)))
 	   (constant-fold-call node)
 	   (return-from ir1-optimize-combination)))
 
-       (let ((fun (function-info-derive-type kind)))
+       (let ((fun (fun-info-derive-type kind)))
 	 (when fun
 	   (let ((res (funcall fun node)))
 	     (when res
-	       (derive-node-type node res)
+	       (derive-node-type node (coerce-to-values res))
 	       (maybe-terminate-block node nil)))))
 
-       (let ((fun (function-info-optimizer kind)))
+       (let ((fun (fun-info-optimizer kind)))
 	 (unless (and fun (funcall fun node))
-	   (dolist (x (function-info-transforms kind))
-	     #!+sb-show 
+	   (dolist (x (fun-info-transforms kind))
+	     #!+sb-show
 	     (when *show-transforms-p*
 	       (let* ((cont (basic-combination-fun node))
 		      (fname (continuation-fun-name cont t)))
@@ -715,51 +784,54 @@
 
   (values))
 
-;;; If Call is to a function that doesn't return (i.e. return type is
-;;; NIL), then terminate the block there, and link it to the component
-;;; tail. We also change the call's CONT to be a dummy continuation to
-;;; prevent the use from confusing things.
+;;; If NODE doesn't return (i.e. return type is NIL), then terminate
+;;; the block there, and link it to the component tail. We also change
+;;; the NODE's CONT to be a dummy continuation to prevent the use from
+;;; confusing things.
 ;;;
-;;; Except when called during IR1, we delete the continuation if it
-;;; has no other uses. (If it does have other uses, we reoptimize.)
+;;; Except when called during IR1 convertion, we delete the
+;;; continuation if it has no other uses. (If it does have other uses,
+;;; we reoptimize.)
 ;;;
-;;; Termination on the basis of a continuation type assertion is
+;;; Termination on the basis of a continuation type is
 ;;; inhibited when:
 ;;; -- The continuation is deleted (hence the assertion is spurious), or
 ;;; -- We are in IR1 conversion (where THE assertions are subject to
-;;;    weakening.)
-(defun maybe-terminate-block (call ir1-p)
-  (declare (type basic-combination call))
-  (let* ((block (node-block call))
-	 (cont (node-cont call))
+;;;    weakening.) FIXME: Now THE assertions are not weakened, but new
+;;;    uses can(?) be added later. -- APD, 2003-07-17
+(defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
+  (declare (type (or basic-combination cast) node))
+  (let* ((block (node-block node))
+	 (cont (node-cont node))
 	 (tail (component-tail (block-component block)))
 	 (succ (first (block-succ block))))
-    (unless (or (and (eq call (block-last block)) (eq succ tail))
+    (unless (or (and (eq node (block-last block)) (eq succ tail))
 		(block-delete-p block))
-      (when (or (and (eq (continuation-asserted-type cont) *empty-type*)
-		     (not (or ir1-p (eq (continuation-kind cont) :deleted))))
-		(eq (node-derived-type call) *empty-type*))
-	(cond (ir1-p
-	       (delete-continuation-use call)
+      (when (or (and (not (or ir1-converting-not-optimizing-p
+			      (eq (continuation-kind cont) :deleted)))
+		     (eq (continuation-derived-type cont) *empty-type*))
+		(eq (node-derived-type node) *empty-type*))
+	(cond (ir1-converting-not-optimizing-p
+	       (delete-continuation-use node)
 	       (cond
 		((block-last block)
-		 (aver (and (eq (block-last block) call)
+		 (aver (and (eq (block-last block) node)
 			    (eq (continuation-kind cont) :block-start))))
 		(t
-		 (setf (block-last block) call)
+		 (setf (block-last block) node)
 		 (link-blocks block (continuation-starts-block cont)))))
 	      (t
-	       (node-ends-block call)
-	       (delete-continuation-use call)
+	       (node-ends-block node)
+	       (delete-continuation-use node)
 	       (if (eq (continuation-kind cont) :unused)
 		   (delete-continuation cont)
 		   (reoptimize-continuation cont))))
-	
+
 	(unlink-blocks block (first (block-succ block)))
 	(setf (component-reanalyze (block-component block)) t)
 	(aver (not (block-succ block)))
 	(link-blocks block tail)
-	(add-continuation-use call (make-continuation))
+	(add-continuation-use node (make-continuation))
 	t))))
 
 ;;; This is called both by IR1 conversion and IR1 optimization when
@@ -771,20 +843,15 @@
 ;;;    the expansion and change the call to call it. Expansion is
 ;;;    enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is
 ;;;    true, we never expand, since this function has already been
-;;;    converted. Local call analysis will duplicate the definition if
-;;;    necessary. We claim that the parent form is LABELS for context
-;;;    declarations, since we don't want it to be considered a real
-;;;    global function.
-;;; -- In addition to a direct check for the function name in the
-;;;    table, we also must check for slot accessors. If the function
-;;;    is a slot accessor, then we set the combination kind to the
-;;;    function info of %Slot-Setter or %Slot-Accessor, as
-;;;    appropriate.
+;;;    converted. Local call analysis will duplicate the definition
+;;;    if necessary. We claim that the parent form is LABELS for
+;;;    context declarations, since we don't want it to be considered
+;;;    a real global function.
 ;;; -- If it is a known function, mark it as such by setting the KIND.
 ;;;
 ;;; We return the leaf referenced (NIL if not a leaf) and the
-;;; FUNCTION-INFO assigned.
-(defun recognize-known-call (call ir1-p)
+;;; FUN-INFO assigned.
+(defun recognize-known-call (call ir1-converting-not-optimizing-p)
   (declare (type combination call))
   (let* ((ref (continuation-use (basic-combination-fun call)))
 	 (leaf (when (ref-p ref) (ref-leaf ref)))
@@ -800,34 +867,32 @@
 	     (:inline t)
 	     (:no-chance nil)
 	     ((nil :maybe-inline) (policy call (zerop space))))
+	   (defined-fun-p leaf)
 	   (defined-fun-inline-expansion leaf)
 	   (let ((fun (defined-fun-functional leaf)))
 	     (or (not fun)
 		 (and (eq inlinep :inline) (functional-kind fun))))
 	   (inline-expansion-ok call))
-      (flet ((frob ()
+      (flet (;; FIXME: Is this what the old CMU CL internal documentation
+	     ;; called semi-inlining? A more descriptive name would
+	     ;; be nice. -- WHN 2002-01-07
+	     (frob ()
 	       (let ((res (ir1-convert-lambda-for-defun
 			   (defined-fun-inline-expansion leaf)
 			   leaf t
 			   #'ir1-convert-inline-lambda)))
 		 (setf (defined-fun-functional leaf) res)
 		 (change-ref-leaf ref res))))
-	(if ir1-p
+	(if ir1-converting-not-optimizing-p
 	    (frob)
-	    (with-ir1-environment call
+	    (with-ir1-environment-from-node call
 	      (frob)
-	      (local-call-analyze *current-component*))))
+	      (locall-analyze-component *current-component*))))
 
       (values (ref-leaf (continuation-use (basic-combination-fun call)))
 	      nil))
      (t
-      (let* ((name (leaf-name leaf))
-	     (info (info :function :info
-			 (if (slot-accessor-p leaf)
-			   (if (consp name)
-			     '%slot-setter
-			     '%slot-accessor)
-			   name))))
+      (let ((info (info :function :info (leaf-source-name leaf))))
 	(if info
 	    (values leaf (setf (basic-combination-kind call) info))
 	    (values leaf nil)))))))
@@ -839,49 +904,49 @@
 ;;; syntax check, arg/result type processing, but still call
 ;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
 ;;; and that checking is done by local call analysis.
-(defun validate-call-type (call type ir1-p)
+(defun validate-call-type (call type ir1-converting-not-optimizing-p)
   (declare (type combination call) (type ctype type))
   (cond ((not (fun-type-p type))
 	 (aver (multiple-value-bind (val win)
 		   (csubtypep type (specifier-type 'function))
 		 (or val (not win))))
-	 (recognize-known-call call ir1-p))
-	((valid-function-use call type
-			     :argument-test #'always-subtypep
-			     :result-test #'always-subtypep
-			     ;; KLUDGE: Common Lisp is such a dynamic
-			     ;; language that all we can do here in
-			     ;; general is issue a STYLE-WARNING. It
-			     ;; would be nice to issue a full WARNING
-			     ;; in the special case of of type
-			     ;; mismatches within a compilation unit
-			     ;; (as in section 3.2.2.3 of the spec)
-			     ;; but at least as of sbcl-0.6.11, we
-			     ;; don't keep track of whether the
-			     ;; mismatched data came from the same
-			     ;; compilation unit, so we can't do that.
-			     ;; -- WHN 2001-02-11
-			     ;;
-			     ;; FIXME: Actually, I think we could
-			     ;; issue a full WARNING if the call
-			     ;; violates a DECLAIM FTYPE.
-			     :error-function #'compiler-style-warning
-			     :warning-function #'compiler-note)
+	 (recognize-known-call call ir1-converting-not-optimizing-p))
+	((valid-fun-use call type
+			:argument-test #'always-subtypep
+			:result-test #'always-subtypep
+			;; KLUDGE: Common Lisp is such a dynamic
+			;; language that all we can do here in
+			;; general is issue a STYLE-WARNING. It
+			;; would be nice to issue a full WARNING
+			;; in the special case of of type
+			;; mismatches within a compilation unit
+			;; (as in section 3.2.2.3 of the spec)
+			;; but at least as of sbcl-0.6.11, we
+			;; don't keep track of whether the
+			;; mismatched data came from the same
+			;; compilation unit, so we can't do that.
+			;; -- WHN 2001-02-11
+			;;
+			;; FIXME: Actually, I think we could
+			;; issue a full WARNING if the call
+			;; violates a DECLAIM FTYPE.
+			:lossage-fun #'compiler-style-warn
+			:unwinnage-fun #'compiler-notify)
 	 (assert-call-type call type)
-	 (maybe-terminate-block call ir1-p)
-	 (recognize-known-call call ir1-p))
+	 (maybe-terminate-block call ir1-converting-not-optimizing-p)
+	 (recognize-known-call call ir1-converting-not-optimizing-p))
 	(t
 	 (setf (combination-kind call) :error)
 	 (values nil nil))))
 
 ;;; This is called by IR1-OPTIMIZE when the function for a call has
-;;; changed. If the call is local, we try to let-convert it, and
+;;; changed. If the call is local, we try to LET-convert it, and
 ;;; derive the result type. If it is a :FULL call, we validate it
 ;;; against the type, which recognizes known calls, does inline
 ;;; expansion, etc. If a call to a predicate in a non-conditional
 ;;; position or to a function with a source transform, then we
 ;;; reconvert the form to give IR1 another chance.
-(defun propagate-function-change (call)
+(defun propagate-fun-change (call)
   (declare (type combination call))
   (let ((*compiler-error-context* call)
 	(fun-cont (basic-combination-fun call)))
@@ -900,19 +965,23 @@
 		 (continuation-use (basic-combination-fun call))
 		 call))
 	       ((not leaf))
-	       ((or (info :function :source-transform (leaf-name leaf))
-		    (and info
-			 (ir1-attributep (function-info-attributes info)
-					 predicate)
-			 (let ((dest (continuation-dest (node-cont call))))
-			   (and dest (not (if-p dest))))))
-		(let ((name (leaf-name leaf)))
-		  (when (symbolp name)
-		    (let ((dums (make-gensym-list (length
-						   (combination-args call)))))
-		      (transform-call call
-				      `(lambda ,dums
-					 (,name ,@dums))))))))))))
+	       ((and (leaf-has-source-name-p leaf)
+                     (or (info :function :source-transform (leaf-source-name leaf))
+                         (and info
+                              (ir1-attributep (fun-info-attributes info)
+                                              predicate)
+                              (let ((dest (continuation-dest (node-cont call))))
+                                (and dest (not (if-p dest)))))))
+		(let ((name (leaf-source-name leaf))
+                      (dummies (make-gensym-list
+                                (length (combination-args call)))))
+                  (transform-call call
+                                  `(lambda ,dummies
+                                     (,@(if (symbolp name)
+                                            `(,name)
+                                            `(funcall #',name))
+                                        ,@dummies))
+                                  (leaf-source-name leaf)))))))))
   (values))
 
 ;;;; known function optimization
@@ -947,24 +1016,13 @@
 		    (policy node (>= speed inhibit-warnings))
 		    (policy node (> speed inhibit-warnings))))
 	 (*compiler-error-context* node))
-    (cond ((not (member (transform-when transform)
-			'(:native :both)))
-	   ;; FIXME: Make sure that there's a transform for
-	   ;; (MEMBER SYMBOL ..) into MEMQ.
-	   ;; FIXME: Note that when/if I make SHARE operation to shared
-	   ;; constant data between objects in the system, remember that a
-	   ;; SHAREd list, or other SHAREd compound object, can be processed
-	   ;; recursively, so that e.g. the two lists above can share their
-	   ;; '(:BOTH) tail sublists.
-	   (let ((when (transform-when transform)))
-	     (not (or (eq when :both)
-		      (eq when :native))))
-	   t)
-	  ((or (not constrained)
-	       (valid-function-use node type :strict-result t))
+    (cond ((or (not constrained)
+	       (valid-fun-use node type))
 	   (multiple-value-bind (severity args)
 	       (catch 'give-up-ir1-transform
-		 (transform-call node (funcall fun node))
+		 (transform-call node
+				 (funcall fun node)
+				 (combination-fun-source-name node))
 		 (values :none nil))
 	     (ecase severity
 	       (:none
@@ -973,7 +1031,7 @@
 	       (:aborted
 		(setf (combination-kind node) :error)
 		(when args
-		  (apply #'compiler-warning args))
+		  (apply #'compiler-warn args))
 		(remhash node table)
 		nil)
 	       (:failure
@@ -987,11 +1045,10 @@
                  (remhash node table)
                  nil))))
 	  ((and flame
-		(valid-function-use node
-				    type
-				    :argument-test #'types-equal-or-intersect
-				    :result-test
-				    #'values-types-equal-or-intersect))
+		(valid-fun-use node
+			       type
+			       :argument-test #'types-equal-or-intersect
+			       :result-test #'values-types-equal-or-intersect))
 	   (record-optimization-failure node transform type)
 	   t)
 	  (t
@@ -1061,48 +1118,115 @@
  		(setf (component-reoptimize (block-component block)) t)))))))
     reoptimize))
 
-
 ;;; Take the lambda-expression RES, IR1 convert it in the proper
 ;;; environment, and then install it as the function for the call
 ;;; NODE. We do local call analysis so that the new function is
 ;;; integrated into the control flow.
-(defun transform-call (node res)
-  (declare (type combination node) (list res))
-  (with-ir1-environment node
-    (let ((new-fun (ir1-convert-inline-lambda res))
-	  (ref (continuation-use (combination-fun node))))
-      (change-ref-leaf ref new-fun)
-      (setf (combination-kind node) :full)
-      (local-call-analyze *current-component*)))
+;;;
+;;; We require the original function source name in order to generate
+;;; a meaningful debug name for the lambda we set up. (It'd be
+;;; possible to do this starting from debug names as well as source
+;;; names, but as of sbcl-0.7.1.5, there was no need for this
+;;; generality, since source names are always known to our callers.)
+(defun transform-call (call res source-name)
+  (declare (type combination call) (list res))
+  (aver (and (legal-fun-name-p source-name)
+	     (not (eql source-name '.anonymous.))))
+  (node-ends-block call)
+  (with-ir1-environment-from-node call
+    (with-component-last-block (*current-component*
+                                (block-next (node-block call)))
+      (let ((new-fun (ir1-convert-inline-lambda
+		      res
+		      :debug-name (debug-namify "LAMBDA-inlined ~A"
+						(as-debug-name
+						 source-name
+						 "<unknown function>"))))
+	    (ref (continuation-use (combination-fun call))))
+	(change-ref-leaf ref new-fun)
+	(setf (combination-kind call) :full)
+	(locall-analyze-component *current-component*))))
   (values))
 
 ;;; Replace a call to a foldable function of constant arguments with
-;;; the result of evaluating the form. We insert the resulting
-;;; constant node after the call, stealing the call's continuation. We
-;;; give the call a continuation with no Dest, which should cause it
-;;; and its arguments to go away. If there is an error during the
+;;; the result of evaluating the form. If there is an error during the
 ;;; evaluation, we give a warning and leave the call alone, making the
 ;;; call a :ERROR call.
 ;;;
 ;;; If there is more than one value, then we transform the call into a
-;;; values form.
+;;; VALUES form.
+;;;
+;;; An old commentary also said:
+;;;
+;;;   We insert the resulting constant node after the call, stealing
+;;;   the call's continuation. We give the call a continuation with no
+;;;   DEST, which should cause it and its arguments to go away.
+;;;
+;;; This seems to be more efficient, than the current code. Maybe we
+;;; should really implement it? -- APD, 2002-12-23
 (defun constant-fold-call (call)
-  (declare (type combination call))
-  (let* ((args (mapcar #'continuation-value (combination-args call)))
-	 (ref (continuation-use (combination-fun call)))
-	 (fun (leaf-name (ref-leaf ref))))
-
+  (let ((args (mapcar #'continuation-value (combination-args call)))
+	(fun-name (combination-fun-source-name call)))
     (multiple-value-bind (values win)
-	(careful-call fun args call "constant folding")
-      (if (not win)
-	(setf (combination-kind call) :error)
-	(let ((dummies (make-gensym-list (length args))))
-	  (transform-call
-	   call
-	   `(lambda ,dummies
-	      (declare (ignore ,@dummies))
-	      (values ,@(mapcar #'(lambda (x) `',x) values))))))))
-
+	(careful-call fun-name
+		      args
+		      call
+		      ;; Note: CMU CL had COMPILER-WARN here, and that
+		      ;; seems more natural, but it's probably not.
+		      ;;
+		      ;; It's especially not while bug 173 exists:
+		      ;; Expressions like
+		      ;;   (COND (END
+		      ;;          (UNLESS (OR UNSAFE? (<= END SIZE)))
+		      ;;            ...))
+		      ;; can cause constant-folding TYPE-ERRORs (in
+		      ;; #'<=) when END can be proved to be NIL, even
+		      ;; though the code is perfectly legal and safe
+		      ;; because a NIL value of END means that the
+		      ;; #'<= will never be executed.
+		      ;;
+		      ;; Moreover, even without bug 173,
+		      ;; quite-possibly-valid code like
+		      ;;   (COND ((NONINLINED-PREDICATE END)
+		      ;;          (UNLESS (<= END SIZE))
+		      ;;            ...))
+		      ;; (where NONINLINED-PREDICATE is something the
+		      ;; compiler can't do at compile time, but which
+		      ;; turns out to make the #'<= expression
+		      ;; unreachable when END=NIL) could cause errors
+		      ;; when the compiler tries to constant-fold (<=
+		      ;; END SIZE).
+		      ;;
+		      ;; So, with or without bug 173, it'd be
+		      ;; unnecessarily evil to do a full
+		      ;; COMPILER-WARNING (and thus return FAILURE-P=T
+		      ;; from COMPILE-FILE) for legal code, so we we
+		      ;; use a wimpier COMPILE-STYLE-WARNING instead.
+		      #'compiler-style-warn
+		      "constant folding")
+      (cond ((not win)
+             (setf (combination-kind call) :error))
+            ((and (proper-list-of-length-p values 1)
+                  (eq (continuation-kind (node-cont call)) :inside-block))
+             (with-ir1-environment-from-node call
+               (let* ((cont (node-cont call))
+                      (next (continuation-next cont))
+                      (prev (make-continuation)))
+                 (delete-continuation-use call)
+                 (add-continuation-use call prev)
+                 (reference-constant prev cont (first values))
+                 (setf (continuation-next cont) next)
+                 ;; FIXME: type checking?
+                 (reoptimize-continuation cont)
+                 (reoptimize-continuation prev)
+                 (flush-combination call))))
+            (t (let ((dummies (make-gensym-list (length args))))
+                 (transform-call
+                  call
+                  `(lambda ,dummies
+                     (declare (ignore ,@dummies))
+                     (values ,@(mapcar (lambda (x) `',x) values)))
+                  fun-name))))))
   (values))
 
 ;;;; local call optimization
@@ -1119,18 +1243,82 @@
 	(when (type/= int var-type)
 	  (setf (leaf-type leaf) int)
 	  (dolist (ref (leaf-refs leaf))
-	    (derive-node-type ref int))))
+	    (derive-node-type ref (make-single-value-type int))
+            (let* ((cont (node-cont ref))
+                   (dest (continuation-dest cont)))
+              ;; KLUDGE: LET var substitution
+              (when (combination-p dest)
+                (reoptimize-continuation cont))))))
       (values))))
 
+;;; Iteration variable: exactly one SETQ of the form:
+;;;
+;;; (let ((var initial))
+;;;   ...
+;;;   (setq var (+ var step))
+;;;   ...)
+(defun maybe-infer-iteration-var-type (var initial-type)
+  (binding* ((sets (lambda-var-sets var) :exit-if-null)
+             (set (first sets))
+             (() (null (rest sets)) :exit-if-null)
+             (set-use (principal-continuation-use (set-value set)))
+             (() (and (combination-p set-use)
+                      (fun-info-p (combination-kind set-use))
+                      (eq (combination-fun-source-name set-use) '+))
+               :exit-if-null)
+             (+-args (basic-combination-args set-use))
+             (() (and (proper-list-of-length-p +-args 2 2)
+                      (let ((first (principal-continuation-use
+                                    (first +-args))))
+                        (and (ref-p first)
+                             (eq (ref-leaf first) var))))
+               :exit-if-null)
+             (step-type (continuation-type (second +-args))))
+    (when (and (numeric-type-p initial-type)
+               (numeric-type-p step-type)
+               (eq (numeric-type-class initial-type)
+                   (numeric-type-class step-type))
+               (eq (numeric-type-format initial-type)
+                   (numeric-type-format step-type))
+               (eq (numeric-type-complexp initial-type)
+                   (numeric-type-complexp step-type)))
+      (multiple-value-bind (low high)
+          (cond ((csubtypep step-type (specifier-type '(real 0 *)))
+                 (values (numeric-type-low initial-type) nil))
+                ((csubtypep step-type (specifier-type '(real * 0)))
+                 (values nil (numeric-type-high initial-type)))
+                (t
+                 (values nil nil)))
+        (modified-numeric-type initial-type
+                               :low low
+                               :high high
+                               :enumerable nil)))))
+(deftransform + ((x y) * * :result result)
+  "check for iteration variable reoptimization"
+  (let ((dest (principal-continuation-end result))
+        (use (principal-continuation-use x)))
+    (when (and (ref-p use)
+               (set-p dest)
+               (eq (ref-leaf use)
+                   (set-var dest)))
+      (reoptimize-continuation (set-value dest))))
+  (give-up-ir1-transform))
+
 ;;; Figure out the type of a LET variable that has sets. We compute
-;;; the union of the initial value Type and the types of all the set
+;;; the union of the INITIAL-TYPE and the types of all the set
 ;;; values and to a PROPAGATE-TO-REFS with this type.
-(defun propagate-from-sets (var type)
-  (collect ((res type type-union))
+(defun propagate-from-sets (var initial-type)
+  (collect ((res initial-type type-union))
     (dolist (set (basic-var-sets var))
-      (res (continuation-type (set-value set)))
-      (setf (node-reoptimize set) nil))
-    (propagate-to-refs var (res)))
+      (let ((type (continuation-type (set-value set))))
+        (res type)
+        (when (node-reoptimize set)
+          (derive-node-type set (make-single-value-type type))
+          (setf (node-reoptimize set) nil))))
+    (let ((res (res)))
+      (awhen (maybe-infer-iteration-var-type var initial-type)
+        (setq res (type-intersection res it)))
+      (propagate-to-refs var res)))
   (values))
 
 ;;; If a LET variable, find the initial value's type and do
@@ -1142,14 +1330,16 @@
     (when (and (lambda-var-p var) (leaf-refs var))
       (let ((home (lambda-var-home var)))
 	(when (eq (functional-kind home) :let)
-	  (let ((iv (let-var-initial-value var)))
-	    (setf (continuation-reoptimize iv) nil)
-	    (propagate-from-sets var (continuation-type iv)))))))
+	  (let* ((initial-value (let-var-initial-value var))
+                 (initial-type (continuation-type initial-value)))
+	    (setf (continuation-reoptimize initial-value) nil)
+            (propagate-from-sets var initial-type))))))
 
-  (derive-node-type node (continuation-type (set-value node)))
+  (derive-node-type node (make-single-value-type
+                          (continuation-type (set-value node))))
   (values))
 
-;;; Return true if the value of Ref will always be the same (and is
+;;; Return true if the value of REF will always be the same (and is
 ;;; thus legal to substitute.)
 (defun constant-reference-p (ref)
   (declare (type ref ref))
@@ -1162,45 +1352,52 @@
        (not (eq (defined-fun-inlinep leaf) :notinline)))
       (global-var
        (case (global-var-kind leaf)
-	 (:global-function t)
-	 (:constant t))))))
+	 (:global-function
+          (let ((name (leaf-source-name leaf)))
+            (or #-sb-xc-host
+                (eq (symbol-package (fun-name-block-name name))
+                    *cl-package*)
+                (info :function :info name)))))))))
 
 ;;; If we have a non-set LET var with a single use, then (if possible)
 ;;; replace the variable reference's CONT with the arg continuation.
 ;;; This is inhibited when:
 ;;; -- CONT has other uses, or
-;;; -- CONT receives multiple values, or
 ;;; -- the reference is in a different environment from the variable, or
-;;; -- either continuation has a funky TYPE-CHECK annotation.
-;;; -- the continuations have incompatible assertions, so the new asserted type
-;;;    would be NIL.
-;;; -- the var's DEST has a different policy than the ARG's (think safety).
+;;; -- CONT carries unknown number of values, or
+;;; -- DEST is return or exit, or
+;;; -- DEST is sensitive to the number of values and ARG return non-one value.
 ;;;
 ;;; We change the REF to be a reference to NIL with unused value, and
-;;; let it be flushed as dead code. A side-effect of this substitution
+;;; let it be flushed as dead code. A side effect of this substitution
 ;;; is to delete the variable.
 (defun substitute-single-use-continuation (arg var)
   (declare (type continuation arg) (type lambda-var var))
   (let* ((ref (first (leaf-refs var)))
 	 (cont (node-cont ref))
-	 (cont-atype (continuation-asserted-type cont))
 	 (dest (continuation-dest cont)))
     (when (and (eq (continuation-use cont) ref)
 	       dest
-	       (not (typep dest '(or creturn exit mv-combination)))
+               (typecase dest
+                 (cast
+                  (and (type-single-value-p (continuation-derived-type arg))
+                       (multiple-value-bind (pdest pprev)
+                           (principal-continuation-end cont)
+                         (declare (ignore pdest))
+                         (continuation-single-value-p pprev))))
+                 (mv-combination
+                  (or (eq (basic-combination-fun dest) cont)
+                      (and (eq (basic-combination-kind dest) :local)
+                           (type-single-value-p (continuation-derived-type arg)))))
+                 ((or creturn exit)
+                  nil)
+                 (t
+                  ;; (AVER (CONTINUATION-SINGLE-VALUE-P CONT))
+                  t))
 	       (eq (node-home-lambda ref)
-		   (lambda-home (lambda-var-home var)))
-	       (member (continuation-type-check arg) '(t nil))
-	       (member (continuation-type-check cont) '(t nil))
-	       (not (eq (values-type-intersection
-			 cont-atype
-			 (continuation-asserted-type arg))
-			*empty-type*))
-	       (eq (lexenv-policy (node-lexenv dest))
-		   (lexenv-policy (node-lexenv (continuation-dest arg)))))
+		   (lambda-home (lambda-var-home var))))
       (aver (member (continuation-kind arg)
 		    '(:block-start :deleted-block-start :inside-block)))
-      (assert-continuation-type arg cont-atype)
       (setf (node-derived-type ref) *wild-type*)
       (change-ref-leaf ref (find-constant nil))
       (substitute-continuation arg cont)
@@ -1211,31 +1408,31 @@
 ;;; any unreferenced variables. Note that FLUSH-DEAD-CODE will come
 ;;; along right away and delete the REF and then the lambda, since we
 ;;; flush the FUN continuation.
-(defun delete-let (fun)
-  (declare (type clambda fun))
-  (aver (member (functional-kind fun) '(:let :mv-let)))
-  (note-unreferenced-vars fun)
-  (let ((call (let-combination fun)))
+(defun delete-let (clambda)
+  (declare (type clambda clambda))
+  (aver (functional-letlike-p clambda))
+  (note-unreferenced-vars clambda)
+  (let ((call (let-combination clambda)))
     (flush-dest (basic-combination-fun call))
     (unlink-node call)
-    (unlink-node (lambda-bind fun))
-    (setf (lambda-bind fun) nil))
+    (unlink-node (lambda-bind clambda))
+    (setf (lambda-bind clambda) nil))
   (values))
 
 ;;; This function is called when one of the arguments to a LET
 ;;; changes. We look at each changed argument. If the corresponding
 ;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we
 ;;; consider substituting for the variable, and also propagate
-;;; derived-type information for the arg to all the Var's refs.
+;;; derived-type information for the arg to all the VAR's refs.
 ;;;
 ;;; Substitution is inhibited when the arg leaf's derived type isn't a
-;;; subtype of the argument's asserted type. This prevents type
-;;; checking from being defeated, and also ensures that the best
-;;; representation for the variable can be used.
+;;; subtype of the argument's leaf type. This prevents type checking
+;;; from being defeated, and also ensures that the best representation
+;;; for the variable can be used.
 ;;;
 ;;; Substitution of individual references is inhibited if the
 ;;; reference is in a different component from the home. This can only
-;;; happen with closures over top-level lambda vars. In such cases,
+;;; happen with closures over top level lambda vars. In such cases,
 ;;; the references may have already been compiled, and thus can't be
 ;;; retroactively modified.
 ;;;
@@ -1243,7 +1440,7 @@
 ;;; are done, then we delete the LET.
 ;;;
 ;;; Note that we are responsible for clearing the
-;;; Continuation-Reoptimize flags.
+;;; CONTINUATION-REOPTIMIZE flags.
 (defun propagate-let-args (call fun)
   (declare (type combination call) (type clambda fun))
   (loop for arg in (combination-args call)
@@ -1257,27 +1454,27 @@
 	  (when (ref-p use)
 	    (let ((leaf (ref-leaf use)))
 	      (when (and (constant-reference-p use)
-			 (values-subtypep (leaf-type leaf)
-					  (continuation-asserted-type arg)))
+                         (csubtypep (leaf-type leaf)
+                                    ;; (NODE-DERIVED-TYPE USE) would
+                                    ;; be better -- APD, 2003-05-15
+                                    (leaf-type var)))
 		(propagate-to-refs var (continuation-type arg))
-		(let ((this-comp (block-component (node-block use))))
+		(let ((use-component (node-component use)))
 		  (substitute-leaf-if
-		   #'(lambda (ref)
-		       (cond ((eq (block-component (node-block ref))
-				  this-comp)
-			      t)
-			     (t
-			      (aver (eq (functional-kind (lambda-home fun))
-					:top-level))
-			      nil)))
+		   (lambda (ref)
+		     (cond ((eq (node-component ref) use-component)
+			    t)
+			   (t
+			    (aver (lambda-toplevelish-p (lambda-home fun)))
+			    nil)))
 		   leaf var))
 		t)))))
        ((and (null (rest (leaf-refs var)))
-	     (substitute-single-use-continuation arg var)))
+             (substitute-single-use-continuation arg var)))
        (t
 	(propagate-to-refs var (continuation-type arg))))))
 
-  (when (every #'null (combination-args call))
+  (when (every #'not (combination-args call))
     (delete-let fun))
 
   (values))
@@ -1290,21 +1487,21 @@
 ;;; If the function has an XEP, then we don't do anything, since we
 ;;; won't discover anything.
 ;;;
-;;; We can clear the Continuation-Reoptimize flags for arguments in
-;;; all calls corresponding to changed arguments in Call, since the
-;;; only use in IR1 optimization of the Reoptimize flag for local call
+;;; We can clear the CONTINUATION-REOPTIMIZE flags for arguments in
+;;; all calls corresponding to changed arguments in CALL, since the
+;;; only use in IR1 optimization of the REOPTIMIZE flag for local call
 ;;; args is right here.
 (defun propagate-local-call-args (call fun)
   (declare (type combination call) (type clambda fun))
 
-  (unless (or (functional-entry-function fun)
+  (unless (or (functional-entry-fun fun)
 	      (lambda-optional-dispatch fun))
     (let* ((vars (lambda-vars fun))
-	   (union (mapcar #'(lambda (arg var)
-			      (when (and arg
-					 (continuation-reoptimize arg)
-					 (null (basic-var-sets var)))
-				(continuation-type arg)))
+	   (union (mapcar (lambda (arg var)
+			    (when (and arg
+				       (continuation-reoptimize arg)
+				       (null (basic-var-sets var)))
+			      (continuation-type arg)))
 			  (basic-combination-args call)
 			  vars))
 	   (this-ref (continuation-use (basic-combination-fun call))))
@@ -1317,16 +1514,16 @@
 	(let ((dest (continuation-dest (node-cont ref))))
 	  (unless (or (eq ref this-ref) (not dest))
 	    (setq union
-		  (mapcar #'(lambda (this-arg old)
-			      (when old
-				(setf (continuation-reoptimize this-arg) nil)
-				(type-union (continuation-type this-arg) old)))
+		  (mapcar (lambda (this-arg old)
+			    (when old
+			      (setf (continuation-reoptimize this-arg) nil)
+			      (type-union (continuation-type this-arg) old)))
 			  (basic-combination-args dest)
 			  union)))))
 
-      (mapc #'(lambda (var type)
-		(when type
-		  (propagate-to-refs var type)))
+      (mapc (lambda (var type)
+	      (when type
+		(propagate-to-refs var type)))
 	    vars union)))
 
   (values))
@@ -1383,19 +1580,16 @@
 ;;; vars.
 (defun ir1-optimize-mv-bind (node)
   (declare (type mv-combination node))
-  (let ((arg (first (basic-combination-args node)))
-	(vars (lambda-vars (combination-lambda node))))
-    (multiple-value-bind (types nvals)
-	(values-types (continuation-derived-type arg))
-      (unless (eq nvals :unknown)
-	(mapc #'(lambda (var type)
-		  (if (basic-var-sets var)
-		      (propagate-from-sets var type)
-		      (propagate-to-refs var type)))
-		vars
-		(append types
-			(make-list (max (- (length vars) nvals) 0)
-				   :initial-element (specifier-type 'null))))))
+  (let* ((arg (first (basic-combination-args node)))
+         (vars (lambda-vars (combination-lambda node)))
+         (n-vars (length vars))
+         (types (values-type-in (continuation-derived-type arg)
+                                n-vars)))
+    (loop for var in vars
+          and type in types
+          do (if (basic-var-sets var)
+                 (propagate-from-sets var type)
+                 (propagate-to-refs var type)))
     (setf (continuation-reoptimize arg) nil))
   (values))
 
@@ -1433,7 +1627,7 @@
 	(args (basic-combination-args node)))
 
     (unless (and (ref-p ref) (constant-reference-p ref)
-		 args (null (rest args)))
+		 (singleton-p args))
       (return-from ir1-optimize-mv-call))
 
     (multiple-value-bind (min max)
@@ -1446,14 +1640,14 @@
 
 	(when total-nvals
 	  (when (and min (< total-nvals min))
-	    (compiler-warning
+	    (compiler-warn
 	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
 	     at least ~R."
 	     total-nvals min)
 	    (setf (basic-combination-kind node) :error)
 	    (return-from ir1-optimize-mv-call))
 	  (when (and max (> total-nvals max))
-	    (compiler-warning
+	    (compiler-warn
 	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
 	     at most ~R."
 	     total-nvals max)
@@ -1461,12 +1655,12 @@
 	    (return-from ir1-optimize-mv-call)))
 
 	(let ((count (cond (total-nvals)
-			   ((and (policy node (zerop safety))
+			   ((and (policy node (zerop verify-arg-count))
 				 (eql min max))
 			    min)
 			   (t nil))))
 	  (when count
-	    (with-ir1-environment node
+	    (with-ir1-environment-from-node node
 	      (let* ((dums (make-gensym-list count))
 		     (ignore (gensym))
 		     (fun (ir1-convert-lambda
@@ -1475,7 +1669,7 @@
 			      (funcall ,(ref-leaf ref) ,@dums)))))
 		(change-ref-leaf ref fun)
 		(aver (eq (basic-combination-kind node) :full))
-		(local-call-analyze *current-component*)
+		(locall-analyze-component *current-component*)
 		(aver (eq (basic-combination-kind node) :local)))))))))
   (values))
 
@@ -1510,30 +1704,33 @@
 	       (mapc #'flush-dest (subseq vals nvars))
 	       (setq vals (subseq vals 0 nvars)))
 	      ((< nvals nvars)
-	       (with-ir1-environment use
+	       (with-ir1-environment-from-node use
 		 (let ((node-prev (node-prev use)))
 		   (setf (node-prev use) nil)
 		   (setf (continuation-next node-prev) nil)
 		   (collect ((res vals))
-		     (loop as cont = (make-continuation use)
+		     (loop for cont = (make-continuation use)
 			   and prev = node-prev then cont
 			   repeat (- nvars nvals)
 			   do (reference-constant prev cont nil)
 			      (res cont))
 		     (setq vals (res)))
-		   (prev-link use (car (last vals)))))))
+		   (link-node-to-previous-continuation use
+						       (car (last vals)))))))
 	(setf (combination-args use) vals)
 	(flush-dest (combination-fun use))
 	(let ((fun-cont (basic-combination-fun call)))
 	  (setf (continuation-dest fun-cont) use)
-	  (setf (combination-fun use) fun-cont))
+          (setf (combination-fun use) fun-cont)
+	  (flush-continuation-externally-checkable-type fun-cont))
 	(setf (combination-kind use) :local)
 	(setf (functional-kind fun) :let)
 	(flush-dest (first (basic-combination-args call)))
 	(unlink-node call)
 	(when vals
 	  (reoptimize-continuation (first vals)))
-	(propagate-to-args use fun))
+	(propagate-to-args use fun)
+        (reoptimize-call use))
       t)))
 
 ;;; If we see:
@@ -1546,17 +1743,22 @@
 ;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
 ;;; args of the VALUES-LIST call, flushing the old argument
 ;;; continuation (allowing the LIST to be flushed.)
+;;;
+;;; FIXME: Thus we lose possible type assertions on (LIST ...).
 (defoptimizer (values-list optimizer) ((list) node)
   (let ((use (continuation-use list)))
     (when (and (combination-p use)
 	       (eq (continuation-fun-name (combination-fun use))
 		   'list))
+
+      ;; FIXME: VALUES might not satisfy an assertion on NODE-CONT.
       (change-ref-leaf (continuation-use (combination-fun node))
-		       (find-free-function 'values "in a strange place"))
+		       (find-free-fun 'values "in a strange place"))
       (setf (combination-kind node) :full)
       (let ((args (combination-args use)))
 	(dolist (arg args)
-	  (setf (continuation-dest arg) node))
+	  (setf (continuation-dest arg) node)
+          (flush-continuation-externally-checkable-type arg))
 	(setf (combination-args use) nil)
 	(flush-dest list)
 	(setf (combination-args node) args))
@@ -1566,13 +1768,88 @@
 ;;; to a PROG1. This allows the computation of the additional values
 ;;; to become dead code.
 (deftransform values ((&rest vals) * * :node node)
-  (when (typep (continuation-dest (node-cont node))
-	       '(or creturn exit mv-combination))
+  (unless (continuation-single-value-p (node-cont node))
     (give-up-ir1-transform))
   (setf (node-derived-type node) *wild-type*)
+  (principal-continuation-single-valuify (node-cont node))
   (if vals
       (let ((dummies (make-gensym-list (length (cdr vals)))))
 	`(lambda (val ,@dummies)
 	   (declare (ignore ,@dummies))
 	   val))
       nil))
+
+;;; TODO:
+;;; - CAST chains;
+(defun ir1-optimize-cast (cast &optional do-not-optimize)
+  (declare (type cast cast))
+  (let* ((value (cast-value cast))
+         (value-type (continuation-derived-type value))
+         (cont (node-cont cast))
+         (dest (continuation-dest cont))
+         (atype (cast-asserted-type cast))
+         (int (values-type-intersection value-type atype)))
+    (derive-node-type cast int)
+    (when (eq int *empty-type*)
+      (unless (eq value-type *empty-type*)
+
+        ;; FIXME: Do it in one step.
+        (filter-continuation
+         value
+         `(multiple-value-call #'list 'dummy))
+        (filter-continuation
+         value
+         ;; FIXME: Derived type.
+         `(%compile-time-type-error 'dummy
+                                    ',(type-specifier atype)
+                                    ',(type-specifier value-type)))
+        ;; KLUDGE: FILTER-CONTINUATION does not work for
+        ;; non-returning functions, so we declare the return type of
+        ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
+        ;; here.
+        (derive-node-type (continuation-use value) *empty-type*)
+        (maybe-terminate-block (continuation-use value) nil)
+        ;; FIXME: Is it necessary?
+        (aver (null (block-pred (node-block cast))))
+        (setf (block-delete-p (node-block cast)) t)
+        (return-from ir1-optimize-cast)))
+    (when (eq (node-derived-type cast) *empty-type*)
+      (maybe-terminate-block cast nil))
+
+    (when (and (not do-not-optimize)
+               (values-subtypep value-type
+                                (cast-asserted-type cast)))
+      (delete-filter cast cont value)
+      (reoptimize-continuation cont)
+      (when (continuation-single-value-p cont)
+        (note-single-valuified-continuation cont))
+      (when (not dest)
+        (reoptimize-continuation-uses cont))
+      (return-from ir1-optimize-cast t))
+
+    (when (and (not do-not-optimize)
+               (not (continuation-use value))
+               dest)
+      (collect ((merges))
+        (do-uses (use value)
+          (when (and (values-subtypep (node-derived-type use) atype)
+                     (immediately-used-p value use))
+            (ensure-block-start cont)
+            (delete-continuation-use use)
+            (add-continuation-use use cont)
+            (unlink-blocks (node-block use) (node-block cast))
+            (link-blocks (node-block use) (continuation-block cont))
+            (when (and (return-p dest)
+                       (basic-combination-p use)
+                       (eq (basic-combination-kind use) :local))
+              (merges use))))
+        (dolist (use (merges))
+          (merge-tail-sets use))))
+
+    (when (and (cast-%type-check cast)
+               (values-subtypep value-type
+                                (cast-type-to-check cast)))
+      (setf (cast-%type-check cast) nil)))
+
+  (unless do-not-optimize
+    (setf (node-reoptimize cast) nil)))