diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp
index a8b55df46f3c3acf9e7bad0dc5376355e2fde078..a48ebedbb3f1a170f4363584e1ee9b11fe790acb 100644
--- a/compiler/mips/char.lisp
+++ b/compiler/mips/char.lisp
@@ -7,64 +7,88 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.4 1990/03/22 23:53:02 ch Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.5 1990/04/23 16:44:49 wlott Exp $
 ;;; 
 ;;; This file contains the RT VM definition of character operations.
 ;;;
 ;;; Written by Rob MacLachlan
 ;;; Converted for the MIPS R2000 by Christopher Hoover.
 ;;;
-(in-package 'c)
+(in-package "C")
 
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-character)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (base-character-reg)))
+  (:generator 1
+    (inst srl y x vm:type-bits)))
+;;;
+(define-move-vop move-to-base-character :move
+  (any-reg descriptor-reg) (base-character-reg))
+
+
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-character)
+  (:args (x :scs (base-character-reg)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (inst sll y x vm:type-bits)
+    (inst ori y y vm:base-character-type)))
+;;;
+(define-move-vop move-from-base-character :move
+  (base-character-reg) (any-reg descriptor-reg))
+
+;;; Move untagged base-character values.
+;;;
 (define-vop (base-character-move)
   (:args (x :target y
 	    :scs (base-character-reg)
-	    :load nil))
+	    :load-if (not (location= x y))))
   (:results (y :scs (base-character-reg)
-	       :load nil))
-  (:temporary (:scs (base-character-reg) :type base-character
-		    :from :argument  :to :result)
-	      temp)
+	       :load-if (not (location= x y))))
   (:effects)
   (:affected)
   (:generator 0
-    (sc-case x ((base-character-reg base-character-stack
-				    immediate-base-character descriptor-reg
-				    any-reg control-stack)))
-    (sc-case y ((base-character-reg base-character-stack
-				 descriptor-reg any-reg control-stack)))
-
-    (let* ((x-char (sc-is x base-character-reg base-character-stack
-			  immediate-base-character))
-	   (y-char (sc-is y base-character-reg base-character-stack))
-	   (same-rep (if x-char y-char (not y-char)))
-	   (src (if (sc-is x control-stack base-character-stack
-			   immediate-base-character)
-		    temp x))
-	   (dest (if (sc-is y control-stack base-character-stack) temp y)))
-
-      (unless (and same-rep (location= x y))
-
-	(unless (eq x src)
-	  (sc-case x
-	    ((base-character-stack control-stack)
-	     (load-stack-tn src x))
-	    (immediate-base-character
-	     (loadi src (char-code (tn-value x))))))
-
-	(cond (same-rep
-	       (move dest src))
-	      (x-char
-	       (inst sll dest src vm:type-bits)
-	       (inst ori dest dest vm:base-character-type))
-	      (t
-	       (inst srl dest src vm:type-bits)))
-
-	(unless (eq y dest)
-	  (store-stack-tn y dest))))))
-
-(primitive-type-vop base-character-move (:coerce-to-t :coerce-from-t :move)
-  base-character)
+    (move y x)))
+;;;
+(define-move-vop base-character-move :move
+  (base-character-reg) (base-character-reg))
+
+
+;;; Move untagged base-character arguments/return-values.
+;;;
+(define-vop (move-base-character-argument)
+  (:args (x :target y
+	    :scs (base-character-reg))
+	 (fp :scs (descriptor-reg)
+	     :load-if (not (sc-is y base-character-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (base-character-reg
+       (move y x))
+      (base-character-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-base-character-argument :move-argument
+  (any-reg descriptor-reg base-character-reg) (base-character-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-character
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (base-character-reg) (any-reg descriptor-reg))
+
+
+
+;;;; Other operations:
 
 (define-vop (char-code)
   (:args (ch :scs (base-character-reg) :target res))
@@ -84,8 +108,8 @@
   (:generator 0
     (inst srl res code 2)))
 
-;;; Comparison of base-characters -- works for boxed and unboxed
-;;; characters since we don't have bits, etc.
+
+;;; Comparison of base-characters.
 ;;;
 (define-vop (base-character-compare pointer-compare)
   (:args (x :scs (base-character-reg))
@@ -103,3 +127,4 @@
 (define-vop (fast-char>/base-character base-character-compare)
   (:translate char>)
   (:variant :gt))
+
diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp
index 6f91705a2f3394c10d756bdff31593fdf83eccc2..fd0c14940205a4f46a49a7f208de14309349b6ec 100644
--- a/compiler/mips/macros.lisp
+++ b/compiler/mips/macros.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.28 1990/04/05 23:53:30 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.29 1990/04/23 16:45:03 wlott Exp $
 ;;;
 ;;;    This file contains various useful macros for generating MIPS code.
 ;;;
@@ -159,17 +159,7 @@
      (let ((offset (tn-offset stack)))
        (sc-case stack
 	 ((control-stack)
-	  (loadw reg cont-tn offset))
-	 ((number-stack base-character-stack sap-stack)
-	  (multiple-value-bind (cs-size ns-size)
-			       (current-frame-size)
-	    (declare (ignore cs-size))
-	    (unless (< (* offset vm:word-bytes) ns-size)
-	      (cerror "Go ahead."
-		      "~S is ~D words offset in the number stack, but ~
-		      the number stack is only ~D words long."
-		      stack offset (/ ns-size 4)))
-	    (loadw reg nsp-tn (- offset (/ ns-size vm:word-bytes)))))))))
+	  (loadw reg fp-tn offset))))))
 
 (defmacro store-stack-tn (stack reg)
   `(let ((stack ,stack)
@@ -177,17 +167,7 @@
      (let ((offset (tn-offset stack)))
        (sc-case stack
 	 ((control-stack)
-	  (storew reg cont-tn offset))
-	 ((number-stack base-character-stack sap-stack)
-	  (multiple-value-bind (cs-size ns-size)
-			       (current-frame-size)
-	    (declare (ignore cs-size))
-	    (unless (< (* offset vm:word-bytes) ns-size)
-	      (cerror "Go ahead."
-		      "~S is ~D words offset in the number stack, but ~
-		      the number stack is only ~D words long."
-		      stack offset (/ ns-size 4)))
-	    (storew reg nsp-tn (- offset (/ ns-size vm:word-bytes)))))))))
+	  (storew reg fp-tn offset))))))
 
 
 ;;;; Three Way Comparison
@@ -424,7 +404,7 @@
     ;; Partition the type codes.
     (collect ((low-tag-types)
 	      (header-word-types))
-      (dolist (type (enumerate-type-codes types))
+      (dolist (type types)
 	(cond ((< type vm:lowtag-limit)
 	       (low-tag-types type))
 	      (t
diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp
index 6f8c00d839d4bdb7692ca2c8d3c8c9c991944362..806310a12bdd763d326108687ac6cb7290675ee5 100644
--- a/compiler/mips/move.lisp
+++ b/compiler/mips/move.lisp
@@ -7,92 +7,104 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.11 1990/04/11 16:49:05 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.12 1990/04/23 16:45:09 wlott Exp $
 ;;;
-;;;    This file contains the RT VM definition of operand loading/saving and
+;;;    This file contains the MIPS VM definition of operand loading/saving and
 ;;; the Move VOP.
 ;;;
-;;; Written by Rob MacLachlan
+;;; Written by Rob MacLachlan.
+;;; MIPS conversion by William Lott.
 ;;;
 (in-package "C")
 
-;;; Load-Constant-TN  --  Internal
-;;;
-;;;    Load the Constant or immediate constant TN X into Y.  Temp is a
-;;; descriptor register temp or NIL, if none is available.  Temp must be
-;;; supplied if Y may be in memory.  Node is for souce context.
-;;;
-(defun load-constant-tn (x y temp node)
-  (declare (type tn x y) (type (or tn null temp)) (type node node))
-  (assemble node
-    (sc-case x
-      ((zero negative-immediate unsigned-immediate immediate
-	     null random-immediate immediate-base-character immediate-sap)
-       (let ((val (tn-value x))
-	     (dest (sc-case y
-		     ((any-reg descriptor-reg base-character-reg sap-reg) y)
-		     ((control-stack number-stack sap-stack
-				     base-character-stack)
-		      temp))))
-	 (etypecase val
-	   (integer
-	    (loadi dest (fixnum val)))
-	   (null
-	    (move dest null-tn))
-	   (symbol
-	    (load-symbol dest val))
-	   (string-char
-	    (loadi dest (logior (ash (char-code val) type-bits)
-				base-character-type))))
-	 (unless (eq dest y)
-	   (store-stack-tn y temp))))
-      (constant
-       (sc-case y
-	 ((any-reg descriptor-reg)
-	  (loadw y code-tn (tn-offset x) other-pointer-type))
-	 (control-stack
-	  (loadw temp code-tn (tn-offset x) other-pointer-type)
-	  (store-stack-tn y temp)))))))
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((null unsigned-immediate immediate zero negative-immediate
+	 random-immediate immediate-base-character immediate-sap)
+   (any-reg descriptor-reg base-character-reg sap-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (loadi y (fixnum val)))
+      (null
+       (move y null-tn))
+      (symbol
+       (load-symbol y val))
+      (character
+       (loadi y (logior (ash (char-code val) type-bits)
+			base-character-type))))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((null unsigned-immediate immediate zero negative-immediate random-immediate)
+   (signed-reg unsigned-reg))
+  (loadi y (tn-value x)))
+
+(define-move-function (load-base-character 1) (vop x y)
+  ((immediate-base-character) (base-character-reg))
+  (loadi y (char-code (tn-value x))))
+
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (any-reg descriptor-reg))
+  (loadw y code-tn (tn-offset x) other-pointer-type))
+
+(define-move-function (load-stack 5) (vop x y)
+  ((control-stack) (any-reg descriptor-reg))
+  (load-stack-tn y x))
+
+(define-move-function (load-number-stack 5) (vop x y)
+  ((base-character-stack) (base-character-reg)
+   (sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (let ((nfp (current-nfp-tn vop)))
+    (loadw y nfp (tn-offset x))))
+
+(define-move-function (load-single 5) (vop x y)
+  ((single-stack) (single-reg))
+  (cerror "Do nothing." "Not yet." x y))
+
+(define-move-function (load-double 7) (vop x y)
+  ((double-stack) (double-reg))
+  (cerror "Do nothing." "Not yet." x y))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((any-reg descriptor-reg) (control-stack))
+  (store-stack-tn y x))
+
+(define-move-function (store-number-stack 5) (vop x y)
+  ((base-character-reg) (base-character-stack)
+   (sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (let ((nfp (current-nfp-tn vop)))
+    (storew x nfp (tn-offset y))))
+
+(define-move-function (store-single 5) (vop x y)
+  ((single-reg) (single-stack))
+  (cerror "Do nothing." "Not yet." x y))
+
+(define-move-function (store-double 7) (vop x y)
+  ((double-reg) (double-stack))
+  (cerror "Do nothing." "Not yet." x y))
+
 
 
 ;;;; The Move VOP:
 ;;;
-;;;    The Move VOP is used for doing arbitrary moves when there is no
-;;; type-specific move/coerce operation.
-
-;;; We need a register to do a memory-memory move.
-;;;
 (define-vop (move)
   (:args (x :target y
 	    :scs (any-reg descriptor-reg)
-	    :load nil))
+	    :load-if (not (location= x y))))
   (:results (y :scs (any-reg descriptor-reg)
-	       :load nil))
-  (:temporary (:scs (descriptor-reg)
-	       :from :argument  :to :result)
-	      temp)
-  (:node-var node)
+	       :load-if (not (location= x y))))
   (:effects)
   (:affected)
   (:generator 0
-    (unless (location= x y)
-      (sc-case x
-	((any-reg descriptor-reg)
-	 (sc-case y
-	   ((any-reg descriptor-reg)
-	    (move y x))
-	   (control-stack
-	    (store-stack-tn y x))))
-	(control-stack
-	 (sc-case y
-	   ((any-reg descriptor-reg)
-	    (load-stack-tn y x))
-	   (control-stack
-	    (load-stack-tn temp x)
-	    (store-stack-tn y temp))))
-	(t
-	 (unassemble (load-constant-tn x y temp node)))))))
+    (move y x)))
 
+(define-move-vop move :move
+  (any-reg descriptor-reg)
+  (any-reg descriptor-reg))
 
 ;;; Make Move the check VOP for T so that type check generation doesn't think
 ;;; it is a hairy type.  This also allows checking of a few of the values in a
@@ -100,6 +112,27 @@
 ;;;
 (primitive-type-vop move (:check) t)
 
+;;;    The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+(define-vop (move-argument)
+  (:args (x :target y
+	    :scs (any-reg descriptor-reg))
+	 (fp :scs (descriptor-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg descriptor-reg)
+       (move y x))
+      (control-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg descriptor-reg)
+  (any-reg descriptor-reg))
+
+
 
 ;;;; ILLEGAL-MOVE
 
@@ -115,73 +148,4 @@
   (:generator 666
     (error-call di:object-not-type-error x type)))
 
-
-;;;; Operand loading and saving:
-;;;
-;;;    These are the VOPs used for loading or saving Load-TNs.  They cannot
-;;; allocate any temporaries since packing has already been done by the time
-;;; that these VOPs are emitted.  It can be assumed that the loaded (saved) TN
-;;; is free before (after) the load (save) (so may be used as a temporary.)
-;;;
 
-(define-vop (load-operand)
-  (:args (x))
-  (:results (y))
-  (:node-var node)
-  (:generator 5
-    (sc-case x
-      (control-stack
-       (sc-case y
-	 ((any-reg descriptor-reg)
-	  (load-stack-tn y x))
-	 (base-character-reg
-	  (load-stack-tn y x)
-	  (inst srl y y vm:type-bits))))
-      (base-character-stack
-       (sc-case y
-	 (base-character-reg
-	  (load-stack-tn y x))))
-      ((any-reg descriptor-reg)
-       (sc-case y
-	 (base-character-reg
-	  (inst srl y x vm:type-bits))))
-      (t
-       (unassemble (load-constant-tn x y nil node))))))
-
-(define-vop (store-operand)
-  (:args (x))
-  (:results (y))
-  (:generator 5
-    (sc-case y
-      (control-stack
-       (sc-case x
-	 ((any-reg descriptor-reg)
-	  (store-stack-tn y x))
-	 (base-character-reg
-	  (inst sll x x vm:type-bits)
-	  (inst ori x x vm:base-character-type)
-	  (store-stack-tn y x))))
-      (base-character-stack
-       (sc-case x
-	 (base-character-reg
-	  (store-stack-tn y x))))
-      ((any-reg descriptor-reg)
-       (sc-case x
-	 (base-character-reg
-	  (inst sll x x vm:type-bits)
-	  (inst ori y x vm:base-character-type)))))))
-
-
-;;;; Register saving and restoring VOPs.
-
-(define-vop (save-reg)
-  (:args (reg))
-  (:results (stack))
-  (:generator 5
-    (store-stack-tn stack reg)))
-
-(define-vop (restore-reg)
-  (:args (stack))
-  (:results (reg))
-  (:generator 5
-    (load-stack-tn reg stack)))
diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp
index aed17fe7485aa5d23ed36fd7d324cecbe2f3f545..0a7620df043f1b6b41b358af88966425de8005ed 100644
--- a/compiler/mips/nlx.lisp
+++ b/compiler/mips/nlx.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.6 1990/03/20 00:09:42 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.7 1990/04/23 16:45:11 wlott Exp $
 ;;;
 ;;;    This file contains the definitions of VOPs used for non-local exit
 ;;; (throw, lexical exit, etc.)
@@ -16,6 +16,15 @@
 ;;;
 (in-package "C")
 
+;;; MAKE-NLX-SP-TN  --  Interface
+;;;
+;;;    Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(defun make-nlx-sp-tn (env)
+  (environment-live-tn (make-representation-tn (sc-number-or-lose 'any-reg))
+		       env))
+
+
 
 ;;; Save and restore dynamic environment.
 ;;;
@@ -33,25 +42,32 @@
 ;;; use with the Save/Restore-Dynamic-Environment VOPs.
 ;;;
 (defun make-dynamic-state-tns ()
-  (make-n-tns 4 *any-primitive-type*))
+  (make-n-tns 5 *any-primitive-type*))
 
 (define-vop (save-dynamic-state)
   (:results (catch :scs (descriptor-reg))
 	    (special :scs (descriptor-reg))
-	    (number :scs (descriptor-reg))
+	    (nfp :scs (descriptor-reg))
+	    (nsp :scs (descriptor-reg))
 	    (eval :scs (descriptor-reg)))
+  (:vop-var vop)
   (:generator 13
     (load-symbol-value catch lisp::*current-catch-block*)
     (move special bsp-tn)
-    (move number nsp-tn)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(move nfp cur-nfp)))
+    (move nsp nsp-tn)
     (load-symbol-value eval lisp::*eval-stack-top*)))
 
 (define-vop (restore-dynamic-state)
   (:args (catch :scs (descriptor-reg))
 	 (special :scs (descriptor-reg))
-	 (number :scs (descriptor-reg))
+	 (nfp :scs (descriptor-reg))
+	 (nsp :scs (descriptor-reg))
 	 (eval :scs (descriptor-reg)))
   (:temporary (:scs (descriptor-reg)) symbol value)
+  (:vop-var vop)
   (:generator 10
     (let ((done (gen-label))
 	  (skip (gen-label))
@@ -59,7 +75,10 @@
 
       (store-symbol-value catch lisp::*current-catch-block*)
       (store-symbol-value eval lisp::*eval-stack-top*)
-      (move nsp-tn number)
+      (let ((cur-nfp (current-nfp-tn vop)))
+	(when cur-nfp
+	  (move cur-nfp nfp)))
+      (move nsp-tn nsp)
       
       (inst beq special bsp-tn done)
       (nop)
@@ -92,7 +111,7 @@
 ;;;; Unwind block hackery:
 
 ;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Cont, Env, Unwind-Protect, and the entry PC.
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
 ;;;
 (define-vop (make-unwind-block)
   (:args (tn))
@@ -101,10 +120,10 @@
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :target block) result)
   (:generator 22
-    (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes))
+    (inst addiu result fp-tn (* (tn-offset tn) vm:word-bytes))
     (load-symbol-value temp lisp::*current-unwind-protect-block*)
     (storew temp result vm:unwind-block-current-uwp-slot)
-    (storew cont-tn result vm:unwind-block-current-cont-slot)
+    (storew fp-tn result vm:unwind-block-current-cont-slot)
     (storew code-tn result vm:unwind-block-current-code-slot)
     (inst compute-lra-from-code temp code-tn entry-label)
     (storew temp result vm:catch-block-entry-pc-slot)
@@ -116,16 +135,16 @@
 ;;;
 (define-vop (make-catch-block)
   (:args (tn)
-	 (tag :scs (any-reg descriptor-reg)))
+	 (tag :scs (descriptor-reg)))
   (:info entry-label)
   (:results (block :scs (descriptor-reg)))
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :target block) result)
   (:generator 44
-    (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes))
+    (inst addiu result fp-tn (* (tn-offset tn) vm:word-bytes))
     (load-symbol-value temp lisp::*current-unwind-protect-block*)
     (storew temp result vm:catch-block-current-uwp-slot)
-    (storew cont-tn result vm:catch-block-current-cont-slot)
+    (storew fp-tn result vm:catch-block-current-cont-slot)
     (storew code-tn result vm:catch-block-current-code-slot)
     (inst compute-lra-from-code temp code-tn entry-label)
     (storew temp result vm:catch-block-entry-pc-slot)
@@ -145,7 +164,7 @@
   (:args (tn))
   (:temporary (:scs (descriptor-reg)) new-uwp)
   (:generator 7
-    (inst addiu new-uwp cont-tn (* (tn-offset tn) vm:word-bytes))
+    (inst addiu new-uwp fp-tn (* (tn-offset tn) vm:word-bytes))
     (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
 
 
@@ -232,12 +251,9 @@
 	 (count :target num))
   (:results (new-start) (new-count))
   (:info label)
-  (:temporary (:scs (any-reg descriptor-reg) :type fixnum :from (:argument 0))
-	      dst)
-  (:temporary (:scs (any-reg descriptor-reg) :type fixnum :from (:argument 1))
-	      src)
-  (:temporary (:scs (any-reg descriptor-reg) :type fixnum :from (:argument 2))
-	      num)
+  (:temporary (:scs (any-reg) :type fixnum :from (:argument 0)) dst)
+  (:temporary (:scs (any-reg) :type fixnum :from (:argument 1)) src)
+  (:temporary (:scs (any-reg) :type fixnum :from (:argument 2)) num)
   (:temporary (:scs (descriptor-reg)) temp)
   (:save-p :force-to-stack)
   (:generator 30
diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp
index bc683cabd00763c2a446a8fe79127eebbaf4968b..35b5888a618e05a36706fd19bd398e50d183e2a4 100644
--- a/compiler/mips/parms.lisp
+++ b/compiler/mips/parms.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.43 1990/04/12 16:33:28 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.44 1990/04/23 16:45:16 wlott Exp $
 ;;;
 ;;;    This file contains some parameterizations of various VM
 ;;; attributes for the MIPS.  This file is separate from other stuff so 
@@ -27,7 +27,7 @@
 
 ;;; Maximum number of SCs allowed.
 ;;;
-(defconstant sc-number-limit 26)
+(defconstant sc-number-limit 32)
 
 ;;; The inclusive upper bound on a cost.  We want to write cost frobbing
 ;;; code so that it is portable, but works on fixnums.  This constant
@@ -57,6 +57,10 @@
   which has the MSB first (RT) or :little-endian which has the MSB last
   (VAX).")
 
+;;; ### This should be somewhere else.
+(defconstant native-byte-order :big-endian
+  "The byte order we are running under.")
+
 
 
 ;;;; Description of the target address space.
diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp
index ade0c6d283efde1e44d477a31d5fdd48fedc8ca2..a198baf6652bdc4b2212bd31863f4170e6bb4c68 100644
--- a/compiler/mips/sap.lisp
+++ b/compiler/mips/sap.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.2 1990/03/22 23:50:34 ch Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.3 1990/04/23 16:45:19 wlott Exp $
 ;;;
 ;;;    This file contains the MIPS VM definition of SAP operations.
 ;;;
@@ -15,58 +15,83 @@
 ;;;
 (in-package "C")
 
-
 
-;;;; The SAP-MOVE vop.
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:generator 1
+    (loadw y x vm:sap-pointer-slot vm:other-pointer-type)))
+
+;;;
+(define-move-vop move-to-sap :move
+  (descriptor-reg) (sap-reg))
+
+
+;;; Move an untagged SAP to a tagged representation.
+;;;
+(define-vop (move-from-sap)
+  (:args (x :scs (sap-reg) :target sap))
+  (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (y :scs (descriptor-reg)))
+  (:generator 1
+    (move sap x)
+    (pseudo-atomic (ndescr)
+      (inst addiu y alloc-tn vm:other-pointer-type)
+      (inst addiu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size))
+      (loadi ndescr (logior (ash vm:sap-size vm:type-bits) vm:sap-type))
+      (storew y ndescr 0 vm:other-pointer-type)
+      (storew y sap vm:sap-pointer-slot vm:other-pointer-type))))
+;;;
+(define-move-vop move-from-sap :move
+  (sap-reg) (descriptor-reg))
 
+
+;;; Move untagged sap values.
+;;;
 (define-vop (sap-move)
-  (:args (x :target y :scs (sap-reg) :load nil))
-  (:results (y :scs (sap-reg) :load nil))
-  (:temporary (:scs (sap-reg) :type system-area-pointer
-		    :from :argument :to :result) sap)
-  (:temporary (:scs (descriptor-reg) :from :argument :to :result) temp)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:args (x :target y
+	    :scs (sap-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (sap-reg)
+	       :load-if (not (location= x y))))
   (:effects)
   (:affected)
   (:generator 0
-    (sc-case x ((sap-reg sap-stack immediate-sap descriptor-reg control-stack)))
-    (sc-case y ((sap-reg sap-stack descriptor-reg control-stack)))
-
-    (let* ((x-sap-p (sc-is x sap-reg sap-stack immediate-sap))
-	   (y-sap-p (sc-is y sap-reg sap-stack))
-	   (src (cond ((sc-is x sap-reg descriptor-reg) x)
-		      (x-sap-p sap)
-		      (t temp)))
-	   (dst (cond ((sc-is y sap-reg descriptor-reg) y)
-		      (y-sap-p sap)
-		      (t temp))))
-
-      (sc-case x
-	((control-stack sap-stack)
-	 (load-stack-tn src x))
-	((descriptor-reg sap-reg))
-	(immediate-sap
-	 (loadi src (tn-value x))))
-      (cond ((and x-sap-p (not y-sap-p))
-	     (pseudo-atomic (ndescr)
-	       (inst addiu dst alloc-tn vm:other-pointer-type)
-	       (inst addiu alloc-tn alloc-tn (pad-data-block vm:sap-size))
-	       (loadi ndescr (logior (ash vm:sap-size vm:type-bits)
-				     vm:sap-type))
-	       (storew ndescr dst 0 vm:other-pointer-type)
-	       (storew src dst vm:sap-pointer-slot vm:other-pointer-type)))
-	    ((and y-sap-p (not x-sap-p))
-	     (loadw sap src vm:sap-pointer-slot vm:other-pointer-type))
-	    (t
-	     (move dst src)))
-      (sc-case y
-	((control-stack sap-stack)
-	 (store-stack-tn y dst))
-	((sap-reg descriptor-reg))))))
-
-(primitive-type-vop sap-move
-		    (:coerce-to-t :coerce-from-t :move)
-		    system-area-pointer)
+    (move y x)))
+;;;
+(define-move-vop sap-move :move
+  (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+  (:args (x :target y
+	    :scs (sap-reg))
+	 (fp :scs (descriptor-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move y x))
+      (sap-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+  (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (sap-reg) (descriptor-reg))
 
 
 
@@ -88,7 +113,7 @@
   (:translate int-sap)
   (:policy :fast-safe)
   (:generator 0
-    ;; ### Need to check to see if it is a bignum.
+    ;; ### Need to check to see if it is a bignum first.
     (inst srl sap int 2)))
 
 
diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp
index b185eadf5d971e57410e751b263162c4989d3c5c..5807d205ee53ba2acf81e8c332a8433a44937134 100644
--- a/compiler/mips/static-fn.lisp
+++ b/compiler/mips/static-fn.lisp
@@ -7,7 +7,7 @@
 ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.4 1990/04/03 12:43:43 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.5 1990/04/23 16:45:22 wlott Exp $
 ;;;
 ;;; This file contains the VOPs and macro magic necessary to call static
 ;;; functions.
@@ -23,7 +23,7 @@
   (:policy :fast-safe)
   (:variant-vars symbol)
   (:node-var node)
-  (:temporary (:scs (descriptor-reg any-reg)) temp)
+  (:temporary (:scs (any-reg)) temp)
   (:temporary (:scs (descriptor-reg)) move-temp)
   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
   (:temporary (:sc descriptor-reg :offset cname-offset) cname)
@@ -31,8 +31,7 @@
   (:temporary (:scs (descriptor-reg)) function)
   (:temporary (:scs (interior-reg) :type interior) lip)
   (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset args-offset) args)
-  (:temporary (:sc any-reg :offset oldcont-offset) old-cont))
+  (:temporary (:sc any-reg :offset old-fp-offset) old-fp))
 
 
 (eval-when (compile load eval)
@@ -91,9 +90,8 @@
 	     (loadi nargs (fixnum ,num-args))
 	     (load-symbol cname symbol)
 	     (loadw lexenv cname vm:symbol-function-slot vm:other-pointer-type)
-	     (move args cont-tn)
-	     (move old-cont cont-tn)
-	     (move cont-tn csp-tn)
+	     (move old-fp fp-tn)
+	     (move fp-tn csp-tn)
 	     (inst compute-lra-from-code lra code-tn lra-label)
 	     (loadw function lexenv vm:closure-function-slot
 		    vm:function-pointer-type)
diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp
index 4a7d6c9f9dd9ccf99b37d4af394b94321ab36e4b..bb42657c032d744a3edb30c7dacfc507f46c5040 100644
--- a/compiler/mips/vm.lisp
+++ b/compiler/mips/vm.lisp
@@ -7,7 +7,7 @@
 ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.21 1990/04/13 17:15:19 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.22 1990/04/23 16:45:25 wlott Exp $
 ;;;
 ;;; This file contains the VM definition for the MIPS R2000 and the new
 ;;; object format.
@@ -20,8 +20,9 @@
 ;;;; SB and SC definition:
 
 (define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 32)
 (define-storage-base control-stack :unbounded :size 8)
-(define-storage-base number-stack :unbounded :size 8)
+(define-storage-base non-descriptor-stack :unbounded :size 0)
 (define-storage-base constant :non-packed)
 (define-storage-base immediate-constant :non-packed)
 
@@ -38,45 +39,11 @@
 		 classes))))
 
 (define-storage-classes
-  ;; Objects that can be stored in any register (immediate objects)
-  (any-reg registers
-   :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 28 31))
-
-  ;; Objects that must be seen by GC (pointer objects)
-  (descriptor-reg registers
-   :locations (8 9 10 11 12 13 14 15 16 17 18 19 28 31))
-
-  ;; Objects that must not be seen by GC (unboxed objects)
-  (non-descriptor-reg registers
-   :locations (2 3 4 5 6 7))
-
-  ;; Pointers to the interior of objects.
-  (interior-reg registers
-   :locations (1))
-
-  ;; Unboxed base-characters
-  (base-character-reg registers
-   :locations (2 3 4 5 6 7))
-
-  ;; Unboxed SAP's (arbitrary pointers into address space)
-  (sap-reg registers
-   :locations (2 3 4 5 6 7))
-
-  ;; Stack for descriptor objects (scanned by GC)
-  (control-stack control-stack)
-
-  ;; Stack for non-descriptor objects (not scanned by GC)
-  (number-stack number-stack)
-
-  ;; Unboxed base-character stack
-  (base-character-stack number-stack)
-
-  ;; Unboxed SAP stack
-  (sap-stack number-stack)
 
   ;; Non-immediate contstants in the constant pool
   (constant constant)
 
+
   ;; Immediate numeric constants.
   ;; 
   ;;   zero = (integer 0 0)
@@ -98,203 +65,183 @@
   (immediate immediate-constant)
   (unsigned-immediate immediate-constant)
 
-  ;; Immediate null/nil.
+  ;; Immediate SCs for things other than numbers. 
   (null immediate-constant)
-
-  ;; Immediate unboxed base-characters.
   (immediate-base-character immediate-constant)
-
-  ;; Immediate unboxed SAP's.
   (immediate-sap immediate-constant)
 
-  ;; Objects that are easier to create using immediate loads than to fetch
-  ;; from the constant pool, but which aren't directly usable as immediate
-  ;; operands.  These are only recognized by move VOPs.
+  ;; Anything else that can be computed faster than loaded that doesn't fit in
+  ;; any of the above immediate SCs.
   (random-immediate immediate-constant)
 
-  ;; A catch or unwind block.
-  (catch-block control-stack :element-size vm:catch-block-size))
 
 
-
-;;;; Interfaces for stack sizes.
+  ;; **** The stacks.
 
-(defun current-frame-size ()
-  (values (* vm:word-bytes
-	     (finite-sb-current-size (sb-or-lose 'control-stack)))
-	  (* vm:word-bytes
-	     (finite-sb-current-size (sb-or-lose 'number-stack)))))
+  ;; The control stack.  (Scanned by GC)
+  (control-stack control-stack)
 
+  ;; The non-descriptor stacks.
+  (signed-stack non-descriptor-stack) ; (signed-byte 32)
+  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
+  (base-character-stack non-descriptor-stack) ; non-descriptor characters.
+  (sap-stack non-descriptor-stack) ; System area pointers.
+  (single-stack non-descriptor-stack) ; single-floats
+  (double-stack non-descriptor-stack :element-size 2) ; double floats.
 
-
-;;;; Move costs.
 
-;;;
-;;; Move costs for operand loading and storing
-;;;
-#+nil ;; These move costs don't work.
-(define-move-costs
-  ((immediate zero null random-immediate)
-   ;; load immediate or reg->reg move.
-   (1 any-reg descriptor-reg))
-
-  ((immediate-base-character)
-   ;; Load immediate.
-   (1 base-character-reg any-reg descriptor-reg))
-
-  ((immediate-sap)
-   ;; lui/ori pair.
-   (2 sap-reg))
-
-  ((any-reg)
-   ;; No conversion necessary for these.
-   (1 any-reg descriptor-reg)
-   ;; Must shift and addiu the type code.
-   (2 base-character-reg)
-   ;; No type conversion, but we have to write it on the stack.
-   (5 control-stack))
-
-  ((descriptor-reg)
-   ;; No conversion necessary for these.
-   (1 any-reg descriptor-reg)
-   ;; Must shift and addiu the type code.
-   (2 base-character-reg)
-   ;; Must indirect the src ptr.
-   (5 sap-reg)
-   ;; No type conversion, but we have to write it on the stack.
-   (5 control-stack))
-
-  ((base-character-reg)
-   ;; Just move.
-   (1 base-character-reg)
-   ;; Must add type info.
-   (2 any-reg descriptor-reg)
-   ;; Must store it.
-   (5 base-character-stack))
-
-  ((sap-reg)
-   ;; Just move
-   (1 sap-reg)
-   ;; Must allocate space for it.
-   (10 descriptor-reg)
-   ;; Must store it.
-   (5 sap-stack))
-
-  ((control-stack constant)
-   ;; Must indirect the stack/code pointer.
-   (5 any-reg descriptor-reg))
-
-  ((base-character-stack)
-   ;; Just indirect.
-   (5 base-character-reg))
-
-  ((sap-stack)
-   ;; Just indirect.
-   (5 sap-reg)))
-
-(define-move-costs
-  ((any-reg descriptor-reg non-descriptor-reg)
-   (1 any-reg descriptor-reg non-descriptor-reg)
-   (2 base-character-reg sap-reg)
-   (5 control-stack number-stack))
-
-  ((control-stack number-stack constant)
-   (5 any-reg descriptor-reg non-descriptor-reg)
-   (6 base-character-reg sap-reg))
-
-  ((immediate zero null random-immediate)
-   (1 any-reg descriptor-reg non-descriptor-reg))
-
-  ((immediate-base-character)
-   (1 base-character-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg))
-
-  ((immediate-sap)
-   (1 sap-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg))
-
-  ((base-character-reg)
-   (1 base-character-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg)
-   (5 base-character-stack)
-   (6 control-stack number-stack))
-
-  ((sap-reg)
-   (1 sap-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg)
-   (5 sap-stack)
-   (6 control-stack number-stack))
-
-  ((base-character-stack)
-   (5 base-character-reg))
-
-  ((sap-stack)
-   (5 sap-reg)))
+
+  ;; **** Things that can go in the integer registers.
+
+  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
+  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
+  (any-reg
+   registers
+   :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 28 31)
+   :constant-scs (constant negative-immediate zero immediate unsigned-immediate
+			   immediate-base-character random-immediate)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Pointer descriptor objects.  Must be seen by GC.
+  (descriptor-reg registers
+   :locations (8 9 10 11 12 13 14 15 16 17 18 19 28 31)
+   :constant-scs (constant negative-immediate zero immediate unsigned-immediate
+			   immediate-base-character random-immediate null)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Non-Descriptor characters
+  (base-character-reg registers
+   :locations (2 3 4 5 6 7)
+   :constant-scs (immediate-base-character)
+   :save-p t
+   :alternate-scs (base-character-stack))
+
+  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
+  (sap-reg registers
+   :locations (2 3 4 5 6 7)
+   :constant-scs (immediate-sap)
+   :save-p t
+   :alternate-scs (sap-stack))
+
+  ;; Non-Descriptor (signed or unsigned) numbers.
+  (signed-reg registers
+   :locations (2 3 4 5 6 7)
+   :constant-scs (negative-immediate zero immediate unsigned-immediate
+				     random-immediate)
+   :save-p t
+   :alternate-scs (signed-stack))
+  (unsigned-reg registers
+   :locations (2 3 4 5 6 7)
+   :constant-scs (zero immediate unsigned-immediate random-immediate)
+   :save-p t
+   :alternate-scs (unsigned-stack))
+
+  ;; Random objects that must not be seen by GC.  Used only as temporaries.
+  (non-descriptor-reg registers
+   :locations (2 3 4 5 6 7))
+
+  ;; Pointers to the interior of objects.  Used only as an temporary.
+  (interior-reg registers
+   :locations (1))
+
+
+  ;; **** Things that can go in the floating point registers.
+
+  ;; Non-Descriptor single-floats.
+  (single-reg float-registers
+   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (single-stack))
+
+  ;; Non-Descriptor double-floats.
+  (double-reg float-registers
+   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+   :element-size 2
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (double-stack))
+
+
+
+
+  ;; A catch or unwind block.
+  (catch-block control-stack :element-size vm:catch-block-size))
 
 
-;;;
-;;; SCs which must saved on a function call.
-(define-save-scs
-  (control-stack any-reg descriptor-reg)
-  (base-character-stack base-character-reg)
-  (sap-stack sap-reg))
 
 
 ;;;; Primitive Type Definitions
 
-(def-primitive-type t (descriptor-reg control-stack))
+;;; *Anything*
+;;; 
+(def-primitive-type t (descriptor-reg))
 (defvar *any-primitive-type* (primitive-type-or-lose 't))
 
-;;; 
-(def-primitive-type fixnum (any-reg control-stack))
+;;; Primitive integer types.
+;;;
+(def-primitive-type fixnum (any-reg))
+#| ### Rob needs to think about this more.
+(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg))
+(def-primitive-type negative-fixnum (any-reg signed-reg))
+(def-primitive-type negative-signed-byte-32 (signed-reg))
+(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg))
+(def-primitive-type unsigned-byte-32 (unsigned-reg))
+|#
 
-(def-primitive-type base-character
-  (base-character-reg any-reg base-character-stack control-stack))
+;;; Other primitive immediate types.
+(def-primitive-type base-character (base-character-reg any-reg))
 
+;;; Primitive pointer types.
 ;;; 
-(def-primitive-type function (descriptor-reg control-stack))
-(def-primitive-type list (descriptor-reg control-stack))
+(def-primitive-type function (descriptor-reg))
+(def-primitive-type list (descriptor-reg))
+(def-primitive-type structure (descriptor-reg))
 
-;;;
-(def-primitive-type bignum (descriptor-reg control-stack))
-(def-primitive-type ratio (descriptor-reg control-stack))
-(def-primitive-type complex (descriptor-reg control-stack))
-(def-primitive-type single-float (descriptor-reg control-stack))
-(def-primitive-type double-float (descriptor-reg control-stack))
+;;; Primitive other-pointer number types.
+;;; 
+(def-primitive-type bignum (descriptor-reg))
+(def-primitive-type ratio (descriptor-reg))
+(def-primitive-type complex (descriptor-reg))
+(def-primitive-type single-float (single-reg descriptor-reg))
+(def-primitive-type double-float (double-reg descriptor-reg))
 
-;;;
-(def-primitive-type simple-string (descriptor-reg control-stack)
-  :type simple-base-string)
-(def-primitive-type simple-bit-vector (descriptor-reg control-stack))
-(def-primitive-type simple-vector (descriptor-reg control-stack))
-(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg control-stack)
+;;; Primitive other-pointer array types.
+;;; 
+(def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
+(def-primitive-type simple-bit-vector (descriptor-reg))
+(def-primitive-type simple-vector (descriptor-reg))
+(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
   :type (simple-array (unsigned-byte 2) (*)))
-(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg control-stack)
+(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
   :type (simple-array (unsigned-byte 4) (*)))
-(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg control-stack)
+(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
   :type (simple-array (unsigned-byte 8) (*)))
-(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg control-stack)
+(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
   :type (simple-array (unsigned-byte 16) (*)))
-(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg control-stack)
+(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
   :type (simple-array (unsigned-byte 32) (*)))
-(def-primitive-type simple-array-single-float (descriptor-reg control-stack)
+(def-primitive-type simple-array-single-float (descriptor-reg)
   :type (simple-array single-float (*)))
-(def-primitive-type simple-array-double-float (descriptor-reg control-stack)
+(def-primitive-type simple-array-double-float (descriptor-reg)
   :type (simple-array double-float (*)))
 
-(def-primitive-type system-area-pointer (sap-reg sap-stack))
+;;; Note: The complex array types are not inclueded, 'cause it is pointless to
+;;; restrict VOPs to them.
 
+;;; Other primitive other-pointer types.
+;;; 
+(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
+
+;;; Random primitive types that don't exist at the LISP level.
+;;; 
 (def-primitive-type random (non-descriptor-reg) :type nil)
 (def-primitive-type interior (interior-reg) :type nil)
 (def-primitive-type catch-block (catch-block) :type nil)
 
 
-;;;
-#|  These are not needed 'cause its pointless to restrict VOPs to them.
-(def-primitive complex-string (descriptor-reg control-stack))
-(def-primitive complex-bit-vector (descriptor-reg control-stack))
-(def-primitive complex-vector (descriptor-reg control-stack))
-|#
 
 
 ;;;; Primitive-type-of and friends.
@@ -337,26 +284,46 @@
 ;;;
 (defun primitive-type (type)
   (declare (type ctype type))
-  (etypecase type
-    (numeric-type
-     (if (not (eq (numeric-type-complexp type) :real))
-	 (values *any-primitive-type* nil)
-	 (case (numeric-type-class type)
-	   (integer
-	    (let ((lo (numeric-type-low type))
-		  (hi (numeric-type-high type)))
-	      (if (and hi lo
-		       (>= lo most-negative-fixnum)
-		       (<= hi most-positive-fixnum))
-		  (values (primitive-type-or-lose 'fixnum)
-			  (and (= lo most-negative-fixnum)
-			       (= hi most-positive-fixnum)))
-		  (values *any-primitive-type* nil))))
+  (macrolet ((any () '(values *any-primitive-type* nil))
+	     (exactly (type) `(values (primitive-type-or-lose ',type) t))
+	     (part-of (type) `(values (primitive-type-or-lose ',type) nil)))
+    (etypecase type
+      (numeric-type
+       (let ((lo (numeric-type-low type))
+	     (hi (numeric-type-high type)))
+	 (case (numeric-type-complexp type)
+	   (:real
+	    (case (numeric-type-class type)
+	      (integer
+	       (cond ((and hi lo
+			   (>= lo most-negative-fixnum)
+			   (<= hi most-positive-fixnum))
+		      (values (primitive-type-or-lose 'fixnum)
+			      (and (= lo most-negative-fixnum)
+				   (= hi most-positive-fixnum))))
+		     ((or (and hi (< hi most-negative-fixnum))
+			  (and lo (> lo most-positive-fixnum)))
+		      (part-of bignum))
+		     (t
+		      (any))))
+	      (float
+	       (let ((exact (and (null lo) (null hi))))
+		 (case (numeric-type-format type)
+		   ((short-float single-float)
+		    (values (primitive-type-or-lose 'single-float) exact))
+		   ((double-float long-float)
+		    (values (primitive-type-or-lose 'double-float) exact))
+		   (t
+		    (any)))))
+	      (t
+	       (any))))
+	   (:complex
+	    (part-of complex))
 	   (t
-	    (values *any-primitive-type* nil)))))
-    (array-type
+	    (any)))))
+      (array-type
        (if (array-type-complexp type)
-	   (values *any-primitive-type* nil)
+	   (any)
 	   (let* ((dims (array-type-dimensions type))
 		  (etype (array-type-specialized-element-type type))
 		  (type-spec (type-specifier etype))
@@ -364,38 +331,39 @@
 				     :test #'equal))))
 	     (if (and (consp dims) (null (rest dims)) ptype)
 		 (values (primitive-type-or-lose ptype) (eq (first dims) '*))
-		 (values *any-primitive-type* nil)))))
-    (union-type
-     (if (type= type (specifier-type 'list))
-	 (values (primitive-type-or-lose 'list) t)
-	 (let ((types (union-type-types type)))
-	   (multiple-value-bind (res exact)
-				(primitive-type (first types))
-	     (dolist (type (rest types))
-	       (multiple-value-bind (ptype ptype-exact)
-				    (primitive-type type)
-		 (unless ptype-exact (setq exact nil))
-		 (setq res (primitive-type-union res ptype))))
-	     (values res exact)))))
-    (member-type
-     (values (reduce #'primitive-type-union
-		     (mapcar #'primitive-type-of 
-			     (member-type-members type)))
-	     nil))
-    (named-type
-     (case (named-type-name type)
-       ((t bignum ratio complex function system-area-pointer)
-	(values (primitive-type-or-lose (named-type-name type)) t))
-       ((character base-character string-char)
-	(values (primitive-type-or-lose 'base-character) t))
-       (standard-char
-	(values (primitive-type-or-lose 'base-character) nil))
-       (cons
-	(values (primitive-type-or-lose 'list) nil))
-       (t
-	(values *any-primitive-type* nil))))
-    (ctype
-     (values *any-primitive-type* nil))))
+		 (any)))))
+      (union-type
+       (if (type= type (specifier-type 'list))
+	   (exactly list)
+	   (let ((types (union-type-types type)))
+	     (multiple-value-bind (res exact)
+				  (primitive-type (first types))
+	       (dolist (type (rest types) (values res exact))
+		 (multiple-value-bind (ptype ptype-exact)
+				      (primitive-type type)
+		   (unless ptype-exact (setq exact nil))
+		   (unless (eq ptype res)
+		     (return (any)))))))))
+      (member-type
+       (let* ((members (member-type-members type))
+	      (res (primitive-type-of (first members))))
+	 (dolist (mem (rest members) (values res nil))
+	   (unless (eq (primitive-type-of mem) res)
+	     (return (values *any-primitive-type* nil))))))
+      (named-type
+       (case (named-type-name type)
+	 ((t bignum ratio complex function system-area-pointer)
+	  (values (primitive-type-or-lose (named-type-name type)) t))
+	 ((character base-character string-char)
+	  (exactly base-character))
+	 (standard-char
+	  (part-of base-character))
+	 (cons
+	  (part-of list))
+	 (t
+	  (any))))
+      (ctype
+       (any)))))
 
 
 ;;;; Magical Registers
@@ -405,7 +373,7 @@
   (defconstant lip-offset 1)
   (defconstant null-offset 20)
   (defconstant bsp-offset 21)
-  (defconstant cont-offset 22)
+  (defconstant fp-offset 22)
   (defconstant csp-offset 23)
   (defconstant flags-offset 24)
   (defconstant alloc-offset 25)
@@ -442,10 +410,10 @@
 
 ;;;
 ;;; Frame Pointer
-(defparameter cont-tn
+(defparameter fp-tn
   (make-random-tn :kind :normal
 		  :sc (sc-or-lose 'any-reg)
-		  :offset cont-offset))
+		  :offset fp-offset))
 
 ;;; 
 ;;; Control stack pointer
@@ -520,15 +488,13 @@
      (if (vm:static-symbol-p value)
 	 (sc-number-or-lose 'random-immediate)
 	 nil))
-    (fixnum
+    ((signed-byte 29) #+nil (or (signed-byte 32) (unsigned-byte 32))
      (sc-number-or-lose 'random-immediate))
-    ;; ### what here?
-    ;(sap
-    ; (sc-number-or-lose 'immediate-sap))
-    (t
-     ;;
-     ;; ### hack around bug in (typep x 'string-char)
-     (if (and (characterp value) (string-char-p value))
+    #+new-compiler
+    (system-area-pointer
+     (sc-number-or-lose 'immediate-sap))
+    (character
+     (if (string-char-p value)
 	 (sc-number-or-lose 'immediate-base-character)
 	 nil))))
 
@@ -548,7 +514,7 @@
 (defconstant cname-offset 14)
 (defconstant lexenv-offset 15)
 (defconstant args-offset 16)
-(defconstant oldcont-offset 17)
+(defconstant old-fp-offset 17)
 (defconstant lra-offset 18)
 
 ;;; A few additional registers distinct from all the linkage regs.  These are
@@ -561,9 +527,9 @@
 (defconstant l0-offset 19)
 
 ;;; Offsets of special stack frame locations
-(defconstant oldcont-save-offset 0)
+(defconstant old-fp-save-offset 0)
 (defconstant lra-save-offset 1)
-(defconstant lexenv-save-offset 2)
+(defconstant nfp-save-offset 2)
 
 ); Eval-When (Compile Load Eval)  
 
@@ -578,6 +544,11 @@
 		  :sc (sc-or-lose 'descriptor-reg)
 		  :offset args-offset))
 
+(defparameter old-fp-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'descriptor-reg)
+		  :offset old-fp-offset))
+
 (defparameter lra-tn
   (make-random-tn :kind :normal
 		  :sc (sc-or-lose 'descriptor-reg)
@@ -610,3 +581,22 @@
 			      :sc (sc-or-lose 'descriptor-reg)
 			      :offset n))
 	  register-arg-offsets))
+
+
+
+;;; LOCATION-PRINT-NAME  --  Interface
+;;;
+;;;    This function is called by debug output routines that want a pretty name
+;;; for a TN's location.  It returns a thing that can be printed with PRINC.
+;;;
+(defun location-print-name (tn)
+  (declare (type tn tn))
+  (let ((sb (sb-name (sc-sb (tn-sc tn))))
+	(offset (tn-offset tn)))
+    (ecase sb
+      (registers (mips:register-name (tn-offset tn)))
+      (float-registers (format nil "F~D" offset))
+      (control-stack (format nil "CS~D" offset))
+      (non-descriptor-stack (format nil "NS~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed"))))