diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp
index e8c033c4f892b0c18d9fd6c27aacfbdb53e9f2d0..6d59e1943d4455584f60a34273288a87942b93fe 100644
--- a/compiler/mips/alloc.lisp
+++ b/compiler/mips/alloc.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.17 1992/07/28 20:34:12 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $
-;;;
 ;;; Allocation VOPs for the MIPS port.
 ;;;
 ;;; Written by William Lott.
@@ -29,7 +27,7 @@
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
 	      res)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:info num)
   (:results (result :scs (descriptor-reg)))
   (:variant-vars star)
@@ -41,7 +39,7 @@
 	   (move result (tn-ref-tn things)))
 	  (t
 	   (macrolet
-	       ((store-car (tn list &optional (slot vm:cons-car-slot))
+	       ((store-car (tn list &optional (slot cons-car-slot))
 		  `(let ((reg
 			  (sc-case ,tn
 			    ((any-reg descriptor-reg) ,tn)
@@ -50,27 +48,27 @@
 			    (control-stack
 			     (load-stack-tn temp ,tn)
 			     temp))))
-		     (storew reg ,list ,slot vm:list-pointer-type))))
+		     (storew reg ,list ,slot list-pointer-type))))
 	     (let ((cons-cells (if star (1- num) num)))
-	       (pseudo-atomic (ndescr)
-		 (inst addu res alloc-tn vm:list-pointer-type)
-		 (inst addu alloc-tn alloc-tn
-		       (* (vm:pad-data-block vm:cons-size) cons-cells))
+	       (pseudo-atomic (pa-flag
+			       :extra (* (pad-data-block cons-size)
+					 cons-cells))
+		 (inst or res alloc-tn list-pointer-type)
 		 (move ptr res)
 		 (dotimes (i (1- cons-cells))
 		   (store-car (tn-ref-tn things) ptr)
 		   (setf things (tn-ref-across things))
-		   (inst addu ptr ptr (vm:pad-data-block vm:cons-size))
+		   (inst addu ptr ptr (pad-data-block cons-size))
 		   (storew ptr ptr
-			   (- vm:cons-cdr-slot vm:cons-size)
-			   vm:list-pointer-type))
+			   (- cons-cdr-slot cons-size)
+			   list-pointer-type))
 		 (store-car (tn-ref-tn things) ptr)
 		 (cond (star
 			(setf things (tn-ref-across things))
-			(store-car (tn-ref-tn things) ptr vm:cons-cdr-slot))
+			(store-car (tn-ref-tn things) ptr cons-cdr-slot))
 		       (t
 			(storew null-tn ptr
-				vm:cons-cdr-slot vm:list-pointer-type)))
+				cons-cdr-slot list-pointer-type)))
 		 (assert (null (tn-ref-across things)))
 		 (move result res))))))))
 
@@ -90,32 +88,34 @@
   (:temporary (:scs (non-descriptor-reg)) ndescr)
   (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:generator 100
-    (inst li ndescr (lognot vm:lowtag-mask))
-    (inst addu boxed boxed-arg (fixnum (1+ vm:code-trace-table-offset-slot)))
+    (inst li ndescr (lognot lowtag-mask))
+    (inst addu boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot)))
     (inst and boxed ndescr)
-    (inst srl unboxed unboxed-arg vm:word-shift)
-    (inst addu unboxed unboxed vm:lowtag-mask)
+    (inst srl unboxed unboxed-arg word-shift)
+    (inst addu unboxed unboxed lowtag-mask)
     (inst and unboxed ndescr)
-    (pseudo-atomic (ndescr)
-      (inst addu result alloc-tn vm:other-pointer-type)
+    (pseudo-atomic (pa-flag)
+      (inst or result alloc-tn other-pointer-type)
       (inst addu alloc-tn boxed)
       (inst addu alloc-tn unboxed)
-      (inst sll ndescr boxed (- vm:type-bits vm:word-shift))
-      (inst or ndescr vm:code-header-type)
-      (storew ndescr result 0 vm:other-pointer-type)
-      (storew unboxed result vm:code-code-size-slot vm:other-pointer-type)
-      (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type)
-      (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type))))
+      (inst sll ndescr boxed (- type-bits word-shift))
+      (inst or ndescr code-header-type)
+      (storew ndescr result 0 other-pointer-type)
+      (storew unboxed result code-code-size-slot other-pointer-type)
+      (storew null-tn result code-entry-points-slot other-pointer-type)
+      (storew null-tn result code-debug-info-slot other-pointer-type))))
 
 (define-vop (make-fdefn)
   (:policy :fast-safe)
   (:translate make-fdefn)
   (:args (name :scs (descriptor-reg) :to :eval))
   (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:results (result :scs (descriptor-reg) :from :argument))
   (:generator 37
-    (with-fixed-allocation (result temp fdefn-type fdefn-size)
+    (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size)
       (storew name result fdefn-name-slot other-pointer-type)
       (storew null-tn result fdefn-function-slot other-pointer-type)
       (inst li temp (make-fixup "undefined_tramp" :foreign))
@@ -124,85 +124,85 @@
 
 ;;;; Automatic allocators for primitive objects.
 
-(vm:define-for-each-primitive-object (obj)
-  (collect ((forms))
-    (let* ((options (vm:primitive-object-options obj))
-	   (alloc-trans (getf options :alloc-trans))
-	   (alloc-vop (getf options :alloc-vop alloc-trans))
-	   (header (vm:primitive-object-header obj))
-	   (lowtag (vm:primitive-object-lowtag obj))
-	   (size (vm:primitive-object-size obj))
-	   (variable-length (vm:primitive-object-variable-length obj))
-	   (need-unbound-marker nil))
-      (collect ((args) (init-forms))
-	(when (and alloc-vop variable-length)
-	  (args 'extra-words))
-	(dolist (slot (vm:primitive-object-slots obj))
-	  (let* ((name (vm:slot-name slot))
-		 (offset (vm:slot-offset slot)))
-	    (ecase (getf (vm:slot-options slot) :init :zero)
-	      (:zero)
-	      (:null
-	       (init-forms `(storew null-tn result ,offset ,lowtag)))
-	      (:unbound
-	       (setf need-unbound-marker t)
-	       (init-forms `(storew temp result ,offset ,lowtag)))
-	      (:arg
-	       (args name)
-	       (init-forms `(storew ,name result ,offset ,lowtag))))))
-	(when (and (null alloc-vop) (args))
-	  (error "Slots ~S want to be initialized, but there is no alloc vop ~
-	          defined for ~S."
-		 (args) (vm:primitive-object-name obj)))
-	(when alloc-vop
-	  (forms
-	   `(define-vop (,alloc-vop)
-	      (:args ,@(mapcar #'(lambda (name)
-				   `(,name :scs (any-reg descriptor-reg)))
-			       (args)))
-	      (:temporary (:scs (non-descriptor-reg) :type random)
-			  ndescr
-			  ,@(when (or need-unbound-marker header
-				      variable-length)
-			      '(temp)))
-	      (:temporary (:scs (descriptor-reg) :to (:result 0)
-				:target real-result) result)
-	      (:results (real-result :scs (descriptor-reg)))
-	      (:policy :fast-safe)
-	      ,@(when alloc-trans
-		  `((:translate ,alloc-trans)))
-	      (:generator 37
-		(pseudo-atomic (ndescr)
-		  (inst addu result alloc-tn ,lowtag)
-		  ,@(cond ((and header variable-length)
-			   `((inst addu temp extra-words
-				   (fixnum (1- ,size)))
-			     (inst addu alloc-tn alloc-tn temp)
-			     (inst sll temp temp
-				   (- vm:type-bits vm:word-shift))
-			     (inst or temp temp ,header)
-			     (storew temp result 0 ,lowtag)
-			     (inst addu alloc-tn alloc-tn
-				   (+ (fixnum 1) vm:lowtag-mask))
-			     (inst li temp (lognot vm:lowtag-mask))
-			     (inst and alloc-tn alloc-tn temp)))
-			  (variable-length
-			   (error ":REST-P T with no header in ~S?"
-				  (vm:primitive-object-name obj)))
-			  (header
-			   `((inst addu alloc-tn alloc-tn
-				   (vm:pad-data-block ,size))
-			     (inst li temp
-				   ,(logior (ash (1- size) vm:type-bits)
-					    (symbol-value header)))
-			     (storew temp result 0 ,lowtag)))
-			  (t
-			   `((inst addu alloc-tn alloc-tn
-				   (vm:pad-data-block ,size)))))
-		  ,@(when need-unbound-marker
-		      `((inst li temp vm:unbound-marker-type)))
-		  ,@(init-forms)
-		  (move real-result result))))))))
-    (when (forms)
-      `(progn
-	 ,@(forms)))))
+(define-for-each-primitive-object (obj)
+  (let* ((options (primitive-object-options obj))
+	 (alloc-trans (getf options :alloc-trans))
+	 (alloc-vop (getf options :alloc-vop alloc-trans))
+	 (header (primitive-object-header obj))
+	 (lowtag (primitive-object-lowtag obj))
+	 (size (primitive-object-size obj))
+	 (variable-length (primitive-object-variable-length obj))
+	 (need-unbound-marker nil))
+    (collect ((args) (init-forms))
+      (when (and alloc-vop variable-length)
+	(args 'extra-words))
+      (dolist (slot (primitive-object-slots obj))
+	(let* ((name (slot-name slot))
+	       (offset (slot-offset slot)))
+	  (ecase (getf (slot-options slot) :init :zero)
+	    (:zero)
+	    (:null
+	     (init-forms `(storew null-tn result ,offset ,lowtag)))
+	    (:unbound
+	     (setf need-unbound-marker t)
+	     (init-forms `(storew temp result ,offset ,lowtag)))
+	    (:arg
+	     (args name)
+	     (init-forms `(storew ,name result ,offset ,lowtag))))))
+      (when (and (null alloc-vop) (args))
+	(error "Slots ~S want to be initialized, but there is no alloc vop ~
+		defined for ~S."
+	       (args) (primitive-object-name obj)))
+      (when alloc-vop
+	`(define-vop (,alloc-vop)
+	   (:args ,@(mapcar #'(lambda (name)
+				`(,name :scs (any-reg descriptor-reg)))
+			    (args)))
+	   (:temporary (:scs (non-descriptor-reg))
+		       ,@(when (or header need-unbound-marker)
+			   '(temp))
+		       ,@(when variable-length '(temp2)))
+	   (:temporary (:scs (descriptor-reg) :to (:result 0)
+			     :target real-result) result)
+	   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+	   (:results (real-result :scs (descriptor-reg)))
+	   (:policy :fast-safe)
+	   ,@(when alloc-trans
+	       `((:translate ,alloc-trans)))
+	   (:generator ,(+ 4
+			   (length (init-forms))
+			   (if header 2 0)
+			   (if variable-length 6 0)
+			   (if need-unbound-marker 1 0))
+	     (pseudo-atomic
+		 (pa-flag :extra ,(if variable-length
+				      0
+				      `(pad-data-block ,size)))
+	       (inst or result alloc-tn ,lowtag)
+	       ,@(cond ((and header variable-length)
+			`((inst addu temp extra-words (fixnum (1+ ,size)))
+			  (inst li temp2 (lognot lowtag-mask))
+			  (inst and temp temp2)
+			  (inst addu alloc-tn temp)
+			  (inst addu temp extra-words (fixnum (1- ,size)))
+			  (inst sll temp extra-words
+				(- type-bits word-shift))
+			  (inst or temp temp ,header)
+			  (storew temp result 0 ,lowtag)))
+		       (variable-length
+			(error ":REST-P T with no header in ~S?"
+			       (primitive-object-name obj)))
+		       (header
+			`((inst addu alloc-tn alloc-tn
+				(pad-data-block ,size))
+			  (inst li temp
+				,(logior (ash (1- size) type-bits)
+					 (symbol-value header)))
+			  (storew temp result 0 ,lowtag)))
+		       (t
+			`((inst addu alloc-tn alloc-tn
+				(pad-data-block ,size)))))
+	       ,@(when need-unbound-marker
+		   `((inst li temp unbound-marker-type)))
+	       ,@(init-forms)
+	       (move real-result result))))))))
diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp
index 3bdab2ae2c6b1502bd67693c07972e2b06501575..872a16a839be30851d0882b6d92025bd9178d958 100644
--- a/compiler/mips/arith.lisp
+++ b/compiler/mips/arith.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.45 1992/03/27 19:35:24 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.46 1992/07/28 20:37:12 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.45 1992/03/27 19:35:24 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.46 1992/07/28 20:37:12 wlott Exp $
 ;;;
 ;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
 ;;;
@@ -104,112 +104,112 @@
   (:affected)
   (:policy :fast-safe))
 
-(defmacro define-binop (translate cost op &optional unsigned)
+(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
+  (:args (x :target r :scs (any-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-signed-c-binop fast-signed-binop)
+  (:args (x :target r :scs (signed-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
+  (:args (x :target r :scs (unsigned-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(defmacro define-binop (translate cost untagged-cost op
+				  tagged-type untagged-type)
   `(progn
-     (define-vop (,(intern (concatenate 'simple-string
-					"FAST-"
-					(string translate)
-					"/FIXNUM=>FIXNUM"))
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 		  fast-fixnum-binop)
-       (:args (x :target r
-		 :scs (any-reg))
-	      (y :target r
-		 :scs (any-reg immediate zero
-			       ,(if unsigned
-				    'unsigned-immediate
-				    'negative-immediate))))
+       (:args (x :target r :scs (any-reg))
+	      (y :target r :scs (any-reg)))
        (:translate ,translate)
        (:generator ,cost
-	 (inst ,op r x
-	       (sc-case y
-		 (any-reg y)
-		 (zero zero-tn)
-		 ((immediate
-		   ,(if unsigned 'unsigned-immediate 'negative-immediate))
-		  (fixnum (tn-value y)))))))
-     (define-vop (,(intern (concatenate 'simple-string
-					"FAST-"
-					(string translate)
-					"/SIGNED=>SIGNED"))
+	 (inst ,op r x y)))
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 		  fast-signed-binop)
-       (:args (x :target r
-		 :scs (signed-reg))
-	      (y :target r
-		 :scs (signed-reg immediate zero
-				  ,(if unsigned
-				       'unsigned-immediate
-				       'negative-immediate))))
+       (:args (x :target r :scs (signed-reg))
+	      (y :target r :scs (signed-reg)))
        (:translate ,translate)
-       (:generator ,(1+ cost)
-	 (inst ,op r x
-	       (sc-case y
-		 (signed-reg y)
-		 (zero zero-tn)
-		 ((immediate
-		   ,(if unsigned 'unsigned-immediate 'negative-immediate))
-		  (tn-value y))))))
-     (define-vop (,(intern (concatenate 'simple-string
-					"FAST-"
-					(string translate)
-					"/UNSIGNED=>UNSIGNED"))
+       (:generator ,untagged-cost
+	 (inst ,op r x y)))
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 		  fast-unsigned-binop)
-       (:args (x :target r
-		 :scs (unsigned-reg))
-	      (y :target r
-		 :scs (unsigned-reg immediate zero
-				    ,(if unsigned
-					 'unsigned-immediate
-					 'negative-immediate))))
+       (:args (x :target r :scs (unsigned-reg))
+	      (y :target r :scs (unsigned-reg)))
+       (:translate ,translate)
+       (:generator ,untagged-cost
+	 (inst ,op r x y)))
+     (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+		  fast-fixnum-c-binop)
+       (:arg-types tagged-num (:constant ,tagged-type))
+       (:translate ,translate)
+       (:generator ,cost
+	 (inst ,op r x (fixnum y))))
+     (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+		  fast-signed-c-binop)
+       (:arg-types signed-num (:constant ,untagged-type))
        (:translate ,translate)
-       (:generator ,(1+ cost)
-	 (inst ,op r x
-	       (sc-case y
-		 (unsigned-reg y)
-		 (zero zero-tn)
-		 ((immediate
-		   ,(if unsigned 'unsigned-immediate 'negative-immediate))
-		  (tn-value y))))))))
-
-(define-binop + 2 addu)
-(define-binop - 2 subu)
-(define-binop logior 1 or t)
-(define-binop logand 1 and t)
-(define-binop logxor 1 xor t)
-
-;;; Special case fixnum + and - that don't check for overflow.  Useful when we
-;;; know the output type is a fixnum.
+       (:generator ,untagged-cost
+	 (inst ,op r x y)))
+     (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-c-binop)
+       (:arg-types unsigned-num (:constant ,untagged-type))
+       (:translate ,translate)
+       (:generator ,untagged-cost
+	 (inst ,op r x y)))))
+
+(define-binop + 2 6 addu (signed-byte 14) (signed-byte 16))
+(define-binop - 2 6 subu
+  (integer #.(- (1- (ash 1 14))) #.(ash 1 14))
+  (integer #.(- (1- (ash 1 16))) #.(ash 1 16)))
+(define-binop logior 1 2 or (unsigned-byte 14) (unsigned-byte 16))
+(define-binop lognor 1 2 nor (unsigned-byte 14) (unsigned-byte 16))
+(define-binop logand 1 2 and (unsigned-byte 14) (unsigned-byte 16))
+(define-binop logxor 1 2 xor (unsigned-byte 14) (unsigned-byte 16))
+
+;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
+;;; know that the result is going to be a fixnum.
 
 (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
   (:results (r :scs (any-reg descriptor-reg)))
   (:result-types (:or signed-num unsigned-num))
   (:note nil)
-  (:generator 1
-    (inst add r x
-	  (sc-case y
-	    (any-reg y)
-	    (zero zero-tn)
-	    ((immediate negative-immediate)
-	     (fixnum (tn-value y)))))))
+  (:generator 4
+    (inst add r x y)))
+
+(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:note nil)
+  (:generator 3
+    (inst add r x (fixnum y))))
 
 (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
   (:results (r :scs (any-reg descriptor-reg)))
   (:result-types (:or signed-num unsigned-num))
   (:note nil)
-  (:generator 1
-    (inst sub r x
-	  (sc-case y
-	    (any-reg y)
-	    (zero zero-tn)
-	    ((immediate negative-immediate)
-	     (fixnum (tn-value y)))))))
+  (:generator 4
+    (inst sub r x y)))
+
+(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:note nil)
+  (:generator 3
+    (inst sub r x (fixnum y))))
 
 
 ;;; Shifting
 
+
 (define-vop (fast-ash)
   (:note "inline ASH")
   (:args (number :scs (signed-reg unsigned-reg) :to :save)
-	 (amount :scs (signed-reg immediate negative-immediate)))
+	 (amount :scs (signed-reg)))
   (:arg-types (:or signed-num unsigned-num) signed-num)
   (:results (result :scs (signed-reg unsigned-reg)))
   (:result-types (:or signed-num unsigned-num))
@@ -218,39 +218,43 @@
   (:temporary (:sc non-descriptor-reg) ndesc)
   (:temporary (:sc non-descriptor-reg :to :eval) temp)
   (:generator 3
-    (sc-case amount
-      (signed-reg
-       (let ((positive (gen-label))
-	     (done (gen-label)))
-	 (inst bgez amount positive)
-	 (inst subu ndesc zero-tn amount)
-	 (inst slt temp ndesc 31)
-	 (inst bne temp zero-tn done)
-	 (sc-case number
-	   (signed-reg (inst sra result number ndesc))
-	   (unsigned-reg (inst srl result number ndesc)))
-	 (inst b done)
-	 (sc-case number
-	   (signed-reg (inst sra result number 31))
-	   (unsigned-reg (inst srl result number 31)))
-
-	 (emit-label positive)
-	 ;; The result-type assures us that this shift will not overflow.
-	 (inst sll result number amount)
-
-	 (emit-label done)))
-
-      ((immediate negative-immediate)
-       (let ((amount (tn-value amount)))
-	 (if (minusp amount)
-	     (sc-case number
-	       (unsigned-reg
-		(inst srl result number (- amount)))
-	       (t
-		(inst sra result number (- amount))))
-	     (inst sll result number amount)))))))
-
+    (inst bgez amount positive)
+    (inst subu ndesc zero-tn amount)
+    (inst slt temp ndesc 31)
+    (inst bne temp zero-tn done)
+    (sc-case number
+      (signed-reg (inst sra result number ndesc))
+      (unsigned-reg (inst srl result number ndesc)))
+    (inst b done)
+    (sc-case number
+      (signed-reg (inst sra result number 31))
+      (unsigned-reg (inst srl result number 31)))
+      
+    POSITIVE
+    ;; The result-type assures us that this shift will not overflow.
+    (inst sll result number amount)
+      
+    DONE))
 
+(define-vop (fast-ash-c)
+  (:policy :fast-safe)
+  (:translate ash)
+  (:note nil)
+  (:args (number :scs (signed-reg unsigned-reg)))
+  (:info count)
+  (:arg-types (:or signed-num unsigned-num) (:constant integer))
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:generator 1
+    (cond ((< count 0)
+	   ;; It is a right shift.
+	   (inst sra result number (min (- count) 31)))
+	  ((> count 0)
+	   ;; It is a left shift.
+	   (inst sll result number (min count 31)))
+	  (t
+	   ;; Count=0?  Shouldn't happen, but it's easy:
+	   (move result number)))))
 
 (define-vop (signed-byte-32-len)
   (:translate integer-length)
@@ -319,7 +323,7 @@
 ;;; Multiply and Divide.
 
 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
-  (:temporary (:scs (non-descriptor-reg) :type random) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:translate *)
   (:generator 4
     (inst sra temp y 2)
@@ -675,34 +679,24 @@
   (:translate bignum::%bignum-set-length)
   (:policy :fast-safe))
 
-(define-vop (bignum-ref word-index-ref)
-  (:variant vm:bignum-digits-offset vm:other-pointer-type)
-  (:translate bignum::%bignum-ref)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num))
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-ref)
 
-(define-vop (bignum-set word-index-set)
-  (:variant vm:bignum-digits-offset vm:other-pointer-type)
-  (:translate bignum::%bignum-set)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg immediate zero negative-immediate))
-	 (value :scs (unsigned-reg)))
-  (:arg-types t positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num))
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-set)
 
 (define-vop (digit-0-or-plus)
   (:translate bignum::%digit-0-or-plusp)
   (:policy :fast-safe)
   (:args (digit :scs (unsigned-reg)))
   (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 3
-    (let ((done (gen-label)))
-      (inst bltz digit done)
-      (move result null-tn)
-      (load-symbol result 't)
-      (emit-label done))))
+  (:conditional)
+  (:info target not-p)
+  (:generator 2
+    (if not-p
+	(inst bltz digit target)
+	(inst bgez digit target))
+    (inst nop)))
 
 (define-vop (add-w/carry)
   (:translate bignum::%add-with-carry)
diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp
index 74117a1dc2759b3d2a3e1aac96255aa6e36d924e..8e237116c0acfa78f7d9dd59081130ef109c4832 100644
--- a/compiler/mips/array.lisp
+++ b/compiler/mips/array.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.34 1992/07/08 20:55:30 hallgren Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.35 1992/07/28 20:37:15 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.34 1992/07/08 20:55:30 hallgren Exp $
-;;;
 ;;;    This file contains the MIPS definitions for array operations.
 ;;;
 ;;; Written by William Lott
@@ -29,56 +27,54 @@
 	 (rank :scs (any-reg)))
   (:arg-types positive-fixnum positive-fixnum)
   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:temporary (:scs (any-reg)) temp1)
+  (:temporary (:scs (non-descriptor-reg)) temp2)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:results (result :scs (descriptor-reg)))
-  (:generator 25
-    (pseudo-atomic (ndescr)
-      (inst addu header alloc-tn vm:other-pointer-type)
-      (inst addu alloc-tn
-	    (+ (* vm:array-dimensions-offset vm:word-bytes)
-	       vm:lowtag-mask))
-      (inst addu alloc-tn rank)
-      (inst li ndescr (lognot vm:lowtag-mask))
-      (inst and alloc-tn ndescr)
-      (inst addu ndescr rank (fixnum (1- vm:array-dimensions-offset)))
-      (inst sll ndescr ndescr vm:type-bits)
-      (inst or ndescr ndescr type)
-      (inst srl ndescr ndescr 2)
-      (storew ndescr header 0 vm:other-pointer-type))
+  (:generator 13
+    (pseudo-atomic (pa-flag)
+      (inst or header alloc-tn other-pointer-type)
+      (inst addu temp1 rank (+ (* array-dimensions-offset word-bytes)
+			       lowtag-mask))
+      (inst li temp2 (lognot lowtag-mask))
+      (inst and temp1 temp2)
+      (inst addu alloc-tn temp1)
+      (inst addu temp2 rank (fixnum (1- array-dimensions-offset)))
+      (inst sll temp2 type-bits)
+      (inst or temp2 temp2 type)
+      (inst srl temp2 2)
+      (storew temp2 header 0 other-pointer-type))
     (move result header)))
 
 
 ;;;; Additional accessors and setters for the array header.
 
-(defknown lisp::%array-dimension (t fixnum) fixnum
+(defknown lisp::%array-dimension (t index) index
   (flushable))
-(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
+(defknown lisp::%set-array-dimension (t index index) index
   ())
 
-(define-vop (%array-dimension word-index-ref)
-  (:translate lisp::%array-dimension)
-  (:policy :fast-safe)
-  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+(define-full-reffer %array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%array-dimension)
 
-(define-vop (%set-array-dimension word-index-set)
-  (:translate lisp::%set-array-dimension)
-  (:policy :fast-safe)
-  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+(define-full-setter %set-array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%set-array-dimension)
 
 
-
-(defknown lisp::%array-rank (t) fixnum (flushable))
+(defknown lisp::%array-rank (t) index (flushable))
 
 (define-vop (array-rank-vop)
   (:translate lisp::%array-rank)
   (:policy :fast-safe)
   (:args (x :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :type random) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:results (res :scs (any-reg descriptor-reg)))
   (:generator 6
-    (loadw temp x 0 vm:other-pointer-type)
-    (inst sra temp vm:type-bits)
-    (inst subu temp (1- vm:array-dimensions-offset))
+    (loadw temp x 0 other-pointer-type)
+    (inst sra temp type-bits)
+    (inst subu temp (1- array-dimensions-offset))
     (inst sll res temp 2)))
 
 
@@ -93,7 +89,7 @@
 	 (bound :scs (any-reg descriptor-reg))
 	 (index :scs (any-reg descriptor-reg) :target result))
   (:results (result :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :type random) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 5
@@ -112,47 +108,43 @@
 ;;; elements are represented in integer registers and are built out of
 ;;; 8, 16, or 32 bit elements.
 
-(defmacro def-data-vector-frobs (type variant element-type &rest scs)
+(eval-when (compile eval)
+
+(defmacro def-full-data-vector-frobs (type element-type &rest scs)
   `(progn
-     (define-vop (,(intern (concatenate 'simple-string
-					"DATA-VECTOR-REF/"
-					(string type)))
-		  ,(intern (concatenate 'simple-string
-					(string variant)
-					"-REF")))
-       (:note "inline array access")
-       (:variant vm:vector-data-offset vm:other-pointer-type)
-       (:translate data-vector-ref)
-       (:arg-types ,type positive-fixnum)
-       (:results (value :scs ,scs))
-       (:result-types ,element-type))
-     (define-vop (,(intern (concatenate 'simple-string
-					"DATA-VECTOR-SET/"
-					(string type)))
-		  ,(intern (concatenate 'simple-string
-					(string variant)
-					"-SET")))
-       (:note "inline array store")
-       (:variant vm:vector-data-offset vm:other-pointer-type)
-       (:translate data-vector-set)
-       (:arg-types ,type positive-fixnum ,element-type)
-       (:args (object :scs (descriptor-reg))
-	      (index :scs (any-reg zero immediate unsigned-immediate))
-	      (value :scs ,scs))
-       (:results (result :scs ,scs))
-       (:result-types ,element-type))))
-
-(def-data-vector-frobs simple-string byte-index
-  base-char base-char-reg)
-(def-data-vector-frobs simple-vector word-index
-  * descriptor-reg any-reg)
-
-(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
-  positive-fixnum unsigned-reg)
-(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
-  positive-fixnum unsigned-reg)
-(def-data-vector-frobs simple-array-unsigned-byte-32 word-index
-  unsigned-num unsigned-reg)
+     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-ref)
+     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-set)))
+
+(defmacro def-partial-data-vector-frobs
+	  (type element-type size signed &rest scs)
+  `(progn
+     (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       ,size ,signed vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-ref)
+     (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       ,size vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-set)))
+
+); eval-when (compile eval)
+
+(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+
+(def-partial-data-vector-frobs simple-string base-char :byte :leave-alone
+  base-char-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+  :byte nil unsigned-reg signed-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+  :short nil unsigned-reg signed-reg)
+
+(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+  unsigned-reg)
+
 
 
 ;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
@@ -160,7 +152,7 @@
 ;;; 
 
 (defmacro def-small-data-vector-frobs (type bits)
-  (let* ((elements-per-word (floor vm:word-bits bits))
+  (let* ((elements-per-word (floor word-bits bits))
 	 (bit-shift (1- (integer-length elements-per-word))))
     `(progn
        (define-vop (,(symbolicate 'data-vector-ref/ type))
@@ -179,8 +171,8 @@
 	   (inst sll temp 2)
 	   (inst addu lip object temp)
 	   (inst lw result lip
-		 (- (* vm:vector-data-offset vm:word-bytes)
-		    vm:other-pointer-type))
+		 (- (* vector-data-offset word-bytes)
+		    other-pointer-type))
 	   (inst and temp index ,(1- elements-per-word))
 	   ,@(when (eq (backend-byte-order *backend*) :big-endian)
 	       `((inst xor temp ,(1- elements-per-word))))
@@ -197,9 +189,9 @@
 		     (:constant
 		      (integer 0
 			       ,(1- (* (1+ (- (floor (+ #x7fff
-							vm:other-pointer-type)
-						     vm:word-bytes)
-					      vm:vector-data-offset))
+							other-pointer-type)
+						     word-bytes)
+					      vector-data-offset))
 				       elements-per-word)))))
 	 (:info index)
 	 (:results (result :scs (unsigned-reg)))
@@ -208,8 +200,8 @@
 	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
 	     ,@(when (eq (backend-byte-order *backend*) :big-endian)
 		 `((setf extra (logxor extra (1- ,elements-per-word)))))
-	     (loadw result object (+ word vm:vector-data-offset) 
-		    vm:other-pointer-type)
+	     (loadw result object (+ word vector-data-offset) 
+		    other-pointer-type)
 	     (unless (zerop extra)
 	       (inst srl result (* extra ,bits)))
 	     (unless (= extra ,(1- elements-per-word))
@@ -232,8 +224,8 @@
 	   (inst sll temp 2)
 	   (inst addu lip object temp)
 	   (inst lw old lip
-		 (- (* vm:vector-data-offset vm:word-bytes)
-		    vm:other-pointer-type))
+		 (- (* vector-data-offset word-bytes)
+		    other-pointer-type))
 	   (inst and shift index ,(1- elements-per-word))
 	   ,@(when (eq (backend-byte-order *backend*) :big-endian)
 	       `((inst xor shift ,(1- elements-per-word))))
@@ -254,8 +246,8 @@
 	     (inst sll temp shift)
 	     (inst or old temp))
 	   (inst sw old lip
-		 (- (* vm:vector-data-offset vm:word-bytes)
-		    vm:other-pointer-type))
+		 (- (* vector-data-offset word-bytes)
+		    other-pointer-type))
 	   (sc-case value
 	     (immediate
 	      (inst li result (tn-value value)))
@@ -272,9 +264,9 @@
 		     (:constant
 		      (integer 0
 			       ,(1- (* (1+ (- (floor (+ #x7fff
-							vm:other-pointer-type)
-						     vm:word-bytes)
-					      vm:vector-data-offset))
+							other-pointer-type)
+						     word-bytes)
+					      vector-data-offset))
 				       elements-per-word))))
 		     positive-fixnum)
 	 (:info index)
@@ -286,8 +278,8 @@
 	     ,@(when (eq (backend-byte-order *backend*) :big-endian)
 		 `((setf extra (logxor extra (1- ,elements-per-word)))))
 	     (inst lw old object
-		   (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-		      vm:other-pointer-type))
+		   (- (* (+ word vector-data-offset) word-bytes)
+		      other-pointer-type))
 	     (unless (and (sc-is value immediate)
 			  (= (tn-value value) ,(1- (ash 1 bits))))
 	       (cond ((= extra ,(1- elements-per-word))
@@ -311,8 +303,8 @@
 		(inst sll temp value (* extra ,bits))
 		(inst or old temp)))
 	     (inst sw old object
-		   (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-		      vm:other-pointer-type))
+		   (- (* (+ word vector-data-offset) word-bytes)
+		      other-pointer-type))
 	     (sc-case value
 	       (immediate
 		(inst li result (tn-value value)))
@@ -342,8 +334,8 @@
   (:generator 20
     (inst addu lip object index)
     (inst lwc1 value lip
-	  (- (* vm:vector-data-offset vm:word-bytes)
-	     vm:other-pointer-type))
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type))
     (inst nop)))
 
 (define-vop (data-vector-set/simple-array-single-float)
@@ -360,8 +352,8 @@
   (:generator 20
     (inst addu lip object index)
     (inst swc1 value lip
-	  (- (* vm:vector-data-offset vm:word-bytes)
-	     vm:other-pointer-type))
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type))
     (unless (location= result value)
       (inst fmove :single result value))))
 
@@ -379,12 +371,12 @@
     (inst addu lip object index)
     (inst addu lip index)
     (inst lwc1 value lip
-	  (- (* vm:vector-data-offset vm:word-bytes)
-	     vm:other-pointer-type))
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type))
     (inst lwc1-odd value lip
-	  (+ (- (* vm:vector-data-offset vm:word-bytes)
-		vm:other-pointer-type)
-	     vm:word-bytes))
+	  (+ (- (* vector-data-offset word-bytes)
+		other-pointer-type)
+	     word-bytes))
     (inst nop)))
 
 (define-vop (data-vector-set/simple-array-double-float)
@@ -402,12 +394,12 @@
     (inst addu lip object index)
     (inst addu lip index)
     (inst swc1 value lip
-	  (- (* vm:vector-data-offset vm:word-bytes)
-	     vm:other-pointer-type))
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type))
     (inst swc1-odd value lip
-	  (+ (- (* vm:vector-data-offset vm:word-bytes)
-		vm:other-pointer-type)
-	     vm:word-bytes))
+	  (+ (- (* vector-data-offset word-bytes)
+		other-pointer-type)
+	     word-bytes))
     (unless (location= result value)
       (inst fmove :double result value))))
 
@@ -417,38 +409,15 @@
 ;;; what type of vector it is.
 ;;; 
 
-(define-vop (raw-bits word-index-ref)
-  (:note "raw-bits VOP")
-  (:translate %raw-bits)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 vm:other-pointer-type))
-
-(define-vop (set-raw-bits word-index-set)
-  (:note "setf raw-bits VOP")
-  (:translate %set-raw-bits)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg zero immediate unsigned-immediate))
-	 (value :scs (unsigned-reg)))
-  (:arg-types * positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 vm:other-pointer-type))
-
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
+  %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+  unsigned-num %set-raw-bits)
 
 
 
 ;;;; Misc. Array VOPs.
 
-
-#+nil
-(define-vop (vector-word-length)
-  (:args (vec :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 6
-    (loadw res vec clc::g-vector-header-words)
-    (inst niuo res res clc::g-vector-words-mask-16)))
-
 (define-vop (get-vector-subtype get-header-data))
 (define-vop (set-vector-subtype set-header-data))
 
diff --git a/compiler/mips/c-call.lisp b/compiler/mips/c-call.lisp
index fdf5cfa3f15760a5f8df294727d4144125c2fbba..93e1aef92ed466f03a8151347e9e75edd7caa95d 100644
--- a/compiler/mips/c-call.lisp
+++ b/compiler/mips/c-call.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.11 1992/03/27 23:25:38 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.12 1992/07/28 20:37:17 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.11 1992/03/27 23:25:38 wlott Exp $
-;;;
 ;;; This file contains the VOPs and other necessary machine specific support
 ;;; routines for call-out to C.
 ;;;
@@ -156,30 +154,22 @@
     (inst li res (make-fixup foreign-symbol :foreign))))
 
 (define-vop (call-out)
-  (:args (function :scs (sap-reg) :target v0)
+  (:args (function :scs (sap-reg) :target cfunc)
 	 (args :more t))
   (:results (results :more t))
   (:ignore args results)
   (:save-p t)
-  (:temporary (:sc any-reg :offset 2 :from (:argument 0) :to (:result 0)) v0)
-  (:temporary (:sc any-reg :offset lra-offset) lra)
-  (:temporary (:sc any-reg :offset code-offset) code)
-  (:temporary (:sc non-descriptor-reg :to (:result 0)) ndescr)
+  (:temporary (:sc any-reg :offset cfunc-offset
+		   :from (:argument 0) :to (:result 0)) cfunc)
   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
   (:vop-var vop)
   (:generator 0
-    (let ((lra-label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
+    (let ((cur-nfp (current-nfp-tn vop)))
       (when cur-nfp
 	(store-stack-tn nfp-save cur-nfp))
-      (move v0 function)
-      (inst compute-lra-from-code lra code lra-label ndescr)
-      (inst j (make-fixup "call_into_c" :foreign))
+      (move cfunc function)
+      (inst jal (make-fixup "call_into_c" :foreign))
       (inst nop)
-
-      (align vm:lowtag-bits)
-      (emit-label lra-label)
-      (inst lra-header-word)
       (when cur-nfp
 	(load-stack-tn cur-nfp nfp-save)))))
 
diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp
index b382cf20c16545108ba60befed568f791f3c2344..635860c725d77b43a8cb12e3c8b1a94526fb8740 100644
--- a/compiler/mips/call.lisp
+++ b/compiler/mips/call.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.48 1992/05/21 22:34:26 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.49 1992/07/28 20:37:20 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.48 1992/05/21 22:34:26 wlott Exp $
-;;;
 ;;;    This file contains the VM definition of function call for the MIPS.
 ;;;
 ;;; Written by Rob MacLachlan
@@ -60,7 +58,7 @@
 ;;;
 (def-vm-support-routine make-old-fp-passing-location (standard)
   (if standard
-      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn old-fp-offset)
+      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
       (make-normal-tn *fixnum-primitive-type*)))
 
 ;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
@@ -74,7 +72,7 @@
    (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
    (make-wired-tn *fixnum-primitive-type*
 		  control-stack-arg-scn
-		  old-fp-save-offset)))
+		  ocfp-save-offset)))
 ;;;
 (def-vm-support-routine make-return-pc-save-location (env)
   (specify-save-tn
@@ -154,7 +152,7 @@
 (define-vop (current-fp)
   (:results (val :scs (any-reg)))
   (:generator 1
-    (move val fp-tn)))
+    (move val cfp-tn)))
 
 ;;; Used for computing the caller's NFP for use in known-values return.  Only
 ;;; works assuming there is no variable size stuff on the nstack.
@@ -188,7 +186,7 @@
       (emit-label entry-point)
       (inst compute-code-from-fn code-tn lip-tn entry-point temp))
     ;; Build our stack frames.
-    (inst addu csp-tn fp-tn
+    (inst addu csp-tn cfp-tn
 	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
     (let ((nfp (current-nfp-tn vop)))
       (when nfp
@@ -260,25 +258,25 @@
 	move a1 null-tn			; Default register values
 	...
 	loadi nargs 1			; Force defaulting of stack values
-	move old-fp csp			; Set up args for SP resetting
+	move ocfp csp			; Set up args for SP resetting
 
 regs-defaulted
 	subu temp nargs register-arg-count
 
 	bltz temp default-value-7	; jump to default code
         addu temp temp -1
-	loadw move-temp old-fp-tn 6	; Move value to correct location.
+	loadw move-temp ocfp-tn 6	; Move value to correct location.
 	store-stack-tn val4-tn move-temp
 
 	bltz temp default-value-8
         addu temp temp -1
-	loadw move-temp old-fp-tn 7
+	loadw move-temp ocfp-tn 7
 	store-stack-tn val5-tn move-temp
 
 	...
 
 defaulting-done
-	move sp old-fp			; Reset SP.
+	move sp ocfp			; Reset SP.
 <end of code>
 
 <elsewhere>
@@ -303,23 +301,23 @@ default-value-8
 	;; the multiple-value entry point for a single desired value, but
 	;; the code location has to be here, or the debugger backtrace
 	;; gets confused.
-	(note-this-location vop :single-value-return)
-	(move csp-tn old-fp-tn)
-	(inst nop)
-	(inst entry-point)
+	(without-scheduling ()
+	  (note-this-location vop :single-value-return)
+	  (move csp-tn ocfp-tn)
+	  (inst nop))
 	(inst compute-code-from-lra code-tn code-tn lra-label temp))
       (let ((regs-defaulted (gen-label))
 	    (defaulting-done (gen-label))
 	    (default-stack-vals (gen-label)))
-	;; Note that this is an unknown-values return point.
-	(note-this-location vop :unknown-return)
-	;; Branch off to the MV case.
-	(inst b regs-defaulted)
-	;; If there are no stack results, clear the stack now.
-	(if (> nvals register-arg-count)
-	    (inst addu temp nargs-tn (fixnum (- register-arg-count)))
-	    (move csp-tn old-fp-tn))
-	(inst entry-point)
+	(without-scheduling ()
+	  ;; Note that this is an unknown-values return point.
+	  (note-this-location vop :unknown-return)
+	  ;; Branch off to the MV case.
+	  (inst b regs-defaulted)
+	  ;; If there are no stack results, clear the stack now.
+	  (if (> nvals register-arg-count)
+	      (inst addu temp nargs-tn (fixnum (- register-arg-count)))
+	      (move csp-tn ocfp-tn)))
 	
 	;; Do the single value calse.
 	(do ((i 1 (1+ i))
@@ -328,7 +326,7 @@ default-value-8
 	  (move (tn-ref-tn val) null-tn))
 	(when (> nvals register-arg-count)
 	  (inst b default-stack-vals)
-	  (move old-fp-tn csp-tn))
+	  (move ocfp-tn csp-tn))
 	
 	(emit-label regs-defaulted)
 	
@@ -348,12 +346,12 @@ default-value-8
 		(defaults (cons default-lab tn))
 		
 		(inst bltz temp default-lab)
-		(inst lw move-temp old-fp-tn (* i vm:word-bytes))
+		(inst lw move-temp ocfp-tn (* i vm:word-bytes))
 		(inst addu temp temp (fixnum -1))
 		(store-stack-tn tn move-temp)))
 	    
 	    (emit-label defaulting-done)
-	    (move csp-tn old-fp-tn)
+	    (move csp-tn ocfp-tn)
 	    
 	    (let ((defaults (defaults)))
 	      (assert defaults)
@@ -398,9 +396,9 @@ default-value-8
   (declare (type tn args nargs start count temp))
   (let ((variable-values (gen-label))
 	(done (gen-label)))
-    (inst b variable-values)
-    (inst nop)
-    (inst entry-point)
+    (without-scheduling ()
+      (inst b variable-values)
+      (inst nop))
     
     (inst compute-code-from-lra code-tn code-tn lra-label temp)
     (inst addu csp-tn csp-tn 4)
@@ -433,7 +431,7 @@ default-value-8
   (:results
    (start :scs (any-reg))
    (count :scs (any-reg)))
-  (:temporary (:sc descriptor-reg :offset old-fp-offset
+  (:temporary (:sc descriptor-reg :offset ocfp-offset
 		   :from :eval :to (:result 0))
 	      values-start)
   (:temporary (:sc any-reg :offset nargs-offset
@@ -475,7 +473,7 @@ default-value-8
   (:temporary (:scs (descriptor-reg) :from :eval) move-temp)
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:temporary (:sc any-reg :offset old-fp-offset :from :eval) ocfp)
+  (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp)
   (:ignore arg-locs args ocfp)
   (:generator 5
     (trace-table-entry trace-table-call-site)
@@ -486,7 +484,7 @@ default-value-8
       (let ((callee-nfp (callee-nfp-tn callee)))
 	(when callee-nfp
 	  (move callee-nfp nfp)))
-      (maybe-load-stack-tn fp-tn fp)
+      (maybe-load-stack-tn cfp-tn fp)
       (inst compute-lra-from-code
 	    (callee-return-pc-tn callee) code-tn label temp)
       (note-this-location vop :call-site)
@@ -526,7 +524,7 @@ default-value-8
       (let ((callee-nfp (callee-nfp-tn callee)))
 	(when callee-nfp
 	  (move callee-nfp nfp)))
-      (maybe-load-stack-tn fp-tn fp)
+      (maybe-load-stack-tn cfp-tn fp)
       (inst compute-lra-from-code
 	    (callee-return-pc-tn callee) code-tn label temp)
       (note-this-location vop :call-site)
@@ -570,7 +568,7 @@ default-value-8
       (let ((callee-nfp (callee-nfp-tn callee)))
 	(when callee-nfp
 	  (move callee-nfp nfp)))
-      (maybe-load-stack-tn fp-tn fp)
+      (maybe-load-stack-tn cfp-tn fp)
       (inst compute-lra-from-code
 	    (callee-return-pc-tn callee) code-tn label temp)
       (note-this-location vop :call-site)
@@ -591,28 +589,28 @@ default-value-8
 ;;; MAYBE-LOAD-STACK-TN.
 ;;;
 (define-vop (known-return)
-  (:args (old-fp :target old-fp-temp)
+  (:args (ocfp :target ocfp-temp)
 	 (return-pc :target return-pc-temp)
 	 (vals :more t))
-  (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
+  (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
   (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
-  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:temporary (:scs (interior-reg)) lip)
   (:move-args :known-return)
   (:info val-locs)
   (:ignore val-locs vals)
   (:vop-var vop)
   (:generator 6
     (trace-table-entry trace-table-function-epilogue)
-    (maybe-load-stack-tn old-fp-temp old-fp)
+    (maybe-load-stack-tn ocfp-temp ocfp)
     (maybe-load-stack-tn return-pc-temp return-pc)
-    (move csp-tn fp-tn)
+    (move csp-tn cfp-tn)
     (let ((cur-nfp (current-nfp-tn vop)))
       (when cur-nfp
 	(inst addu nsp-tn cur-nfp
 	      (bytes-needed-for-non-descriptor-stack-frame))))
     (inst addu lip return-pc-temp (- vm:word-bytes vm:other-pointer-type))
     (inst j lip)
-    (move fp-tn old-fp-temp)
+    (move cfp-tn ocfp-temp)
     (trace-table-entry trace-table-normal)))
 
 
@@ -646,7 +644,7 @@ default-value-8
 ;;;    result values are specified by the Start and Count as in the
 ;;;    unknown-values continuation representation.
 ;;; -- If :Tail, then do a tail-recursive call.  No values are returned.
-;;;    The Old-Fp and Return-PC are passed as the second and third arguments.
+;;;    The Ocfp and Return-PC are passed as the second and third arguments.
 ;;;
 ;;; In non-tail calls, the pointer to the stack arguments is passed as the last
 ;;; fixed argument.  If Variable is false, then the passing locations are
@@ -672,7 +670,7 @@ default-value-8
 	   '(arg-fun :target lexenv))
       
       ,@(when (eq return :tail)
-	  '((old-fp :target old-fp-pass)
+	  '((ocfp :target ocfp-pass)
 	    (return-pc :target return-pc-pass)))
       
       ,@(unless variable '((args :more t :scs (descriptor-reg)))))
@@ -695,11 +693,11 @@ default-value-8
       ,@(unless variable '(args)))
 
      (:temporary (:sc descriptor-reg
-		  :offset old-fp-offset
+		  :offset ocfp-offset
 		  :from (:argument 1)
 		  ,@(unless (eq return :fixed)
 		      '(:to :eval)))
-		 old-fp-pass)
+		 ocfp-pass)
 
      (:temporary (:sc descriptor-reg
 		  :offset lra-offset
@@ -708,7 +706,7 @@ default-value-8
 		 return-pc-pass)
 
      ,@(if named
-	 `((:temporary (:sc descriptor-reg :offset cname-offset
+	 `((:temporary (:sc descriptor-reg :offset fdefn-offset
 			:from (:argument ,(if (eq return :tail) 0 1))
 			:to :eval)
 		       name-pass))
@@ -737,7 +735,7 @@ default-value-8
 	 '((:temporary (:scs (non-descriptor-reg) :from :eval) temp)
 	   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
 
-     (:temporary (:scs (interior-reg) :type interior) lip)
+     (:temporary (:scs (interior-reg)) lip)
 
      (:generator ,(+ (if named 5 0)
 		     (if variable 19 1)
@@ -752,8 +750,8 @@ default-value-8
 	       (remove nil
 		       (list :load-nargs
 			     ,@(if (eq return :tail)
-				   '((unless (location= old-fp old-fp-pass)
-				       :load-old-fp)
+				   '((unless (location= ocfp ocfp-pass)
+				       :load-ocfp)
 				     (unless (location= return-pc
 							return-pc-pass)
 				       :load-return-pc)
@@ -779,20 +777,20 @@ default-value-8
 					   register-arg-names)))
 			     '((inst li nargs-pass (fixnum nargs)))))
 		      ,@(if (eq return :tail)
-			    '((:load-old-fp
-			       (sc-case old-fp
+			    '((:load-ocfp
+			       (sc-case ocfp
 				 (any-reg
-				  (inst move old-fp-pass old-fp))
+				  (inst move ocfp-pass ocfp))
 				 (control-stack
-				  (inst lw old-fp-pass fp-tn
-					(ash (tn-offset old-fp)
+				  (inst lw ocfp-pass cfp-tn
+					(ash (tn-offset ocfp)
 					     vm:word-shift)))))
 			      (:load-return-pc
 			       (sc-case return-pc
 				 (descriptor-reg
 				  (inst move return-pc-pass return-pc))
 				 (control-stack
-				  (inst lw return-pc-pass fp-tn
+				  (inst lw return-pc-pass cfp-tn
 					(ash (tn-offset return-pc)
 					     vm:word-shift)))))
 			      (:frob-nfp
@@ -804,13 +802,13 @@ default-value-8
 			      (:frob-nfp
 			       (store-stack-tn nfp-save cur-nfp))
 			      (:save-fp
-			       (inst move old-fp-pass fp-tn))
+			       (inst move ocfp-pass cfp-tn))
 			      (:load-fp
 			       ,(if variable
-				    '(move fp-tn new-fp)
+				    '(move cfp-tn new-fp)
 				    '(if (> nargs register-arg-count)
-					 (move fp-tn new-fp)
-					 (move fp-tn csp-tn))))))
+					 (move cfp-tn new-fp)
+					 (move cfp-tn csp-tn))))))
 		      ((nil)
 		       (inst nop))))))
 
@@ -818,7 +816,7 @@ default-value-8
 		 `((sc-case name
 		     (descriptor-reg (move name-pass name))
 		     (control-stack
-		      (inst lw name-pass fp-tn
+		      (inst lw name-pass cfp-tn
 			    (ash (tn-offset name) vm:word-shift))
 		      (do-next-filler))
 		     (constant
@@ -833,7 +831,7 @@ default-value-8
 		 `((sc-case arg-fun
 		     (descriptor-reg (move lexenv arg-fun))
 		     (control-stack
-		      (inst lw lexenv fp-tn
+		      (inst lw lexenv cfp-tn
 			    (ash (tn-offset arg-fun) vm:word-shift))
 		      (do-next-filler))
 		     (constant
@@ -894,12 +892,12 @@ default-value-8
   (:args
    (args-arg :scs (any-reg) :target args)
    (function-arg :scs (descriptor-reg) :target lexenv)
-   (old-fp-arg :scs (any-reg) :target old-fp)
+   (ocfp-arg :scs (any-reg) :target ocfp)
    (lra-arg :scs (descriptor-reg) :target lra))
 
   (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
   (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
-  (:temporary (:sc any-reg :offset old-fp-offset :from (:argument 2)) old-fp)
+  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp)
   (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
 
   (:vop-var vop)
@@ -909,7 +907,7 @@ default-value-8
     ;; Move these into the passing locations if they are not already there.
     (move args args-arg)
     (move lexenv function-arg)
-    (move old-fp old-fp-arg)
+    (move ocfp ocfp-arg)
     (move lra lra-arg)
 
     ;; Clear the number stack if anything is there.
@@ -928,7 +926,7 @@ default-value-8
 ;;; Return a single value using the unknown-values convention.
 ;;; 
 (define-vop (return-single)
-  (:args (old-fp :scs (any-reg))
+  (:args (ocfp :scs (any-reg))
 	 (return-pc :scs (descriptor-reg))
 	 (value))
   (:ignore value)
@@ -943,7 +941,7 @@ default-value-8
 	      (bytes-needed-for-non-descriptor-stack-frame))))
     ;; Clear the control stack, and restore the frame pointer.
     (move csp-tn cfp-tn)
-    (move cfp-tn old-fp)
+    (move cfp-tn ocfp)
     ;; Out of here.
     (lisp-return return-pc lip :offset 2)
     (trace-table-entry trace-table-normal)))
@@ -964,7 +962,7 @@ default-value-8
 ;;;
 (define-vop (return)
   (:args
-   (old-fp :scs (any-reg))
+   (ocfp :scs (any-reg))
    (return-pc :scs (descriptor-reg) :to (:eval 1))
    (values :more t))
   (:ignore values)
@@ -976,8 +974,8 @@ default-value-8
   (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
   (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
   (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset old-fp-offset) val-ptr)
-  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+  (:temporary (:scs (interior-reg)) lip)
   (:vop-var vop)
   (:generator 6
     ;; Clear the number stack.
@@ -988,17 +986,17 @@ default-value-8
 	      (bytes-needed-for-non-descriptor-stack-frame))))
     (cond ((= nvals 1)
 	   ;; Clear the control stack, and restore the frame pointer.
-	   (move csp-tn fp-tn)
-	   (move fp-tn old-fp)
+	   (move csp-tn cfp-tn)
+	   (move cfp-tn ocfp)
 	   ;; Out of here.
 	   (lisp-return return-pc lip :offset 2))
 	  (t
 	   ;; Establish the values pointer and values count.
-	   (move val-ptr fp-tn)
+	   (move val-ptr cfp-tn)
 	   (inst li nargs (fixnum nvals))
 	   ;; restore the frame pointer and clear as much of the control
 	   ;; stack as possible.
-	   (move fp-tn old-fp)
+	   (move cfp-tn ocfp)
 	   (inst addu csp-tn val-ptr (* nvals word-bytes))
 	   ;; pre-default any argument register that need it.
 	   (when (< nvals register-arg-count)
@@ -1015,17 +1013,17 @@ default-value-8
 ;;;
 (define-vop (return-multiple)
   (:args
-   (old-fp-arg :scs (any-reg) :to (:eval 1))
+   (ocfp-arg :scs (any-reg) :to (:eval 1))
    (lra-arg :scs (descriptor-reg) :to (:eval 1))
    (vals-arg :scs (any-reg) :target vals)
    (nvals-arg :scs (any-reg) :target nvals))
 
-  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
+  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
   (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
   (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
   (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
   (:temporary (:sc descriptor-reg :offset a0-offset) a0)
-  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:temporary (:scs (interior-reg)) lip)
 
   (:vop-var vop)
 
@@ -1044,13 +1042,13 @@ default-value-8
       (inst lw a0 vals-arg)
 
       ;; Return with one value.
-      (move csp-tn fp-tn)
-      (move fp-tn old-fp-arg)
+      (move csp-tn cfp-tn)
+      (move cfp-tn ocfp-arg)
       (lisp-return lra-arg lip :offset 2)
 		
       ;; Nope, not the single case.
       (emit-label not-single)
-      (move old-fp old-fp-arg)
+      (move ocfp ocfp-arg)
       (move lra lra-arg)
       (move vals vals-arg)
       (move nvals nvals-arg)
@@ -1121,7 +1119,7 @@ default-value-8
       ;; Initialize dst to be end of stack.
       (move dst csp-tn)
       ;; Initialize src to be end of args.
-      (inst addu src fp-tn nargs-tn)
+      (inst addu src cfp-tn nargs-tn)
 
       (emit-label loop)
       ;; *--dst = *--src, --count
@@ -1152,9 +1150,7 @@ default-value-8
 ;;; More args are stored consequtively on the stack, starting immediately at
 ;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
 ;;;
-(define-vop (more-arg word-index-ref)
-  (:variant 0 0)
-  (:translate %more-arg))
+(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
 
 
 ;;; Turn more arg (context, count) into a list.
@@ -1165,8 +1161,8 @@ default-value-8
   (:arg-types * tagged-num)
   (:temporary (:scs (any-reg) :from (:argument 0)) context)
   (:temporary (:scs (any-reg) :from (:argument 1)) count)
-  (:temporary (:scs (descriptor-reg) :from :eval) temp)
-  (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst)
+  (:temporary (:scs (descriptor-reg) :from :eval) temp dst)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:results (result :scs (descriptor-reg)))
   (:translate %listify-rest-args)
   (:policy :safe)
@@ -1181,13 +1177,13 @@ default-value-8
       (move result null-tn)
 
       ;; We need to do this atomically.
-      (pseudo-atomic (ndescr)
+      (pseudo-atomic (pa-flag)
 	;; Allocate a cons (2 words) for each item.
-	(inst addu result alloc-tn vm:list-pointer-type)
+	(inst or result alloc-tn vm:list-pointer-type)
 	(move dst result)
-	(inst addu alloc-tn alloc-tn count)
+	(inst sll temp count 1)
 	(inst b enter)
-	(inst addu alloc-tn alloc-tn count)
+	(inst addu alloc-tn alloc-tn temp)
 
 	;; Store the current cons in the cdr of the previous cons.
 	(emit-label loop)
diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp
index 171f5edd37f3c2bbc4c1270b51dcda615b02dd1e..598a1abaa78bbaf4e264cc2df8bde21a0b54c5ab 100644
--- a/compiler/mips/cell.lisp
+++ b/compiler/mips/cell.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.58 1992/04/12 20:53:51 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.59 1992/07/28 20:37:24 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.58 1992/04/12 20:53:51 wlott Exp $
-;;;
 ;;;    This file contains the VM definition of various primitive memory access
 ;;; VOPs for the MIPS.
 ;;;
@@ -89,7 +87,7 @@
   (:policy :fast-safe)
   (:vop-var vop)
   (:save-p :compute-only)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
 
 ;;; With Symbol-Value, we check that the value isn't the trap object.  So
@@ -112,7 +110,7 @@
   (:info target not-p)
   (:policy :fast-safe)
   (:temporary (:scs (descriptor-reg)) value)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
+  (:temporary (:scs (non-descriptor-reg)) temp))
 
 (define-vop (boundp boundp-frob)
   (:translate boundp)
@@ -240,13 +238,13 @@
 
 ;;;; Closure indexing.
 
-(define-vop (closure-index-ref word-index-ref)
-  (:variant closure-info-offset function-pointer-type)
-  (:translate %closure-index-ref))
+(define-full-reffer closure-index-ref *
+  closure-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %closure-index-ref)
 
-(define-vop (set-funcallable-instance-info word-index-set)
-  (:variant funcallable-instance-info-offset function-pointer-type)
-  (:translate %set-funcallable-instance-info))
+(define-full-reffer set-funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %set-funcallable-instance-info)
 
 
 
@@ -256,12 +254,11 @@
   (:policy :fast-safe)
   (:translate structure-length)
   (:args (struct :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
   (:results (res :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 4
-    (loadw temp struct 0 structure-pointer-type)
-    (inst srl res temp type-bits)))
+    (loadw res struct 0 structure-pointer-type)
+    (inst srl res type-bits)))
 
 (define-vop (structure-ref slot-ref)
   (:variant structure-slots-offset structure-pointer-type)
@@ -275,28 +272,18 @@
   (:variant structure-slots-offset structure-pointer-type)
   (:arg-types structure (:constant index) *))
 
-(define-vop (structure-index-ref word-index-ref)
-  (:policy :fast-safe) 
-  (:translate structure-ref)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure positive-fixnum))
+(define-full-reffer structure-index-ref * structure-slots-offset
+  structure-pointer-type (descriptor-reg any-reg) * structure-ref)
 
-(define-vop (structure-index-set word-index-set)
-  (:policy :fast-safe) 
-  (:translate structure-set)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure positive-fixnum *))
+(define-full-setter structure-index-set * structure-slots-offset
+  structure-pointer-type (descriptor-reg any-reg) * structure-set)
 
 
 
 ;;;; Code object frobbing.
 
-(define-vop (code-header-ref word-index-ref)
-  (:translate code-header-ref)
-  (:policy :fast-safe)
-  (:variant 0 other-pointer-type))
+(define-full-reffer code-header-ref * 0 other-pointer-type
+  (descriptor-reg any-reg) * code-header-ref)
 
-(define-vop (code-header-set word-index-set)
-  (:translate code-header-set)
-  (:policy :fast-safe)
-  (:variant 0 other-pointer-type))
+(define-full-setter code-header-set * 0 other-pointer-type
+  (descriptor-reg any-reg) * code-header-set)
diff --git a/compiler/mips/debug.lisp b/compiler/mips/debug.lisp
index 21b98d1c9773ac2c25571ea8477d99230eb0a95c..08215ccb5d127adfb8f38d15c86775b2e15e1382 100644
--- a/compiler/mips/debug.lisp
+++ b/compiler/mips/debug.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.12 1992/05/18 19:54:03 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.13 1992/07/28 20:37:29 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.12 1992/05/18 19:54:03 ram Exp $
-;;;
 ;;; Compiler support for the new whizzy debugger.
 ;;;
 ;;; Written by William Lott.
@@ -34,49 +32,63 @@
   (:results (res :scs (sap-reg)))
   (:result-types system-area-pointer)
   (:generator 1
-    (move res fp-tn)))
+    (move res cfp-tn)))
 
 (define-vop (read-control-stack)
   (:translate stack-ref)
   (:policy :fast-safe)
   (:args (object :scs (sap-reg) :target sap)
-	 (offset :scs (any-reg negative-immediate zero immediate)))
+	 (offset :scs (any-reg)))
   (:arg-types system-area-pointer positive-fixnum)
-  (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
+  (:temporary (:scs (sap-reg) :from :eval) sap)
   (:results (result :scs (descriptor-reg)))
   (:result-types *)
   (:generator 5
-    (sc-case offset
-      ((zero)
-       (inst lw result object 0))
-      ((negative-immediate immediate)
-       (inst lw result object (* (tn-value offset) vm:word-bytes)))
-      ((any-reg)
-       (inst addu sap object offset)
-       (inst lw result sap 0)))
+    (inst add sap object offset)
+    (inst lw result sap 0)
+    (inst nop)))
+
+(define-vop (read-control-stack-c)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 14)))
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 4
+    (inst lw result object (* offset word-bytes))
     (inst nop)))
 
 (define-vop (write-control-stack)
   (:translate %set-stack-ref)
   (:policy :fast-safe)
   (:args (object :scs (sap-reg) :target sap)
-	 (offset :scs (any-reg negative-immediate zero immediate))
+	 (offset :scs (any-reg))
 	 (value :scs (descriptor-reg) :target result))
   (:arg-types system-area-pointer positive-fixnum *)
   (:results (result :scs (descriptor-reg)))
   (:result-types *)
   (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
-  (:generator 5
-    (sc-case offset
-      ((zero)
-       (inst sw value object 0))
-      ((negative-immediate immediate)
-       (inst sw value object (* (tn-value offset) vm:word-bytes)))
-      ((any-reg)
-       (inst addu sap object offset)
-       (inst sw value sap 0)))
+  (:generator 2
+    (inst add sap object offset)
+    (inst sw sap value 0)
     (move result value)))
 
+(define-vop (write-control-stack-c)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 1
+    (inst sw value sap (* offset word-bytes))
+    (move result value)))
+
+
 (define-vop (code-from-mumble)
   (:policy :fast-safe)
   (:args (thing :scs (descriptor-reg)))
diff --git a/compiler/mips/float.lisp b/compiler/mips/float.lisp
index f11ad37f58e86a910de604e874b625a12a0a7a9e..2bd284a58fce1c2e505ab7c91e711c13d31a36f0 100644
--- a/compiler/mips/float.lisp
+++ b/compiler/mips/float.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/mips/float.lisp,v 1.15 1992/07/08 20:56:37 hallgren Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/float.lisp,v 1.16 1992/07/28 20:37:30 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -22,28 +22,28 @@
 
 (define-move-function (load-single 1) (vop x y)
   ((single-stack) (single-reg))
-  (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
+  (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) word-bytes))
   (inst nop))
 
 (define-move-function (store-single 1) (vop x y)
   ((single-reg) (single-stack))
-  (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)))
+  (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) word-bytes)))
 
 
 (define-move-function (load-double 2) (vop x y)
   ((double-stack) (double-reg))
   (let ((nfp (current-nfp-tn vop))
-	(offset (* (tn-offset x) vm:word-bytes)))
+	(offset (* (tn-offset x) word-bytes)))
     (inst lwc1 y nfp offset)
-    (inst lwc1-odd y nfp (+ offset vm:word-bytes)))
+    (inst lwc1-odd y nfp (+ offset word-bytes)))
   (inst nop))
 
 (define-move-function (store-double 2) (vop x y)
   ((double-reg) (double-stack))
   (let ((nfp (current-nfp-tn vop))
-	(offset (* (tn-offset y) vm:word-bytes)))
+	(offset (* (tn-offset y) word-bytes)))
     (inst swc1 x nfp offset)
-    (inst swc1-odd x nfp (+ offset vm:word-bytes))))
+    (inst swc1-odd x nfp (+ offset word-bytes))))
 
 
 
@@ -70,14 +70,15 @@
   (:args (x :to :save))
   (:results (y))
   (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:variant-vars double-p size type data)
   (:note "float to pointer coercion")
   (:generator 13
-    (with-fixed-allocation (y ndescr type size)
-      (inst swc1 x y (- (* data vm:word-bytes) vm:other-pointer-type))
+    (with-fixed-allocation (y pa-flag ndescr type size)
+      (inst swc1 x y (- (* data word-bytes) other-pointer-type))
       (when double-p
-	(inst swc1-odd x y (- (* (1+ data) vm:word-bytes)
-			      vm:other-pointer-type))))))
+	(inst swc1-odd x y (- (* (1+ data) word-bytes)
+			      other-pointer-type))))))
 
 (macrolet ((frob (name sc &rest args)
 	     `(progn
@@ -87,9 +88,9 @@
 		  (:variant ,@args))
 		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
   (frob move-from-single single-reg
-    nil vm:single-float-size vm:single-float-type vm:single-float-value-slot)
+    nil single-float-size single-float-type single-float-value-slot)
   (frob move-from-double double-reg
-    t vm:double-float-size vm:double-float-type vm:double-float-value-slot))
+    t double-float-size double-float-type double-float-value-slot))
 
 (macrolet ((frob (name sc double-p value)
 	     `(progn
@@ -98,15 +99,15 @@
 		  (:results (y :scs (,sc)))
 		  (:note "pointer to float coercion")
 		  (:generator 2
-		    (inst lwc1 y x (- (* ,value vm:word-bytes)
-				      vm:other-pointer-type))
+		    (inst lwc1 y x (- (* ,value word-bytes)
+				      other-pointer-type))
 		    ,@(when double-p
-			`((inst lwc1-odd y x (- (* (1+ ,value) vm:word-bytes)
-						vm:other-pointer-type))))
+			`((inst lwc1-odd y x (- (* (1+ ,value) word-bytes)
+						other-pointer-type))))
 		    (inst nop)))
 		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
-  (frob move-to-single single-reg nil vm:single-float-value-slot)
-  (frob move-to-double double-reg t vm:double-float-value-slot))
+  (frob move-to-single single-reg nil single-float-value-slot)
+  (frob move-to-double double-reg t double-float-value-slot))
 
 
 (macrolet ((frob (name sc stack-sc format double-p)
@@ -123,11 +124,11 @@
 		       (unless (location= x y)
 			 (inst fmove ,format y x)))
 		      (,stack-sc
-		       (let ((offset (* (tn-offset y) vm:word-bytes)))
+		       (let ((offset (* (tn-offset y) word-bytes)))
 			 (inst swc1 x nfp offset)
 			 ,@(when double-p
 			     '((inst swc1-odd x nfp
-				     (+ offset vm:word-bytes)))))))))
+				     (+ offset word-bytes)))))))))
 		(define-move-vop ,name :move-argument
 		  (,sc descriptor-reg) (,sc)))))
   (frob move-single-float-argument single-reg single-stack :single nil)
@@ -306,6 +307,8 @@
 		(:results (y :scs (signed-reg)))
 		(:temporary (:from (:argument 0) :sc ,from-sc) temp)
 		(:temporary (:sc non-descriptor-reg) status-save new-status)
+		(:temporary (:sc non-descriptor-reg :offset nl4-offset)
+			    pa-flag)
 		(:arg-types ,from-type)
 		(:result-types signed-num)
 		(:translate %unary-truncate)
@@ -314,7 +317,7 @@
 		(:vop-var vop)
 		(:save-p :compute-only)
 		(:generator 16
-		  (pseudo-atomic (status-save)
+		  (pseudo-atomic (pa-flag)
 		    (inst cfc1 status-save 31)
 		    (inst li new-status (lognot 3))
 		    (inst and new-status status-save)
diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp
index 47aedc502381c6e851d75e319ba28be5ab96d4ea..f74c1706ffd88f3ad175b49ad9fb72851252d6cf 100644
--- a/compiler/mips/macros.lisp
+++ b/compiler/mips/macros.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/mips/macros.lisp,v 1.46 1991/11/09 02:37:41 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.47 1992/07/28 20:37:32 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -52,7 +52,7 @@
 
 
 (defmacro load-symbol (reg symbol)
-  `(inst add ,reg null-tn (vm:static-symbol-offset ,symbol)))
+  `(inst add ,reg null-tn (static-symbol-offset ,symbol)))
 
 (macrolet
     ((frob (slot)
@@ -71,15 +71,15 @@
 	    (defmacro ,loader (reg symbol)
 	      `(progn
 		 (inst lw ,reg null-tn
-		       (+ (vm:static-symbol-offset ',symbol)
-			  (ash ,',offset vm:word-shift)
-			  (- vm:other-pointer-type)))
+		       (+ (static-symbol-offset ',symbol)
+			  (ash ,',offset word-shift)
+			  (- other-pointer-type)))
 		 (inst nop)))
 	    (defmacro ,storer (reg symbol)
 	      `(inst sw ,reg null-tn
-		     (+ (vm:static-symbol-offset ',symbol)
-			(ash ,',offset vm:word-shift)
-			(- vm:other-pointer-type))))))))
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))))))
   (frob value)
   (frob function))
 
@@ -102,9 +102,9 @@
 (defmacro lisp-jump (function lip)
   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
   `(progn
-     (inst addu ,lip ,function (- (ash vm:function-header-code-offset
-					vm:word-shift)
-				   vm:function-pointer-type))
+     (inst addu ,lip ,function (- (ash function-header-code-offset
+					word-shift)
+				   function-pointer-type))
      (inst j ,lip)
      (move code-tn ,function)))
 
@@ -112,7 +112,7 @@
   "Return to RETURN-PC.  LIP is an interior-reg temporary."
   `(progn
      (inst addu ,lip ,return-pc
-	   (- (* (1+ ,offset) vm:word-bytes) vm:other-pointer-type))
+	   (- (* (1+ ,offset) word-bytes) other-pointer-type))
      (inst j ,lip)
      ,(if frob-code
 	  `(move code-tn ,return-pc)
@@ -121,7 +121,7 @@
 (defmacro emit-return-pc (label)
   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
   `(progn
-     (align vm:lowtag-bits)
+     (align lowtag-bits)
      (emit-label ,label)
      (inst lra-header-word)))
 
@@ -139,7 +139,7 @@
      (let ((offset (tn-offset stack)))
        (sc-case stack
 	 ((control-stack)
-	  (loadw reg fp-tn offset))))))
+	  (loadw reg cfp-tn offset))))))
 
 (defmacro store-stack-tn (stack reg)
   `(let ((stack ,stack)
@@ -147,7 +147,7 @@
      (let ((offset (tn-offset stack)))
        (sc-case stack
 	 ((control-stack)
-	  (storew reg fp-tn offset))))))
+	  (storew reg cfp-tn offset))))))
 
 
 ;;; MAYBE-LOAD-STACK-TN  --  Interface
@@ -162,23 +162,22 @@
 	  ((any-reg descriptor-reg)
 	   (move ,n-reg ,n-stack))
 	  ((control-stack)
-	   (loadw ,n-reg fp-tn (tn-offset ,n-stack))))))))
+	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 
 
 ;;;; Storage allocation:
 
-(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
 				 &body body)
   "Do stuff to allocate an other-pointer object of fixed Size with a single
-  word header having the specified Type-Code.  The result is placed in
-  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
-  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
-  initializes the object."
-  `(pseudo-atomic (,temp-tn)
-     (inst addu ,result-tn alloc-tn vm:other-pointer-type)
-     (inst addu alloc-tn alloc-tn (vm:pad-data-block ,size))
-     (inst li ,temp-tn (logior (ash (1- ,size) vm:type-bits) ,type-code))
-     (storew ,temp-tn ,result-tn 0 vm:other-pointer-type)
+   word header having the specified Type-Code.  The result is placed in
+   Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
+   descriptor temp (which may be randomly used by the body.)  The body is
+   placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
+  `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
+     (inst or ,result-tn alloc-tn other-pointer-type)
+     (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
+     (storew ,temp-tn ,result-tn 0 other-pointer-type)
      ,@body))
 
 
@@ -210,227 +209,6 @@
 	 (inst bne temp zero-tn target))))
   (inst nop))
 
-
-;;;; Simple Type Checking Macros
-
-(defmacro simple-test-tag (register temp target not-p tag-type tag-mask)
-  `(progn
-     (unless (zerop ,tag-mask)
-       (inst and ,temp ,register ,tag-mask))
-     (inst xor ,temp ,temp ,tag-type)
-     (if ,not-p
-	 (inst bne ,temp zero-tn ,target)
-	 (inst beq ,temp zero-tn ,target))
-     (inst nop)))
-
-(defmacro simple-test-simple-type (register temp target not-p type-code)
-  "Emit conditional code that test whether Register holds an object with
-  the tag specificed if Tag-Type.  Temp should be an unboxed register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p)
-	      (n-type-code type-code))
-    `(cond ((< ,n-type-code vm:lowtag-limit)
-	    (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-			     ,n-type-code lowtag-mask))
-	   (t
-	    ;; Nothing clever in this version.  Assume other-immediate
-	    ;; type is already in register.
-	    ;; 
-	    (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
-			     ,n-type-code type-mask)))))
-
-(defmacro test-simple-type (register temp target not-p type-code
-				     &key (lowtag 'vm:other-pointer-type))
-  "Emit conditional code that test whether Register holds an object with
-  the tag specificed if Tag-Type.  If the Tag-Type is a type for a heap
-  object than the register is dereferencd and the heap object is
-  checked.  Temp should be an unboxed register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p)
-	      (n-type-code type-code))
-    `(cond ((< ,n-type-code vm:lowtag-limit)
-	    (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-			     ,n-type-code vm:lowtag-mask))
-	   ((or (= ,n-type-code vm:base-char-type)
-		(= ,n-type-code vm:unbound-marker-type))
-	    (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-			     ,n-type-code vm:type-mask))
-	   (t
-	    (let* ((out-label (gen-label))
-		   (not-other-label (if ,n-not-p ,n-target out-label)))
-	      (simple-test-tag ,n-register ,n-temp not-other-label t
-			       ,lowtag vm:lowtag-mask)
-	      (load-type ,n-temp ,n-register (- ,lowtag))
-	      (inst nop)
-	      (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
-			       ,n-type-code 0)
-	      (emit-label out-label))))))
-
-
-;;;; Hairy Type Checking Macros
-
-(defun canonicalize-type-codes (type-codes &optional (shift 0))
-  (unless type-codes (return-from canonicalize-type-codes nil))
-  (let* ((type-codes (sort (remove-duplicates type-codes) #'<))
-	 (canonical-type-codes nil)
-	 (first-type-code (pop type-codes))
-	 (last-type-code (ash first-type-code shift))
-	 (range-start first-type-code)
-	 (range-end nil))
-    (dolist (type-code type-codes)
-      (let ((shifted-type-code (ash type-code shift)))
-	(cond ((= last-type-code (1- shifted-type-code))
-	       (setf range-end type-code))
-	      (t
-	       (push (if range-end (cons range-start range-end) range-start)
-		     canonical-type-codes)
-	       (setf range-start type-code)
-	       (setf range-end nil)))
-	(setf last-type-code shifted-type-code)))
-    (push (if range-end (cons range-start range-end) range-start)
-	  canonical-type-codes)
-    (nreverse canonical-type-codes)))
-
-(defmacro hairy-test-tag (register temp target not-p tag-types tag-mask)
-  (let ((in-label (gensym))
-	(out-label (gensym)))
-    (collect ((emit))
-      (macrolet ((frob (value)
-		   `(let ((diff (+ (- ,value) last-type-code)))
-		      (unless (zerop diff)
-			(emit `(inst add ,temp ,temp ,diff))
-			(setf last-type-code ,value)))))
-	(do* ((types tag-types (cdr types))
-	      (type (car types) (car types))
-	      (last-type-check-p (null (cdr types)) (null (cdr types)))
-	      (last-type-code 0))
-	     ((null types))
-	  (cond ((consp type)
-		 (let ((low (car type))
-		       (high (cdr type)))
-		   (frob low)
-		   (emit `(inst bltz ,temp ,out-label))
-		   (frob high)
-		   (cond (last-type-check-p
-			  (emit `(if ,not-p
-				     (inst bgtz ,temp ,target)
-				     (inst blez ,temp ,target))))
-			 (t
-			  (emit `(inst blez ,temp ,in-label))))))
-		(t
-		 (frob type)
-		 (cond (last-type-check-p
-			(emit `(if ,not-p
-				   (inst bne ,temp zero-tn ,target)
-				   (inst beq ,temp zero-tn ,target))))
-		       (t
-			(emit `(inst beq ,temp zero-tn ,in-label))))))))
-      `(let* ((drop-through (gen-label))
-	      (,in-label (if ,not-p drop-through ,target))
-	      (,out-label (if ,not-p ,target drop-through)))
-	 ,in-label			; squelch possible warning
-	 ,out-label
-	 (unless (zerop ,tag-mask)
-	   (inst and ,temp ,register ,tag-mask))
-	 ,@(emit)
-	 (inst nop)
-	 (emit-label drop-through)))))
-
-(defmacro test-hairy-type (register temp target not-p &rest types)
-  "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+
-  
-  Test whether Register holds a value with one of a specified union of
-  type codes.  All low tag type codes will be checked first.  Then the
-  pointer will be checked to see if it is an other-pointer-type type
-  pointer in which case it will be dereferenced and the remaining type
-  codes (the header word type codes) will be checked.  All of the
-  type-code expressions are evaluated at macroexpand time.  Temp should
-  be an unboxed register." 
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p))
-    (unless types (error "Must specify at least one type."))
-    ;; 
-    ;; Partition the type codes.
-    (collect ((low-tag-types)
-	      (header-word-types))
-      (dolist (type types)
-	(let ((type (eval type)))
-	  (cond ((< type vm:lowtag-limit)
-		 (low-tag-types type))
-		(t
-		 (header-word-types type)))))
-      
-      (let ((low-tag-types (canonicalize-type-codes (low-tag-types)))
-	    (header-word-types (canonicalize-type-codes
-				(header-word-types) (- (1- lowtag-bits)))))
-	;; 
-	;; Generate code
-	`(let* ((out-label (gen-label))
-		(in-low-tag-label (if ,n-not-p out-label ,n-target))
-		(not-other-label (if ,n-not-p ,n-target out-label)))
-	   in-low-tag-label            ; may not be used -- squelch warning
-	   not-other-label
-	   ,@(when low-tag-types
-	       (if header-word-types
-		   `((hairy-test-tag ,n-register ,n-temp in-low-tag-label nil
-				     ,low-tag-types vm:lowtag-mask))
-		   `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-				     ,low-tag-types vm:lowtag-mask))))
-	   ,@(when header-word-types
-	       `((simple-test-tag ,n-register ,n-temp not-other-label t
-				  vm:other-pointer-type vm:lowtag-mask)
-		 (load-type ,n-temp ,n-register (- vm:other-pointer-type))
-		 (inst nop)
-		 (hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-				 ,header-word-types 0)))
-	   (emit-label out-label))))))
-
-(defmacro simple-test-hairy-type (register temp target not-p &rest types)
-  "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+
-
-  Test whether Register holds a value with one of a specified union of
-  type codes.  The type codes must either be all low tag codes or all
-  header word tag codes.  Each separately specified Type is matched, and
-  also all types between a Low-Type and High-Type pair (inclusive) are
-  matched.  All of the type-code expressions are evaluated at
-  macroexpand time.  Temp should be an unboxed register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p))
-    (unless types (error "Must specify at least one type."))
-    ;; 
-    ;; Partition the type codes.
-    (collect ((low-tag-types)
-	      (header-word-types))
-      (dolist (type types)
-	(cond ((< type vm:lowtag-limit)
-	       (low-tag-types type))
-	      (t
-	       (header-word-types type))))
-      (let ((low-tag-types (low-tag-types))
-	    (header-word-types (header-word-types)))
-	(cond ((and low-tag-types header-word-types)
-	       (error "SIMPLE-TEST-HAIRY-TYPE cannot check both low tag ~
-	       types and other-pointer-type tag types."))
-	      (low-tag-types
-	       `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-				 ,(canonicalize-type-codes low-tag-types)
-				 vm:lowtag-mask)))
-	      (header-word-types
-	       `(progn
-		  (inst srl ,n-temp ,n-register vm:lowtag-bits)
-		  (hairy-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
-				  ,(canonicalize-type-codes header-word-types)
-				  vm:type-mask)))
-	      (t
-	       (error "Lost big.  Should not be here.")))))))
 
 
 ;;;; Error Code
@@ -469,12 +247,12 @@
 	  (inst byte (length ,vector))
 	  (dotimes (i (length ,vector))
 	    (inst byte (aref ,vector i))))
-	(align vm:word-shift)))))
+	(align word-shift)))))
 
 (defmacro error-call (vop error-code &rest values)
   "Cause an error.  ERROR-CODE is the error to cause."
   (cons 'progn
-	(emit-error-break vop vm:error-trap error-code values)))
+	(emit-error-break vop error-trap error-code values)))
 
 
 (defmacro cerror-call (vop label error-code &rest values)
@@ -482,7 +260,7 @@
   LABEL."
   `(progn
      (inst b ,label)
-     ,@(emit-error-break vop vm:cerror-trap error-code values)))
+     ,@(emit-error-break vop cerror-trap error-code values)))
 
 (defmacro generate-error-code (vop error-code &rest values)
   "Generate-Error-Code Error-code Value*
@@ -511,17 +289,180 @@
 
 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 ;;;
-(defmacro pseudo-atomic ((ndescr-temp) &rest forms)
-  (let ((label (gensym "LABEL-")))
-    `(let ((,label (gen-label)))
-       (inst and flags-tn flags-tn (logxor (ash 1 interrupted-flag) #Xffff))
-       (inst or flags-tn flags-tn (ash 1 atomic-flag))
-       ,@forms
-       (inst and flags-tn flags-tn (logxor (ash 1 atomic-flag) #Xffff))
-       (inst and ,ndescr-temp flags-tn (ash 1 interrupted-flag))
-       (inst beq ,ndescr-temp zero-tn ,label)
-       (inst nop)
-       (inst break vm:pending-interrupt-trap)
-       (emit-label ,label))))
+(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
+  `(progn
+     (assert (= (tn-offset ,flag-tn) nl4-offset))
+     (without-scheduling ()
+       (inst li ,flag-tn (1- ,extra))
+       (inst addu alloc-tn 1))
+     ,@forms
+     (without-scheduling ()
+       (inst add alloc-tn ,flag-tn))))
+
 
+
+;;;; Memory accessor vop generators
+
+(deftype load/store-index (scale lowtag min-offset
+				 &optional (max-offset min-offset))
+  `(integer ,(- (truncate (+ (ash 1 16)
+			     (* min-offset word-bytes)
+			     (- lowtag))
+			  scale))
+	    ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+			  (* max-offset word-bytes))
+		       scale)))
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type
+				   &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg)))
+       (:arg-types ,type tagged-num)
+       (:temporary (:scs (interior-reg)) lip)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 5
+	 (inst add lip object index)
+	 (inst lw value lip (- (* ,offset word-bytes) ,lowtag))
+	 (inst nop)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
+						,(eval offset))))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4
+	 (inst lw value object (- (* (+ ,offset index) word-bytes) ,lowtag))
+	 (inst nop)))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type
+				   &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type tagged-num ,el-type)
+       (:temporary (:scs (interior-reg)) lip)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 2
+	 (inst add lip object index)
+	 (inst sw value lip (- (* ,offset word-bytes) ,lowtag))
+	 (move result value)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
+						,(eval offset)))
+		   ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 1
+	 (inst sw value object (- (* (+ ,offset index) word-bytes) ,lowtag))
+	 (move result value)))))
+
+
+(defmacro define-partial-reffer (name type size signed offset lowtag scs
+				      el-type &optional translate)
+  (let ((scale (ecase size (:byte 1) (:short 2))))
+    `(progn
+       (define-vop (,name)
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (value :scs ,scs))
+	 (:result-types ,el-type)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:generator 5
+	   (inst addu lip object index)
+	   ,@(when (eq size :short)
+	       '((inst addu lip index)))
+	   (inst ,(ecase size
+		    (:byte (if signed 'lb 'lbu))
+		    (:short (if signed 'lh 'lhu)))
+		 value lip (- (* ,offset word-bytes) ,lowtag))
+	   (inst nop)))
+       (define-vop (,(symbolicate name "-C"))
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:info index)
+	 (:arg-types ,type
+		     (:constant (load/store-index ,scale
+						  ,(eval lowtag)
+						  ,(eval offset))))
+	 (:results (value :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (inst ,(ecase size
+		    (:byte (if signed 'lb 'lbu))
+		    (:short (if signed 'lh 'lhu)))
+		 value object
+		 (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag))
+	   (inst nop))))))
+
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+				      &optional translate)
+  (let ((scale (ecase size (:byte 1) (:short 2))))
+    `(progn
+       (define-vop (,name)
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg))
+		(value :scs ,scs :target result))
+	 (:arg-types ,type positive-fixnum ,el-type)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:results (result :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (inst addu lip object index)
+	   ,@(when (eq size :short)
+	       '((inst addu lip index)))
+	   (inst ,(ecase size (:byte 'sb) (:short 'sh))
+		 value lip (- (* ,offset word-bytes) ,lowtag))
+	   (move result value)))
+       (define-vop (,(symbolicate name "-C"))
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs ,scs :target result))
+	 (:info index)
+	 (:arg-types ,type
+		     (:constant (load/store-index ,scale
+						  ,(eval lowtag)
+						  ,(eval offset)))
+		     ,el-type)
+	 (:results (result :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (inst ,(ecase size (:byte 'sb) (:short 'sh))
+		 value object
+		 (- (* ,offset word-bytes) (* index ,scale) ,lowtag))
+	   (move result value))))))
 
diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp
index 7550c9a2beab1f7fb919b35dfc82626d253de316..7980d518664528ccf6e27f696a123635ee59e92b 100644
--- a/compiler/mips/memory.lisp
+++ b/compiler/mips/memory.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: C; Log: C.Log -*-
+;;; -*- Package: MIPS -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.12 1991/02/20 15:14:39 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.13 1992/07/28 20:37:35 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.12 1991/02/20 15:14:39 ram Exp $
-;;;
 ;;;    This file contains the MIPS definitions of some general purpose memory
 ;;; reference VOPs inherited by basic memory reference operations.
 ;;;
@@ -109,62 +107,3 @@
   (:generator 4
     (storew value object (+ base offset) lowtag)))
 
-
-
-;;;; Indexed references:
-
-;;; Define-Indexer  --  Internal
-;;;
-;;;    Define some VOPs for indexed memory reference.  Unless the index is
-;;; constant, we must compute an intermediate result in a boxed temporary,
-;;; since the RT doesn't have any indexed addressing modes.  This means that GC
-;;; has to adjust the "raw" pointer in Index-Temp by observing that Index-Temp
-;;; points within Object-Temp.  After we are done, we clear Index-Temp so that
-;;; we don't raw pointers lying around.
-;;;
-(defmacro define-indexer (name write-p op shift)
-  `(define-vop (,name)
-     (:args (object :scs (descriptor-reg))
-	    (index :scs (any-reg zero immediate negative-immediate))
-	    ,@(when write-p
-		'((value :scs (any-reg descriptor-reg) :target result))))
-     (:arg-types * tagged-num ,@(when write-p '(*)))
-     (:temporary (:scs (interior-reg) :type interior) lip)
-     ,@(unless (zerop shift)
-	 `((:temporary (:scs (non-descriptor-reg) :type random) temp)))
-     (:results (,(if write-p 'result 'value)
-		:scs (any-reg descriptor-reg)))
-     (:result-types *)
-     (:variant-vars offset lowtag)
-     (:policy :fast-safe)
-     (:generator 5
-       (sc-case index
-	 ((immediate zero negative-immediate)
-	  (inst ,op value object
-		(- (+ (if (sc-is index zero)
-			  0
-			  (ash (tn-value index) (- word-shift ,shift)))
-		      (ash offset word-shift))
-		   lowtag))
-	  ,(if write-p
-	       '(move result value)
-	       '(inst nop)))
-	 (t
-	  ,@(if (zerop shift)
-		`((inst addu lip object index))
-		`((inst srl temp index ,shift)
-		  (inst addu lip temp object)))
-	  (inst ,op value lip (- (ash offset word-shift) lowtag))
-	  ,(if write-p
-	       '(move result value)
-	       '(inst nop)))))))
-
-(define-indexer word-index-ref nil lw 0)
-(define-indexer word-index-set t sw 0)
-(define-indexer halfword-index-ref nil lhu 1)
-(define-indexer signed-halfword-index-ref nil lh 1)
-(define-indexer halfword-index-set t sh 1)
-(define-indexer byte-index-ref nil lbu 2)
-(define-indexer signed-byte-index-ref nil lb 2)
-(define-indexer byte-index-set t sb 2)
-
diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp
index 67d72ef3e34672aae27c03802019347125f3c956..cd0c9adcc4ad57ee8763b27aec52f81b214bc7bb 100644
--- a/compiler/mips/move.lisp
+++ b/compiler/mips/move.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: C; Log: C.Log -*-
+;;; -*- Package: MIPS -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.29 1991/11/09 02:37:43 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.30 1992/07/28 20:37:37 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.29 1991/11/09 02:37:43 wlott Exp $
-;;;
 ;;;    This file contains the MIPS VM definition of operand loading/saving and
 ;;; the Move VOP.
 ;;;
@@ -23,8 +21,7 @@
 
 
 (define-move-function (load-immediate 1) (vop x y)
-  ((null unsigned-immediate immediate zero negative-immediate
-	 random-immediate immediate-base-char)
+  ((null zero immediate)
    (any-reg descriptor-reg))
   (let ((val (tn-value x)))
     (etypecase val
@@ -39,20 +36,20 @@
 			  base-char-type))))))
 
 (define-move-function (load-number 1) (vop x y)
-  ((unsigned-immediate immediate zero negative-immediate random-immediate)
+  ((zero immediate)
    (signed-reg unsigned-reg))
   (inst li y (tn-value x)))
 
 (define-move-function (load-base-char 1) (vop x y)
-  ((immediate-base-char) (base-char-reg))
+  ((immediate) (base-char-reg))
   (inst li y (char-code (tn-value x))))
 
 (define-move-function (load-system-area-pointer 1) (vop x y)
-  ((immediate-sap) (sap-reg))
+  ((immediate) (sap-reg))
   (inst li y (sap-int (tn-value x))))
 
 (define-move-function (load-constant 5) (vop x y)
-  ((constant) (descriptor-reg))
+  ((constant) (descriptor-reg any-reg))
   (loadw y code-tn (tn-offset x) other-pointer-type))
 
 (define-move-function (load-stack 5) (vop x y)
@@ -186,7 +183,7 @@
       (inst beq temp done)
       (inst sra y x 2)
 
-      (loadw y x vm:bignum-digits-offset vm:other-pointer-type)
+      (loadw y x bignum-digits-offset other-pointer-type)
       (emit-label done))))
 ;;;
 (define-move-vop move-to-word/integer :move
@@ -214,6 +211,7 @@
   (:args (arg :scs (signed-reg unsigned-reg) :target x))
   (:results (y :scs (any-reg descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:note "signed word to integer coercion")
   (:generator 18
     (move x arg)
@@ -225,13 +223,9 @@
       (inst beq temp done)
       (inst sll y x 2)
       
-      (pseudo-atomic (temp)
-	(inst addu y alloc-tn vm:other-pointer-type)
-	(inst addu alloc-tn
-	      (vm:pad-data-block (1+ vm:bignum-digits-offset)))
-	(inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type))
-	(storew temp y 0 vm:other-pointer-type)
-	(storew x y vm:bignum-digits-offset vm:other-pointer-type))
+      (with-fixed-allocation
+	  (y pa-flag temp bignum-type (1+ bignum-digits-offset))
+	(storew x y bignum-digits-offset other-pointer-type))
       (inst b done)
       (inst nop)
       
@@ -250,27 +244,24 @@
   (:args (arg :scs (signed-reg unsigned-reg) :target x))
   (:results (y :scs (any-reg descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:note "unsigned word to integer coercion")
   (:generator 20
     (move x arg)
-    (let ((done (gen-label))
-	  (one-word (gen-label)))
-      (inst sra temp x 29)
-      (inst beq temp done)
-      (inst sll y x 2)
+    (inst sra temp x 29)
+    (inst beq temp done)
+    (inst sll y x 2)
       
-      (pseudo-atomic (temp)
-	(inst addu y alloc-tn vm:other-pointer-type)
-	(inst addu alloc-tn
-	      (vm:pad-data-block (1+ vm:bignum-digits-offset)))
-	(inst bgez x one-word)
-	(inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type))
-	(inst addu alloc-tn (vm:pad-data-block 1))
-	(inst li temp (logior (ash 2 vm:type-bits) vm:bignum-type))
-	(emit-label one-word)
-	(storew temp y 0 vm:other-pointer-type)
-	(storew x y vm:bignum-digits-offset vm:other-pointer-type))
-      (emit-label done))))
+    (pseudo-atomic
+	(pa-flag :extra (pad-data-block (+ bignum-digits-offset 2)))
+      (inst or y alloc-tn other-pointer-type)
+      (inst sltu temp x zero-tn)
+      (inst sll temp type-bits)
+      (inst addu temp (logior (ash 1 type-bits) bignum-type))
+      (storew temp y 0 other-pointer-type)
+      (storew x y bignum-digits-offset other-pointer-type))
+    DONE))
+  
 ;;;
 (define-move-vop move-from-unsigned :move
   (unsigned-reg) (descriptor-reg))
diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp
index 2438ba3dca16a263198adb02e2b01e023dd39839..38658b63e09542ca49cec7fa2bd4b88b46efac26 100644
--- a/compiler/mips/nlx.lisp
+++ b/compiler/mips/nlx.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.17 1992/05/21 23:23:29 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.18 1992/07/28 20:37:40 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.17 1992/05/21 23:23:29 wlott Exp $
-;;;
 ;;;    This file contains the definitions of VOPs used for non-local exit
 ;;; (throw, lexical exit, etc.)
 ;;;
@@ -101,10 +99,10 @@
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (non-descriptor-reg)) ndescr)
   (:generator 22
-    (inst addu block fp-tn (* (tn-offset tn) vm:word-bytes))
+    (inst addu block cfp-tn (* (tn-offset tn) vm:word-bytes))
     (load-symbol-value temp lisp::*current-unwind-protect-block*)
     (storew temp block vm:unwind-block-current-uwp-slot)
-    (storew fp-tn block vm:unwind-block-current-cont-slot)
+    (storew cfp-tn block vm:unwind-block-current-cont-slot)
     (storew code-tn block vm:unwind-block-current-code-slot)
     (inst compute-lra-from-code temp code-tn entry-label ndescr)
     (storew temp block vm:catch-block-entry-pc-slot)))
@@ -122,10 +120,10 @@
   (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
   (:temporary (:scs (non-descriptor-reg)) ndescr)
   (:generator 44
-    (inst addu result fp-tn (* (tn-offset tn) vm:word-bytes))
+    (inst addu result cfp-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 fp-tn result vm:catch-block-current-cont-slot)
+    (storew cfp-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 ndescr)
     (storew temp result vm:catch-block-entry-pc-slot)
@@ -145,7 +143,7 @@
   (:args (tn))
   (:temporary (:scs (descriptor-reg)) new-uwp)
   (:generator 7
-    (inst addu new-uwp fp-tn (* (tn-offset tn) vm:word-bytes))
+    (inst addu new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
     (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
 
 
diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp
index 9a78eca75dfcde4ab33ff857da567e103acae9d4..f34cf6d19c90350369837b0f9671705b52f96886 100644
--- a/compiler/mips/parms.lisp
+++ b/compiler/mips/parms.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/mips/parms.lisp,v 1.104 1992/07/08 23:46:14 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.105 1992/07/28 20:37:43 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -23,13 +23,6 @@
 (in-package "MIPS")
 (use-package "C")
 
-(export '(word-bits byte-bits word-shift word-bytes))
-
-(export '(float-underflow-trap-bit float-overflow-trap-bit
-	  float-imprecise-trap-bit float-invalid-trap-bit
-	  float-divide-by-zero-trap-bit single-float-trapping-nan-bit
-	  double-float-trapping-nan-bit))
-
 
 ;;;; Compiler constants.
 
@@ -40,7 +33,7 @@
 (setf (backend-fasl-file-type *target-backend*) "pmaxf")
 (setf (backend-fasl-file-implementation *target-backend*)
       pmax-fasl-file-implementation)
-(setf (backend-fasl-file-version *target-backend*) 4)
+(setf (backend-fasl-file-version *target-backend*) 5)
 (setf (backend-register-save-penalty *target-backend*) 3)
 (setf (backend-byte-order *target-backend*) :little-endian)
 (setf (backend-page-size *target-backend*) 4096)
@@ -52,6 +45,23 @@
 
 ;;;; Machine Architecture parameters:
 
+(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+
+	  single-float-bias single-float-exponent-byte
+	  single-float-significand-byte single-float-normal-exponent-min
+	  single-float-normal-exponent-max single-float-hidden-bit
+	  single-float-trapping-nan-bit single-float-digits
+
+	  double-float-bias double-float-exponent-byte
+	  double-float-significand-byte double-float-normal-exponent-min
+	  double-float-normal-exponent-max double-float-hidden-bit
+	  double-float-trapping-nan-bit double-float-digits
+
+	  float-underflow-trap-bit float-overflow-trap-bit
+	  float-imprecise-trap-bit float-invalid-trap-bit
+	  float-divide-by-zero-trap-bit))
+
+
 (eval-when (compile load eval)
 
 (defconstant word-bits 32
@@ -114,6 +124,10 @@
 
 ;;;; Description of the target address space.
 
+(export '(target-read-only-space-start
+	  target-static-space-start
+	  target-dynamic-space-start))
+
 ;;; Where to put the different spaces.
 ;;; 
 (defparameter target-read-only-space-start #x01000000)
@@ -176,6 +190,7 @@
     lisp::maybe-gc
     kernel::internal-error
     di::handle-breakpoint
+    di::handle-function-end-breakpoint
     lisp::fdefinition-object
 
     ;; Free Pointers
diff --git a/compiler/mips/print.lisp b/compiler/mips/print.lisp
index d31b632d5ba32faf3550510cba915023301580c1..66772e0491fa424bc48dedc9fdd8bedd0a601978 100644
--- a/compiler/mips/print.lisp
+++ b/compiler/mips/print.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.8 1991/07/14 03:49:26 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.9 1992/07/28 20:37:46 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.8 1991/07/14 03:49:26 wlott Exp $
-;;;
 ;;; This file contains temporary printing utilities and similar noise.
 ;;;
 ;;; Written by William Lott.
@@ -24,28 +22,20 @@
   (:args (object :scs (descriptor-reg) :target a0))
   (:results (result :scs (descriptor-reg)))
   (:save-p t)
-  (:temporary (:sc any-reg :offset 2) v0)
+  (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
+	      cfunc)
   (:temporary (:sc descriptor-reg :offset 4 :from (:argument 0)) a0)
-  (:temporary (:sc any-reg :offset lra-offset) lra)
-  (:temporary (:sc any-reg :offset code-offset) code)
   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
   (:vop-var vop)
   (:generator 0
-    (let ((lra-label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
+    (let ((cur-nfp (current-nfp-tn vop)))
       (move a0 object)
       (when cur-nfp
 	(store-stack-tn nfp-save cur-nfp))
+      (inst li cfunc (make-fixup "debug_print" :foreign))
+      (inst jal (make-fixup "call_into_c" :foreign))
       (inst addu nsp-tn nsp-tn -16)
-      (inst compute-lra-from-code lra code lra-label v0)
-      (inst li v0 (make-fixup "debug_print" :foreign))
-      (inst j (make-fixup "call_into_c" :foreign))
-      (inst nop)
-
-      (align vm:lowtag-bits)
-      (emit-label lra-label)
-      (inst lra-header-word)
       (inst addu nsp-tn nsp-tn 16)
       (when cur-nfp
 	(load-stack-tn cur-nfp nfp-save))
-      (move result v0))))
+      (move result cfunc))))
diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp
index d7f96bbde6ab4336afb95dcbf8402dbdfd68302c..cbb3214953f8e3e3fc53a3927f984fad269afb5d 100644
--- a/compiler/mips/sap.lisp
+++ b/compiler/mips/sap.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/mips/sap.lisp,v 1.25 1992/07/08 20:56:59 hallgren Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.26 1992/07/28 20:37:48 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -27,7 +27,7 @@
   (:results (y :scs (sap-reg)))
   (:note "system area pointer indirection")
   (:generator 1
-    (loadw y x vm:sap-pointer-slot vm:other-pointer-type)))
+    (loadw y x sap-pointer-slot other-pointer-type)))
 
 ;;;
 (define-move-vop move-to-sap :move
@@ -40,16 +40,13 @@
   (:args (x :scs (sap-reg) :target sap))
   (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
   (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:results (y :scs (descriptor-reg)))
   (:note "system area pointer allocation")
   (:generator 20
     (move sap x)
-    (pseudo-atomic (ndescr)
-      (inst addu y alloc-tn vm:other-pointer-type)
-      (inst addu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size))
-      (inst li ndescr (logior (ash (1- vm:sap-size) vm:type-bits) vm:sap-type))
-      (storew ndescr y 0 vm:other-pointer-type)
-      (storew sap y vm:sap-pointer-slot vm:other-pointer-type))))
+    (with-fixed-allocation (y pa-flag ndescr sap-type sap-size)
+      (storew sap y sap-pointer-slot other-pointer-type))))
 ;;;
 (define-move-vop move-from-sap :move
   (sap-reg) (descriptor-reg))
@@ -188,7 +185,7 @@
 		  '((inst lwc1 result sap 0)))
 		 (:double
 		  '((inst lwc1 result sap 0)
-		    (inst lwc1-odd result sap vm:word-bytes))))
+		    (inst lwc1-odd result sap word-bytes))))
 	   (inst nop)))
        (define-vop (,ref-name-c)
 	 (:translate ,ref-name)
@@ -219,7 +216,7 @@
 		'((inst lwc1 result object offset)))
 	       (:double
 		'((inst lwc1 result object offset)
-		  (inst lwc1-odd result object (+ offset vm:word-bytes)))))
+		  (inst lwc1-odd result object (+ offset word-bytes)))))
 	   (inst nop)))
        (define-vop (,set-name)
 	 (:translate ,set-name)
@@ -249,7 +246,7 @@
 		    (inst fmove :single result value))))
 	       (:double
 		'((inst swc1 value sap 0)
-		  (inst swc1-odd value sap vm:word-bytes)
+		  (inst swc1-odd value sap word-bytes)
 		  (unless (location= result value)
 		    (inst fmove :double result value)))))))
        (define-vop (,set-name-c)
@@ -284,7 +281,7 @@
 		    (inst fmove :single result value))))
 	       (:double
 		'((inst swc1 value object offset)
-		  (inst swc1-odd value object (+ offset vm:word-bytes))
+		  (inst swc1-odd value object (+ offset word-bytes))
 		  (unless (location= result value)
 		    (inst fmove :double result value))))))))))
 
@@ -320,5 +317,5 @@
   (:result-types system-area-pointer)
   (:generator 2
     (inst addu sap vector
-	  (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))))
+	  (- (* vector-data-offset word-bytes) other-pointer-type))))
 
diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp
index 1b3ebdbe75467e3f10d0b7cf14436d5bb08a2a87..03da29f8e5dafb86b2cc73a9fd95c401cb1724f4 100644
--- a/compiler/mips/static-fn.lisp
+++ b/compiler/mips/static-fn.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.17 1992/05/21 02:12:53 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.18 1992/07/28 20:37:50 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.17 1992/05/21 02:12:53 wlott Exp $
-;;;
 ;;; This file contains the VOPs and macro magic necessary to call static
 ;;; functions.
 ;;;
@@ -30,9 +28,9 @@
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg)) move-temp)
   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
-  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:temporary (:scs (interior-reg)) lip)
   (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
+  (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
 
 
@@ -94,7 +92,7 @@
 	     (inst lw lip null-tn (static-function-offset symbol))
 	     (when cur-nfp
 	       (store-stack-tn nfp-save cur-nfp))
-	     (inst move old-fp cfp-tn)
+	     (inst move ocfp cfp-tn)
 	     (inst compute-lra-from-code lra code-tn lra-label temp)
 	     (note-this-location vop :call-site)
 	     (inst j lip)
diff --git a/compiler/mips/subprim.lisp b/compiler/mips/subprim.lisp
index 1494b18d25740c1ae4c7b827daca585fd9c417d3..5b0449e5815af291a35af25216f3920450aabf4f 100644
--- a/compiler/mips/subprim.lisp
+++ b/compiler/mips/subprim.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.20 1991/02/20 15:15:14 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.21 1992/07/28 20:37:52 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.20 1991/02/20 15:15:14 ram Exp $
-;;;
 ;;;    Linkage information for standard static functions, and random vops.
 ;;;
 ;;; Written by William Lott.
@@ -28,7 +26,7 @@
   (:args (object :scs (descriptor-reg) :target ptr))
   (:arg-types list)
   (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
-  (:temporary (:scs (non-descriptor-reg) :type random) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
 	      count)
   (:results (result :scs (any-reg descriptor-reg)))
@@ -36,27 +34,28 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 50
-    (let ((done (gen-label))
-	  (loop (gen-label))
-	  (not-list (generate-cerror-code vop object-not-list-error object)))
-      (move ptr object)
-      (move count zero-tn)
-
-      (emit-label loop)
-
-      (inst beq ptr null-tn done)
-      (inst nop)
-
-      (simple-test-simple-type ptr temp not-list t vm:list-pointer-type)
-
-      (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
-      (inst addu count count (fixnum 1))
-      (simple-test-simple-type ptr temp loop nil vm:list-pointer-type)
-
-      (cerror-call vop done object-not-list-error ptr)
-
-      (emit-label done)
-      (move result count))))
+    (move ptr object)
+    (move count zero-tn)
+    
+    LOOP
+    
+    (inst beq ptr null-tn done)
+    (inst nop)
+    
+    (inst and temp ptr lowtag-mask)
+    (inst xor temp list-pointer-type)
+    (inst bne temp zero-tn not-list)
+    (inst nop)
+    
+    (loadw ptr ptr cons-cdr-slot list-pointer-type)
+    (inst b loop)
+    (inst addu count count (fixnum 1))
+    
+    NOT-LIST
+    (cerror-call vop done object-not-list-error ptr)
+    
+    DONE
+    (move result count)))
        
 
 (define-static-function length (object) :translate length)
diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp
index ec98033b6c1b9f882df5beaecdc64709c7a64a4f..6978f4b0db6f34b58231a52636e4413bb4114210 100644
--- a/compiler/mips/system.lisp
+++ b/compiler/mips/system.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.45 1992/04/21 04:22:20 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.46 1992/07/28 20:37:54 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.45 1992/04/21 04:22:20 wlott Exp $
-;;;
 ;;;    MIPS VM definitions of various system hacking operations.
 ;;;
 ;;; Written by Rob MacLachlan
@@ -28,7 +26,7 @@
   (:args (x :scs (sap-reg))
 	 (y :scs (sap-reg)))
   (:arg-types system-area-pointer system-area-pointer)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:conditional)
   (:info target not-p)
   (:policy :fast-safe)
@@ -58,7 +56,7 @@
   (:results (result :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 1
-    (inst and result object vm:lowtag-mask)))
+    (inst and result object lowtag-mask)))
 
 (define-vop (get-type)
   (:translate get-type)
@@ -68,43 +66,40 @@
   (:results (result :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 6
-    (let ((other-ptr (gen-label))
-	  (lowtag-only (gen-label))
-	  (function-ptr (gen-label))
-	  (done (gen-label)))
-      ;; Pick off objects with headers.
-      (simple-test-simple-type object ndescr other-ptr
-			       nil vm:other-pointer-type)
-      (simple-test-simple-type object ndescr function-ptr
-			       nil vm:function-pointer-type)
-
-      ;; Pick off fixnums.
-      (inst and result object 3)
-      (inst beq result done)
-
-      ;; Pick off structure and list pointers.
-      (inst and result object 1)
-      (inst bne result lowtag-only)
-      (inst nop)
+    ;; Pick off objects with headers.
+    (inst and ndescr object lowtag-mask)
+    (inst xor ndescr other-pointer-type)
+    (inst beq ndescr other-ptr)
+    (inst xor ndescr (logxor other-pointer-type function-pointer-type))
+    (inst beq ndescr function-ptr)
+
+    ;; Pick off fixnums.
+    (inst and result object 3)
+    (inst beq result done)
+
+    ;; Pick off structure and list pointers.
+    (inst and result object 1)
+    (inst bne result lowtag-only)
+    (inst nop)
 
       ;; Must be an other immediate.
-      (inst b done)
-      (inst and result object vm:type-mask)
+    (inst b done)
+    (inst and result object type-mask)
 
-      (emit-label function-ptr)
-      (load-type result object (- vm:function-pointer-type))
-      (inst b done)
-      (inst nop)
+    FUNCTION-PTR
+    (load-type result object (- function-pointer-type))
+    (inst b done)
+    (inst nop)
 
-      (emit-label lowtag-only)
-      (inst b done)
-      (inst and result object lowtag-mask)
+    LOWTAG-ONLY
+    (inst b done)
+    (inst and result object lowtag-mask)
 
-      (emit-label other-ptr)
-      (load-type result object (- vm:other-pointer-type))
-      (inst nop)
+    OTHER-PTR
+    (load-type result object (- other-pointer-type))
+    (inst nop)
       
-      (emit-label done))))
+    DONE))
 
 (define-vop (function-subtype)
   (:translate function-subtype)
@@ -113,7 +108,7 @@
   (:results (result :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 6
-    (load-type result function (- vm:function-pointer-type))
+    (load-type result function (- function-pointer-type))
     (inst nop)))
 
 (define-vop (set-function-subtype)
@@ -136,8 +131,8 @@
   (:results (res :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 6
-    (loadw res x 0 vm:other-pointer-type)
-    (inst srl res res vm:type-bits)))
+    (loadw res x 0 other-pointer-type)
+    (inst srl res res type-bits)))
 
 (define-vop (get-closure-length)
   (:translate get-closure-length)
@@ -146,8 +141,8 @@
   (:results (res :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 6
-    (loadw res x 0 vm:function-pointer-type)
-    (inst srl res res vm:type-bits)))
+    (loadw res x 0 function-pointer-type)
+    (inst srl res res type-bits)))
 
 (define-vop (set-header-data)
   (:translate set-header-data)
@@ -156,18 +151,18 @@
 	 (data :scs (any-reg immediate zero)))
   (:arg-types * positive-fixnum)
   (:results (res :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :type random) t1 t2)
+  (:temporary (:scs (non-descriptor-reg)) t1 t2)
   (:generator 6
-    (loadw t1 x 0 vm:other-pointer-type)
-    (inst and t1 vm:type-mask)
+    (loadw t1 x 0 other-pointer-type)
+    (inst and t1 type-mask)
     (sc-case data
       (any-reg
-       (inst sll t2 data (- vm:type-bits 2))
+       (inst sll t2 data (- type-bits 2))
        (inst or t1 t2))
       (immediate
-       (inst or t1 (ash (tn-value data) vm:type-bits)))
+       (inst or t1 (ash (tn-value data) type-bits)))
       (zero))
-    (storew t1 x 0 vm:other-pointer-type)
+    (storew t1 x 0 other-pointer-type)
     (move res x)))
 
 (define-vop (c::make-fixnum)
@@ -182,18 +177,18 @@
 
 (define-vop (c::make-other-immediate-type)
   (:args (val :scs (any-reg descriptor-reg))
-	 (type :scs (any-reg descriptor-reg immediate unsigned-immediate)
+	 (type :scs (any-reg descriptor-reg immediate)
 	       :target temp))
   (:results (res :scs (any-reg descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 2
     (sc-case type
-      ((immediate unsigned-immediate)
-       (inst sll temp val vm:type-bits)
+      ((immediate)
+       (inst sll temp val type-bits)
        (inst or res temp (tn-value type)))
       (t
        (inst sra temp type 2)
-       (inst sll res val (- vm:type-bits 2))
+       (inst sll res val (- type-bits 2))
        (inst or res res temp)))))
 
 
@@ -234,10 +229,10 @@
   (:results (sap :scs (sap-reg)))
   (:result-types system-area-pointer)
   (:generator 10
-    (loadw ndescr code 0 vm:other-pointer-type)
-    (inst srl ndescr vm:type-bits)
-    (inst sll ndescr vm:word-shift)
-    (inst subu ndescr vm:other-pointer-type)
+    (loadw ndescr code 0 other-pointer-type)
+    (inst srl ndescr type-bits)
+    (inst sll ndescr word-shift)
+    (inst subu ndescr other-pointer-type)
     (inst addu sap code ndescr)))
 
 (define-vop (compute-function)
@@ -247,11 +242,11 @@
   (:results (func :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) ndescr)
   (:generator 10
-    (loadw ndescr code 0 vm:other-pointer-type)
-    (inst srl ndescr vm:type-bits)
-    (inst sll ndescr vm:word-shift)
+    (loadw ndescr code 0 other-pointer-type)
+    (inst srl ndescr type-bits)
+    (inst sll ndescr word-shift)
     (inst addu ndescr offset)
-    (inst addu ndescr (- vm:function-pointer-type vm:other-pointer-type))
+    (inst addu ndescr (- function-pointer-type other-pointer-type))
     (inst addu func code ndescr)))
 
 
@@ -263,12 +258,12 @@
   (:policy :fast-safe)
   (:translate unix::do-pending-interrupt)
   (:generator 1
-    (inst break vm:pending-interrupt-trap)))
+    (inst break pending-interrupt-trap)))
 
 
 (define-vop (halt)
   (:generator 1
-    (inst break vm:halt-trap)))
+    (inst break halt-trap)))
 
 
 ;;;; Dynamic vop count collection support
diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp
index a55cc50de2674fc64237a097e2fca97e1ff53a31..272baefa2426cab5fee82fc2b96f4793418d8e64 100644
--- a/compiler/mips/type-vops.lisp
+++ b/compiler/mips/type-vops.lisp
@@ -7,278 +7,393 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.33 1992/03/11 21:26:52 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.34 1992/07/28 20:37:57 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;; This file contains the VM definition of type testing and checking VOPs
-;;; for the RT.
+;;; for the MIPS.
 ;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted for the MIPS R2000 by Christopher Hoover.
+;;; Written by William Lott
+;;; Earlier versions by Rob MacLachlan and Christopher Hoover.
 ;;;
 (in-package "MIPS")
 
-
-;;;; Simple type checking and testing:
-;;;
-;;;    These types are represented by a single type code, so are easily
-;;; open-coded as non-shifting type test.
-
-(define-vop (check-simple-type)
-  (:args
-   (value :target result
-	  :scs (any-reg descriptor-reg)))
-  (:results
-   (result :scs (any-reg descriptor-reg)))
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-(define-vop (simple-type-predicate)
-  (:args
-   (value :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:variant-vars type-code)
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (test-simple-type value temp target not-p type-code)))
-
-(macrolet ((frob (pred-name check-name ptype type-code error-code)
-	     (let ((cost (if (< (eval type-code) vm:lowtag-limit) 4 9)))
-	       `(progn
-		  (define-vop (,pred-name simple-type-predicate)
-		    (:variant ,type-code)
-		    (:variant-cost ,cost)
-		    (:translate ,pred-name))
-		  (define-vop (,check-name check-simple-type)
-		    (:generator ,cost
-		      (let ((err-lab
-			     (generate-error-code vop ,error-code value)))
-			(test-simple-type value temp err-lab t ,type-code)
-			(move result value))))
-		  (primitive-type-vop ,check-name (:check) ,ptype)))))
-
-  (frob functionp check-function function
-    vm:function-pointer-type object-not-function-error)
-
-  (frob listp check-list list
-    vm:list-pointer-type object-not-list-error)
-
-  (frob structurep check-structure structure
-    vm:structure-pointer-type object-not-structure-error)
-
-  (frob bignump check-bigunm bignum
-    vm:bignum-type object-not-bignum-error)
 
-  (frob ratiop check-ratio ratio
-    vm:ratio-type object-not-ratio-error)
-
-  (frob complexp check-complex complex
-    vm:complex-type object-not-complex-error)
-
-  (frob single-float-p check-single-float single-float
-    vm:single-float-type object-not-single-float-error)
+
+;;;; Test generation utilities.
+
+(eval-when (compile eval)
+
+(defparameter immediate-types
+  (list unbound-marker-type base-char-type))
+
+(defparameter function-header-types
+  (list funcallable-instance-header-type closure-header-type
+	byte-code-function-type byte-code-closure-type
+	function-header-type closure-function-header-type))
+
+(defun canonicalize-headers (headers)
+  (collect ((results))
+    (let ((start nil)
+	  (prev nil)
+	  (delta (- other-immediate-1-type other-immediate-0-type)))
+      (flet ((emit-test ()
+	       (results (if (= start prev)
+			    start
+			    (cons start prev)))))
+	(dolist (header (sort headers #'<))
+	  (cond ((null start)
+		 (setf start header)
+		 (setf prev header))
+		((= header (+ prev delta))
+		 (setf prev header))
+		(t
+		 (emit-test)
+		 (setf start header)
+		 (setf prev header))))
+	(emit-test)))
+    (results)))
+
+(defmacro test-type (value temp target not-p &rest type-codes)
+  ;; Determine what interesting combinations we need to test for.
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (fixnump (and (member even-fixnum-type type-codes)
+		       (member odd-fixnum-type type-codes)
+		       t))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended immediate-types :test #'eql))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p (if (intersection headers function-header-types)
+			 (if (subsetp headers function-header-types)
+			     t
+			     (error "Can't test for mix of function subtypes ~
+				     and normal header types."))
+			 nil)))
+    (unless type-codes
+      (error "Must supply at least on type for test-type."))
+    (cond
+     (fixnump
+      (when (remove-if #'(lambda (x)
+			   (or (= x even-fixnum-type)
+			       (= x odd-fixnum-type)))
+		       lowtags)
+	(error "Can't mix fixnum testing with other lowtags."))
+      (when function-p
+	(error "Can't mix fixnum testing with function subtype testing."))
+      (when immediates
+	(error "Can't mix fixnum testing with other immediates."))
+      (if headers
+	  `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
+				     ',(canonicalize-headers headers))
+	  `(%test-fixnum ,value ,temp ,target ,not-p)))
+     (immediates
+      (when headers
+	(error "Can't mix testing of immediates with testing of headers."))
+      (when lowtags
+	(error "Can't mix testing of immediates with testing of lowtags."))
+      (when (cdr immediates)
+	(error "Can't test multiple immediates at the same time."))
+      `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
+     (lowtags
+      (when (cdr lowtags)
+	(error "Can't test multiple lowtags at the same time."))
+      (if headers
+	  `(%test-lowtag-and-headers
+	    ,value ,temp ,target ,not-p ,(car lowtags)
+	    ,function-p ',(canonicalize-headers headers))
+	  `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
+     (headers
+      `(%test-headers ,value ,temp ,target ,not-p ,function-p
+		      ',(canonicalize-headers headers)))
+     (t
+      (error "Nothing to test?")))))
+
+); eval-when (compile eval)
+
+(defun %test-fixnum (value temp target not-p)
+  (assemble ()
+    (inst and temp value 3)
+    (if not-p
+	(inst bne temp zero-tn target)
+	(inst beq temp zero-tn target))
+    (inst nop)))
 
-  (frob double-float-p check-double-float double-float
-    vm:double-float-type object-not-double-float-error)
+(defun %test-fixnum-and-headers (value temp target not-p headers)
+  (let ((drop-through (gen-label)))
+    (assemble ()
+      (inst and temp value 3)
+      (inst beq temp zero-tn (if not-p drop-through target)))
+    (%test-headers value temp target not-p nil headers drop-through)))
+
+(defun %test-immediate (value temp target not-p immediate)
+  (assemble ()
+    (inst and temp value 255)
+    (inst xor temp immediate)
+    (if not-p
+	(inst bne temp zero-tn target)
+	(inst beq temp zero-tn target))
+    (inst nop)))
 
-  (frob simple-string-p check-simple-string simple-string
-    vm:simple-string-type object-not-simple-string-error)
+(defun %test-lowtag (value temp target not-p lowtag &optional skip-nop)
+  (assemble ()
+    (inst and temp value lowtag-mask)
+    (inst xor temp lowtag)
+    (if not-p
+	(inst bne temp zero-tn target)
+	(inst beq temp zero-tn target))
+    (unless skip-nop
+      (inst nop))))
+
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+				       function-p headers)
+  (let ((drop-through (gen-label)))
+    (%test-lowtag value temp (if not-p drop-through target) nil lowtag t)
+    (%test-headers value temp target not-p function-p headers drop-through)))
+
+(defun %test-headers (value temp target not-p function-p headers
+			    &optional (drop-through (gen-label)))
+  (let ((lowtag (if function-p function-header-type other-pointer-type)))
+    (multiple-value-bind
+	(when-true when-false)
+	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
+	;; we know it's true and when we know it's false respectively.
+	(if not-p
+	    (values drop-through target)
+	    (values target drop-through))
+      (assemble ()
+	(%test-lowtag value temp when-false t lowtag)
+	(load-type temp value (- lowtag))
+	(inst nop)
+	(let ((delta 0))
+	  (do ((remaining headers (cdr remaining)))
+	      ((null remaining))
+	    (let ((header (car remaining))
+		  (last (null (cdr remaining))))
+	      (cond
+	       ((atom header)
+		(inst subu temp (- header delta))
+		(setf delta header)
+		(if last
+		    (if not-p
+			(inst bne temp zero-tn target)
+			(inst beq temp zero-tn target))
+		    (inst beq temp zero-tn when-true)))
+	       (t
+		(let ((start (car header))
+		      (end (cdr header)))
+		  (unless (= start bignum-type)
+		    (inst subu temp (- start delta))
+		    (setf delta start)
+		    (inst bltz temp when-false))
+		  (inst subu temp (- end delta))
+		  (setf delta end)
+		  (if last
+		      (if not-p
+			  (inst bgtz temp target)
+			  (inst blez temp target))
+		      (inst blez temp when-true))))))))
+	(inst nop)
+	(emit-label drop-through)))))
 
-  (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-    vm:simple-bit-vector-type object-not-simple-bit-vector-error)
 
-  (frob simple-vector-p check-simple-vector simple-vector
-    vm:simple-vector-type object-not-simple-vector-error)
+
+;;;; Type checking and testing:
 
-  (frob simple-array-unsigned-byte-2-p check-simple-array-unsigned-byte-2
-    simple-array-unsigned-byte-2 vm:simple-array-unsigned-byte-2-type
-    object-not-simple-array-unsigned-byte-2-error)
+(define-vop (check-type)
+  (:args (value :target result :scs (any-reg descriptor-reg)))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
+  (:vop-var vop)
+  (:save-p :compute-only))
 
-  (frob simple-array-unsigned-byte-4-p check-simple-array-unsigned-byte-4
-    simple-array-unsigned-byte-4 vm:simple-array-unsigned-byte-4-type
-    object-not-simple-array-unsigned-byte-4-error)
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe))
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+				   &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value temp target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value temp err-lab t ,@type-codes)
+		   (move result value))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
 
-  (frob simple-array-unsigned-byte-8-p check-simple-array-unsigned-byte-8
-    simple-array-unsigned-byte-8 vm:simple-array-unsigned-byte-8-type
-    object-not-simple-array-unsigned-byte-8-error)
+); eval-when (compile eval)
 
-  (frob simple-array-unsigned-byte-16-p check-simple-array-unsigned-byte-16
-    simple-array-unsigned-byte-16 vm:simple-array-unsigned-byte-16-type
-    object-not-simple-array-unsigned-byte-16-error)
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+  even-fixnum-type odd-fixnum-type)
 
-  (frob simple-array-unsigned-byte-32-p check-simple-array-unsigned-byte-32
-    simple-array-unsigned-byte-32 vm:simple-array-unsigned-byte-32-type
-    object-not-simple-array-unsigned-byte-32-error)
+(def-type-vops functionp check-function function
+  object-not-function-error function-pointer-type)
 
-  (frob simple-array-single-float-p check-simple-array-single-float
-    simple-array-single-float vm:simple-array-single-float-type
-    object-not-simple-array-single-float-error)
+(def-type-vops listp check-list list object-not-list-error
+  list-pointer-type)
 
-  (frob simple-array-double-float-p check-simple-array-double-float
-    simple-array-double-float vm:simple-array-double-float-type
-    object-not-simple-array-double-float-error)
+(def-type-vops structurep check-structure structure object-not-structure-error
+  structure-pointer-type)
 
-  (frob base-char-p check-base-char base-char
-    vm:base-char-type object-not-base-char-error)
+(def-type-vops bignump check-bigunm bignum
+  object-not-bignum-error bignum-type)
 
-  (frob system-area-pointer-p check-system-area-pointer system-area-pointer
-    vm:sap-type object-not-sap-error)
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error ratio-type)
 
-  (frob weak-pointer-p check-weak-pointer weak-pointer
-    vm:weak-pointer-type object-not-weak-pointer-error))
+(def-type-vops complexp check-complex complex
+  object-not-complex-error complex-type)
 
-(define-vop (funcallable-instance-p simple-type-predicate)
-  (:translate funcallable-instance-p)
-  (:variant-vars)
-  (:generator 4
-    (test-simple-type value temp target not-p
-		      vm:funcallable-instance-header-type
-		      :lowtag vm:function-pointer-type)))
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+  check-simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-2
+  object-not-simple-array-unsigned-byte-2-error
+  simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+  check-simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-4
+  object-not-simple-array-unsigned-byte-4-error
+  simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+  check-simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-8
+  object-not-simple-array-unsigned-byte-8-error
+  simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+  check-simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-16
+  object-not-simple-array-unsigned-byte-16-error
+  simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+  check-simple-array-unsigned-byte-32
+  simple-array-unsigned-byte-32
+  object-not-simple-array-unsigned-byte-32-error
+  simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+  simple-array-single-float object-not-simple-array-single-float-error
+  simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+  simple-array-double-float object-not-simple-array-double-float-error
+  simple-array-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  0)
+
+(def-type-vops code-component-p nil nil nil
+  code-header-type)
 
-(define-vop (code-component-p simple-type-predicate)
-  (:variant code-header-type)
-  (:variant-cost 9)
-  (:translate code-component-p))
+(def-type-vops lra-p nil nil nil
+  return-pc-header-type)
 
-(define-vop (lra-p simple-type-predicate)
-  (:variant return-pc-header-type)
-  (:variant-cost 9)
-  (:translate lra-p))
+(def-type-vops fdefn-p nil nil nil
+  fdefn-type)
 
-(define-vop (fdefn-p simple-type-predicate)
-  (:variant fdefn-type)
-  (:variant-cost 9)
-  (:translate fdefn-p))
+(def-type-vops funcallable-instance-p nil nil nil
+  funcallable-instance-header-type)
 
-(define-vop (scavenger-hook-p simple-type-predicate)
-  (:variant 0)
-  (:variant-cost 9)
-  (:translate scavenger-hook-p))
+(def-type-vops array-header-p nil nil nil
+  simple-array-type complex-string-type complex-bit-vector-type
+  complex-vector-type complex-array-type)
 
+(def-type-vops nil check-function-or-symbol nil
+  object-not-function-or-symbol-error
+  function-pointer-type symbol-header-type)
 
+(def-type-vops stringp check-string nil object-not-string-error
+  simple-string-type complex-string-type)
 
-;;; Slightly tenser versions for FIXNUM's
-;;; 
-(define-vop (check-fixnum check-simple-type)
-  (:generator 3
-    (let ((err-lab (generate-error-code vop object-not-fixnum-error value)))
-      (inst and temp value #x3)
-      (inst bne temp zero-tn err-lab)
-      (move result value t))))
-
-(primitive-type-vop check-fixnum (:check) fixnum)
-
-(define-vop (fixnump simple-type-predicate)
-  (:ignore type-code)
-  (:translate ext:fixnump)
-  (:generator 3
-    (inst and temp value #x3)
-    (if not-p
-	(inst bne temp zero-tn target)
-	(inst beq temp zero-tn target))
-    (inst nop)))
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  simple-bit-vector-type complex-bit-vector-type)
 
-
-;;;; Hairy type tests:
-;;;
-;;;    These types are represented by a union of type codes.  
-;;;
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  simple-string-type simple-bit-vector-type simple-vector-type
+  simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+  simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+  simple-array-unsigned-byte-32-type simple-array-single-float-type
+  simple-array-double-float-type complex-string-type
+  complex-bit-vector-type complex-vector-type)
 
-(define-vop (hairy-type-predicate)
-  (:args
-   (obj :scs (any-reg descriptor-reg)
-	:target temp))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:type random :scs (non-descriptor-reg)) temp))
-
-(define-vop (check-hairy-type)
-  (:args
-   (obj :scs (any-reg descriptor-reg)
-	:target res))
-  (:results
-   (res :scs (any-reg descriptor-reg)))
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only))
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type)
 
-(macrolet ((frob (pred-name check-name error-code &rest types)
-	     (let ((cost (* (+ (length types)
-			       (count-if #'consp types))
-			    4)))
-	       `(progn
-		  ,@(when pred-name
-		      `((define-vop (,pred-name hairy-type-predicate)
-			  (:translate ,pred-name)
-			  (:generator ,cost
-			    (test-hairy-type obj temp target not-p ,@types)))))
-			
-		  ,@(when check-name
-		      `((define-vop (,check-name check-hairy-type)
-			  (:generator ,cost
-			    (let ((err-lab (generate-error-code vop
-								,error-code
-								obj)))
-			      (test-hairy-type obj temp err-lab t ,@types))
-			    (move res obj)))))))))
-
-  (frob array-header-p nil nil
-    vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
-    vm:complex-vector-type vm:complex-array-type)
-
-  (frob stringp check-string object-not-string-error
-    vm:simple-string-type vm:complex-string-type)
-
-  (frob bit-vector-p check-bit-vector object-not-bit-vector-error
-    vm:simple-bit-vector-type vm:complex-bit-vector-type)
-
-  (frob vectorp check-vector object-not-vector-error
-    vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
-    vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
-    vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
-    vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
-    vm:simple-array-double-float-type vm:complex-string-type
-    vm:complex-bit-vector-type vm:complex-vector-type)
-
-  (frob simple-array-p check-simple-array object-not-simple-array-error
-    vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
-    vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
-    vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
-    vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
-    vm:simple-array-single-float-type vm:simple-array-double-float-type)
-
-  (frob arrayp check-array object-not-array-error
-    vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
-    vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
-    vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
-    vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
-    vm:simple-array-single-float-type vm:simple-array-double-float-type
-    vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
-    vm:complex-array-type)
-    
-  (frob numberp check-number object-not-number-error
-    vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
-    vm:single-float-type vm:double-float-type vm:complex-type)
-
-  (frob rationalp check-rational object-not-rational-error
-    vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
-
-  (frob floatp check-float object-not-float-error
-    vm:single-float-type vm:double-float-type)
-
-  (frob realp check-real object-not-real-error
-    vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
-    vm:single-float-type vm:double-float-type)
-  
-  ;; ### May want to make this more tense.
-  (frob integerp check-integer object-not-integer-error
-    vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type))
+(def-type-vops arrayp check-array nil object-not-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type
+  complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  even-fixnum-type odd-fixnum-type bignum-type ratio-type
+  single-float-type double-float-type complex-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  single-float-type double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type
+  single-float-type double-float-type)
 
 
 ;;;; Other integer ranges.
@@ -286,146 +401,101 @@
 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 ;;; exactly one digit.
 
-(define-vop (signed-byte-32-p hairy-type-predicate)
-  (:translate signed-byte-32-p)
-  (:generator 45
-    (let ((not-target (gen-label)))
-      (multiple-value-bind
-	  (yep nope)
-	  (if not-p
-	      (values not-target target)
-	      (values target not-target))
-	(inst and temp obj #x3)
-	(inst beq temp zero-tn yep)
-	(test-simple-type obj temp nope t vm:bignum-type)
-	(loadw temp obj 0 vm:other-pointer-type)
-	(inst srl temp temp (1+ vm:type-bits))
-	(if not-p
-	    (inst bne temp zero-tn target)
-	    (inst beq temp zero-tn target))
-	(inst nop)
-	(emit-label not-target)))))
-
-(define-vop (check-signed-byte-32 check-hairy-type)
-  (:generator 45
-    (let ((nope (generate-error-code vop object-not-signed-byte-32-error obj))
-	  (yep (gen-label)))
-      (inst and temp obj #x3)
+(defun signed-byte-32-test (value temp not-p target not-target)
+  (multiple-value-bind
+      (yep nope)
+      (if not-p
+	  (values not-target target)
+	  (values target not-target))
+    (assemble ()
+      (inst and temp value 3)
       (inst beq temp zero-tn yep)
-      (test-simple-type obj temp nope t vm:bignum-type)
-      (loadw temp obj 0 vm:other-pointer-type)
-      (inst srl temp temp (1+ vm:type-bits))
+      (inst and temp value lowtag-mask)
+      (inst xor temp other-pointer-type)
       (inst bne temp zero-tn nope)
       (inst nop)
-      (emit-label yep)
-      (move res obj))))
+      (loadw temp value 0 other-pointer-type)
+      (inst xor temp (+ (ash 1 type-bits) bignum-type))
+      (if not-p
+	  (inst bne temp zero-tn target)
+	  (inst beq temp zero-tn target))
+      (inst nop)))
+  (undefined-value))
+
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:generator 45
+    (signed-byte-32-test value temp not-p target not-target)
+    NOT-TARGET))
 
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((loose (generate-error-code vop object-not-signed-byte-32-error
+				      value)))
+      (signed-byte-32-test value temp t loose okay))
+    OKAY
+    (move result value)))
 
 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 ;;; and the second digit all zeros.
 
-(define-vop (unsigned-byte-32-p hairy-type-predicate)
-  (:translate unsigned-byte-32-p)
-  (:generator 45
-    (let ((not-target (gen-label))
-	  (single-word (gen-label))
-	  (fixnum (gen-label)))
-      (multiple-value-bind
-	  (yep nope)
-	  (if not-p
-	      (values not-target target)
-	      (values target not-target))
-	;; Is it a fixnum?
-	(inst and temp obj #x3)
-	(inst beq temp zero-tn fixnum)
-	;; If not, is it a bignum?
-	(test-simple-type obj temp nope t vm:bignum-type)
-	;; Get the number of digits.
-	(loadw temp obj 0 vm:other-pointer-type)
-	(inst srl temp temp vm:type-bits)
-	;; Is it one?
-	(inst addu temp -1)
-	(inst beq temp single-word)
-	;; If it's other than two, we can't be an (unsigned-byte 32)
-	(inst addu temp -1)
-	(inst bne temp nope)
-	;; Get the second digit.
-	(loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type)
-	;; All zeros, its an (unsigned-byte 32).
-	(inst beq temp yep)
-	(inst nop)
-	;; Otherwise, it isn't.
-	(inst b nope)
-	(inst nop)
-	
-	(emit-label single-word)
-	;; Get the single digit.
-	(loadw temp obj vm:bignum-digits-offset vm:other-pointer-type)
-	;; positive implies (unsigned-byte 32).
-	(inst bgez temp yep)
-	(inst nop)
-	;; Otherwise, nope.
-	(inst b nope)
-	(inst nop)
-
-	(emit-label fixnum)
-	;; positive fixnums are (unsigned-byte 32).
-	(if not-p
-	    (inst bltz obj target)
-	    (inst bgez obj target))
-	(inst nop)
-
-	(emit-label not-target)))))	  
-
-(define-vop (check-unsigned-byte-32 check-hairy-type)
-  (:generator 45
-    (let ((nope
-	   (generate-error-code vop object-not-unsigned-byte-32-error obj))
-	  (yep (gen-label))
-	  (fixnum (gen-label))
-	  (single-word (gen-label)))
+(defun unsigned-byte-32-test (value temp not-p target not-target)
+  (let ((nope (if not-p target not-target)))
+    (assemble ()
       ;; Is it a fixnum?
-      (inst and temp obj #x3)
+      (inst and temp value 3)
       (inst beq temp zero-tn fixnum)
-      ;; If not, is it a bignum?
-      (test-simple-type obj temp nope t vm:bignum-type)
-      ;; Get the number of digits.
-      (loadw temp obj 0 vm:other-pointer-type)
-      (inst srl temp temp vm:type-bits)
+      (inst move temp value)
+
+      ;; If not, is it an other pointer?
+      (inst and temp value lowtag-mask)
+      (inst xor temp other-pointer-type)
+      (inst bne temp zero-tn nope)
+      (inst nop)
+      ;; Get the header.
+      (loadw temp value 0 other-pointer-type)
       ;; Is it one?
-      (inst addu temp -1)
-      (inst beq temp single-word)
+      (inst xor temp (+ (ash 1 type-bits) bignum-type))
+      (inst beq temp zero-tn single-word)
+      (inst nop)
       ;; If it's other than two, we can't be an (unsigned-byte 32)
-      (inst addu temp -1)
-      (inst bne temp nope)
+      (inst xor temp (logxor (+ (ash 1 type-bits) bignum-type)
+			     (+ (ash 2 type-bits) bignum-type)))
+      (inst bne temp zero-tn nope)
       ;; Get the second digit.
-      (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+      (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
       ;; All zeros, its an (unsigned-byte 32).
-      (inst beq temp yep)
+      (if not-p
+	  (inst beq temp zero-tn target)
+	  (inst bne temp zero-tn target))
       (inst nop)
-      ;; Otherwise, it isn't.
-      (inst b nope)
-      (inst nop)
-      
-      (emit-label single-word)
+	
+      SINGLE-WORD
       ;; Get the single digit.
-      (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type)
+      (loadw temp value bignum-digits-offset other-pointer-type)
+
       ;; positive implies (unsigned-byte 32).
-      (inst bgez temp yep)
-      (inst nop)
-      ;; Otherwise, nope.
-      (inst b nope)
-      (inst nop)
-      
-      (emit-label fixnum)
-      ;; positive fixnums are (unsigned-byte 32).
-      (inst bltz obj nope)
-      (inst nop)
-      
-      (emit-label yep)
-      (move res obj))))
+      FIXNUM
+      (if not-p
+	  (inst bltz temp target)
+	  (inst bgez temp target))
+      (inst nop)))
+  (undefined-value))
+
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:generator 45
+    (unsigned-byte-32-test value temp not-p target not-target)
+    NOT-TARGET))
 
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
+				      value)))
+      (unsigned-byte-32-test value temp t loose okay))
+    OKAY
+    (move result value)))
 
 
 
@@ -434,44 +504,31 @@
 ;;; symbolp (or symbol (eq nil))
 ;;; consp (and list (not (eq nil)))
 
-(define-vop (list-symbol-predicate)
-  (:args
-   (obj :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)))
-
-(define-vop (check-list-symbol check-hairy-type)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
-
-
-(macrolet ((frob (pred-name check-name error-code &rest body)
-	     `(progn
-		(define-vop (,pred-name list-symbol-predicate)
-		  (:translate ,pred-name)
-		  (:generator 8
-		    ,@body))
-		(define-vop (,check-name check-list-symbol)
-		  (:generator 8
-		    (let ((target (generate-error-code vop ,error-code obj))
-			  (not-p t))
-		      ,@body
-		      (move res obj)))))))
-
-  (frob symbolp check-symbol object-not-symbol-error
-    (let* ((drop-thru (gen-label))
-	   (is-symbol-label (if not-p drop-thru target)))
-      (inst beq obj null-tn is-symbol-label)
-      (inst nop)
-      (test-simple-type obj temp target not-p vm:symbol-header-type)
-      (emit-label drop-thru)))
-
-  (frob consp check-cons object-not-cons-error
-    (let* ((drop-thru (gen-label))
-	   (is-not-cons-label (if not-p target drop-thru)))
-      (inst beq obj null-tn is-not-cons-label)
-      (inst nop)
-      (test-simple-type obj temp target not-p vm:list-pointer-type)
-      (emit-label drop-thru))))
-
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (inst beq value null-tn (if not-p drop-thru target))
+    (test-type value temp target not-p symbol-header-type)
+    DROP-THRU))
+
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (inst beq value null-tn drop-thru)
+    (let ((error (generate-error-code vop object-not-symbol-error value)))
+      (test-type value temp error t symbol-header-type))
+    DROP-THRU
+    (move result value)))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (inst beq value null-tn (if not-p target drop-thru))
+    (test-type value temp target not-p list-pointer-type)
+    DROP-THRU))
+
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst beq value null-tn error)
+      (test-type value temp error t list-pointer-type))
+    (move result value)))
diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp
index 4c14ec45c9c4f44c265d97321b92a92d6b7207d0..4e16808ebeb996886dc5cadd7cd3840b07190df2 100644
--- a/compiler/mips/values.lisp
+++ b/compiler/mips/values.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: C; Log: C.Log -*-
+;;; -*- Package: MIPS -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.12 1991/02/20 15:15:29 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.13 1992/07/28 20:38:01 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.12 1991/02/20 15:15:29 ram Exp $
-;;;
 ;;;    This file contains the implementation of unknown-values VOPs.
 ;;;
 ;;; Written by Rob MacLachlan
@@ -50,7 +48,7 @@
 	      start-temp)
   (:generator 20
     (move start-temp csp-tn)
-    (inst addu csp-tn csp-tn (* nvals vm:word-bytes))
+    (inst addu csp-tn csp-tn (* nvals word-bytes))
     (do ((val vals (tn-ref-across val))
 	 (i 0 (1+ i)))
 	((null val))
@@ -76,25 +74,25 @@
 	    (count :scs (any-reg)))
   (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
   (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 0
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      (move list arg)
-      (move start csp-tn)
-
-      (emit-label loop)
-      (inst beq list null-tn done)
-      (loadw temp list vm:cons-car-slot vm:list-pointer-type)
-      (loadw list list vm:cons-cdr-slot vm:list-pointer-type)
-      (inst addu csp-tn csp-tn vm:word-bytes)
-      (storew temp csp-tn -1)
-      (test-simple-type list ndescr loop nil vm:list-pointer-type)
-      (error-call vop bogus-argument-to-values-list-error list)
-
-      (emit-label done)
-      (inst subu count csp-tn start))))
+    (move list arg)
+    (move start csp-tn)
+    
+    LOOP
+    (inst beq list null-tn done)
+    (loadw temp list cons-car-slot list-pointer-type)
+    (loadw list list cons-cdr-slot list-pointer-type)
+    (inst addu csp-tn csp-tn word-bytes)
+    (storew temp csp-tn -1)
+    (inst and ndescr list lowtag-mask)
+    (inst xor ndescr list-pointer-type)
+    (inst beq ndescr zero-tn loop)
+    (inst nop)
+    (error-call vop bogus-argument-to-values-list-error list)
+    
+    DONE
+    (inst subu count csp-tn start)))
 
diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp
index 9d62a129cff62599d60231e8c1b251abdedec0e0..ca895258dc63645d274423234853f4ade5db3e5e 100644
--- a/compiler/mips/vm.lisp
+++ b/compiler/mips/vm.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: MIPS; Log: C.Log -*-
+;;; -*- Package: MIPS -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.45 1992/05/21 02:10:32 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.46 1992/07/28 20:38:03 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.45 1992/05/21 02:10:32 wlott Exp $
-;;;
 ;;; This file contains the VM definition for the MIPS R2000 and the new
 ;;; object format.
 ;;;
@@ -27,9 +25,8 @@
 
 (defmacro defreg (name offset)
   (let ((offset-sym (symbolicate name "-OFFSET")))
-    `(progn
-       (eval-when (compile eval load)
-	 (defconstant ,offset-sym ,offset))
+    `(eval-when (compile eval load)
+       (defconstant ,offset-sym ,offset)
        (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
 
 (defmacro defregset (name &rest regs)
@@ -39,12 +36,16 @@
 
 )
 
+(eval-when (compile eval load)
+
 (defvar *register-names* (make-array 32 :initial-element nil))
 
+); eval-when
+
 (defreg zero 0)
 (defreg nl3 1)
-(defreg nl4 2)
-(defreg flags 3)
+(defreg cfunc 2)
+(defreg nl4 3)
 (defreg nl0 4) ; First C argument reg.
 (defreg nl1 5)
 (defreg nl2 6)
@@ -55,41 +56,37 @@
 (defreg a3 11)
 (defreg a4 12)
 (defreg a5 13)
-(defreg cname 14)
+(defreg fdefn 14)
 (defreg lexenv 15)
+;; First saved reg
 (defreg nfp 16)
 (defreg ocfp 17)
-(eval-when (compile load eval)
-  (defconstant old-fp-offset 17)) ; for backwards compatibility
 (defreg lra 18)
 (defreg l0 19)
 (defreg null 20)
 (defreg bsp 21)
 (defreg cfp 22)
-(eval-when (compile load eval)
-  (defconstant fp-offset 22)) ; for backwards compatibility
 (defreg csp 23)
 (defreg l1 24)
 (defreg alloc 25)
-(defreg l2 28)
 (defreg nsp 29)
 (defreg code 30)
 (defreg lip 31)
 
 (defregset non-descriptor-regs
-  nl0 nl1 nl2 nl3 nl4 nargs)
+  nl0 nl1 nl2 nl3 nl4 cfunc nargs)
 
 (defregset descriptor-regs
-  a0 a1 a2 a3 a4 a5 cname lexenv nfp ocfp lra l0 l1 l2)
+  a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp lra l0 l1)
 
 (defregset register-arg-offsets
   a0 a1 a2 a3 a4 a5)
 
 (defregset reserve-descriptor-regs
-  cname lexenv)
+  fdefn lexenv)
 
 (defregset reserve-non-descriptor-regs
-  nl3 nl4)
+  nl4 cfunc)
 
 
 ;;;; SB and SC definition:
@@ -124,41 +121,13 @@
 
 (define-storage-classes
 
-  ;; Non-immediate contstants in the constant pool
+  ;; Non-immediate constants in the constant pool
   (constant constant)
 
-
-  ;; Immediate numeric constants.
-  ;; 
-  ;;   zero = (integer 0 0)
-  ;; 
-  ;;   negative-immediate = (integer #x-1FFF #-x0001)
-  ;;        The funny lower bound guarantees that the negation of an immediate
-  ;;        is still an immediate.
-  ;; 
-  ;;   immediate = (integer 0 #x1FFE)
-  ;;	   The funny upper bound guarantees that (1+ immediate) will fit in
-  ;;        16 bits.
-  ;; 
-  ;;   unsigned-immediate = (integer #x1FFF #x3FFE)
-  ;;	   The funny upper bound guarantees that (1+ immediate) will fit in
-  ;;        16 bits.
-  ;;
+  ;; Immediate constant.
+  (null immediate-constant)
   (zero immediate-constant)
-  (negative-immediate immediate-constant)
   (immediate immediate-constant)
-  (unsigned-immediate immediate-constant)
-
-  ;; Immediate SCs for things other than numbers. 
-  (null immediate-constant)
-  (immediate-base-char immediate-constant)
-  (immediate-sap immediate-constant)
-
-  ;; Anything else that can be computed faster than loaded that doesn't fit in
-  ;; any of the above immediate SCs.
-  (random-immediate immediate-constant)
-
-
 
   ;; **** The stacks.
 
@@ -174,7 +143,6 @@
   (double-stack non-descriptor-stack :element-size 2) ; double floats.
 
 
-
   ;; **** Things that can go in the integer registers.
 
   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
@@ -184,8 +152,7 @@
    :locations #.(append non-descriptor-regs descriptor-regs)
    :reserve-locations #.(append reserve-non-descriptor-regs
 				reserve-descriptor-regs)
-   :constant-scs (negative-immediate zero immediate unsigned-immediate
-			   immediate-base-char random-immediate)
+   :constant-scs (constant zero immediate)
    :save-p t
    :alternate-scs (control-stack))
 
@@ -193,7 +160,7 @@
   (descriptor-reg registers
    :locations #.descriptor-regs
    :reserve-locations #.reserve-descriptor-regs
-   :constant-scs (constant null random-immediate)
+   :constant-scs (constant null immediate)
    :save-p t
    :alternate-scs (control-stack))
 
@@ -201,7 +168,7 @@
   (base-char-reg registers
    :locations #.non-descriptor-regs
    :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (immediate-base-char)
+   :constant-scs (immediate)
    :save-p t
    :alternate-scs (base-char-stack))
 
@@ -209,7 +176,7 @@
   (sap-reg registers
    :locations #.non-descriptor-regs
    :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (immediate-sap)
+   :constant-scs (immediate)
    :save-p t
    :alternate-scs (sap-stack))
 
@@ -217,14 +184,13 @@
   (signed-reg registers
    :locations #.non-descriptor-regs
    :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (negative-immediate zero immediate unsigned-immediate
-				     random-immediate)
+   :constant-scs (zero immediate)
    :save-p t
    :alternate-scs (signed-stack))
   (unsigned-reg registers
    :locations #.non-descriptor-regs
    :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (zero immediate unsigned-immediate random-immediate)
+   :constant-scs (zero immediate)
    :save-p t
    :alternate-scs (unsigned-stack))
 
@@ -280,20 +246,17 @@
 (defregtn zero any-reg)
 (defregtn lip interior-reg)
 (defregtn code descriptor-reg)
-(defregtn flags non-descriptor-reg)
 (defregtn alloc any-reg)
 (defregtn null descriptor-reg)
 
 (defregtn nargs any-reg)
-(defregtn cname descriptor-reg)
+(defregtn fdefn descriptor-reg)
 (defregtn lexenv descriptor-reg)
 
 (defregtn bsp any-reg)
 (defregtn csp any-reg)
 (defregtn cfp any-reg)
 (defregtn ocfp any-reg)
-(defregtn fp any-reg) ; for backwards compatibility
-(defregtn old-fp any-reg) ; for backwards compatibility
 (defregtn nsp any-reg)
 (defregtn nfp any-reg)
 
@@ -311,29 +274,16 @@
      (sc-number-or-lose 'zero *backend*))
     (null
      (sc-number-or-lose 'null *backend*))
-    ((integer #x-1FFF #x-0001)
-     (sc-number-or-lose 'negative-immediate *backend*))
-    ((integer 0 #x1FFE)
-     (sc-number-or-lose 'immediate *backend*))
-    ((integer #x1FFF #x3FFE)
-     (sc-number-or-lose 'unsigned-immediate *backend*))
     (symbol
      (if (vm:static-symbol-p value)
-	 (sc-number-or-lose 'random-immediate *backend*)
+	 (sc-number-or-lose 'immediate *backend*)
 	 nil))
-    (#-new-compiler (signed-byte 30)
-     #+new-compiler fixnum
-     (sc-number-or-lose 'random-immediate *backend*))
-    #+new-compiler
+    ((signed-byte 30)
+     (sc-number-or-lose 'immediate *backend*))
     (system-area-pointer
-     (sc-number-or-lose 'immediate-sap *backend*))
+     (sc-number-or-lose 'immediate *backend*))
     (character
-     #-new-compiler
-     (if (string-char-p value)
-	 (sc-number-or-lose 'immediate-base-char *backend*)
-	 nil)
-     #+new-compiler
-     (sc-number-or-lose 'immediate-base-char *backend*))))
+     (sc-number-or-lose 'immediate *backend*))))
 
 
 ;;;; Function Call Parameters
@@ -348,7 +298,6 @@
 
 ;;; Offsets of special stack frame locations
 (defconstant ocfp-save-offset 0)
-(defconstant old-fp-save-offset 0) ; for backwards compatablility.
 (defconstant lra-save-offset 1)
 (defconstant nfp-save-offset 2)