X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=e4c633b9e178d6258ba2f71090224e236eb442f5;hb=7ce2c42adf3d62f03086de940adaee48e6161a40;hp=7d9bebdfb9a47498d60a4872b85d497347469172;hpb=031ae238d37250e935dabaf2a3efb6e0305dd3e7;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 7d9bebd..e4c633b 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -56,9 +56,9 @@
      (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
@@ -84,6 +84,18 @@
     (cond ((values-subtypep proven asserted)
 	   (setf (continuation-%type-check cont) nil)
 	   (setf (continuation-%derived-type cont) proven))
+          ((and (values-subtypep proven (specifier-type 'function))
+                (values-subtypep asserted (specifier-type 'function)))
+	   ;; It's physically impossible for a runtime type check to
+	   ;; distinguish between the various subtypes of FUNCTION, so
+	   ;; it'd be pointless to do more type checks here.
+           (setf (continuation-%type-check cont) nil)
+           (setf (continuation-%derived-type cont)
+		 ;; FIXME: This should depend on optimization
+		 ;; policy. This is for SPEED > SAFETY:
+                 #+nil (values-type-intersection asserted proven)
+                 ;; and this is for SAFETY >= SPEED:
+                 #-nil proven))
 	  (t
 	   (unless (or (continuation-%type-check cont)
 		       (not (continuation-dest cont))
@@ -106,6 +118,43 @@
 (declaim (ftype (function (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)))
+            (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)
+                                type)))
+                  (continuation-%externally-checkable-type cont)))))))
 
 ;;;; interface routines used by optimizers
 
@@ -140,15 +189,15 @@
       (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
+;;; 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)))
@@ -159,60 +208,73 @@
 		     (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))))))
   (values))
 
+(defun set-continuation-type-assertion (cont atype ctype)
+  (declare (type continuation cont) (type ctype atype ctype))
+  (when (eq atype *wild-type*)
+    (return-from set-continuation-type-assertion))
+  (let* ((old-atype (continuation-asserted-type cont))
+         (old-ctype (continuation-type-to-check cont))
+         (new-atype (values-type-intersection old-atype atype))
+         (new-ctype (values-type-intersection old-ctype ctype)))
+    (when (or (type/= old-atype new-atype)
+              (type/= old-ctype new-ctype))
+      (setf (continuation-asserted-type cont) new-atype)
+      (setf (continuation-type-to-check cont) new-ctype)
+      (do-uses (node cont)
+        (setf (block-attributep (block-flags (node-block node))
+                                type-check type-asserted)
+              t))
+      (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)
+(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))
+  (when (eq type *wild-type*)
+    (return-from assert-continuation-type))
+  (set-continuation-type-assertion cont type (maybe-weaken-check type policy)))
 
 ;;; 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
 ;;; keyword positions.
 (defun assert-call-type (call type)
-  (declare (type combination call) (type function-type type))
-  (derive-node-type call (function-type-returns type))
-  (let ((args (combination-args call)))
-    (dolist (req (function-type-required type))
+  (declare (type combination call) (type fun-type type))
+  (derive-node-type call (fun-type-returns type))
+  (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)))
-    (dolist (opt (function-type-optional type))
+	(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 (function-type-rest type)))
+    (let ((rest (fun-type-rest type)))
       (when rest
 	(dolist (arg args)
-	  (assert-continuation-type arg rest))))
+	  (assert-continuation-type arg rest policy))))
 
-    (dolist (key (function-type-keywords type))
+    (dolist (key (fun-type-keywords type))
       (let ((name (key-info-name key)))
 	(do ((arg args (cddr arg)))
 	    ((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,26 +283,33 @@
 ;;; 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))
+	  (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).
+      (labels ((mark-blocks (block)
+                 (dolist (pred (block-pred block))
+                   (unless (or (block-delete-p pred)
+                               (eq (component-head (block-component pred))
+                                   pred))
+                     (setf (block-delete-p pred) t)
+                     (mark-blocks pred)))))
+        (mark-blocks block)
+        (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
@@ -250,56 +319,66 @@
 	    (exit
 	     (when (maybe-delete-exit last)
 	       (return)))))
-	
-	(unless (join-successor-if-possible block)
+
+        (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))
 
+      ;; 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.
       (when (and (block-flush-p block) (block-component block))
 	(aver (not (block-delete-p 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)))))
@@ -307,22 +386,8 @@
 	 (ir1-optimize-set 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))))
@@ -330,24 +395,41 @@
       (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.
+		(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)
@@ -359,7 +441,7 @@
 	       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 +476,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,10 +489,30 @@
 	 (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)))
+	   (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))
+                              (and (ir1-attributep attr flushable)
+                                   (every (lambda (arg)
+                                            ;; FIXME: when bug 203
+                                            ;; will be fixed, remove
+                                            ;; this check
+                                            (member (continuation-type-check arg)
+                                                    '(nil :deleted)))
+                                          (basic-combination-args node))
+                                   (valid-fun-use node
+                                                  (info :function :type
+                                                        (leaf-source-name (ref-leaf (continuation-use (basic-combination-fun node)))))
+                                                  :result-test #'always-subtypep
+                                                  :lossage-fun nil
+                                                  :unwinnage-fun nil))
+                              (ir1-attributep attr unsafely-flushable)))
 		 (flush-dest (combination-fun node))
 		 (dolist (arg (combination-args node))
 		   (flush-dest arg))
@@ -497,7 +595,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 +607,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)))))))
 
@@ -548,13 +646,13 @@
 	(flush-dest test)
 	(when (rest (block-succ block))
 	  (unlink-blocks block victim))
-	(setf (component-reanalyze (block-component (node-block node))) t)
+	(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 +666,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 +678,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)
+      (setf (continuation-%externally-checkable-type new-cont) nil)
       (add-continuation-use new-node dummy-cont)
       (setf (block-last new-block) new-node)
 
@@ -605,9 +704,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
@@ -650,7 +749,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 +767,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,26 +785,24 @@
 		    ;; 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)))
+		    (fboundp (combination-fun-source-name node)))
 	   (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)
 	       (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))
+	   (dolist (x (fun-info-transforms kind))
 	     #!+sb-show 
 	     (when *show-transforms-p*
 	       (let* ((cont (basic-combination-fun node))
-		      (fname (continuation-function-name cont t)))
+		      (fname (continuation-fun-name cont t)))
 		 (/show "trying transform" x (transform-function x) "for" fname)))
 	     (unless (ir1-transform node x)
 	       #!+sb-show
@@ -715,20 +812,22 @@
 
   (values))
 
-;;; If Call is to a function that doesn't return (i.e. return type is
+;;; 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.
 ;;;
-;;; 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 [FIXME: What does this mean? Except
+;;; during IR1 conversion? What about IR1 optimization?], 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
 ;;; 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)
+(defun maybe-terminate-block (call ir1-converting-not-optimizing-p)
   (declare (type basic-combination call))
   (let* ((block (node-block call))
 	 (cont (node-cont call))
@@ -737,9 +836,10 @@
     (unless (or (and (eq call (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))))
+		     (not (or ir1-converting-not-optimizing-p
+			      (eq (continuation-kind cont) :deleted))))
 		(eq (node-derived-type call) *empty-type*))
-	(cond (ir1-p
+	(cond (ir1-converting-not-optimizing-p
 	       (delete-continuation-use call)
 	       (cond
 		((block-last block)
@@ -767,30 +867,32 @@
 ;;; wondering if something should be done to special-case the call. If
 ;;; CALL is a call to a global function, then see whether it defined
 ;;; or known:
-;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert
+;;; -- If a DEFINED-FUN should be inline expanded, then convert
 ;;;    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.
+;;;
+;;; FIXME: The IR1-CONVERTING-NOT-OPTIMIZING-P argument is what the
+;;; old CMU CL code called IR1-P, without explanation. My (WHN
+;;; 2002-01-09) tentative understanding of it is that we can call this
+;;; operation either in initial IR1 conversion or in later IR1
+;;; optimization, and it tells which is which. But it would be good
+;;; for someone who really understands it to check whether this is
+;;; really right.
+(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)))
-	 (inlinep (if (and (defined-function-p leaf)
-			   (not (byte-compiling)))
-		      (defined-function-inlinep leaf)
+	 (inlinep (if (defined-fun-p leaf)
+		      (defined-fun-inlinep leaf)
 		      :no-chance)))
     (cond
      ((eq inlinep :notinline) (values nil nil))
@@ -801,34 +903,32 @@
 	     (:inline t)
 	     (:no-chance nil)
 	     ((nil :maybe-inline) (policy call (zerop space))))
-	   (defined-function-inline-expansion leaf)
-	   (let ((fun (defined-function-functional leaf)))
+	   (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-function-inline-expansion leaf)
+			   (defined-fun-inline-expansion leaf)
 			   leaf t
 			   #'ir1-convert-inline-lambda)))
-		 (setf (defined-function-functional leaf) res)
+		 (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)))))))
@@ -840,49 +940,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 (function-type-p 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-note)
 	 (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)))
@@ -901,19 +1001,31 @@
 		 (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)))))))
+                ;; FIXME: This SYMBOLP is part of a literal
+                ;; translation of a test in the old CMU CL
+                ;; source, and it's not quite clear what
+                ;; the old source meant. Did it mean "has a
+                ;; valid name"? Or did it mean "is an
+                ;; ordinary function name, not a SETF
+                ;; function"? Either way, the old CMU CL
+                ;; code probably didn't deal with SETF
+                ;; functions correctly, and neither does
+                ;; this new SBCL code, and that should be fixed.
+		(when (symbolp (leaf-source-name leaf))
+                  (let ((dummies (make-gensym-list
+                                  (length (combination-args call)))))
+                    (transform-call call
+                                    `(lambda ,dummies
+                                      (,(leaf-source-name leaf)
+                                       ,@dummies))
+                                    (leaf-source-name leaf))))))))))
   (values))
 
 ;;;; known function optimization
@@ -923,7 +1035,7 @@
 ;;; replace it, otherwise add a new one.
 (defun record-optimization-failure (node transform args)
   (declare (type combination node) (type transform transform)
-	   (type (or function-type list) args))
+	   (type (or fun-type list) args))
   (let* ((table (component-failed-optimizations *component-being-compiled*))
 	 (found (assoc transform (gethash node table))))
     (if found
@@ -942,32 +1054,19 @@
   (declare (type combination node) (type transform transform))
   (let* ((type (transform-type transform))
 	 (fun (transform-function transform))
-	 (constrained (function-type-p type))
+	 (constrained (fun-type-p type))
 	 (table (component-failed-optimizations *component-being-compiled*))
 	 (flame (if (transform-important transform)
 		    (policy node (>= speed inhibit-warnings))
 		    (policy node (> speed inhibit-warnings))))
 	 (*compiler-error-context* node))
-    (cond ((not (member (transform-when transform)
-			(if *byte-compiling*
-			    '(:byte   :both)
-			    '(: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 (if *byte-compiling* :byte :native)))))
-	   t)
-	  ((or (not constrained)
-	       (valid-function-use node type :strict-result t))
+    (cond ((or (not constrained)
+	       (valid-fun-use node type :strict-result t))
 	   (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
@@ -976,7 +1075,7 @@
 	       (:aborted
 		(setf (combination-kind node) :error)
 		(when args
-		  (apply #'compiler-warning args))
+		  (apply #'compiler-warn args))
 		(remhash node table)
 		nil)
 	       (:failure
@@ -990,11 +1089,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
@@ -1064,48 +1162,92 @@
  		(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)
+;;;
+;;; 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 (node res source-name)
   (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*)))
+  (aver (and (legal-fun-name-p source-name)
+	     (not (eql source-name '.anonymous.))))
+  (with-ir1-environment-from-node node
+      (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 node))))
+	(change-ref-leaf ref new-fun)
+	(setf (combination-kind node) :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
+;;; 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
 ;;; 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.
 (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")
+	(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")
       (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))))))))
-
+	  (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)))
+	     fun-name)))))
   (values))
 
 ;;;; local call optimization
@@ -1117,7 +1259,7 @@
 (defun propagate-to-refs (leaf type)
   (declare (type leaf leaf) (type ctype type))
   (let ((var-type (leaf-type leaf)))
-    (unless (function-type-p var-type)
+    (unless (fun-type-p var-type)
       (let ((int (type-approx-intersection2 var-type type)))
 	(when (type/= int var-type)
 	  (setf (leaf-type leaf) int)
@@ -1152,7 +1294,7 @@
   (derive-node-type node (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))
@@ -1161,12 +1303,11 @@
       ((or constant functional) t)
       (lambda-var
        (null (lambda-var-sets leaf)))
-      (defined-function
-       (not (eq (defined-function-inlinep leaf) :notinline)))
+      (defined-fun
+       (not (eq (defined-fun-inlinep leaf) :notinline)))
       (global-var
        (case (global-var-kind leaf)
-	 (:global-function t)
-	 (:constant t))))))
+	 (:global-function t))))))
 
 ;;; 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.
@@ -1180,13 +1321,14 @@
 ;;; -- the var's DEST has a different policy than the ARG's (think safety).
 ;;;
 ;;; 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))
+         (cont-ctype (continuation-type-to-check cont))
 	 (dest (continuation-dest cont)))
     (when (and (eq (continuation-use cont) ref)
 	       dest
@@ -1203,7 +1345,7 @@
 		   (lexenv-policy (node-lexenv (continuation-dest arg)))))
       (aver (member (continuation-kind arg)
 		    '(:block-start :deleted-block-start :inside-block)))
-      (assert-continuation-type arg cont-atype)
+      (set-continuation-type-assertion arg cont-atype cont-ctype)
       (setf (node-derived-type ref) *wild-type*)
       (change-ref-leaf ref (find-constant nil))
       (substitute-continuation arg cont)
@@ -1214,22 +1356,22 @@
 ;;; 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
@@ -1238,7 +1380,7 @@
 ;;;
 ;;; 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.
 ;;;
@@ -1246,7 +1388,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)
@@ -1263,20 +1405,17 @@
 			 (values-subtypep (leaf-type leaf)
 					  (continuation-asserted-type arg)))
 		(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)))
-	     (not *byte-compiling*)
 	     (substitute-single-use-continuation arg var)))
        (t
 	(propagate-to-refs var (continuation-type arg))))))
@@ -1301,14 +1440,14 @@
 (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))))
@@ -1321,16 +1460,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))
@@ -1367,8 +1506,8 @@
        (when fun-changed
 	 (setf (continuation-reoptimize fun) nil)
 	 (let ((type (continuation-type fun)))
-	   (when (function-type-p type)
-	     (derive-node-type node (function-type-returns type))))
+	   (when (fun-type-p type)
+	     (derive-node-type node (fun-type-returns type))))
 	 (maybe-terminate-block node nil)
 	 (let ((use (continuation-use fun)))
 	   (when (and (ref-p use) (functional-p (ref-leaf use)))
@@ -1376,7 +1515,7 @@
 	     (when (eq (basic-combination-kind node) :local)
 	       (maybe-let-convert (ref-leaf use))))))
        (unless (or (eq (basic-combination-kind node) :local)
-		   (eq (continuation-function-name fun) '%throw))
+		   (eq (continuation-fun-name fun) '%throw))
 	 (ir1-optimize-mv-call node))
        (dolist (arg args)
 	 (setf (continuation-reoptimize arg) nil))))
@@ -1392,11 +1531,11 @@
     (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
+	(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))))))
@@ -1441,7 +1580,7 @@
       (return-from ir1-optimize-mv-call))
 
     (multiple-value-bind (min max)
-	(function-type-nargs (continuation-type fun))
+	(fun-type-nargs (continuation-type fun))
       (let ((total-nvals
 	     (multiple-value-bind (types nvals)
 		 (values-types (continuation-derived-type (first args)))
@@ -1450,14 +1589,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)
@@ -1470,7 +1609,7 @@
 			    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
@@ -1479,7 +1618,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))
 
@@ -1503,7 +1642,7 @@
   (let* ((arg (first (basic-combination-args call)))
 	 (use (continuation-use arg)))
     (when (and (combination-p use)
-	       (eq (continuation-function-name (combination-fun use))
+	       (eq (continuation-fun-name (combination-fun use))
 		   'values))
       (let* ((fun (combination-lambda call))
 	     (vars (lambda-vars fun))
@@ -1514,7 +1653,7 @@
 	       (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)
@@ -1525,12 +1664,14 @@
 			   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)
+	  (setf (continuation-%externally-checkable-type fun-cont) nil))
 	(setf (combination-kind use) :local)
 	(setf (functional-kind fun) :let)
 	(flush-dest (first (basic-combination-args call)))
@@ -1553,14 +1694,15 @@
 (defoptimizer (values-list optimizer) ((list) node)
   (let ((use (continuation-use list)))
     (when (and (combination-p use)
-	       (eq (continuation-function-name (combination-fun use))
+	       (eq (continuation-fun-name (combination-fun use))
 		   'list))
       (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)
+          (setf (continuation-%externally-checkable-type arg) nil))
 	(setf (combination-args use) nil)
 	(flush-dest list)
 	(setf (combination-args node) args))