diff --git a/compiler/pack.lisp b/compiler/pack.lisp
index 1df06846e635531235c0bb8f48ea3ad49dfe4b69..ac93cb9b1ae4b9b562a26fe23a6bed17985b37ce 100644
--- a/compiler/pack.lisp
+++ b/compiler/pack.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/pack.lisp,v 1.38 1991/07/10 17:52:46 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.39 1991/07/17 23:05:34 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -379,42 +379,43 @@
 ;;;    If load TN packing fails, try to give a helpful error message.  We find
 ;;; a TN in each location that conflicts, and print it.
 ;;;
-(defun failed-to-pack-load-tn-error (sc op)
-  (declare (type sc sc) (type tn-ref op))
+(defun failed-to-pack-load-tn-error (scs op)
+  (declare (list scs) (type tn-ref op))
   (collect ((used)
 	    (unused))
-    (let* ((sb (sc-sb sc))
-	   (confs (finite-sb-live-tns sb)))
-      (assert (eq (sb-kind sb) :finite))
-      (dolist (el (sc-locations sc))
-	(let ((conf (load-tn-conflicts-in-sc op sc el t)))
-	  (if conf
-	      (used (describe-tn-use el conf op))
-	      (loop for i from el
-		as victim = (svref confs i)
-		repeat (sc-element-size sc) do
-		(when (and victim (eq (tn-kind victim) :component))
-		  (used (describe-tn-use el victim op))
-		  (return t))
-		finally (unused el))))))
-	
+    (dolist (sc scs)
+      (let* ((sb (sc-sb sc))
+	     (confs (finite-sb-live-tns sb)))
+	(assert (eq (sb-kind sb) :finite))
+	(dolist (el (sc-locations sc))
+	  (let ((conf (load-tn-conflicts-in-sc op sc el t)))
+	    (if conf
+		(used (describe-tn-use el conf op))
+		(loop for i from el
+		      as victim = (svref confs i)
+		      repeat (sc-element-size sc) do
+		  (when (and victim (eq (tn-kind victim) :component))
+		    (used (describe-tn-use el victim op))
+		    (return t))
+		  finally (unused el)))))))
+      
     (multiple-value-bind (arg-p n more-p costs load-scs incon)
 			 (get-operand-info op)
-      (declare (ignore costs load-scs))
-      (assert (not more-p))
-      (error "Unable to pack a Load-TN in SC ~S for the ~:R ~
-             ~:[result~;argument~] to~@
-	     the ~S VOP,~@
-	     ~:[since all SC elements are in use:~:{~%~@?~}~%~;~
-	     ~:*but these SC elements are not in use:~%  ~S~%Bug?~*~]~
-	     ~:[~;~@
-	     Current cost info inconsistent with that in effect at compile ~
-	     time.  Recompile.~%Compilation order may be incorrect.~]"
-	     (sc-name sc)
-	     n arg-p
-	     (vop-info-name (vop-info (tn-ref-vop op)))
-	     (unused) (used)
-	     incon)))
+	(declare (ignore costs load-scs))
+	(assert (not more-p))
+	(error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~
+		for the ~:R ~:[result~;argument~] to~@
+		the ~S VOP,~@
+		~:[since all SC elements are in use:~:{~%~@?~}~%~;~
+		~:*but these SC elements are not in use:~%  ~S~%Bug?~*~]~
+		~:[~;~@
+		Current cost info inconsistent with that in effect at compile ~
+		time.  Recompile.~%Compilation order may be incorrect.~]"
+	       (mapcar #'sc-name scs)
+	       n arg-p
+	       (vop-info-name (vop-info (tn-ref-vop op)))
+	       (unused) (used)
+	       incon)))
   (undefined-value))
 
 
@@ -891,7 +892,6 @@
     (if (and (eq target-sb (sc-sb sc))
 	     (or (eq (sb-kind target-sb) :unbounded)
 		 (member loc (sc-locations sc)))
-	     (not (member loc (sc-reserve-locations sc)))
 	     (= (sc-element-size target-sc) (sc-element-size sc))
 	     (not (conflicts-in-sc tn sc loc))
 	     (zerop (mod loc (sc-alignment sc))))
@@ -1001,6 +1001,12 @@
 (defvar *live-block*)
 (defvar *live-vop*)
 
+;;; If we unpack some TNs, then we mark all affected blocks by sticking them in
+;;; this hash-table.  This is initially null.  We create the hashtable if we do
+;;; any unpacking.
+;;;
+(defvar *repack-blocks*)
+(declaim (type (or hash-table null) *repack-blocks*))
 
 ;;; Init-Live-TNs  --  Internal
 ;;;
@@ -1178,97 +1184,93 @@
       (return loc))))
 
 
-(defevent spill-conditional-arg-tn
-	  "Spilled a TN that was an arg to a :CONDITIONAL VOP.")
-
-;;; SPILL-CONDITIONAL-ARG-TN  --  Internal
-;;;
-;;;    Fix things up when we spill a TN for loading of an argument to a
-;;; conditional VOP.  We have to insert a block on the branch target path that
-;;; restores the spilled value.  In addition to inserting a block in the IR1
-;;; flow graph, we must also insert an IR2 block into the emit order and frob
-;;; the assembly level control flow by emitting or modifying branches.
-;;;
-;;;    We change the conditional's target label to be the new block's label.
-;;; We insert the new block in the emit order immediately after the conditional
-;;; block.  In order to do this, we must insert a branch at the end of the
-;;; conditional block if it currently drops through.
-;;;
-(defun spill-conditional-arg-tn (victim vop)
-  (declare (type tn victim) (type vop vop))
-  (let* ((info-args (vop-codegen-info vop))
-	 (lab (first info-args))
-	 (node (vop-node vop))
-	 (2block (vop-block vop))
-	 (block (ir2-block-block 2block))
-	 (succ (find lab (block-succ block) :key #'block-label))
-	 (new (insert-cleanup-code block succ node
-				   "<conditional spill hack>"))
-	 (new-2block (make-ir2-block new)))
-    (event spill-conditional-arg-tn node)
-    (setf (block-info new) new-2block)
-    (setf (first info-args) (block-label new))
-    (emit-operand-load node new-2block (tn-save-tn victim) victim nil)
-    (vop branch node new-2block lab)
-    
-    (let ((next-lab (block-label (ir2-block-block (ir2-block-next 2block)))))
-      (add-to-emit-order new-2block 2block)
-      (unless (eq (vop-info-name (vop-info (ir2-block-last-vop 2block)))
-		  'branch)
-	(vop branch node 2block next-lab)))
-    (undefined-value)))
+(defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.")
 
+;;; UNPACK-TN  --  Internal
+;;;
+;;;    Make TN's location the same as for its save TN (allocating a save TN if
+;;; necessary.)  Delete any save/restore code that has been emitted thus far.
+;;; Mark all blocks containing references as needing to be repacked.
+;;;
+(defun unpack-tn (tn)
+  (event unpack-tn)
+  (let ((stn (or (tn-save-tn tn)
+		 (pack-save-tn tn))))
+    (setf (tn-sc tn) (tn-sc stn))
+    (setf (tn-offset tn) (tn-offset stn))
+    (flet ((zot (refs)
+	     (do ((ref refs (tn-ref-next ref)))
+		 ((null ref))
+	       (let ((vop (tn-ref-vop ref)))
+		 (if (eq (vop-info-name (vop-info vop)) 'move-operand)
+		     (delete-vop vop)
+		     (setf (gethash (vop-block vop) *repack-blocks*) t))))))
+      (zot (tn-reads tn))
+      (zot (tn-writes tn))))
 
-(defevent spill-tn "Spilled a TN to satisfy operand SC restriction.")
+  (undefined-value))
 
-;;; Spill-And-Pack-Load-TN  --  Internal
-;;;
-;;;     Handle the case of Pack-Load-TN where there isn't any location free
-;;; that we can pack into.  What we do is spill some live TN to memory, and
-;;; then pack the load TN in the freed location.
+(defevent unpack-fallback "Unpacked some random operand TN.")
+
+;;; UNPACK-FOR-LOAD-TN  --  Internal
 ;;;
-;;; When we find any location in SC that isn't in use within the VOP, we spill
-;;; the TN in that location.  There must be some TN live in every location,
-;;; since normal load TN packing failed.
+;;;     Called by Pack-Load-TN where there isn't any location free that we can
+;;; pack into.  What we do is move some live TN in one of the specified SCs to
+;;; memory, then mark this block all blocks that reference the TN as needing
+;;; repacking.  If we suceed, we throw to UNPACKED-TN.  If we fail, we return
+;;; NIL.
 ;;;
-;;; We never spill component TNs, since there are used magically within VOPs.
-;;; Spilling is done using the same mechanism as register saving.  We mark the
-;;; spilled TN for the debugger, so that it doesn't think it is valid when the
-;;; value has been moved elsewhere.
+;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired
+;;; or restricted.)  We prefer to unpack TNs that are not used by the VOP.  If
+;;; we can't find any such TN, then we unpack some random argument or result
+;;; TN.  The only way we can fail is if all locations in SC are used by
+;;; load-TNs or temporaries in VOP.
 ;;;
-(defun spill-and-pack-load-tn (sc op)
+(defun unpack-for-load-tn (sc op)
   (declare (type sc sc) (type tn-ref op))
-  (let ((vop (tn-ref-vop op))
-	(sb (sc-sb sc)))
-    
-    (dolist (loc (sc-locations sc)
-		 (failed-to-pack-load-tn-error sc op))
-      (declare (type index loc))
-      (unless (load-tn-conflicts-in-sc op sc loc t)
-	(let ((spills (delete-duplicates
-		       (loop for i from loc
-			     as victim = (svref (finite-sb-live-tns sb) i)
-			     repeat (sc-element-size sc)
-			     when victim
-			     collect victim))))
-	  (assert spills)
-	  (unless (find :component spills :key #'tn-kind)
-	    (dolist (victim spills)
-	      (event spill-tn (vop-node vop))
-	      (basic-save-tn victim vop)
-	      (note-spilled-tn victim vop)
-	      (when (eq (template-result-types (vop-info vop)) :conditional)
-		(spill-conditional-arg-tn victim vop)))
+  (let ((sb (sc-sb sc))
+	(normal-tns (ir2-component-normal-tns
+		     (component-info *compile-component*)))
+	(fallback nil))
+    (flet ((unpack-em (victims)
+	     (unless *repack-blocks*
+	       (setq *repack-blocks* (make-hash-table :test #'eq)))
+	     (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t)
+	     (dolist (victim victims)
+	       (unpack-tn victim))
+	     (throw 'unpacked-tn nil)))
+      (dolist (loc (sc-locations sc))
+	(declare (type index loc))
+	(block SKIP
+	  (collect ((victims nil adjoin))
+	    (loop for i from loc
+	      as victim = (svref (finite-sb-live-tns sb) i)
+	      repeat (sc-element-size sc) do
+	      (when victim
+		(unless (find-in #'tn-next victim normal-tns)
+		  (return-from SKIP))
+		(victims victim)))
 	    
-	    (let ((res (make-tn 0 :load nil sc)))
-	      (setf (tn-offset res) loc)
-	      (return res))))))))
+	    (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
+	      (cond ((not conf)
+		     (unpack-em (victims)))
+		    ((eq conf :overflow))
+		    ((not fallback)
+		     (if (find conf (victims))
+			 (setq fallback (victims))
+			 (setq fallback (list conf)))))))))
+      
+      (when fallback
+	(event unpack-fallback)
+	(unpack-em fallback))))
+
+  nil)
 
 
 ;;; Pack-Load-TN  --  Internal
 ;;;
-;;;    Try to pack a load TN in the SCs indicated by Load-SCs.  If this fails,
-;;; then we let Spill-And-Pack-Load-TN do its thing.  We return the packed load
+;;;    Try to pack a load TN in the SCs indicated by Load-SCs.  If we run out
+;;; of SCs, then we unpack some TN and try again.  We return the packed load
 ;;; TN.
 ;;;
 ;;; Note: we allow a Load-TN to be packed in the target location even if that
@@ -1285,31 +1287,38 @@
     (compute-live-tns (vop-block vop) vop))
   
   (let* ((tn (tn-ref-tn op))
-	 (ptype (tn-primitive-type tn)))
-    (let ((scs (svref load-scs (sc-number (tn-sc tn))))
-	  (allowed nil))
+	 (ptype (tn-primitive-type tn))
+	 (scs (svref load-scs (sc-number (tn-sc tn)))))
+    (let ((current-scs scs)
+	  (allowed ()))
       (loop
-	(when (null scs)
-	  (unless allowed (no-load-scs-allowed-by-primitive-type-error op))
-	  (return (spill-and-pack-load-tn allowed op)))
-	
-	(let* ((sc (svref (backend-sc-numbers *backend*) (pop scs)))
-	       (target (find-load-tn-target op sc)))
-	  (when (or target (sc-allowed-by-primitive-type sc ptype))
-	    (setq allowed sc)
-	    (let ((loc (or target
-			   (select-load-tn-location op sc))))
-	      (when loc
-		(let ((res (make-tn 0 :load nil sc)))
-		  (setf (tn-offset res) loc)
-		  (return res))))))))))
+	(cond
+	 ((null current-scs)
+	  (unless allowed
+	    (no-load-scs-allowed-by-primitive-type-error op))
+	  (dolist (sc allowed (failed-to-pack-load-tn-error allowed op))
+	    (when (unpack-for-load-tn sc op) (return)))
+	  (setq current-scs scs  allowed ()))
+	(t
+	 (let* ((sc (svref (backend-sc-numbers *backend*) (pop current-scs)))
+		(target (find-load-tn-target op sc)))
+	   (when (or target (sc-allowed-by-primitive-type sc ptype))
+	     (let ((loc (or target
+			    (select-load-tn-location op sc))))
+	       (when loc
+		 (let ((res (make-tn 0 :load nil sc)))
+		   (setf (tn-offset res) loc)
+		   (return res))))
+	     (push sc allowed)))))))))
 
 
 ;;; Check-Operand-Restrictions  --  Internal
 ;;;
 ;;;    Scan a list of load-SCs vectors and a list of TN-Refs threaded by
 ;;; TN-Ref-Across.  When we find a reference whose TN doesn't satisfy the
-;;; restriction, we pack a Load-TN and load the operand into it.
+;;; restriction, we pack a Load-TN and load the operand into it.  If a load-tn
+;;; has already been allocated, we can assume that the restriction is
+;;; satisfied.
 ;;;
 (proclaim '(inline check-operand-restrictions))
 (defun check-operand-restrictions (scs ops)
@@ -1317,9 +1326,13 @@
   (do ((scs scs (cdr scs))
        (op ops (tn-ref-across op)))
       ((null scs))
-    (let ((ref-scn (sc-number (tn-sc (tn-ref-tn op)))))
-      (unless (eq (svref (car scs) ref-scn) t)
-	(setf (tn-ref-load-tn op) (pack-load-tn (car scs) op)))))
+    (let* ((load-tn (tn-ref-load-tn op))
+	   (load-scs (svref (car scs)
+			    (sc-number (tn-sc (or load-tn (tn-ref-tn op)))))))
+      (if load-tn
+	  (assert (eq load-scs t))
+	  (unless (eq load-scs t)
+	    (setf (tn-ref-load-tn op) (pack-load-tn (car scs) op))))))
   (undefined-value))
 	
 
@@ -1330,13 +1343,14 @@
 ;;; later, and our conflict analysis is a backward scan.
 ;;;
 (defun pack-load-tns (block)
-  (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-      ((null vop))
-    (let ((info (vop-info vop)))
-      (check-operand-restrictions (vop-info-result-load-scs info)
-				  (vop-results vop))
-      (check-operand-restrictions (vop-info-arg-load-scs info)
-				  (vop-args vop))))
+  (catch 'unpacked-tn
+    (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
+	((null vop))
+      (let ((info (vop-info vop)))
+	(check-operand-restrictions (vop-info-result-load-scs info)
+				    (vop-results vop))
+	(check-operand-restrictions (vop-info-arg-load-scs info)
+				    (vop-args vop)))))
   (undefined-value))
 
 
@@ -1419,9 +1433,12 @@
     (add-location-conflicts original sc offset)))
 
 
+(defevent repack-block "Repacked a block due to TN unpacking.")
+
 ;;; Pack  --  Interface
 ;;;
 (defun pack (component)
+  (assert (not *in-pack*))
   (let ((*in-pack* t)
 	(optimize (policy nil (or (>= speed cspeed) (>= space cspeed))))
 	(2comp (component-info component)))
@@ -1480,15 +1497,27 @@
 	(pack-tn tn nil)))
     ;;
     ;; Do load TN packing and emit saves.
-    (let ((*live-block* nil)
-	  (*live-vop* nil))
-      (cond ((and optimize pack-optimize-saves)
-	     (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)))))
-    
+    (let ((*repack-blocks* nil))
+      (let ((*live-block* nil)
+	    (*live-vop* nil))
+	(cond ((and optimize pack-optimize-saves)
+	       (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)))))
+      (when *repack-blocks*
+	(loop
+	  (when (zerop (hash-table-count *repack-blocks*)) (return))
+	  (let ((*live-block* nil)
+		(*live-vop* nil))
+	    (maphash #'(lambda (block v)
+			 (declare (ignore v))
+			 (remhash block *repack-blocks*)
+			 (event repack-block)
+			 (pack-load-tns block))
+		     *repack-blocks*)))))
+
     (undefined-value)))