diff --git a/compiler/locall.lisp b/compiler/locall.lisp
index 343ce2831189f920f868f65475a748ffc750d731..f06cf327e78ac44175c62048c631fdff085c04f8 100644
--- a/compiler/locall.lisp
+++ b/compiler/locall.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.22 1991/11/15 13:41:17 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.23 1991/12/11 17:14:07 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -567,17 +567,59 @@
 ;;;    longer in effect.
 
 
+;;; Insert-Let-Body  --  Internal
+;;;
+;;;    Set up the control transfer to the called lambda.  We split the call
+;;; block immediately after the call, and link the head of Fun to the call
+;;; block.  The successor block after splitting (where we return to) is
+;;; returned.
+;;;
+;;;    If the lambda is is a different component than the call, then we call
+;;; JOIN-COMPONENTS.  This only happens in block compilation before
+;;; FIND-INITIAL-DFO.
+;;;
+(defun insert-let-body (fun call)
+  (declare (type clambda fun) (type basic-combination call))
+  (let* ((call-block (node-block call))
+	 (bind-block (node-block (lambda-bind fun)))
+	 (component (block-component call-block)))
+    (let ((fun-component (block-component bind-block)))
+      (unless (eq fun-component component)
+	(assert (eq (component-kind component) :initial))
+	(join-components component fun-component)))
+
+    (let ((*current-component* component))
+      (node-ends-block call))
+    (assert (= (length (block-succ call-block)) 1))
+    (let ((next-block (first (block-succ call-block))))
+      (unlink-blocks call-block next-block)
+      (link-blocks call-block bind-block)
+      next-block)))
+
+
 ;;; Merge-Lets  --  Internal
 ;;;
 ;;;    Handle the environment semantics of let conversion.  We add the lambda
-;;; and its lets to lets for the call's home function.  We merge the calls for
+;;; and its lets to lets for the Call's home function.  We merge the calls for
 ;;; Fun with the calls for the home function, removing Fun in the process.  We
 ;;; also merge the Entries.
 ;;;
+;;;   We also unlink the function head from the component head and set
+;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
+;;;
 (defun merge-lets (fun call)
   (declare (type clambda fun) (type basic-combination call))
-  (let* ((prev (node-prev call))
-	 (home (block-home-lambda (continuation-block prev)))
+  (let ((component (block-component (node-block call))))
+    (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
+    (setf (component-lambdas component)
+	  (delete fun (component-lambdas component)))
+    (setf (component-reanalyze component) t))
+  (setf (lambda-call-lexenv fun) (node-lexenv call))
+  (let ((tails (lambda-tail-set fun)))
+    (setf (tail-set-functions tails)
+	  (delete fun (tail-set-functions tails))))
+  (setf (lambda-tail-set fun) nil)
+  (let* ((home (node-home-lambda call))
 	 (home-env (lambda-environment home)))
     (push fun (lambda-lets home))
     (setf (lambda-home fun) home)
@@ -602,53 +644,11 @@
   (undefined-value))
 
 
-;;; Insert-Let-Body  --  Internal
-;;;
-;;;    Handle the control semantics of let conversion.  We split the call block
-;;; immediately after the call, and link the head and tail of Fun to the call
-;;; block and the following block.  We also unlink the function head and tail
-;;; from the component head and tail and flush the function from the
-;;; Component-Lambdas.  We set Component-Reanalyze to true to indicate that the
-;;; DFO should be recomputed.
-;;;
-;;;    If the lambda is is a different component than the call, then we call
-;;; JOIN-COMPONENTS.  This only happens before the FIND-INITIAL-DFO in block
-;;; compilation.
-;;;
-(defun insert-let-body (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (setf (lambda-call-lexenv fun) (node-lexenv call))
-  (let* ((call-block (node-block call))
-	 (bind-block (node-block (lambda-bind fun)))
-	 (component (block-component call-block)))
-    (let ((fun-component (block-component bind-block)))
-      (unless (eq fun-component component)
-	(assert (eq (component-kind component) :initial))
-	(join-components component fun-component)))
-
-    (let ((*current-component* component))
-      (node-ends-block call))
-    (setf (component-lambdas component)
-	  (delete fun (component-lambdas component)))
-    (assert (= (length (block-succ call-block)) 1))
-    (let ((next-block (first (block-succ call-block))))
-      (unlink-blocks call-block next-block)
-      (unlink-blocks (component-head component) bind-block)
-      (link-blocks call-block bind-block)
-      (let ((return (lambda-return fun)))
-	(when return
-	  (let ((return-block (node-block return)))
-	    (unlink-blocks return-block (component-tail component))
-	    (link-blocks return-block next-block)))))
-    (setf (component-reanalyze component) t))
-  (undefined-value))
-
-
 ;;; Move-Return-Uses  --  Internal
 ;;;
-;;;    Handle the value semantics of let conversion.  When Fun has a return
-;;; node, we delete it and move all the uses of the result continuation to
-;;; Call's Cont.
+;;;    Handle the value semantics of let conversion.  Delete Fun's return node,
+;;; and change the control flow to transfer to Next-Block instead.  Move all
+;;; the uses of the result continuation to Call's Cont.
 ;;;
 ;;;    If the actual continuation is only used by the let call, then we
 ;;; intersect the type assertion on the dummy continuation with the assertion
@@ -659,26 +659,76 @@
 ;;; all the dummy continuation's uses.  This serves mainly to propagate
 ;;; TRULY-THE through lets.
 ;;;
-(defun move-return-uses (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (let ((return (lambda-return fun)))
-    (when return
-      (unlink-node return)
-      (delete-return return)
-
-      (let ((result (return-result return))
-	    (cont (node-cont call))
-	    (call-type (node-derived-type call)))
-	(when (eq (continuation-use cont) call)
-	  (assert-continuation-type cont (continuation-asserted-type result)))
-	(unless (eq call-type *wild-type*)
-	  (do-uses (use result)
-	    (derive-node-type use call-type)))
-	  
-	(delete-continuation-use call)
-	(add-continuation-use call (node-prev (lambda-bind fun)))
-	(substitute-continuation-uses cont result))))
+(defun move-return-uses (fun call next-block)
+  (declare (type clambda fun) (type basic-combination call)
+	   (type cblock next-block))
+  (let* ((return (lambda-return fun))
+	 (return-block (node-block return)))
+    (unlink-blocks return-block
+		   (component-tail (block-component return-block)))
+    (link-blocks return-block next-block)
+    (unlink-node return)
+    (delete-return return)
+    (let ((result (return-result return))
+	  (cont (node-cont call))
+	  (call-type (node-derived-type call)))
+      (when (eq (continuation-use cont) call)
+	(assert-continuation-type cont (continuation-asserted-type result)))
+      (unless (eq call-type *wild-type*)
+	(do-uses (use result)
+	  (derive-node-type use call-type)))
+      (substitute-continuation-uses cont result)))
+  (undefined-value))
+
+
+
+;;; MOVE-LET-CALL-CONT  --  Internal
+;;;
+;;;    Change all Cont for all the calls to Fun to be the start continuation
+;;; for the bind node.  This allows the blocks to be joined if the caller count
+;;; ever goes to one.
+;;;
+(defun move-let-call-cont (fun)
+  (declare (type clambda fun))
+  (let ((new-cont (node-prev (lambda-bind fun))))
+    (dolist (ref (leaf-refs fun))
+      (let ((dest (continuation-dest (node-cont ref))))
+	(delete-continuation-use dest)
+	(add-continuation-use dest new-cont))))
+  (undefined-value))
+
 
+;;; MOVE-RETURN-STUFF  --  Internal
+;;;
+;;;    Deal with returning from a let or assignment that we are converting.
+;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
+;;; is the return point for a non-tail call, or NULL if call is a tail call.
+;;;
+;;; We do different things depending on whether the caller and callee have
+;;; returns left:
+;;; -- If the callee has no return, it doesn't return, so we just do
+;;;    MOVE-LET-CALL-CONT.
+;;; -- If CALL is a non-tail call, or if both have returns, then we
+;;;    delete the callee's return, move its uses to the call's result
+;;;    continuation, and transfer control to the appropriate return point.
+;;; -- If the callee has a return, but the caller doesn't, then we move the
+;;;    return to the caller.  [Note: here CALL is always TR.]
+;;;
+(defun move-return-stuff (fun call next-block)
+  (declare (type clambda fun) (type basic-combination call)
+	   (type (or cblock null) next-block))
+  (let* ((return (lambda-return fun))
+	 (call-fun (node-home-lambda call))
+	 (call-return (lambda-return call-fun)))
+    (when return
+      (cond ((or next-block call-return)
+	     (unless (block-delete-p (node-block return))
+	       (move-return-uses fun call
+				 (or next-block (node-block call-return)))))
+	    (t
+	     (setf (lambda-return call-fun) return)
+	     (setf (return-lambda return) call-fun))))
+    (move-let-call-cont fun))
   (undefined-value))
 
 
@@ -693,9 +743,12 @@
 ;;;
 (defun let-convert (fun call)
   (declare (type clambda fun) (type basic-combination call))
-  (insert-let-body fun call)
-  (merge-lets fun call)
-  (move-return-uses fun call)
+  (let ((next-block (if (node-tail-p call)
+			nil
+			(insert-let-body fun call))))
+    (merge-lets fun call)
+    (move-return-stuff fun call next-block))
+
   (maybe-remove-free-function fun)
   (dolist (arg (basic-combination-args call))
     (when arg
@@ -711,13 +764,15 @@
 ;;; call analysis, and also when a reference is deleted.  We only convert to a
 ;;; let when the function is a normal local function, has no XEP, and is
 ;;; referenced in exactly one local call.  Conversion is also inhibited if the
-;;; only reference is in a block about to be deleted.
+;;; only reference is in a block about to be deleted.  We return true if we
+;;; converted.
 ;;;
 ;;;    These rules may seem unnecessarily restrictive, since there are some
 ;;; cases where we could do the return with a jump that don't satisfy these
 ;;; requirements.  The reason for doing things this way is that it makes the
-;;; concept of a let much more useful at the level of IR1 semantics.  Low-level
-;;; control and environment optimizations can always be done later on.
+;;; concept of a let much more useful at the level of IR1 semantics.  The
+;;; :ASSIGNMENT function kind provides another way to optimize calls to
+;;; single-return/multiple call functions.
 ;;;
 ;;;    We don't attempt to convert calls to functions that have an XEP, since
 ;;; we might be embarrassed later when we want to convert a newly discovered
@@ -728,7 +783,7 @@
   (let ((refs (leaf-refs fun)))
     (when (and refs (null (rest refs))
 	       (not (block-delete-p (node-block (first refs))))
-	       (not (functional-kind fun))
+	       (member (functional-kind fun) '(nil :assignment))
 	       (not (functional-entry-function fun)))
       (let* ((ref-cont (node-cont (first refs)))
 	     (dest (continuation-dest ref-cont)))
@@ -737,5 +792,92 @@
 		   (eq (basic-combination-kind dest) :local))
 	  (let-convert fun dest)
 	  (setf (functional-kind fun)
-		(if (mv-combination-p dest) :mv-let :let))))))
-  (undefined-value))
+		(if (mv-combination-p dest) :mv-let :let))))
+      t)))
+
+
+;;;; Tail local calls and assignments:
+
+;;; ONLY-HARMLESS-CLEANUPS  --  Internal
+;;;
+;;;    Return T if there are no cleanups between Block1 and Block2, or if they
+;;; definitely won't generate any cleanup code.  Currently we recognize lexical
+;;; entry points that are only used locally (if at all).
+;;;
+(defun only-harmless-cleanups (block1 block2)
+  (declare (type cblock block1 block2))
+  (or (eq block1 block2)
+      (let ((cleanup2 (block-start-cleanup block2)))
+	(do ((cleanup (block-end-cleanup block1)
+		      (node-enclosing-cleanup (cleanup-mess-up cleanup))))
+	    ((eq cleanup cleanup2) t)
+	  (case (cleanup-kind cleanup)
+	    ((:block :tagbody)
+	     (unless (null (entry-exits (cleanup-mess-up cleanup)))
+	       (return nil)))
+	    (t (return nil)))))))
+
+
+;;; MAYBE-CONVERT-TAIL-LOCAL-CALL  --  Interface
+;;;
+;;;    If possible, convert a tail-local call to jump directly to the called
+;;; function.  We also call MAYBE-CONVERT-TO-ASSIGNMENT.  We can switch the
+;;; succesor (potentially deleting the RETURN node) unless:
+;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
+;;;    we can use known return inside the component.)
+;;; -- There is a change in the cleanup between the call in the return, so we
+;;;    might need to introduce cleanup code.
+;;;
+(defun maybe-convert-tail-local-call (call)
+  (declare (type combination call))
+  (let ((return (continuation-dest (node-cont call))))
+    (assert (return-p return))
+    (when (and (not (node-tail-p call))
+	       (not (eq (functional-kind (node-home-lambda call))
+			:external))
+	       (only-harmless-cleanups (node-block call)
+				       (node-block return)))
+      (node-ends-block call)
+      (let ((block (node-block call))
+	    (fun (combination-lambda call)))
+	(setf (node-tail-p call) t)
+	(unlink-blocks block (first (block-succ block)))
+	(link-blocks block (node-block (lambda-bind fun)))
+	(values t (maybe-convert-to-assignment fun))))))
+
+
+;;; MAYBE-CONVERT-TO-ASSIGNMENT  --  Interface
+;;;
+;;;    Called when we believe it might make sense to convert Fun to an
+;;; assignment.  We can convert when:
+;;; -- The function is a normal, non-entry function, and
+;;; -- There is at most one non-tail call (which must not be recursive), and
+;;; -- All calls are self-recursive or appear in at most one other function (so
+;;;    we can be sure that we can merge all the code into a single
+;;;    environment.)
+;;;
+;;; If there is one non-tail call, then we convert exactly like a let.  If
+;;; there are no non-tail calls, then we merge the environments and deal with
+;;; the return.
+;;;
+(defun maybe-convert-to-assignment (fun)
+  (declare (type clambda fun))
+  (when (and (not (functional-kind fun))
+	     (not (functional-entry-function fun)))
+    (let ((non-tail nil)
+	  (call-fun nil))
+      (when (dolist (ref (leaf-refs fun) t)
+	      (let ((dest (continuation-dest (node-cont ref))))
+		(when (block-delete-p (node-block dest)) (return nil))
+		(let ((home (node-home-lambda ref)))
+		  (unless (eq home fun)
+		    (when call-fun (return nil))
+		    (setq call-fun home))
+		  (unless (node-tail-p dest)
+		    (when (or non-tail (eq home fun)) (return nil))
+		    (setq non-tail dest)))))
+	(let-convert fun (or non-tail
+			     (continuation-dest
+			      (node-cont (first (leaf-refs fun))))))
+	(setf (functional-kind fun) :assignment)
+	t))))