diff --git a/compiler/pack.lisp b/compiler/pack.lisp
index da0e849e47309e5eed6f25b57ba4dde550c72eda..6e62738626d6b6d4e24cff80a2d4a4de27e08c70 100644
--- a/compiler/pack.lisp
+++ b/compiler/pack.lisp
@@ -25,9 +25,7 @@
 ;;; with TN:
 ;;; -- If an component-live TN (:component kind), then iterate over all the
 ;;;    blocks.  If the element at Offset is used anywhere in any of the
-;;;    environment's blocks (always-live /= 0), then there is a conflict.
-;;; -- :Environment is similar to :Component, except that we iterate only over
-;;;    the blocks in the environment.
+;;;    component's blocks (always-live /= 0), then there is a conflict.
 ;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in
 ;;;    (using TN-Global-Conflicts).  If the TN is live everywhere in the block
 ;;;    (:Live), then there is a conflict if the element at offset is used
@@ -47,11 +45,6 @@
 	(dotimes (i (ir2-block-count *compile-component*) nil)
 	  (when (/= (sbit loc-live i) 0)
 	    (return t)))))
-     ((eq kind :environment)
-      (let ((loc-live (svref (finite-sb-always-live sb) offset)))
-	(do-environment-ir2-blocks (env-block (tn-environment tn) nil)
-	  (when (/= (sbit loc-live (ir2-block-number env-block)) 0)
-	    (return t)))))
      (confs
       (let ((loc-confs (svref (finite-sb-conflicts sb) offset))
 	    (loc-live (svref (finite-sb-always-live sb) offset)))
@@ -95,8 +88,6 @@
 ;;;    all of the local conflict bits and the always-live bit.  This records a
 ;;;    conflict with any TN that has a LTN number in the block, as well as with
 ;;;    :Always-Live and :Environment TNs.
-;;; -- :Environment is similar to :Component, except that we iterate over only
-;;;    the blocks in the environment.
 ;;; -- If TN is global, then iterate over the blocks TN is live in.  In
 ;;;    addition to setting the always-live bit to represent the conflict with
 ;;;    TNs live throughout the block, we also set bits in the local conflicts.
@@ -119,11 +110,6 @@
 	  (dotimes (num (ir2-block-count *compile-component*) nil)
 	    (setf (sbit loc-live num) 1)
 	    (set-bit-vector (svref loc-confs num))))
-	 ((eq kind :environment)
-	  (do-environment-ir2-blocks (env-block (tn-environment tn))
-	    (let ((num (ir2-block-number env-block)))
-	      (setf (sbit loc-live num) 1)
-	      (set-bit-vector (svref loc-confs num)))))
 	 (confs
 	  (do ((conf confs (global-conflicts-tn-next conf)))
 	      ((null conf))
@@ -391,14 +377,14 @@
 
 ;;;; Register saving:
 
-;;; Orignal-TN  --  Internal
+;;; Original-TN  --  Internal
 ;;;
 ;;;    If a save TN, return the saved TN, otherwise return TN.  Useful for
 ;;; getting the conflicts of a TN that might be a save TN.
 ;;;
 (defun original-tn (tn)
   (declare (type tn tn))
-  (if (member (tn-kind tn) '(:save :save-once))
+  (if (member (tn-kind tn) '(:save :save-once :specified-save))
       (tn-save-tn tn)
       tn))
 
@@ -427,23 +413,42 @@
 ;;;    Find the load function for moving from Src to Dest and emit a
 ;;; MOVE-OPERAND VOP with that function as its info arg.
 ;;;
-(defun emit-operand-load (node block src dest after)
+(defun emit-operand-load (node block src dest before)
   (declare (type node node) (type ir2-block block)
-	   (type tn src dest) (type (or vop null) after))
+	   (type tn src dest) (type (or vop null) before))
   (emit-load-template node block
 		      (template-or-lose 'move-operand)
 		      src dest
 		      (list (or (svref (sc-move-functions (tn-sc dest))
 				       (sc-number (tn-sc src)))
 				(no-load-function-error src dest)))
-		      after)
+		      before)
   (undefined-value))
 
-  
+
+;;; REVERSE-FIND-VOP  --  Internal
+;;;
+;;;    Find the preceding use of the VOP NAME in the emit order, starting with
+;;; VOP.  We must find the VOP in the same IR1 block.
+;;;
+(defun reverse-find-vop (name vop)
+  (do ((block (vop-block vop) (ir2-block-prev block)))
+      (nil)
+    (assert (eq (ir2-block-block block) (ir2-block-block (vop-block vop))))
+    (do ((current vop (vop-prev current)))
+	((null current))
+      (when (eq (vop-info-name (vop-info current)) name)
+	(return-from reverse-find-vop current)))))
+
+
 ;;; Save-Complex-Writer-TN  --  Internal
 ;;;
 ;;;    For TNs that have other than one writer, we save the TN before each
-;;; call.
+;;; call.  If a local call (MOVE-ARGS is :LOCAL-CALL), then we scan back for
+;;; the ALLOCATE-FRAME VOP, and emit the save there.  This is necessary because
+;;; in a self-recursive local call, the registers holding the current arguments
+;;; may get trashed by setting up the call arguments.  The ALLOCATE-FRAME VOP
+;;; marks a place at which the values are known to be good.
 ;;;
 (defun save-complex-writer-tn (tn vop)
   (let ((save (or (tn-save-tn tn)
@@ -451,7 +456,14 @@
 	(node (vop-node vop))
 	(block (vop-block vop))
 	(next (vop-next vop)))
-    (emit-operand-load node block tn save vop)
+    (when (eq (tn-kind save) :specified-save)
+      (setf (tn-kind save) :save))
+    (assert (eq (tn-kind save) :save))
+    (emit-operand-load node block tn save
+		       (if (eq (vop-info-move-args (vop-info vop))
+			       :local-call)
+			   (reverse-find-vop 'allocate-frame vop)
+			   vop))
     (emit-operand-load node block save tn next)))
 
 
@@ -464,10 +476,11 @@
   (let* ((old-save (tn-save-tn tn))
 	 (save (or old-save (pack-save-tn tn))))
 
-    (unless old-save
+    (when (or (not old-save)
+	      (eq (tn-kind old-save) :specified-save))
       (let ((writer (tn-ref-vop (tn-writes tn))))
 	(emit-operand-load (vop-node writer) (vop-block writer)
-			    tn save (vop-next writer)))
+			   tn save (vop-next writer)))
       (setf (tn-kind save) :save-once))
 
     (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop)))
@@ -475,13 +488,6 @@
   (undefined-value))
 
 
-;;; Emit-Saves  --  Internal
-;;;
-;;;    Scan over the VOPs in Block, emiting saving code for TNs noted in the
-;;; codegen info that are packed into saved SCs.
-;;;
-
-
 ;;; Emit-Saves  --  Internal
 ;;;
 ;;;    Scan over the VOPs in Block, emiting saving code for TNs noted in the
@@ -504,6 +510,194 @@
 
   (undefined-value))
 
+
+;;;; Optimized saving:
+
+;;; SAVE-IF-NECESSARY  --  Internal
+;;;
+;;;    Save TN if it isn't a single-writer TN that has already been saved.  If
+;;; multi-write, we insert the save Before the specified VOP.  Context is a VOP
+;;; used to tell which node/block to use for the new VOP.
+;;;
+(defun save-if-necessary (tn before context)
+  (declare (type tn tn) (type (or vop null) before) (type vop context))
+  (let ((writes (tn-writes tn))
+	(save (tn-save-tn tn)))
+    (assert save)
+    (cond
+     ((eq (tn-kind save) :save-once))
+     ((and writes (null (tn-ref-next writes)))
+      (let ((writer (tn-ref-vop (tn-writes tn))))
+	(emit-operand-load (vop-node writer) (vop-block writer)
+			   tn save (vop-next writer)))
+      (setf (tn-kind save) :save-once))
+     (t
+      (emit-operand-load (vop-node context) (vop-block context)
+			 tn save before)))))
+
+;;; RESTORE-TN  --  Internal
+;;;
+;;;    Load the TN from its save location, allocating one if necessary.  The
+;;; load is inserted Before the specifier VOP.  Context is a VOP used to tell
+;;; which node/block to use for the new VOP.
+;;;
+(defun restore-tn (tn before context)
+  (declare (type tn tn) (type (or vop null) before) (type vop context))
+  (let ((save (or (tn-save-tn tn) (pack-save-tn tn))))
+    (emit-operand-load (vop-node context) (vop-block context)
+		       save tn before))
+  (undefined-value))
+
+
+;;; OPTIMIZED-EMIT-SAVES-BLOCK  --  Internal
+;;;
+;;;    Start scanning backward at the end of Block, looking tracking which TNs
+;;; are live and looking for places where we have to save.  We manipulate two
+;;; sets: SAVES and RESTORES.
+;;;
+;;;    SAVES is a set of all the TNs that have to be saved because they are
+;;; restored after some call.  We normally delay saving until the beginning of
+;;; the block, but we must save immediately if we see a write of the saved TN.
+;;; We also immediately save all TNs and exit when we see a
+;;; NOTE-ENVIRONMENT-START VOP, since saves can't be done before the
+;;; environment is properly initialized.
+;;;
+;;;    RESTORES is a set of all the TNs read (and not written) between here and
+;;; the next call, i.e. the set of TNs that must be restored when we reach the
+;;; next (earlier) call VOP.   Unlike SAVES, this set is cleared when we do
+;;; the restoring after a call.  Any TNs that were in RESTORES are moved into
+;;; SAVES to ensure that they are saved at some point.
+;;;
+;;;    SAVES and RESTORES are represented using both a list and a bit-vector so
+;;; that we can quickly iterate and test for membership.  The incoming Saves
+;;; and Restores args are used for computing theses sets (the initial contents
+;;; are ignored.)
+;;;
+(defun optimized-emit-saves-block (block saves restores)
+  (declare (type ir2-block block) (type simple-bit-vector saves restores))
+  (let ((1block (ir2-block-block block))
+	(saves-list ())
+	(restores-list ())
+	(skipping nil))
+    (clear-bit-vector saves)
+    (clear-bit-vector restores)
+    (do-live-tns (tn (ir2-block-live-in block) block)
+      (when (and (sc-save-p (tn-sc tn))
+		 (not (eq (tn-kind tn) :component)))
+	(let ((num (tn-number tn)))
+	  (setf (sbit restores num) 1)
+	  (push tn restores-list))))
+
+    (do ((block block (ir2-block-prev block))
+	 (prev nil block))
+	((not (eq (ir2-block-block block) 1block))
+	 (assert (not skipping))
+	 (dolist (save saves-list)
+	   (let ((start (ir2-block-start-vop prev)))
+	     (save-if-necessary save start start)))
+	 prev)
+      (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
+	  ((null vop))
+	(let ((info (vop-info vop)))
+	  (case (vop-info-name info)
+	    (allocate-frame
+	     (assert skipping)
+	     (setq skipping nil))
+	    (note-environment-start
+	     (assert (not skipping))
+	     (dolist (save saves-list)
+	       (save-if-necessary save (vop-next vop) vop))
+	     (return-from optimized-emit-saves-block block)))
+	  
+	  (unless skipping
+	    (do ((write (vop-results vop) (tn-ref-across write)))
+		((null write))
+	      (let* ((tn (tn-ref-tn write))
+		     (num (tn-number tn)))
+		(unless (zerop (sbit restores num))
+		  (setf (sbit restores num) 0)
+		  (setq restores-list (delete tn restores-list)))
+		(unless (zerop (sbit saves num))
+		  (setf (sbit saves num) 0)
+		  (save-if-necessary tn (vop-next vop) vop)
+		  (setq saves-list (delete tn saves-list))))))
+	  
+	  (when (eq (vop-info-save-p info) t)
+	    (dolist (tn restores-list)
+	      (restore-tn tn (vop-next vop) vop)
+	      (let ((num (tn-number tn)))
+		(when (zerop (sbit saves num))
+		  (push tn saves-list)
+		  (setf (sbit saves num) 1))))
+	    (setq restores-list nil)
+	    (clear-bit-vector restores))
+	  
+	  (if (eq (vop-info-move-args info) :local-call)
+	      (setq skipping t)
+	      (do ((read (vop-args vop) (tn-ref-across read)))
+		  ((null read))
+		(let* ((tn (tn-ref-tn read))
+		       (num (tn-number tn)))
+		  (when (and (sc-save-p (tn-sc tn))
+			     (zerop (sbit restores num))
+			     (not (eq (tn-kind tn) :component)))
+		    (setf (sbit restores num) 1)
+		    (push tn restores-list))))))))))
+	
+
+;;; OPTIMIZED-EMIT-SAVES  --  Internal
+;;;
+;;;    Like EMIT-SAVES, only different.  We avoid redundant saving within the
+;;; block, and don't restore values that aren't used before the next call.
+;;; This function is just the top-level loop over the blocks in the component,
+;;; which locates blocks that need saving done.
+;;;
+(defun optimized-emit-saves (component)
+  (declare (type component component))
+  (let* ((gtn-count (1+ (ir2-component-global-tn-counter
+			 (component-info component))))
+	 (saves (make-array gtn-count :element-type 'bit))
+	 (restores (make-array gtn-count :element-type 'bit))
+	 (block (ir2-block-prev (block-info (component-tail component))))
+	 (head (block-info (component-head component))))
+    (loop
+      (when (eq block head) (return))
+      (when (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+		((null vop) nil)
+	      (when (eq (vop-info-save-p (vop-info vop)) t)
+		(return t)))
+	(setq block (optimized-emit-saves-block block saves restores)))
+      (setq block (ir2-block-prev block)))))
+
+
+;;; ASSIGN-TN-COSTS  --  Internal
+;;;
+;;;    Iterate over the normal TNs, finding the cost of packing on the stack in
+;;; units of the number of references.  We count all references as +1, and
+;;; subtract out REGISTER-SAVE-PENALTY for each place where we would have to
+;;; save a register.
+;;;
+(defun assign-tn-costs (component)
+  (do-ir2-blocks (block component)
+    (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+	((null vop))
+      (when (eq (vop-info-save-p (vop-info vop)) t)
+	(do-live-tns (tn (vop-save-set vop) block)
+	  (decf (tn-cost tn) register-save-penalty)))))
+  
+  (do ((tn (ir2-component-normal-tns (component-info component))
+	   (tn-next tn)))
+      ((null tn))
+    (let ((cost (tn-cost tn)))
+      (declare (fixnum cost))
+      (do ((ref (tn-reads tn) (tn-ref-next ref)))
+	  ((null ref))
+	(incf cost))
+      (do ((ref (tn-writes tn) (tn-ref-next ref)))
+	  ((null ref))
+	(incf cost))
+      (setf (tn-cost tn) cost))))
+
 
 ;;;; Targeting:
 
@@ -950,9 +1144,15 @@
 
 ;;; Pack-TN  --  Internal
 ;;;
-;;;    Attempt to pack TN in all possible SCs, in order of decreasing
-;;; desirability (according to the costs.)  If Restricted, then we can only
-;;; pack in TN-SC, not in any Alternate-SCs.
+;;;    Attempt to pack TN in all possible SCs, first in the SC chosen by
+;;; representation selection, then in the alternate SCs in the order they were
+;;; specified in the SC definition.  If the TN-COST is negative, then we
+;;; don't attempt to pack in SCs that must be saved.  If Restricted, then we
+;;; can only pack in TN-SC, not in any Alternate-SCs.
+;;;
+;;;    If we can't pack in the initial SC, and the TN has a :SPECIFIED-SAVE TN,
+;;; then instead of using the latnerate SCs, pack the save TN (if necessary)
+;;; and then pack this TN in the same location.
 ;;;
 (defun pack-tn (tn restricted)
   (declare (type tn tn))
@@ -962,23 +1162,31 @@
     (do ((sc fsc (pop alternates)))
 	((null sc)
 	 (failed-to-pack-error tn restricted))
-      (let ((loc (or (find-ok-target-offset original sc)
-		     (select-location original sc)
-		     (when (eq (sb-kind (sc-sb sc)) :unbounded)
-		       (grow-sc sc)
-		       (or (select-location original sc)
-			   (error "Failed to pack after growing SC?"))))))
-	(when loc
-	  (add-location-conflicts original sc loc)
-	  (setf (tn-sc tn) sc)
-	  (setf (tn-offset tn) loc)
-	  (return)))))
+      (when (or restricted
+		(not (and (minusp (tn-cost tn)) (sc-save-p sc))))
+	(let ((loc (or (find-ok-target-offset original sc)
+		       (select-location original sc)
+		       (when (eq (sb-kind (sc-sb sc)) :unbounded)
+			 (grow-sc sc)
+			 (or (select-location original sc)
+			     (error "Failed to pack after growing SC?"))))))
+	  (when loc
+	    (add-location-conflicts original sc loc)
+	    (setf (tn-sc tn) sc)
+	    (setf (tn-offset tn) loc)
+	    (return))
+	  (let ((save (tn-save-tn tn)))
+	    (when (and save
+		       (eq (tn-kind save) :specified-save))
+	      (unless (tn-offset save)
+		(pack-tn save nil))
+	      (setf (tn-offset tn) (tn-offset save))
+	      (setf (tn-sc tn) (tn-sc save))
+	      (return)))))))
+	    
   (undefined-value))
 
 
-(defun pack-targeting-tns (tn)
-  )
-
 ;;; Pack-Wired-TN  --  Internal
 ;;;
 ;;;    Pack a wired TN, checking that the offset is in bounds for the SB, and
@@ -986,70 +1194,99 @@
 ;;; location.  If the TN is wired to a location beyond the end of a :Unbounded
 ;;; SB, then grow the SB enough to hold the TN.
 ;;;
+;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs.  This is
+;;; kind of a hack to make specifying wired stack save locations for local call
+;;; arguments (such as OLD-FP) work, since the caller and callee OLD-FP save
+;;; locations may conflict when the save locations don't really (due to being
+;;; in different frames.)
+;;;
 (defun pack-wired-tn (tn)
   (declare (type tn tn))
   (let* ((sc (tn-sc tn))
 	 (sb (sc-sb sc))
 	 (offset (tn-offset tn))
-	 (end (+ offset (sc-element-size sc))))
+	 (end (+ offset (sc-element-size sc)))
+	 (original (original-tn tn)))
     (when (> end (finite-sb-current-size sb))
       (unless (eq (sb-kind sb) :unbounded)
 	(error "~S wired to a location that is out of bounds." tn))
       (grow-sc sc end))
-    (when (conflicts-in-sc tn sc offset)
+    (when (and (not (eq (tn-kind tn) :specified-save))
+	       (conflicts-in-sc original sc offset))
       (error "~S wired to a location that it conflicts with." tn))
-    (add-location-conflicts tn sc offset)))
+    (add-location-conflicts original sc offset)))
 
 
 ;;; Pack  --  Interface
 ;;;
 (defun pack (component)
-  (let ((*in-pack* t))
+  (let ((*in-pack* t)
+	(optimize (policy nil (or (>= speed cspeed) (>= space cspeed))))
+	(2comp (component-info component)))
     (init-sb-vectors component)
-
+    ;;
+    ;; Call the target functions.
     (do-ir2-blocks (block component)
       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 	  ((null vop))
 	(let ((target-fun (vop-info-target-function (vop-info vop))))
 	  (when target-fun
 	    (funcall target-fun vop)))))
-
-    (let ((2comp (component-info component)))
-      (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(pack-wired-tn tn))
-      
-      (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(when (eq (tn-kind tn) :component)
-	  (pack-tn tn t)))
-
-      (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(unless (tn-offset tn)
-	  (pack-tn tn t)))
-      
-      (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(unless (and (eq (tn-kind tn) :normal)
-		     (not (tn-global-conflicts tn)))
-	  (pack-tn tn nil)
-	  (pack-targeting-tns tn))))
     
+    ;;
+    ;; Pack wired TNs first.
+    (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
+	((null tn))
+      (pack-wired-tn tn))
+    ;;
+    ;; Pack restricted component TNs.
+    (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+	((null tn))
+      (when (eq (tn-kind tn) :component)
+	(pack-tn tn t)))
+    ;;
+    ;; Pack other restricted TNs.
+    (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+	((null tn))
+      (unless (tn-offset tn)
+	(pack-tn tn t)))
+    ;;
+    ;; Assign costs to normal TNs so we know which ones should always be
+    ;; packed on the stack.
+    (when optimize
+      (assign-tn-costs component))
+    ;;
+    ;; Pack normal TNs in the order that they appear in the code.  This
+    ;; should have some tendency to pack important TNs first, since control
+    ;; analysis favors the drop-through.  This should also help targeting,
+    ;; since we will pack the target TN soon after we determine the location
+    ;; of the targeting TN.
+    (do-ir2-blocks (block component)
+      (let ((ltns (ir2-block-local-tns block)))
+	(do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
+	    ((minusp i))
+	  (declare (fixnum i))
+	  (let ((tn (svref ltns i)))
+	    (unless (or (null tn) (tn-offset tn) (eq tn :more))
+	      (pack-tn tn nil))))))
+    ;;
+    ;; Pack any leftover normal TNs.  This is to deal with :MORE TNs, which
+    ;; could possibly not appear in any local TN map.
+    (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
+	((null tn))
+      (unless (tn-offset tn)
+	(pack-tn tn nil)))
+    ;;
+    ;; Do load TN packing and emit saves.
     (let ((*live-block* nil)
 	  (*live-vop* nil))
-      (do-ir2-blocks (block component)
-	(let ((ltns (ir2-block-local-tns block)))
-	  (dotimes (i (ir2-block-local-tn-count block))
-	    (let ((tn (svref ltns i)))
-	      (unless (or (null tn)
-			  (eq tn :more)
-			  (tn-global-conflicts tn)
-			  (tn-offset tn))
-		(pack-tn tn nil)
-		(pack-targeting-tns tn)))))
-	
-	(emit-saves block)
-	(pack-load-tns block)))
+      (cond (optimize
+	     (optimized-emit-saves component)
+	     (do-ir2-blocks (block component)
+	       (pack-load-tns block)))
+	    (t
+	     (do-ir2-blocks (block component)
+	       (emit-saves block)
+	       (pack-load-tns block)))))
     
     (undefined-value)))