diff --git a/compiler/rt/alloc.lisp b/compiler/rt/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..db33c1efbc143884e641ddc87e93bc82ce13338f
--- /dev/null
+++ b/compiler/rt/alloc.lisp
@@ -0,0 +1,135 @@
+;;; -*- Package: rt -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/alloc.lisp,v 1.1 1991/02/18 15:07:30 chiles Exp $
+;;;
+;;; Allocation VOPs for the IBM RT port.
+;;;
+;;; Written by William Lott.
+;;; Converted by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+  (:args (things :more t))
+  (:temporary (:scs (descriptor-reg) :type list) ptr)
+  (: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 (:scs (word-pointer-reg)) alloc)
+  (:info num)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:generator 0
+    (cond ((zerop num)
+	   (move result null-tn))
+	  ((and star (= num 1))
+	   (move result (tn-ref-tn things)))
+	  (t
+	   (macrolet
+	       ((store-car (tn list &optional (slot cons-car-slot))
+		  `(let ((reg
+			  (sc-case ,tn
+			    ((any-reg descriptor-reg) ,tn)
+			    (null null-tn)
+			    (control-stack
+			     (load-stack-tn temp ,tn)
+			     temp))))
+		     (storew reg ,list ,slot list-pointer-type))))
+	     (let ((cons-cells (if star (1- num) num)))
+	       (pseudo-atomic (ndescr)
+		 (load-symbol-value alloc *allocation-pointer*)
+		 (inst cal res alloc list-pointer-type)
+		 (inst cal alloc alloc (* (pad-data-block cons-size)
+					  cons-cells))
+		 (store-symbol-value alloc *allocation-pointer*)
+		 (move ptr res)
+		 (dotimes (i (1- cons-cells))
+		   (store-car (tn-ref-tn things) ptr)
+		   (setf things (tn-ref-across things))
+		   (inst cal ptr ptr (pad-data-block cons-size))
+		   (storew ptr ptr
+			   (- 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 cons-cdr-slot))
+		       (t
+			(storew null-tn ptr
+				cons-cdr-slot list-pointer-type)))
+		 (assert (null (tn-ref-across things)))
+		 (move result res))))))))
+
+(define-vop (list list-or-list*)
+  (:variant nil))
+
+(define-vop (list* list-or-list*)
+  (:variant t))
+
+
+
+;;;; Special purpose inline allocators.
+
+(define-vop (allocate-code-object)
+  (:args (boxed-arg :scs (any-reg))
+	 (unboxed-arg :scs (any-reg) :target unboxed))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:scs (word-pointer-reg)) alloc)
+  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
+  (:generator 100
+    (inst li ndescr (lognot lowtag-mask))
+    (inst cal boxed boxed-arg (fixnum (1+ code-constants-offset)))
+    (inst n boxed ndescr)
+    (move unboxed unboxed-arg)
+    (inst sr unboxed word-shift)
+    (inst a unboxed lowtag-mask)
+    (inst n unboxed ndescr)
+    (pseudo-atomic (ndescr)
+      (load-symbol-value alloc *allocation-pointer*)
+      (inst cal result alloc other-pointer-type)
+      (inst cas alloc boxed alloc)
+      (inst cas alloc unboxed alloc)
+      (store-symbol-value alloc *allocation-pointer*)
+      (move ndescr boxed)
+      (inst sl ndescr (- type-bits word-shift))
+      (inst o 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-symbol)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:temporary (:scs (sap-reg)) temp)
+  (:temporary (:scs (word-pointer-reg)) alloc)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:policy :fast-safe)
+  (:translate make-symbol)
+  (:generator 37
+    (with-fixed-allocation (result temp alloc symbol-header-type symbol-size)
+      (inst li temp unbound-marker-type)
+      (storew temp result symbol-value-slot other-pointer-type)
+      (storew temp result symbol-function-slot other-pointer-type)
+      (storew temp result symbol-setf-function-slot other-pointer-type)
+      (inst cai temp (make-fixup "undefined_tramp" :foreign))
+      (storew temp result symbol-raw-function-addr-slot
+	      other-pointer-type)
+      (storew null-tn result symbol-plist-slot other-pointer-type)
+      (storew name result symbol-name-slot other-pointer-type)
+      (storew null-tn result symbol-package-slot other-pointer-type))))
diff --git a/compiler/rt/arith.lisp b/compiler/rt/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..f6d6d9e37fad79acf0d7fce550b00da97ed67cd0
--- /dev/null
+++ b/compiler/rt/arith.lisp
@@ -0,0 +1,849 @@
+;;; -*- Package: C; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/arith.lisp,v 1.1 1991/02/18 15:07:33 chiles Exp $
+;;;
+;;; This file contains the VM definition arithmetic VOPs for the IBM RT.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Unary operations.
+
+(define-vop (fixnum-unop)
+  (:args (x :scs (any-reg)))
+  (:results (res :scs (any-reg)))
+  (:note "inline fixnum arithmetic")
+  (:arg-types tagged-num)
+  (:result-types tagged-num)
+  (:policy :fast-safe))
+
+(define-vop (signed-unop)
+  (:args (x :scs (signed-reg)))
+  (:results (res :scs (signed-reg)))
+  (:note "inline (signed-byte 32) arithmetic")
+  (:arg-types signed-num)
+  (:result-types signed-num)
+  (:policy :fast-safe))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+  (:translate %negate)
+  (:generator 1
+    (inst neg res x)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (inst neg res x)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target res)
+	      temp)
+  (:translate lognot)
+  (:generator 2
+    (inst li temp (fixnum -1))
+    (inst x temp x)
+    (move res temp)))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (inst not res x)))
+
+
+
+;;;; Binary fixnum operations (+, -, LOGIOR, LOGAND, LOGXOR).
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop)
+  (:args (x :target r :scs (any-reg))
+	 (y :scs (any-reg immediate) :to :save))
+  (:arg-types tagged-num tagged-num)
+  (:temporary (:scs (any-reg)) temp)
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-unsigned-binop)
+  (:args (x :target r :scs (unsigned-reg))
+	 (y :scs (unsigned-reg immediate) :to :save))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:scs (any-reg)) temp)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-signed-binop)
+  (:args (x :target r :scs (signed-reg))
+	 (y :scs (signed-reg immediate) :to :save))
+  (:arg-types signed-num signed-num)
+  (:temporary (:scs (any-reg)) temp)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(eval-when (compile eval)
+
+(defmacro define-binop (translate cost op &body imm-body)
+  `(progn
+     (define-vop (,(intern (concatenate 'simple-string
+					"FAST-"
+					(string translate)
+					"/FIXNUM=>FIXNUM"))
+		  fast-fixnum-binop)
+       (:translate ,translate)
+       (:generator ,cost
+	 (sc-case y
+	   (any-reg
+	    (move r x)
+	    (inst ,op r y))
+	   (immediate
+	    (let ((value (fixnum (tn-value y))))
+	      ,@imm-body)))))
+     (define-vop (,(intern (concatenate 'simple-string
+					"FAST-"
+					(string translate)
+					"/SIGNED=>SIGNED"))
+		  fast-signed-binop)
+       (:translate ,translate)
+       (:generator ,(1+ cost)
+	 (sc-case y
+	   (signed-reg
+	    (move r x)
+	    (inst ,op r y))
+	   (immediate
+	    (let ((value (tn-value y)))
+	      ,@imm-body)))))
+     (define-vop (,(intern (concatenate 'simple-string
+					"FAST-"
+					(string translate)
+					"/UNSIGNED=>UNSIGNED"))
+		  fast-unsigned-binop)
+       (:translate ,translate)
+       (:generator ,(1+ cost)
+	 (sc-case y
+	   (unsigned-reg
+	    (move r x)
+	    (inst ,op r y))
+	   (immediate
+	    (let ((value (tn-value y)))
+	      ,@imm-body)))))))
+
+) ;EVAL-WHEN
+
+
+(define-binop + 3 a
+  (cond ((typep value '(signed-byte 16))
+	 (inst a r x value))
+	(t
+	 (move r x)
+	 (inst li temp value)
+	 (inst a r temp))))
+
+(define-binop - 3 s
+  (cond ((typep value '(signed-byte 16))
+	 (inst s r x value))
+	(t
+	 (move r x)
+	 (inst li temp value)
+	 (inst s r temp))))
+
+(define-binop logior 2 o
+  (let ((low (ldb (byte 16 0) value))
+	(high (ldb (byte 16 16) value)))
+    (cond ((zerop value)
+	   (move r x))
+	  ((zerop low)
+	   (inst oiu r x high))
+	  ((zerop high)
+	   (inst oil r x low))
+	  (t
+	   (inst oil r x low)
+	   (inst oiu r r high)))))
+
+(define-binop logxor 2 x
+  (let ((low (ldb (byte 16 0) value))
+	(high (ldb (byte 16 16) value)))
+    (cond ((zerop value)
+	   (move r x))
+	  ((zerop low)
+	   (inst xiu r x high))
+	  ((zerop high)
+	   (inst xil r x low))
+	  (t
+	   (inst xil r x low)
+	   (inst xiu r r high)))))
+
+(define-binop logand 1 n
+  (let ((low (ldb (byte 16 0) value))
+	(high (ldb (byte 16 16) value)))
+    (cond ((= low high #xFFFF)
+	   (move r x))
+	  ((zerop low)
+	   (inst niuz r x high))
+	  ((= low #xFFFF)
+	   (inst niuo r x high))
+	  ((zerop high)
+	   (inst nilz r x low))
+	  ((= high #xFFFF)
+	   (inst nilo r x low))
+	  (t
+	   (inst nilo r x low)
+	   (inst niuo r r high)))))
+
+
+
+;;;; Binary fixnum operations.
+
+(define-vop (fast-ash)
+  (:note "inline ASH")
+  (:args (number :scs (signed-reg unsigned-reg) :to :save)
+	 (amount :scs (signed-reg immediate)))
+  (:arg-types (:or signed-num unsigned-num) signed-num)
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:sc non-descriptor-reg) ndesc)
+  (:generator 12
+    (sc-case amount
+      (signed-reg
+       (let ((positive (gen-label))
+	     (done (gen-label)))
+	 (inst c amount 0)
+	 (inst bncx :lt positive)
+	 (inst neg ndesc amount)
+	 (inst c ndesc 32)
+	 ;; If less than 32, goto done while shifting.
+	 (inst bcx :lt done)
+	 (sc-case number
+	   (signed-reg
+	    (move result number)
+	    (inst sar result ndesc))
+	   (unsigned-reg
+	    (move result number)
+	    (inst sr result ndesc)))
+	 ;; 32 or greater case.
+	 (inst bx done)
+	 (sc-case number
+	   (signed-reg
+	    (move result number)
+	    (inst sar result 31))
+	   (unsigned-reg
+	    (move result number)
+	    (inst sr result 31)))
+
+	 (emit-label positive)
+	 ;; The result-type assures us that this shift will not overflow.
+	 (move result number)
+	 (inst sl result amount)
+
+	 (emit-label done)))
+
+      (immediate
+       (let ((amount (tn-value amount)))
+	 (cond ((minusp amount)
+		(sc-case number
+		  (unsigned-reg
+		   (move result number)
+		   (inst sr result (min (- amount) 31)))
+		  (t
+		   (move result number)
+		   (inst sar result (min (- amount) 31)))))
+	       (t
+		(move result number)
+		(inst sl result (min amount 31)))))))))
+
+
+;;; SIGNED-BYTE-32-LEN -- VOP.
+;;;
+;;; Common Lisp INTEGER-LENGTH.  Due to the definition of this operation,
+;;;    (integer-length x) == (integer-length (lognot x)).
+;;; We determine the result by using the RT's count-leading-zeros which only
+;;; works on the zeros in the lower half of a word, so we have to use it on
+;;; the upperhalf and lowerhalf of number separately and do a little addition
+;;; (actually, subtraction from the right values) to get the length.
+;;;
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note "inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg)))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg)) number)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 16
+    (let ((upper-not-zero (gen-label))
+	  (count (gen-label)))
+      ;; Move arg and tell us if number is positive.
+      (inst oil number arg 0)
+      (inst bnc :lt count)
+      ;; Number is negative, so logically negate it to compute length.
+      (inst not number)
+      (emit-label count)
+      ;; Shift the upperhalf down and see if there are any 1's in it.
+      (move temp number)
+      (inst sr temp 16)
+      (inst bncx :eq upper-not-zero)
+      (inst li res 32)
+      ;; Upper half is all 0's, so get ready to subtract leading 0's in
+      ;; the lowerhalf from 16 to determine integer length.
+      (inst li res 16)
+      (move temp number)
+      (emit-label upper-not-zero)
+      ;; Here temp contains the upperhalf if not all 0's or the lowerhalf.
+      ;; Res contains the appropriate value (32 or 16) from which to subtract
+      ;; the number of leading 0's in temp to determine integer length.
+      (inst clz temp)
+      (inst s res temp))))
+
+;;; UNSIGNED-BYTE-32-COUNT -- VOP.
+;;;
+;;; To count the 1's in number, count how many times you can do the following:
+;;;    AND number and the result of subtracting 1 from number.
+;;;    Set number to the result of the AND operation.
+;;; This subtract and AND clears the lowest 1 in number, so when number becomes
+;;; zero, you're done.
+;;;
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note "inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg)) number temp)
+  (:generator 14
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+      ;; Move arg and tell us if number is zero, in which case res is 0.
+      (inst oil number arg 0)
+      (inst bcx :eq done)
+      (inst li res 0)
+      ;; Count 1's in number.
+      (emit-label loop)
+      (move temp number)
+      (inst s temp 1)
+      (inst n number temp)
+      (inst bncx :eq loop)
+      (inst a res 1)
+      ;; We're done and res already has result.
+      (emit-label done))))      
+
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+  (:args (x :scs (any-reg))
+	 (y :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg)))
+  ;; Leave room in the signed field for
+  (:arg-types tagged-num (:constant (signed-byte 14)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+  (:args (x :scs (signed-reg))
+	 (y :scs (signed-reg)))
+  (:arg-types signed-num signed-num)
+  (:note "inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+  (:args (x :scs (signed-reg)))
+  (:arg-types signed-num (:constant (signed-byte 16)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:note "inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 15)))
+  (:info target not-p y))
+
+
+(defmacro define-conditional-vop (translate &rest generator)
+  `(progn
+     ,@(mapcar #'(lambda (suffix cost signed)
+		   (unless (and (member suffix '(/fixnum -c/fixnum))
+				(eq translate 'eql))
+		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+						    translate suffix))
+				   ,(intern
+				     (format nil "~:@(FAST-CONDITIONAL~A~)"
+					     suffix)))
+			(:translate ,translate)
+			(:generator ,cost
+			  (let* ((signed ,signed)
+				 (-c/fixnum ,(eq suffix '-c/fixnum))
+				 (y (if -c/fixnum (fixnum y) y)))
+			    ,@generator)))))
+	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+	       ;; All these really take six cycles, but we decrease the -c/...
+	       ;; cost to prefer these VOPs since we avoid doing
+	       ;; load-immediates.  Then the first two are decreased by by one
+	       ;; more to prefer comparing the fixnum representation directly.
+	       '(5 4 6 5 6 5)
+	       '(t t t t nil nil))))
+
+(define-conditional-vop <
+  (if signed
+      (inst c x y)
+      (inst cl x y))
+  (if not-p
+      (inst bnc :lt target)
+      (inst bc :lt target)))
+
+(define-conditional-vop >
+  (if signed
+      (inst c x y)
+      (inst cl x y))
+  (if not-p
+      (inst bnc :gt target)
+      (inst bc :gt target)))
+
+;;; This only handles EQL of restricted integers, so it's simple.
+;;;
+(define-conditional-vop eql
+  (declare (ignore signed))
+  (inst c x y)
+  (if not-p
+      (inst bnc :eq target)
+      (inst bc :eq target)))
+
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+;;;
+
+(define-vop (fast-eql/fixnum fast-conditional)
+  (:args (x :scs (any-reg descriptor-reg))
+	 (y :scs (any-reg)))
+  (:arg-types * tagged-num)
+  (:note "inline fixnum comparison")
+  (:translate eql)
+  (:ignore temp)
+  (:generator 4
+    (inst c x y)
+    (if not-p
+	(inst bnc :eq target)
+	(inst bc :eq target))))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:arg-types * (:constant (signed-byte 14)))
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 3
+    (inst c x y)
+    (if not-p
+	(inst bnc :eq target)
+	(inst bc :eq target))))
+
+
+
+;;;; 32-bit logical operations
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg) :target r)
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe))
+
+(define-vop (32bit-logical-not 32bit-logical)
+  (:translate 32bit-logical-not)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:generator 1
+    (inst not r x)))
+
+(define-vop (32bit-logical-nor 32bit-logical)
+  (:translate 32bit-logical-nor)
+  (:generator 2
+    (move r x)
+    (inst o r y)
+    (inst not r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (move r x)
+    (inst n r y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+  (:translate 32bit-logical-or)
+  (:generator 1
+    (move r x)
+    (inst o r y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+  (:translate 32bit-logical-xor)
+  (:generator 1
+    (move r x)
+    (inst x r y)))
+
+
+
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+  (:translate bignum::%bignum-length)
+  (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+  (: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-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))
+	 (value :scs (unsigned-reg)))
+  (:arg-types t positive-fixnum unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(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 7
+    (let ((done (gen-label)))
+      (inst c digit 0)
+      (inst bcx :lt done)
+      (move result null-tn)
+      (load-symbol result 't)
+      (emit-label done))))
+
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg) :target result)
+	 (b :scs (unsigned-reg))
+	 (carry-in :scs (any-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg))
+	    (carry :scs (unsigned-reg) :from :eval))
+  (:result-types unsigned-num positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 5
+    (move result a)
+    ;; Set the carry condition bit.
+    (inst a temp carry-in -1)
+    (inst ae result b)
+    ;; Set carry to the condition bit.
+    ;; Add zero to zero and see if we get a one.
+    (inst li carry 0)
+    (inst ae carry carry)))
+
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg) :target result)
+	 (b :scs (unsigned-reg))
+	 (borrow-in :scs (any-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg))
+	    (borrow :scs (unsigned-reg) :from :eval))
+  (:result-types unsigned-num positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 5
+    (move result a)
+    ;; Set the carry condition bit.
+    ;; Borrow-in is zero if there was a borrow, one if there was no borrow.
+    ;; The RT has the same sense with its C0 condition bit.
+    (inst a temp borrow-in -1)
+    (inst se result b)
+    ;; Set borrow to 0 if the carry condition bit is zero, or to 1 otherwise.
+    (inst li borrow 0)
+    (inst ae borrow borrow)))
+
+(define-vop (bignum-mult-and-add-3-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg))
+	 (carry-in :scs (unsigned-reg)
+		   :load-if (not (sc-is carry-in unsigned-stack))
+		   :to :save))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
+  (:results (high :scs (unsigned-reg) :from :load)
+	    (low :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 76
+    ;; Do the multiply.
+    (unsigned-multiply x y high low)
+
+    ;; Add the carry-in.
+    (sc-case carry-in
+      (unsigned-stack
+       (load-stack-tn temp carry-in vop)
+       (inst a low temp))
+      (unsigned-reg
+       (inst a low carry-in)))
+    (inst ae high 0)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+  (:translate bignum::%multiply-and-add)
+  (:vop-var vop)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg))
+	 (prev :scs (unsigned-reg)
+	       :load-if (not (sc-is prev unsigned-stack))
+	       :to :save)
+	 (carry-in :scs (unsigned-reg)
+		   :load-if (not (sc-is carry-in unsigned-stack))
+		   :to :save))
+  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
+  (:results (high :scs (unsigned-reg) :from :load)
+	    (low :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 81
+    ;; Do the multiply.
+    (unsigned-multiply x y high low)
+
+    ;; Add the carry-in.
+    (sc-case carry-in
+      (unsigned-stack
+       (load-stack-tn temp carry-in vop)
+       (inst a low temp))
+      (unsigned-reg
+       (inst a low carry-in)))
+    (inst ae high 0)
+    
+    ;; Add in digit from accumulating result.
+    (sc-case carry-in
+      (unsigned-stack
+       (load-stack-tn temp prev vop)
+       (inst a low temp))
+      (unsigned-reg
+       (inst a low prev)))
+    (inst ae high 0)))
+
+(define-vop (bignum-mult)
+  (:translate bignum::%multiply)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (high :scs (unsigned-reg) :from :load)
+	    (low :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 74
+    ;; Do the multiply.
+    (unsigned-multiply x y high low)))
+
+;;; UNSIGNED-MULTIPLY -- Internal.
+;;;
+;;; The RT has a signed multiply.  To unsigned-multiply bignum digits, we use
+;;; the following identity:
+;;;    signed-interpretation
+;;;       =  unsigned-interpretation  -  (sign-bit)(2^32)
+;;;    ==>
+;;;    ui = si + (sb)(2^32)
+;;; This gives us the following equation:
+;;;    (ui1) (ui2)  =  [si1 + (sb1)(2^32)] [si2 + (sb2)(2^32)]
+;;;    (ui1) (ui2)  =  (si1) (si2)
+;;;                  + [(sb1)(si2) + (sb2)(si1)] (2^32)
+;;; 		     + (sb1)(sb2)(2^32)
+;;; Inspection and the fact that the result must fit into 64 bits reveals that
+;;; the third time can always be ignored.
+;;;
+(defun unsigned-multiply (x y high low)
+  ;; Setup system register for multiply.
+  (inst mtmqscr x)
+  
+  ;; Do the multiply.
+  ;; Subtract high from high to set it to zero and to set the C0 condition
+  ;; bit appropriately for the m instruction.
+  (inst s high high)
+  (dotimes (i 16)
+    (inst m high y))
+  ;; Adjust high word of result for unsigned multiply.
+  ;; If x is negative, add in y.  If y is negative, add in x.
+  (let ((x-pos (gen-label))
+	(y-pos (gen-label)))
+    (inst c x 0)
+    (inst bnc :lt x-pos)
+    (inst a high y)
+    (emit-label x-pos)
+    (inst c y 0)
+    (inst bnc :lt y-pos)
+    (inst a high x)
+    (emit-label y-pos))
+  
+  ;; Get the low 32 bits of the product.
+  (inst mfmqscr low))
+
+
+(define-vop (bignum-lognot)
+  (:translate bignum::%lognot)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst not r x)))
+
+(define-vop (fixnum-to-digit)
+  (:translate bignum::%fixnum-to-digit)
+  (:policy :fast-safe)
+  (:args (fixnum :scs (any-reg) :target digit))
+  (:arg-types tagged-num)
+  (:results (digit :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move digit fixnum)
+    (inst sar digit 2)))
+
+;;; BIGNUM-FLOOR -- VOP.
+;;;
+;;; The way the bignum code uses this allows us to ignore dividing by 0, 1, or
+;;; -1.  Furthermore, we always divided a positive high:low value by a positive
+;;; divisor value.  This means we don't have to worry about using the RT's
+;;; signed divide instruction to get an unsigned division result.
+;;;
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (dividend-high :scs (unsigned-reg) :target rem)
+	 (dividend-low :scs (unsigned-reg))
+	 (divisor :scs (unsigned-reg) :to (:eval 1)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg) :from (:eval 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 44
+    (inst mtmqscr dividend-low)
+    (move rem dividend-high)
+    (dotimes (i 32)
+      (inst d rem divisor))
+    ;; Check preliminary remainder by considering signs of rem and divisor.
+    ;; This is an extra step to account for the non-restoring divide-step instr.
+    ;; We don't actually have to check this since the d instruction set :c0
+    ;; when the signs of rem and divisor are the same.
+    (let ((rem-okay (gen-label)))
+      (inst bc :c0 rem-okay)
+      (inst a rem divisor)
+      (emit-label rem-okay))
+    (inst mfmqscr quo)))
+
+;;; SIGNIFY-DIGIT -- VOP.
+;;;
+;;; This is supposed to make digit into a fixnum which is signed.  We just
+;;; move it here, letting the compiler's operand motion stuff make this
+;;; result into a fixnum.
+;;;
+(define-vop (signify-digit)
+  (:translate bignum::%fixnum-digit-with-correct-sign)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg) :target res))
+  (:arg-types unsigned-num)
+  (:results (res :scs (signed-reg)))
+  (:result-types signed-num)
+  (:generator 1
+    (move res digit)))
+
+(define-vop (digit-ashr)
+  (:translate bignum::%ashr)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg) :target result)
+	 (count :scs (unsigned-reg)))
+  (:arg-types unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 2
+    (move result digit)
+    (inst sar result count)))
+
+(define-vop (digit-lshr digit-ashr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:generator 2
+    (move result digit)
+    (inst sr result count)))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 2
+    (move result digit)
+    (inst sl result count)))
+
+
+
+;;;; Static functions.
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-+ (x y) :translate +)
+(define-static-function two-arg-- (x y) :translate -)
+(define-static-function two-arg-* (x y) :translate *)
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-< (x y) :translate <)
+(define-static-function two-arg-<= (x y) :translate <=)
+(define-static-function two-arg-> (x y) :translate >)
+(define-static-function two-arg->= (x y) :translate >=)
+(define-static-function two-arg-= (x y) :translate =)
+(define-static-function two-arg-/= (x y) :translate /=)
+
+(define-static-function %negate (x) :translate %negate)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/rt/array.lisp b/compiler/rt/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5d0616f8d5d2a03ae783216f78cac75d7c091381
--- /dev/null
+++ b/compiler/rt/array.lisp
@@ -0,0 +1,500 @@
+;;; -*- Package: C; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/array.lisp,v 1.1 1991/02/18 15:07:37 chiles Exp $
+;;;
+;;; This file contains the IBM RT definitions for array operations.
+;;;
+;;; Written by William Lott and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Allocator for the array header.
+
+(define-vop (make-array-header)
+  (:args (type :scs (any-reg descriptor-reg))
+	 (rank :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
+  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
+  (:temporary (:sc word-pointer-reg) alloc)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 0
+    (pseudo-atomic (ndescr)
+      ;; Take free pointer and make descriptor pointer for the result.  Just
+      ;; add in the three low-tag bits since alloc ptr is dual-word aligned,
+      ;; and its three low bits are zero.
+      (load-symbol-value alloc *allocation-pointer*)
+      (inst cal header alloc vm:other-pointer-type)
+      (inst cal alloc
+	    (+ (* vm:array-dimensions-offset vm:word-bytes)
+	       vm:lowtag-mask))
+      ;; Rank is the dimensions as a fixnum which happens to be the number of
+      ;; bytes (by the machine's interpretation) we need to add to the alloc
+      ;; ptr.
+      (inst cas alloc rank alloc)
+      (inst nilo alloc (logand #xFFFF (lognot vm:lowtag-mask)))
+      (store-symbol-value alloc *allocation-pointer*)
+      (inst cal ndescr rank (fixnum (1- vm:array-dimensions-offset)))
+      ;; Shift the fixnum representation of the length, then OR in the fixnum
+      ;; rep of the type code, and then shift off the two extra fixnum zeros.
+      (inst sl ndescr vm:type-bits)
+      (inst oil ndescr type)
+      (inst sr ndescr 2)
+      (storew ndescr header 0 vm:other-pointer-type))
+    (move result header)))
+
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t fixnum) fixnum
+  (flushable))
+(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
+  ())
+
+(define-vop (%array-dimension word-index-ref)
+  (:translate lisp::%array-dimension)
+  (:policy :fast-safe)
+  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+
+(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))
+
+
+
+(defknown lisp::%array-rank (t) fixnum (flushable))
+
+;;; ARRAY-RANK-VOP -- VOP.
+;;;
+;;; The length of the array header manifests the rank of the array.  We fetch
+;;; the header word, extract the length, and subtract off the start of the
+;;; dimension slots.
+;;;
+(define-vop (array-rank-vop)
+  (:translate lisp::%array-rank)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :type random :target res) temp)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 6
+    (loadw temp x 0 vm:other-pointer-type)
+    (inst sr temp vm:type-bits)
+    (inst s temp (1- vm:array-dimensions-offset))
+    (inst sl temp 2)
+    (move res temp)))
+
+
+
+;;;; Bounds checking routine.
+
+(define-vop (check-bound)
+  (:translate %check-bound)
+  (:policy :fast-safe)
+  (:args (array :scs (descriptor-reg))
+	 (bound :scs (any-reg descriptor-reg))
+	 (index :scs (any-reg descriptor-reg) :target result))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (let ((error (generate-error-code vop invalid-array-index-error
+				      array bound index)))
+      (inst c index bound)
+      (inst bnc :lt error)
+      (move result index))))
+
+
+
+;;;; 32-bit, 16-bit, and 8-bit vectors.
+
+;;; We build these variants on top of VOP's defined in memory.lisp.  These
+;;; vectors' elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(eval-when (compile eval)
+(defmacro def-data-vector-frobs (type variant 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 immediate))
+	      (value :scs ,scs))
+       (:results (result :scs ,scs))
+       (:result-types ,element-type))))
+) ;EVAL-WHEN
+
+(def-data-vector-frobs simple-string byte-index
+  base-character base-character-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)
+
+
+
+;;;; Integer vectors with 1, 2, and 4 bit elements.
+
+(eval-when (compile eval)
+
+(defmacro def-small-data-vector-frobs (type bits)
+  (let* ((elements-per-word (floor vm:word-bits bits))
+	 (bit-shift (1- (integer-length elements-per-word))))
+    `(progn
+       (define-vop (,(symbolicate 'data-vector-ref/ type))
+	 (:note "inline array access")
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (value :scs (any-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+	 (:generator 20
+	   (move temp index)
+	   (inst sr temp ,bit-shift)
+	   (inst sl temp 2)
+	   (move lip object)
+	   (inst a lip temp)
+	   (loadw result lip vm:vector-data-offset vm:other-pointer-type)
+	   (inst nilz temp index ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst sl temp ,(1- (integer-length bits)))))
+	   (inst sr result temp)
+	   (inst nilz result ,(1- (ash 1 bits)))
+	   (move value result)
+	   (inst sl value 2)))
+       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:arg-types ,type (:constant index))
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:generator 15
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
+			      vm:other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 16))
+		      ;; Use the load with immediate offset if possible.
+		      (inst l result offset))
+		     (t
+		      ;; Load the upper half of the offset in one instruction
+		      ;; and add the lower half as an immediate offset in
+		      ;; the load.  NOTE: if bit 15 is on, the load will sign-
+		      ;; extend it, so we have to add 1 to the upper half now
+		      ;; to counter the effect of the -1 from the sign-extension.
+		      (inst cau lip object
+			    (if (logbitp 15 offset)
+				(1+ (ash offset -16))
+				(ash offset -16)))
+		      (inst l result lip (logand #xFFFF offset)))))
+	     (unless (zerop extra)
+	       (inst sr result (* extra ,bits)))
+	     (unless (= extra ,(1- elements-per-word))
+	       (inst n result ,(1- (ash 1 bits)))))))
+       (define-vop (,(symbolicate 'data-vector-set/ type))
+	 (:note "inline array store")
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:vop-var vop)
+	 (:args (object :scs (descriptor-reg) :to (:eval 0))
+		;; Normally, we would take the next arg in an unsigned-reg too.
+		;; This caused a discrimination problem in the compiler for
+		;; choosing a move function.  Since this VOP uses so many
+		;; non-descriptor registers anyway which has been a hassle, we
+		;; just removed unsigned-reg.
+		(index :scs (any-reg) :to (:eval 1))
+		(value :scs (unsigned-reg immediate)
+		       :load-if (not (sc-is value unsigned-stack))
+		       :target value-save))
+	 (:arg-types ,type positive-fixnum positive-fixnum)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (unsigned-stack) :from (:argument 2)) value-save)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:temporary (:scs (non-descriptor-reg) :from (:argument 2)
+			   :to (:result 0)) temp)
+	 (:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:result 0))
+		     old)
+	 (:temporary (:scs (non-descriptor-reg) :from (:eval 1) :to (:result 0))
+		     shift)
+	 (:generator 25
+	   (when (sc-is value unsigned-reg)
+	     (storew value (current-nfp-tn vop) (tn-offset value-save)))
+	   (move temp index)
+	   (inst sr temp
+		 (sc-case index
+		   ;; In addition to dividing the index to map it to
+		   ;; a number of words to skip, shift off the fixnum tag
+		   ;; bits too.
+		   (any-reg ,(+ bit-shift 2))
+		   ;; No extraneous bits in this case.
+		   (unsigned-reg ,bit-shift)))
+	   (inst sl temp 2)
+	   (move lip object)
+	   (inst a lip temp)
+	   (loadw old lip vm:vector-data-offset vm:other-pointer-type)
+	   (sc-case index
+	     (unsigned-reg
+	      (inst nilz shift index ,(1- elements-per-word))
+	      ,@(unless (= bits 1)
+		  `((inst sl shift ,(1- (integer-length bits))))))
+	     (any-reg
+	      (inst nilz shift index ,(ash (1- elements-per-word) 2))
+	      ,@(unless (= bits 4)
+		  `((inst sr shift ,(- 3 (integer-length bits)))))))
+	      
+	   ;; Unless our immediate is all 1's, zero the destination bits.
+	   (unless (and (sc-is value immediate)
+			(= (tn-value value) ,(1- (ash 1 bits))))
+	     (inst li temp ,(1- (ash 1 bits)))
+	     (inst sl temp shift)
+	     (inst not temp)
+	     (inst n old temp))
+	   ;; Unless the value is zero, really deposit it.
+	   (unless (and (sc-is value immediate)
+			(zerop (tn-value value)))
+	     (sc-case value
+	       (immediate
+		(inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
+	       ((unsigned-reg unsigned-stack)
+		(loadw temp (current-nfp-tn vop)
+		       (tn-offset (if (sc-is value unsigned-stack)
+				      value
+				      value-save)))
+		(inst nilz temp ,(1- (ash 1 bits)))))
+	     (inst sl temp shift)
+	     (inst o old temp))
+	   (storew old lip vm:vector-data-offset vm:other-pointer-type)
+	   (sc-case value
+	     (immediate
+	      (inst li result (tn-value value)))
+	     ((unsigned-reg unsigned-stack)
+	      (loadw result (current-nfp-tn vop)
+		     (tn-offset (if (sc-is value unsigned-stack)
+				    value
+				    value-save)))))))
+       (define-vop (,(symbolicate 'data-vector-set-c/ type))
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs (unsigned-reg immediate) :target result))
+	 (:arg-types ,type (:constant index) positive-fixnum)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) temp old)
+	 (:generator 20
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
+			      vm:other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 16))
+		      ;; Use the load with immediate offset if possible.
+		      (inst l old offset))
+		     (t
+		      ;; Load the upper half of the offset in one instruction
+		      ;; and add the lower half as an immediate offset in
+		      ;; the load.  NOTE: if bit 15 is on, the load will sign-
+		      ;; extend it, so we have to add 1 to the upper half now
+		      ;; to counter the effect of the -1 from the sign-extension.
+		      (inst cau lip object
+			    (if (logbitp 15 offset)
+				(1+ (ash offset -16))
+				(ash offset -16)))
+		      (inst l old lip (logand #xFFFF offset)))))
+	     ;; Unless our immediate is all 1's, zero the destination bits.
+	     (unless (and (sc-is value immediate)
+			  (= (tn-value value) ,(1- (ash 1 bits))))
+	       (inst li temp
+		     (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
+	       (inst n old temp))
+	     ;; Unless the value is zero, really deposit it.
+	     (unless (and (sc-is value immediate)
+			  (zerop (tn-value value)))
+	       (sc-case value
+		 (immediate
+		  (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
+				    (* extra ,bits))))
+		    ;; Isn't this test silly, or the otherwise branch doesn't
+		    ;; work anyway????
+		    (cond ((< value #x10000)
+			   (inst oil old (logand #xFF value))
+			   (inst oiu old (logand #xFF00 value)))
+			  (t
+			   (inst li temp value)
+			   (inst o old temp)))))
+		 (unsigned-reg
+		  (move temp value)
+		  ;; Shouldn't we do this to check the size of the value?
+		  (inst nilz temp ,(1- (ash 1 bits)))
+		  (inst sl temp (* extra ,bits))
+		  (inst o old temp))))
+	     (storew old object vm:vector-data-offset vm:other-pointer-type)
+	     (sc-case value
+	       (immediate
+		(inst li result (tn-value value)))
+	       (unsigned-reg
+		(move result value)))))))))
+
+) ;EVAL-WHEN
+
+(def-small-data-vector-frobs simple-bit-vector 1)
+(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
+(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
+
+
+
+;;;; Float vectors.
+
+#|
+(define-vop (data-vector-ref/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-single-float positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 20
+    (inst add lip object index)
+    (inst lwc1 value lip
+	  (- (* vm:vector-data-offset vm:word-bytes)
+	     vm:other-pointer-type))
+    (inst nop)))
+
+(define-vop (data-vector-set/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (single-reg) :target result))
+  (:arg-types simple-array-single-float positive-fixnum single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 20
+    (inst add lip object index)
+    (inst swc1 value lip
+	  (- (* vm:vector-data-offset vm:word-bytes)
+	     vm:other-pointer-type))
+    (unless (location= result value)
+      (inst move :single result value))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-float positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 20
+    (inst add lip object index)
+    (inst add lip index)
+    (inst lwc1 value lip
+	  (- (* vm:vector-data-offset vm:word-bytes)
+	     vm:other-pointer-type))
+    (inst lwc1-odd value lip
+	  (+ (- (* vm:vector-data-offset vm:word-bytes)
+		vm:other-pointer-type)
+	     vm:word-bytes))
+    (inst nop)))
+
+(define-vop (data-vector-set/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (double-reg) :target result))
+  (:arg-types simple-array-double-float positive-fixnum double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 20
+    (inst add lip object index)
+    (inst add lip index)
+    (inst swc1 value lip
+	  (- (* vm:vector-data-offset vm:word-bytes)
+	     vm:other-pointer-type))
+    (inst swc1-odd value lip
+	  (+ (- (* vm:vector-data-offset vm:word-bytes)
+		vm:other-pointer-type)
+	     vm:word-bytes))
+    (unless (location= result value)
+      (inst move :double result value))))
+|#
+
+
+;;;; Raw bits without regard to vector type.
+
+(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 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))
+
+
+
+;;;; Vector subtype frobs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
diff --git a/compiler/rt/c-call.lisp b/compiler/rt/c-call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d6780ecf4cace98898e12a4fec58d9ea1cb957ac
--- /dev/null
+++ b/compiler/rt/c-call.lisp
@@ -0,0 +1,174 @@
+;;; -*- Package: RT -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.1 1991/02/18 15:07:39 chiles Exp $
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;; Converted by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+(defun c-call-wired-tn (primitive-type sc-name offset)
+  (make-wired-tn (primitive-type-or-lose primitive-type)
+		 (sc-number-or-lose sc-name)
+		 offset))
+
+(def-vm-support-routine make-call-out-nsp-tn ()
+  (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset))
+
+
+(def-vm-support-routine make-call-out-argument-tns (arg-types)
+  (let ((nargs 0))
+    (collect ((tns))
+      (dolist (type arg-types)
+	(multiple-value-bind
+	    (ptype reg-sc stack-sc)
+	    (ecase (if (consp type) (car type) type)
+	      ((unsigned-byte port)
+	       (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
+	      (signed-byte
+	       (values 'signed-byte-32 'signed-reg 'signed-stack))
+	      (system-area-pointer
+	       (values 'system-area-pointer 'sap-reg 'sap-stack)))
+	  ;; C expects 4 register args and the 5th arg at the top of the stack.
+	  ;; We can't put args in registers, because we need those registers
+	  ;; for something else.  So we put them just beyond the end of the
+	  ;; stack and the trampoline code will move them into place.
+	  (tns (c-call-wired-tn ptype stack-sc nargs))
+	  (incf nargs)))
+      (values (tns)
+	      (logandc2 (1+ nargs) 1)))))
+
+(def-vm-support-routine make-call-out-result-tn (type)
+  (let ((name (if (consp type) (car type) type)))
+    (ecase name
+      ((unsigned-byte port)
+       (c-call-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))
+      (signed-byte
+       (c-call-wired-tn 'signed-byte-32 'signed-reg nl0-offset))
+      (system-area-pointer
+       (c-call-wired-tn 'system-area-pointer 'sap-reg nl0-offset)))))
+
+(deftransform ext::call-foreign-function
+	      ((name return-type arg-types &rest args)
+	       (string * list &rest t))
+  (assert (c::constant-continuation-p name))
+  (assert (c::constant-continuation-p return-type))
+  (assert (c::constant-continuation-p arg-types))
+  (let ((name (c::continuation-value name))
+	(return-type (c::continuation-value return-type))
+	(arg-types (c::continuation-value arg-types)))
+    (assert (= (length arg-types) (length args)))
+    (if (member 'double-float arg-types)
+	(let ((new-args nil)
+	      (lambda-vars nil)
+	      (new-types nil))
+	  (dolist (type arg-types)
+	    (let ((arg (gensym)))
+	      (push arg lambda-vars)
+	      (case type
+		(double-float
+		 (push `(double-float-high-bits ,arg) new-args)
+		 (push '(signed-byte 32) new-types)
+		 (push `(double-float-low-bits ,arg) new-args)
+		 (push '(unsigned-byte 32) new-types))
+		(t
+		 (push arg new-args)
+		 (push type new-types)))))
+	  `(lambda (name return-type arg-types ,@(nreverse lambda-vars))
+	     (declare (ignore name return-type arg-types))
+	     (ext::call-foreign-function ,name ',return-type
+					 ',(nreverse new-types)
+					 ,@(nreverse new-args))))
+	(c::give-up))))
+
+(deftransform ext::call-foreign-function
+	      ((name return-type arg-types &rest args)
+	       (string t * &rest t))
+  (assert (c::constant-continuation-p name))
+  (assert (c::constant-continuation-p return-type))
+  (assert (c::constant-continuation-p arg-types))
+  (let ((name (c::continuation-value name))
+	(return-type (c::continuation-value return-type))
+	(arg-types (c::continuation-value arg-types))
+	(arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
+    (case return-type
+      (double-float
+       `(lambda (name return-type arg-types ,@args)
+	  (multiple-value-bind
+	      (hi lo)
+	      (ext::call-foreign-function ,name
+					  '(values signed-byte unsigned-byte)
+					  ',arg-types
+					  ,@arg-names)
+	    (make-double-float hi lo))))
+      (single-float
+       `(lambda (name return-type arg-types ,@args)
+	  (make-single-float
+	   (ext::call-foreign-function ,name 'signed-byte ',arg-types
+				       ,@arg-names))))
+      (t
+       (c::give-up)))))
+
+(define-vop (foreign-symbol-address)
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:generator 2
+    (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
+			      :foreign))))
+
+(define-vop (call-out)
+  (:args (args :more t))
+  (:results (results :more t))
+  (:ignore args results)
+  (:save-p t)
+  (:info function)
+  (:temporary (:sc any-reg :offset nl0-offset :to (:result 0)) nl0)
+  (:temporary (:sc any-reg :offset lra-offset) lra)
+  (:temporary (:sc any-reg :offset code-offset) code)
+  (:temporary (:scs (sap-reg)) temp)
+  (: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)))
+      (when cur-nfp
+	(store-stack-tn cur-nfp nfp-save))
+      (inst compute-lra-from-code lra code lra-label)
+      (inst cai nl0
+	    (make-fixup (concatenate 'simple-string "_" function) :foreign))
+      (inst cai temp (make-fixup "call_into_c" :foreign))
+      (inst b temp)
+
+      (align vm:lowtag-bits)
+      (emit-label lra-label)
+      (inst lra-header-word)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))))
+
+(define-vop (alloc-number-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:generator 0
+    (unless (zerop amount)
+      (inst cal nsp-tn nsp-tn (- (logandc2 (+ amount 7) 7))))
+    (move result nsp-tn)))
+
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:policy :fast-safe)
+  (:generator 0
+    (unless (zerop amount)
+      (inst cal nsp-tn  nsp-tn (logandc2 (+ amount 7) 7)))))
diff --git a/compiler/rt/call.lisp b/compiler/rt/call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..75ccdf3571551aeac91349dbd51e47d83a43f17f
--- /dev/null
+++ b/compiler/rt/call.lisp
@@ -0,0 +1,1146 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the IBM RT.
+;;;
+;;; Written by Rob MacLachlan, William Lott, and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Interfaces to IR2 conversion:
+
+;;; STANDARD-ARGUMENT-LOCATION -- Interface.
+;;;
+;;; Return a wired TN describing the N'th full call argument passing location.
+;;;
+(def-vm-support-routine standard-argument-location (n)
+  (declare (type unsigned-byte n))
+  (if (< n register-arg-count)
+      (make-wired-tn *any-primitive-type*
+		     register-arg-scn
+		     (elt register-arg-offsets n))
+      (make-wired-tn *any-primitive-type*
+		     control-stack-arg-scn n)))
+
+;;; MAKE-RETURN-PC-PASSING-LOCATION -- Interface.
+;;;
+;;; Make a passing location TN for a local call return-PC.  If standard is
+;;; true, then use the standard (full call) location, otherwise use any legal
+;;; location.  Even in the non-standard case, this may be restricted by a
+;;; desire to use a subroutine call instruction.
+;;;
+;;; These are *any-primitive-type* since LRA's are descriptor objects.
+;;;
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  (if standard
+      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
+      (make-restricted-tn *any-primitive-type* register-arg-scn)))
+
+;;; MAKE-OLD-FP-PASSING-LOCATION -- Interface.
+;;;
+;;; Similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a location to supply
+;;; the old control FP.  This is (obviously) wired in the standard convention,
+;;; but is totally unrestricted in non-standard conventions, since we can
+;;; always fetch it off of the stack using the arg pointer.
+;;;
+;;; These are *word-pointer-type* since FP's are word aligned pointers,
+;;; so the low tow bits are zero.
+;;;
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (if standard
+      (make-wired-tn *word-pointer-type* immediate-arg-scn ocfp-offset)
+      (make-normal-tn *word-pointer-type*)))
+
+;;; MAKE-OLD-FP-SAVE-LOCATION, MAKE-RETURN-PC-SAVE-LOCATION -- Interface.
+;;;
+;;; Make the TN's used to hold the old control FP and return-PC within the
+;;; current function.  We treat these specially so that the debugger can find
+;;; them at a known location.
+;;;
+;;; ### Fix to use specified save TNs...
+;;;
+;;; See comments for MAKE-RETURN-PC-PASSING-LOCATION and M-O-FP-P-L.
+;;;
+(def-vm-support-routine make-old-fp-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *word-pointer-type*) env)
+   (make-wired-tn *word-pointer-type*
+		  control-stack-arg-scn
+		  ocfp-save-offset)))
+;;;
+(def-vm-support-routine make-return-pc-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env)
+   (make-wired-tn *any-primitive-type*
+		  control-stack-arg-scn
+		  lra-save-offset)))
+
+;;; MAKE-ARGUMENT-COUNT-LOCATION -- Interface.
+;;;
+;;; Make a TN for the standard argument count passing location.  We only need
+;;; to make the standard location, since a count is never passed when we are
+;;; using non-standard conventions.
+;;;
+(def-vm-support-routine make-argument-count-location ()
+  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
+
+
+;;; MAKE-NFP-TN -- Interface.
+;;;
+;;; Make a TN to hold the number-stack frame pointer.  This is allocated once
+;;; per component, and is component-live.
+;;;
+(def-vm-support-routine make-nfp-tn ()
+  (component-live-tn
+   (make-wired-tn *word-pointer-type* immediate-arg-scn nfp-offset)))
+
+;;; MAKE-STACK-POINTER-TN -- Interface.
+;;;
+;;; This is of fixnum type because stack pointers are word aligned on our
+;;; byte-addressable machine, so they have fixnum tag bits inherently.  Also,
+;;; GC doesn't need to fix these since the stack doesn't move.
+;;;
+(def-vm-support-routine make-stack-pointer-tn ()
+  (make-normal-tn *word-pointer-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN -- Interface.
+;;; 
+(def-vm-support-routine make-number-stack-pointer-tn ()
+  (make-normal-tn *word-pointer-type*))
+
+;;; MAKE-UNKNOWN-VALUES-LOCATIONS -- Interface.
+;;;
+;;; Return a list of TN's that can be used to represent an unknown-values
+;;; continuation within a function.  The first one is a stack pointer TN, and
+;;; the second is an argument count TN.
+;;;
+(def-vm-support-routine make-unknown-values-locations ()
+  (list (make-stack-pointer-tn)
+	(make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; SELECT-COMPONENT-FORMAT -- Interface.
+;;;
+;;; This function is called by the Entry-Analyze phase, allowing VM-dependent
+;;; initialization of the IR2-Component structure.  We push placeholder entries
+;;; in the Constants to leave room for additional noise in the code object
+;;; header.
+;;;
+(def-vm-support-routine select-component-format (component)
+  (declare (type component component))
+  (dotimes (i code-constants-offset)
+    (vector-push-extend nil
+			(ir2-component-constants (component-info component))))
+  (undefined-value))
+
+
+
+;;;; Frame hackery:
+
+;;; CURRENT-FP -- VOP.
+;;;
+;;; Used for setting up the OCFP in local call.
+;;;
+(define-vop (current-fp)
+  ;; Stack pointers look like fixnums, and GC doesn't need to fix them.
+  (:results (val :scs (word-pointer-reg)))
+  (:generator 1
+    (move val cfp-tn)))
+
+;;; COMPUTE-OLD-NFP  --  VOP.
+;;;
+;;; A returner uses this for computing the returnee's NFP for use in
+;;; known-values return.  Only works assuming there is no variable size stuff
+;;; on the nstack.
+;;;
+(define-vop (compute-old-nfp)
+  (:results (val :scs (word-pointer-reg)))
+  (:vop-var vop)
+  (:generator 1
+    (let ((nfp (current-nfp-tn vop)))
+      ;; We know nfp is in a register.
+      (when nfp
+	;; The number stack grows down in memory, so the old-nfp is greater
+	;; than the current one -- add a positive number.
+	(inst cal val nfp
+	      (component-non-descriptor-stack-usage))))))
+
+;;; XEP-ALLOCATE-FRAME -- VOP.
+;;;
+;;; This is the first VOP invoked by the compiler at every entry point for a
+;;; component.  It sets up to be dual-word aligned (because of our low-tag
+;;; bits), emits the header-word for the function data-block, and emits any
+;;; extra words for data about the function (such as debug-info, its name,
+;;; etc.).  Then it emits instructions to allocate whatever room the function
+;;; will need on the control stack.
+;;;
+(define-vop (xep-allocate-frame)
+  (:info start-lab)
+  (:vop-var vop)
+  (:generator 1
+    ;; Make sure the label is aligned.
+    (align vm:lowtag-bits)
+    (emit-label start-lab)
+    ;; Allocate function header.
+    (inst function-header-word)
+    (dotimes (i (1- vm:function-header-code-offset))
+      (inst word 0))
+    ;; The start of the actual code.  A pointer to here is stored in symbols
+    ;; for named call.  Make CODE point to the component from this pointer.
+    (let ((entry-point (gen-label)))
+      (emit-label entry-point)
+      (inst compute-code-from-fn code-tn lip-tn entry-point))
+    ;; Caller has set FP to the beginning of the callee's frame.
+    (inst cal csp-tn cfp-tn
+	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
+    (let ((nfp-tn (current-nfp-tn vop)))
+      (when nfp-tn
+	(inst cal nsp-tn nsp-tn
+	      (- (component-non-descriptor-stack-usage)))
+	(move nfp-tn nsp-tn)))))
+
+;;; ALLOCATE-FRAME -- VOP.
+;;;
+;;; The compiler invokes this in local call for the caller.
+;;;
+(define-vop (allocate-frame)
+  (:results (res :scs (word-pointer-reg))
+	    (nfp :scs (word-pointer-reg)))
+  (:info callee)
+  (:generator 2
+    (move res csp-tn)
+    (inst cal csp-tn csp-tn
+	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
+    (when (ir2-environment-number-stack-p callee)
+      (inst cal nsp-tn nsp-tn
+	    (- (component-non-descriptor-stack-usage)))
+      (move nfp nsp-tn))))
+
+;;; ALLOCATE-FULL-CALL-FRAME -- VOP.
+;;;
+;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
+;;; is the number of arguments passed.  If no stack arguments are passed, then
+;;; we don't have to do anything.  The compiler only invokes this for the
+;;; caller.
+;;;
+(define-vop (allocate-full-call-frame)
+  (:info nargs)
+  (:results (res :scs (word-pointer-reg)))
+  (:generator 2
+    (when (> nargs register-arg-count)
+      (move res csp-tn)
+      (inst cal csp-tn csp-tn (* nargs vm:word-bytes)))))
+
+
+
+
+;;; DEFAULT-UNKNOWN-VALUES  --  Internal.
+;;;
+;;; Emit code needed at the return-point from an unknown-values call to get or
+;;; default a desired, fixed number of values.  Values is the head of the
+;;; TN-Ref list for the locations that the values are to be received into.
+;;; Nvals is the number of values that are to be received (should equal the
+;;; length of Values).
+;;;
+;;; Move-Temp is a Descriptor-Reg TNs used as a temporary.
+;;;
+;;; This code exploits the fact that in the unknown-values convention, a single
+;;; value return returns at the return PC + 4, whereas a return of other than
+;;; one value returns directly at the return PC.
+;;;
+;;; If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case, we have to do three things:
+;;;  -- Default unsupplied register values.  This need only be done when a
+;;;     single value is returned, since register values are defaulted by the
+;;;     called in the non-single case.
+;;;  -- Default unsupplied stack values.  This needs to be done whenever there
+;;;     are stack values.
+;;;  -- Reset SP.  This must be done whenever other than 1 value is returned,
+;;;     regardless of the number of values desired.
+;;;
+;;; The general-case code looks like this:
+#|
+	br regs-defaulted		; Skip if MVs
+	cau a1 0 nil-16			; Default register values
+	...
+	loadi nargs 1			; Force defaulting of stack values
+	lr args sp			; Set up args for SP resetting
+
+regs-defaulted
+	cau nil-temp 0 nil-16		; Cache nil
+
+	cmpi nargs 3			; If 4'th value unsupplied...
+	blex default-value-4		;    jump to default code
+	loadw move-temp ocfp-tn 3	; Move value to correct location.
+	store-stack-tn val4-tn move-temp
+
+	cmpi nargs 4			; Check 5'th value, etc.
+	blex default-value-5
+	loadw move-temp ocfp-tn 4
+	store-stack-tn val5-tn move-temp
+
+	...
+
+defaulting-done
+	lr sp args			; Reset SP.
+<end of code>
+
+<elsewhere>
+default-value-4 
+	store-stack-tn val4-tn nil-temp ; Nil out 4'th value.
+
+default-value-5
+	store-stack-tn val5-tn nil-temp ; Nil out 5'th value.
+
+	...
+
+	br defaulting-done
+|#
+;;;
+(defun default-unknown-values (values nvals move-temp lra-label)
+  (declare (type (or tn-ref null) values)
+	   (type unsigned-byte nvals) (type tn move-temp))
+  (cond
+   ((<= nvals 1)
+    ;; Don't use MOVE.  Use a known 32-bit long instruction, so the returner
+    ;; can know how many bytes we used here in the multiple-value return case.
+    ;; The returner wants to add a known quantity to LRA indicating how many
+    ;; values it returned.
+    (inst cal csp-tn ocfp-tn 0)
+    (inst compute-code-from-lra code-tn code-tn lra-label))
+   (t
+    (let ((regs-defaulted (gen-label))
+	  (defaulting-done (gen-label)))
+      ;; Branch off to the MV case.
+      ;; The returner has setup value registers and NARGS, and OCFP points to
+      ;; any stack values.
+      ;; Use a known 32-bit long instruction, so the returner can know how many
+      ;; bytes we used here in the multiple-value return case.  The returner
+      ;; wants to add a known quantity to LRA indicating how many values it
+      ;; returned.
+      (inst bnb :pz regs-defaulted)
+      ;;
+      ;; Do the single value case.
+      ;; Fill in some n-1 registers with nil to get to a consistent state with
+      ;; having gotten multiple values, so the code after regs-defaulted can
+      ;; be the same for both cases.  This includes setting up NARGS and OCFP.
+      ;; This says there's one value and no stack values.
+      (do ((i 1 (1+ i))
+	   (val (tn-ref-across values) (tn-ref-across val)))
+	  ((= i (min nvals register-arg-count)))
+	(move (tn-ref-tn val) null-tn))
+      ;; Only setup NARGS and OCFP we the returnee expected stack values.  If
+      ;; it doesn't want them, then it won't look at NARGS or OCFP.
+      (when (> nvals register-arg-count)
+	(inst li nargs-tn (fixnum 1))
+	(move ocfp-tn csp-tn))
+      
+      (emit-label regs-defaulted)
+      (inst compute-code-from-lra code-tn code-tn lra-label)
+      
+      (when (> nvals register-arg-count)
+	(collect ((defaults))
+	  (do ((i register-arg-count (1+ i))
+	       (val (do ((i 0 (1+ i))
+			 (val values (tn-ref-across val)))
+			((= i register-arg-count) val))
+		    (tn-ref-across val)))
+	      ((null val))
+
+	    (let ((default-lab (gen-label))
+		  (tn (tn-ref-tn val)))
+	      (defaults (cons default-lab tn))
+	      (inst c nargs-tn (fixnum i))
+	      (inst bnbx :gt default-lab)
+	      (loadw move-temp ocfp-tn i)
+	      (store-stack-tn move-temp tn)))
+
+	  (emit-label defaulting-done)
+	  (move csp-tn ocfp-tn)
+
+	  (assemble (*elsewhere*)
+	    (dolist (def (defaults))
+	      (emit-label (car def))
+	      (store-stack-tn null-tn (cdr def)))
+	    (inst b defaulting-done)))))))
+  (undefined-value))
+
+
+
+;;;; Unknown values receiving:
+
+;;; Receive-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;;    We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;;    When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;;    When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;;    Args and Nargs are TNs wired to the named locations.  We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+;;;
+(defun receive-unknown-values (args nargs start count lra-label)
+  (declare (type tn args nargs start count))
+  (let ((variable-values (gen-label))
+	(done (gen-label)))
+    ;; Use a known 32-bit long instruction, so the returner can know how many
+    ;; bytes we used here in the multiple-value return case.  The returner
+    ;; wants to add a known quantity to LRA indicating how many values it
+    ;; returned.
+    (inst bnb :pz variable-values)
+    ;; Here's the return point for the single-value return.
+    (inst compute-code-from-lra code-tn code-tn lra-label)
+    (inst inc csp-tn vm:word-bytes)
+    (storew (first register-arg-tns) csp-tn -1)
+    (inst cal start csp-tn -4)
+    (inst li count (fixnum 1))
+    
+    (emit-label done)
+    
+    (assemble (*elsewhere*)
+      (emit-label variable-values)
+      (inst compute-code-from-lra code-tn code-tn lra-label)
+      (do ((arg register-arg-tns (rest arg))
+	   (i 0 (1+ i)))
+	  ((null arg))
+	(storew (first arg) args i))
+      (move start args)
+      (move count nargs)
+      (inst b done)))
+  (undefined-value))
+
+
+;;; UNKNOWN-VALUES-RECEIVER -- VOP.
+;;;
+;;; This is inherited by unknown values receivers.  The main thing this handles
+;;; is allocation of the result temporaries.  This has to be included for in
+;;; any VOP using RECEIVE-UNKNOWN-VALUES.
+;;;
+(define-vop (unknown-values-receiver)
+  (:results
+   (start :scs (word-pointer-reg))
+   (count :scs (any-reg)))
+  (:temporary (:sc descriptor-reg :offset ocfp-offset
+		   :from :eval :to (:result 0))
+	      values-start)
+  (:temporary (:sc any-reg :offset nargs-offset
+	       :from :eval :to (:result 1))
+	      nvals))
+
+
+
+;;;; Local call with unknown values convention return:
+
+;;; Non-TR local call for a fixed number of values passed according to the
+;;; unknown values convention.
+;;;
+;;; Args are the argument passing locations, which are specified only to
+;;; terminate their lifetimes in the caller.
+;;;
+;;; Values are the return value locations (wired to the standard passing
+;;; locations).
+;;;
+;;; Save is the save info, which we can ignore since saving has been done.
+;;; Return-PC is the TN that the return PC should be passed in.
+;;; Target is a continuation pointing to the start of the called function.
+;;; Nvals is the number of values received.
+;;;
+(define-vop (call-local)
+  (:args (fp :scs (word-pointer-reg))
+	 (nfp :scs (word-pointer-reg))
+	 (args :more t))
+  (:results (values :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info arg-locs callee target nvals)
+  (:ignore arg-locs args nfp)
+  (:vop-var vop)
+  (:temporary (:scs (descriptor-reg)) move-temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:generator 5
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn cur-nfp nfp-save))
+      (move cfp-tn fp)
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(when callee-nfp
+	  (move callee-nfp nfp)))
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label)
+      (inst b target)
+      (emit-return-pc label)
+      (note-this-location vop :unknown-return)
+      (default-unknown-values values nvals move-temp label)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))))
+
+
+;;; Non-TR local call for a variable number of return values passed according
+;;; to the unknown values convention.  The results are the start of the values
+;;; glob and the number of values received.
+;;;
+(define-vop (multiple-call-local unknown-values-receiver)
+  (:args (fp :scs (word-pointer-reg))
+	 (nfp :scs (word-pointer-reg))
+	 (args :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info save callee target)
+  (:ignore args save)
+  (:vop-var vop)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:generator 20
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn cur-nfp nfp-save))
+      (move cfp-tn fp)
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(when callee-nfp
+	  (move callee-nfp nfp)))
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label)
+      (inst b target)
+      (emit-return-pc label)
+      (note-this-location vop :unknown-return)
+      (receive-unknown-values values-start nvals start count label)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))))
+
+
+
+;;;; Local call with known values return:
+
+;;; Non-TR local call with known return locations.  Known-value return works
+;;; just like argument passing in local call.
+;;;
+(define-vop (known-call-local)
+  (:args (fp :scs (word-pointer-reg))
+	 (nfp :scs (word-pointer-reg))
+	 (args :more t))
+  (:results (res :more t))
+  (:move-args :local-call)
+  (:save-p t)
+  (:info save callee target)
+  (:ignore args res save)
+  (:vop-var vop)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:generator 5
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn cur-nfp nfp-save))
+      (move cfp-tn fp)
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(when callee-nfp
+	  (move callee-nfp nfp)))
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label)
+      (inst b target)
+      (emit-return-pc label)
+      (note-this-location vop :known-return)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))))
+
+;;; Return from known values call.  We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function.  We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+(define-vop (known-return)
+  (:args (old-fp :scs (word-pointer-reg))
+	 (return-pc :scs (descriptor-reg))
+	 (vals :more t))
+  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:move-args :known-return)
+  (:info val-locs)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (move csp-tn cfp-tn)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst cal nsp-tn cur-nfp
+	      (component-non-descriptor-stack-usage))))
+    ;; Skip over a word, the LRA header, and subtract out low-tag bits.
+    (inst cal lip return-pc (- vm:word-bytes vm:other-pointer-type))
+    (inst bx lip)
+    (move cfp-tn old-fp)))
+
+
+
+;;;; Full call:
+;;;
+;;;    There is something of a cross-product effect with full calls.  Different
+;;; versions are used depending on whether we know the number of arguments or
+;;; the name of the called function, and whether we want fixed values, unknown
+;;; values, or a tail call.
+;;;
+;;; In full call, the arguments are passed creating a partial frame on the
+;;; stack top and storing stack arguments into that frame.  On entry to the
+;;; callee, this partial frame is pointed to by FP.  If there are no stack
+;;; arguments, we don't bother allocating a partial frame, and instead set FP
+;;; to SP just before the call.
+
+;;; Define-Full-Call  --  Internal.
+;;;
+;;;    This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;; 
+;;; Named is true if the first argument is a symbol whose global function
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;;    the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;;    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.
+;;;
+;;; 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
+;;; passed as a more arg.  Variable is true if there are a variable number of
+;;; arguments passed on the stack.  Variable cannot be specified with :Tail
+;;; return.  TR variable argument call is implemented separately.
+;;;
+;;; When variable is false, the compiler actually has already invoked VOP's to
+;;; explicitly move arguments into their passing locations.  Hence the VOP
+;;; argument args (which is :more t) is actually ignored.  We pass it into the
+;;; call VOP's for lifetime analysis, and the TN references it represents stand
+;;; in at the call site for the references to those TN's where the callee
+;;; actually reads them.
+;;;
+;;; In tail call with fixed arguments, the passing locations are passed as a
+;;; more arg, but there is no new-FP, since the arguments have been set up in
+;;; the current frame.
+;;;
+(eval-when (compile eval)
+(defmacro define-full-call (name named return variable)
+  (assert (not (and variable (eq return :tail))))
+  `(define-vop (,name
+		,@(when (eq return :unknown)
+		    '(unknown-values-receiver)))
+     (:args
+      ,@(unless (eq return :tail)
+	  '((new-fp :scs (word-pointer-reg) :to :eval)))
+
+      ,(if named
+	   '(name :scs (descriptor-reg) :target name-pass)
+	   '(arg-fun :scs (descriptor-reg) :target lexenv))
+      
+      ,@(when (eq return :tail)
+	  '((old-fp :scs (word-pointer-reg) :target old-fp-pass)
+	    (return-pc :scs (descriptor-reg) :target return-pc-pass)))
+      
+      ,@(unless variable '((args :more t))))
+
+     ,@(when (eq return :fixed)
+	 '((:results (values :more t))))
+   
+     ,@(unless (eq return :tail)
+	 `((:save-p t)
+	   ,@(unless variable
+	       '((:move-args :full-call)))))
+
+     (:vop-var vop)
+     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
+	    ,@(unless variable '(nargs))
+	    ,@(when (eq return :fixed) '(nvals)))
+
+     (:ignore
+      ,@(unless (or variable (eq return :tail)) '(arg-locs))
+      ,@(unless variable '(args)))
+
+     (:temporary (:sc descriptor-reg
+		  :offset ocfp-offset
+		  :from (:argument 1)
+		  :to :eval)
+		 old-fp-pass)
+
+     (:temporary (:sc descriptor-reg
+		  :offset lra-offset
+		  :from (:argument ,(if (eq return :tail) 2 1))
+		  :to :eval)
+		 return-pc-pass)
+
+     ,@(if named
+	 `((:temporary (:sc descriptor-reg :offset cname-offset
+			:from (:argument ,(if (eq return :tail) 0 1))
+			:to :eval)
+		       name-pass))
+
+	 `((:temporary (:sc descriptor-reg :offset lexenv-offset
+			:from (:argument ,(if (eq return :tail) 0 1))
+			:to :eval)
+		       lexenv)
+	   (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+		       function)))
+
+
+     (:temporary (:sc descriptor-reg :offset nargs-offset :to :eval)
+		 nargs-pass)
+
+     ,@(when variable
+	 (mapcar #'(lambda (name offset)
+		     `(:temporary (:sc descriptor-reg
+				   :offset ,offset
+				   :to :eval)
+			 ,name))
+		 register-arg-names register-arg-offsets))
+     ,@(when (eq return :fixed)
+	 '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+
+     ,@(unless (eq return :tail)
+	 '((:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+
+     (:temporary (:scs (interior-reg) :type interior) lip)
+
+     (:generator ,(+ (if named 5 0)
+		     (if variable 19 1)
+		     (if (eq return :tail) 0 10)
+		     15
+		     (if (eq return :unknown) 25 0))
+       
+       (let ((cur-nfp (current-nfp-tn vop))
+	     ,@(unless (eq return :tail)
+		 '((lra-label (gen-label)))))
+
+	 ,@(if variable
+	       ;; Compute the number of arguments and move some of the arguments
+	       ;; from the stack to the argument registers.
+	       `((move nargs-pass csp-tn)
+		 ;; This computes a byte difference, but due to the number of
+		 ;; bytes per word and out fixnum tags, this leaves a fixnum
+		 ;; word count for the callee.
+		 (inst s nargs-pass new-fp)
+		 ,@(let ((index -1))
+		     (mapcar #'(lambda (name)
+				 `(loadw ,name new-fp ,(incf index)))
+			     register-arg-names)))
+	       `((inst li nargs-pass (fixnum nargs))))
+ 
+
+	 ,@(unless (eq return :tail)
+	     `((inst compute-lra-from-code
+		     return-pc-pass code-tn lra-label)))
+
+	 ,@(if named
+	       `((move name-pass name)
+		 (loadw lip name-pass vm:symbol-raw-function-addr-slot
+			vm:other-pointer-type))
+	       `((move lexenv arg-fun)
+		 (loadw function lexenv vm:closure-function-slot
+			vm:function-pointer-type)
+		 (inst cal lip function (- (ash vm:function-header-code-offset
+						vm:word-shift)
+					   vm:function-pointer-type))))
+
+	 ,@(if (eq return :tail)
+	       '((move old-fp-pass old-fp)
+		 (move return-pc-pass return-pc)
+		 (when cur-nfp
+		   (inst cal nsp-tn cur-nfp
+			 (component-non-descriptor-stack-usage)))
+		 (inst b lip))
+	       `((move old-fp-pass cfp-tn)
+		 (when cur-nfp
+		   (store-stack-tn cur-nfp nfp-save))
+		 ,(if variable
+		      '(move cfp-tn new-fp)
+		      '(if (> nargs register-arg-count)
+			   (move cfp-tn new-fp)
+			   (move cfp-tn csp-tn)))
+		 (inst b lip)
+		 (emit-return-pc lra-label)))
+
+	 ,@(ecase return
+	     (:fixed
+	      '((note-this-location vop :unknown-return)
+		(default-unknown-values values nvals move-temp lra-label)
+		(when cur-nfp
+		  (load-stack-tn cur-nfp nfp-save))))
+	     (:unknown
+	      '((note-this-location vop :unknown-return)
+		(receive-unknown-values values-start nvals start count
+					lra-label)
+		(when cur-nfp
+		  (load-stack-tn cur-nfp nfp-save))))
+	     (:tail))))))
+) ;EVAL-WHEN
+
+(define-full-call call nil :fixed nil)
+(define-full-call call-named t :fixed nil)
+(define-full-call multiple-call nil :unknown nil)
+(define-full-call multiple-call-named t :unknown nil)
+(define-full-call tail-call nil :tail nil)
+(define-full-call tail-call-named t :tail nil)
+
+(define-full-call call-variable nil :fixed t)
+(define-full-call multiple-call-variable nil :unknown t)
+
+
+;;; Defined separately, since needs special code that BLT's the arguments
+;;; down.
+;;;
+(define-vop (tail-call-variable)
+  (:args (args-arg :scs (word-pointer-reg) :target args)
+	 (function-arg :scs (descriptor-reg) :target lexenv)
+	 (old-fp-arg :scs (word-pointer-reg) :target old-fp)
+	 (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 ocfp-offset :from (:argument 2)) old-fp)
+  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
+  (:temporary (:scs (any-reg) :from :eval) temp)
+  (:vop-var vop)
+  (:generator 75
+    ;; 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 lra lra-arg)
+
+    ;; Clear the number stack if anything is there.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst cal nsp-tn cur-nfp
+	      (component-non-descriptor-stack-usage))))
+
+    ;; And jump to the assembly-routine that moves the arguments for us.
+    (inst bala (make-fixup 'really-tail-call-variable :assembly-routine))))
+
+
+
+;;;; Unknown values return:
+
+
+;;; Do unknown-values return of a fixed number of values.  The Values are
+;;; required to be set up in the standard passing locations.  Nvals is the
+;;; number of values returned.
+;;;
+;;; If returning a single value, then deallocate the current frame, restore
+;;; FP and jump to the single-value entry at Return-PC + 4.
+;;;
+;;; If returning other than one value, then load the number of values returned,
+;;; NIL out unsupplied values registers, restore FP and return at Return-PC.
+;;; When there are stack values, we must initialize the argument pointer to
+;;; point to the beginning of the values block (which is the beginning of the
+;;; current frame.)
+;;;
+(define-vop (return)
+  (:args
+   (old-fp :scs (word-pointer-reg))
+   (return-pc :scs (descriptor-reg) :to (:eval 1))
+   (values :more t))
+  (:ignore values)
+  (:info nvals)
+  (:temporary (:sc any-reg :offset a0-offset :from (:eval 0) :to (:eval 1))
+	      a0)
+  (:temporary (:sc any-reg :offset a1-offset :from (:eval 0) :to (:eval 1))
+	      a1)
+  (:temporary (:sc any-reg :offset a2-offset :from (:eval 0) :to (:eval 1))
+	      a2)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:vop-var vop)
+  (:generator 6
+    (cond ((= nvals 1)
+	   ;; Clear the stacks.
+	   (let ((cur-nfp (current-nfp-tn vop)))
+	     (when cur-nfp
+	       (inst cal nsp-tn cur-nfp
+		     (component-non-descriptor-stack-usage))))
+	   (move csp-tn cfp-tn)
+	   ;; Reset the frame pointer.
+	   (move cfp-tn old-fp)
+	   ;; Out of here.
+	   ;; The return-pc (LRA) has other-pointer lowtag bits.  Also, in the
+	   ;; instruction sequence in which the LRA points, there is a header
+	   ;; word with immediate data indicating the offset back to the
+	   ;; beginning of the component.  The calling convention says to
+	   ;; return one word past the return point when the returner knows
+	   ;; it has only one value, so we skip that word here and the header
+	   ;; for the LRA.
+	   (inst cal lip return-pc (- (* 2 word-bytes) other-pointer-type))
+	   (inst bx lip)
+	   (move code-tn return-pc))
+	  (t
+	   (inst li nargs (fixnum nvals))
+	   ;; Clear the number stack.
+	   (let ((cur-nfp (current-nfp-tn vop)))
+	     (when cur-nfp
+	       (inst cal nsp-tn cur-nfp
+		     (component-non-descriptor-stack-usage))))
+	   (move val-ptr cfp-tn)
+	   ;; Reset the frame pointer.
+	   (move cfp-tn old-fp)
+	   
+	   (let ((immediate (* nvals word-bytes)))
+	     (assert (typep immediate '(signed-byte 16)))
+	     (inst cal csp-tn val-ptr immediate))
+	   
+	   (when (< nvals 1) (move a0 null-tn))
+	   (when (< nvals 2) (move a1 null-tn))
+	   (when (< nvals 3) (move a2 null-tn))
+	   
+	   (lisp-return return-pc lip)))))
+
+;;; RETURN-MULTIPLE -- VOP.
+;;;
+;;; Do unknown-values return of an arbitrary number of values (passed on the
+;;; stack.)  We check for the common case of a single return value, and do that
+;;; inline using the normal single value return convention.  Otherwise, we
+;;; branch off to an assembler routine.
+;;;
+;;; The Return-Multiple miscop uses a non-standard calling convention.  For one
+;;; thing, it doesn't return.  We only use BALA because there isn't a BA
+;;; instruction.   Also, we don't use A0..A2 for argument passing, since the
+;;; miscop will want to load these with values off of the stack.  Instead, we
+;;; pass Old-Fp, Start and Count in the normal locations for these values.
+;;; Return-PC is passed in A3 since PC is trashed by the BALA. 
+;;;
+(define-vop (return-multiple)
+  (:args
+   (ocfp-arg :scs (word-pointer-reg) :target ocfp)
+   (lra-arg :scs (descriptor-reg) :target lra)
+   (vals-arg :scs (word-pointer-reg) :target vals)
+   (nvals-arg :scs (any-reg) :target nvals))
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) ocfp)
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
+  (:temporary (:sc any-reg :offset cname-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)
+  (:vop-var vop)
+  (:generator 13
+    (let ((not-single (gen-label)))
+      ;; Clear the number stack.
+      (let ((cur-nfp (current-nfp-tn vop)))
+	(when cur-nfp
+	  (inst cal nsp-tn cur-nfp
+		(component-non-descriptor-stack-usage))))
+      
+      ;; Single case?
+      (inst c nvals-arg (fixnum 1))
+      (inst bnc :eq not-single)
+      
+      ;; Return with one value.
+      (loadw a0 vals-arg)
+      (move csp-tn cfp-tn)
+      (move cfp-tn ocfp-arg)
+      (lisp-return lra-arg lip :offset 1)
+      
+      ;; Nope, not the single case.
+      (emit-label not-single)
+      
+      ;; Load the register args, bailing out when we are done.
+      (move ocfp ocfp-arg)
+      (move lra lra-arg)
+      (move vals vals-arg)
+      (move nvals nvals-arg)
+      (inst bala (make-fixup 'really-return-multiple :assembly-routine)))))
+
+;;; COMPONENT-NON-DESCRIPTOR-STACK-USAGE -- Internal.
+;;;
+;;; This returns the non-descriptor stack usage in bytes for the component on
+;;; which the compiler is currently working.
+;;;
+;;; On the MIPS, the stack must be dual-word aligned since it is also the C
+;;; call stack.
+;;;
+;;; We're going to make the same assumption on the RT, but we don't even know
+;;; why this is true on the MIPS.
+;;;
+(defun component-non-descriptor-stack-usage ()
+  (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
+     vm:word-bytes))
+
+
+
+;;;; XEP hackery:
+
+
+;;; We don't need to do any special setup for regular functions.
+;;;
+(define-vop (setup-environment)
+  (:info label)
+  (:generator 5))
+
+;;; Extract the closure from the passing location (LEXENV).
+;;;
+(define-vop (setup-closure-environment)
+  (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
+	       :to (:result 0))
+	      lexenv)
+  (:results (closure :scs (descriptor-reg)))
+  (:info label)
+  (:generator 6
+    ;; Get result.
+    (move closure lexenv)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments. 
+;;;
+;;; We wire the temporaries to make sure they do not interfere with any of
+;;; special registers used during full-call, because we do not have acurate
+;;; lifetime info about them at the time this vop is used.
+;;; 
+(define-vop (copy-more-arg)
+  (:temporary (:sc descriptor-reg :offset cname-offset) temp)
+  (:info fixed)
+  (:generator 20
+    (let ((do-more-args (gen-label))
+	  (done-more-args (gen-label)))
+      (inst c nargs-tn (fixnum fixed))
+      (inst bc :gt do-more-args)
+      (assemble (*elsewhere*)
+	(emit-label do-more-args)
+	;; Jump to assembler routine passing fixed at cname-offset.
+	(inst li temp (fixnum fixed))
+	(inst bala (make-fixup 'really-copy-more-args :assembly-routine))
+	(inst b done-more-args))
+      (emit-label done-more-args))))
+
+
+;;; 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))
+
+
+;;; Turn more arg (context, count) into a list.
+;;;
+(define-vop (listify-rest-args)
+  (:args (context-arg :target context :scs (descriptor-reg))
+	 (count-arg :target count :scs (any-reg)))
+  (:arg-types * tagged-num)
+  (:temporary (:scs (word-pointer-reg) :from (:argument 0)) context)
+  (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst)
+  (:temporary (:scs (any-reg) :from (:argument 1)) count)
+  (:temporary (:scs (word-pointer-reg) :from :eval) alloc)
+  (:temporary (:scs (descriptor-reg) :from :eval) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:translate %listify-rest-args)
+  (:policy :safe)
+  (:generator 20
+    (let ((enter (gen-label))
+	  (loop (gen-label))
+	  (done (gen-label)))
+      (move context context-arg)
+      (move count count-arg)
+      ;; Check to see if there are any arguments.
+      (inst c count 0)
+      (inst bcx :eq done)
+      (move result null-tn)
+
+      ;; We need to do this atomically.
+      (pseudo-atomic (ndescr)
+	(load-symbol-value alloc *allocation-pointer*)
+	;; Allocate a cons (2 words) for each item.
+	(inst cal result alloc vm:list-pointer-type)
+	(move dst result)
+	(inst cas alloc count alloc)
+	(inst cas alloc count alloc)
+	(inst bx enter)
+	(store-symbol-value alloc *allocation-pointer*)
+
+	;; Store the current cons in the cdr of the previous cons.
+	(emit-label loop)
+	(storew dst dst -1 vm:list-pointer-type)
+
+	;; Grab one value and stash it in the car of this cons.
+	(emit-label enter)
+	(loadw temp context)
+	(inst inc context vm:word-bytes)
+	(storew temp dst 0 vm:list-pointer-type)
+
+	;; Dec count, and if != zero, go back for more.
+	(inst s count (fixnum 1))
+	(inst bncx :eq loop)
+	(inst inc dst (* 2 vm:word-bytes))
+
+	;; NIL out the last cons.
+	(storew null-tn dst -1 vm:list-pointer-type))
+      (emit-label done))))
+
+
+
+;;; Return the location and size of the more arg glob created by Copy-More-Arg.
+;;; Supplied is the total number of arguments supplied (originally passed in
+;;; NARGS.)  Fixed is the number of non-rest arguments.
+;;;
+;;; We must duplicate some of the work done by Copy-More-Arg, since at that
+;;; time the environment is in a pretty brain-damaged state, preventing this
+;;; info from being returned as values.  What we do is compute
+;;; supplied - fixed, and return a pointer that many words below the current
+;;; stack top.
+;;;
+(define-vop (more-arg-context)
+  (:args (supplied :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info fixed)
+  (:results
+   (context :scs (descriptor-reg))
+   (count :scs (any-reg)))
+  (:generator 5
+    (inst s count supplied (fixnum fixed))
+    (move context csp-tn)
+    (inst s context count)))
+
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+(define-vop (verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (inst c nargs (fixnum count))
+      (inst bnc :eq err-lab))))
+
+;;; Signal an argument count error.
+;;;
+(macrolet ((frob (name error &rest args)
+	     `(define-vop (,name)
+		(:args ,@(mapcar #'(lambda (arg)
+				     `(,arg :scs (any-reg descriptor-reg)))
+				 args))
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1000
+		  (error-call vop ,error ,@args)))))
+  (frob argument-count-error invalid-argument-count-error nargs)
+  (frob type-check-error object-not-type-error object type)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error key))
diff --git a/compiler/rt/cell.lisp b/compiler/rt/cell.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e617d9e8609392c5f3120014ddcd55270011fa9d
--- /dev/null
+++ b/compiler/rt/cell.lisp
@@ -0,0 +1,337 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/cell.lisp,v 1.1 1991/02/18 15:07:46 chiles Exp $
+;;;
+;;; This file contains the VM definition of various primitive memory access
+;;; VOPs for the IBM RT.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Data object definition macros.
+
+(vm:define-for-each-primitive-object (obj)
+  (collect ((forms))
+    (let ((lowtag (vm:primitive-object-lowtag obj)))
+      (dolist (slot (vm:primitive-object-slots obj))
+	(let* ((name (vm:slot-name slot))
+	       (offset (vm:slot-offset slot))
+	       (rest-p (vm:slot-rest-p slot))
+	       (slot-opts (vm:slot-options slot))
+	       (ref-trans (getf slot-opts :ref-trans))
+	       (ref-vop (getf slot-opts :ref-vop ref-trans))
+	       (set-trans (getf slot-opts :set-trans))
+	       (setf-function-p (and (listp set-trans)
+				     (= (length set-trans) 2)
+				     (eq (car set-trans) 'setf)))
+	       (setf-vop (getf slot-opts :setf-vop
+			       (when setf-function-p
+				 (intern (concatenate
+					  'simple-string
+					  "SET-"
+					  (string (cadr set-trans)))))))
+	       (set-vop (getf slot-opts :set-vop
+			      (if setf-vop nil set-trans))))
+	  (when ref-vop
+	    (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
+				(:variant ,offset ,lowtag)
+		      ,@(when ref-trans
+			  `((:translate ,ref-trans))))))
+	  (when (or set-vop setf-vop)
+	    (forms `(define-vop ,(cond ((and rest-p setf-vop)
+					(error "Can't automatically generate ~
+					a setf VOP for :rest-p ~
+					slots: ~S in ~S"
+					       name
+					       (vm:primitive-object-name obj)))
+				       (rest-p `(,set-vop slot-set))
+				       ((and set-vop setf-function-p)
+					(error "Setf functions (list ~S) must ~
+					use :setf-vops."
+					       set-trans))
+				       (set-vop `(,set-vop cell-set))
+				       (setf-function-p
+					`(,setf-vop cell-setf-function))
+				       (t
+					`(,setf-vop cell-setf)))
+		      (:variant ,offset ,lowtag)
+		      ,@(when set-trans
+			  `((:translate ,set-trans)))))))))
+    (when (forms)
+      `(progn
+	 ,@(forms)))))
+
+
+
+;;;; Symbol hacking VOPs:
+
+;;; CHECKED-CELL-REF -- VOP.
+;;;
+;;; Do a cell ref with an error check for being unbound.
+;;;
+(define-vop (checked-cell-ref)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (word-pointer-reg descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
+
+;;; SYMBOL-VALUE -- VOP.
+;;;
+;;; Check that the value isn't the trap object.
+;;;
+(define-vop (symbol-value checked-cell-ref)
+  (:translate symbol-value)
+  (:generator 9
+    (move obj-temp object)
+    (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type)
+    (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+      (inst c value vm:unbound-marker-type)
+      (inst bc :eq err-lab))))
+
+;;; SYMBOL-FUNCTION -- VOP.
+;;;
+;;; Check that the result is a function, so NIL is always un-fbound.
+;;;
+(define-vop (symbol-function checked-cell-ref)
+  (:translate symbol-function)
+  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:generator 10
+    (move obj-temp object)
+    (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+      (test-type value temp err-lab t vm:function-pointer-type))))
+
+
+;;; BOUNDP-FROB -- VOP.
+;;;
+;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
+;;;
+(define-vop (boundp-frob)
+  (:args (object :scs (descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:temporary (:scs (descriptor-reg)) value)
+  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
+
+(define-vop (boundp boundp-frob)
+  (:translate boundp)
+  (:generator 9
+    (loadw value object vm:symbol-value-slot vm:other-pointer-type)
+    (inst c value vm:unbound-marker-type)
+    (if not-p
+	;; If they're the same, symbol is unbound, so if not-p (the symbol is
+	;; bound), then go to target.
+	(inst bc :eq target)
+	(inst bnc :eq target))))
+
+
+;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction
+;;; on the symbol case of fboundp.  Instead, we transform to a funny function.
+
+(defknown fboundp/symbol (t) boolean (flushable))
+;;;
+(deftransform fboundp ((x) (symbol))
+  '(fboundp/symbol x))
+;;;
+(define-vop (fboundp/symbol boundp-frob)
+  (:translate fboundp/symbol)
+  (:generator 10
+    (loadw value object vm:symbol-function-slot vm:other-pointer-type)
+    (test-type value temp target not-p vm:function-pointer-type)))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant vm:symbol-value-slot vm:other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+(define-vop (fast-symbol-function cell-ref)
+  (:variant vm:symbol-function-slot vm:other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-function))
+
+(define-vop (set-symbol-function)
+  (:translate %sp-set-definition)
+  (:policy :fast-safe)
+  (:args (symbol :scs (descriptor-reg))
+	 (function :scs (descriptor-reg) :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) type)
+  (:temporary (:scs (any-reg)) temp)
+  (:save-p :compute-only)
+  (:vop-var vop)
+  (:generator 30
+    (let ((closure (gen-label))
+	  (normal-fn (gen-label)))
+      (load-type type function (- vm:function-pointer-type))
+      (inst c type vm:closure-header-type)
+      (inst bc :eq closure)
+      (inst c type vm:function-header-type)
+      (inst bcx :eq normal-fn)
+      (inst a temp function
+	    (- (ash vm:function-header-code-offset vm:word-shift)
+	       vm:function-pointer-type))
+      (error-call vop kernel:object-not-function-error function)
+      (emit-label closure)
+      (inst cai temp (make-fixup "closure_tramp" :foreign))
+      (emit-label normal-fn)
+      (storew function symbol vm:symbol-function-slot vm:other-pointer-type)
+      (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type)
+      (move result function))))
+
+
+(defknown fmakunbound/symbol (symbol) symbol (unsafe))
+;;;
+(deftransform fmakunbound ((symbol) (symbol))
+  '(progn
+     (fmakunbound/symbol symbol)
+     t))
+;;;
+(define-vop (fmakunbound/symbol)
+  (:translate fmakunbound/symbol)
+  (:policy :fast-safe)
+  (:args (symbol :scs (descriptor-reg) :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (sap-reg)) temp)
+  (:generator 5
+    (inst li temp vm:unbound-marker-type)
+    (storew temp symbol vm:symbol-function-slot vm:other-pointer-type)
+    (inst cai temp (make-fixup "undefined_tramp" :foreign))
+    (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type)
+    (move result symbol)))
+
+
+;;; Binding and Unbinding.
+
+;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (symbol :scs (descriptor-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (word-pointer-reg)) bsp)
+  (:generator 7
+    (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type)
+    (load-symbol-value bsp *binding-stack-pointer*)
+    (inst inc bsp (* vm:binding-size vm:word-bytes))
+    (store-symbol-value bsp *binding-stack-pointer*)
+    (storew temp bsp (- vm:binding-value-slot vm:binding-size))
+    (storew symbol bsp (- vm:binding-symbol-slot vm:binding-size))
+    (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
+
+(define-vop (unbind)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:temporary (:scs (word-pointer-reg)) bsp)
+  (:generator 7
+    (load-symbol-value bsp *binding-stack-pointer*)
+    (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
+    (loadw value bsp (- vm:binding-value-slot vm:binding-size))
+    (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+    (inst li value 0)
+    (storew value bsp (- vm:binding-symbol-slot vm:binding-size))
+    (inst dec bsp (* vm:binding-size vm:word-bytes))
+    (store-symbol-value bsp *binding-stack-pointer*)))
+
+(define-vop (unbind-to-here)
+  (:args (arg :scs (descriptor-reg any-reg) :target where))
+  (:temporary (:scs (any-reg) :from (:argument 0)) where)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:temporary (:scs (word-pointer-reg)) bsp)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (skip (gen-label))
+	  (done (gen-label)))
+      (move where arg)
+      (load-symbol-value bsp *binding-stack-pointer*)
+      (inst c where bsp)
+      (inst bc :eq done)
+      (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
+
+      (emit-label loop)
+      (inst c symbol 0)
+      (inst bc :eq skip)
+      (loadw value bsp (- vm:binding-value-slot vm:binding-size))
+      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+      (inst li value 0)
+      (storew value bsp (- vm:binding-symbol-slot vm:binding-size))
+
+      (emit-label skip)
+      (inst dec bsp (* vm:binding-size vm:word-bytes))
+      (store-symbol-value bsp *binding-stack-pointer*)
+      (inst c where bsp)
+      (inst bnc :eq loop)
+      (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
+
+      (emit-label done))))
+
+
+
+;;;; Closure indexing.
+
+(define-vop (closure-index-ref word-index-ref)
+  (:variant vm:closure-info-offset vm:function-pointer-type)
+  (:translate %closure-index-ref))
+
+
+
+;;;; Structure hackery:
+
+(define-vop (structure-length)
+  (: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 res struct 0 structure-pointer-type)
+    (inst sr res vm:type-bits)))
+
+(define-vop (structure-ref slot-ref)
+  (:variant structure-slots-offset structure-pointer-type)
+  (:policy :fast-safe)
+  (:translate structure-ref)
+  (:arg-types structure (:constant index)))
+
+(define-vop (structure-set slot-set)
+  (:policy :fast-safe)
+  (:translate structure-set)
+  (: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-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 *))
+
+
+
+;;;; Extra random indexers.
+
+(define-vop (code-constant-set word-index-set)
+  (:variant vm:code-constants-offset vm:other-pointer-type))
+
diff --git a/compiler/rt/char.lisp b/compiler/rt/char.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0193fb267acc6d94f536d69c55459bd868b4c23b
--- /dev/null
+++ b/compiler/rt/char.lisp
@@ -0,0 +1,157 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/char.lisp,v 1.1 1991/02/18 15:07:48 chiles Exp $
+;;; 
+;;; This file contains the RT VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Moves and coercions:
+
+;;; MOVE-TO-BASE-CHARACTER -- VOP.
+;;;
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-character)
+  (:args (x :scs (any-reg descriptor-reg) :target y))
+  (:arg-types base-character)
+  (:results (y :scs (base-character-reg)))
+  (:generator 1
+    (move y x)
+    (inst sr y vm:type-bits)))
+;;;
+(define-move-vop move-to-base-character :move
+  (any-reg descriptor-reg) (base-character-reg))
+
+
+;;; MOVE-FROM-BASE-CHARACTER -- VOP.
+;;;
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-character)
+  (:args (x :scs (base-character-reg) :target temp))
+  (:temporary (:scs (base-character-reg) :from (:argument 0)) temp)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:result-types base-character)
+  (:generator 1
+    (move temp x)
+    (inst sl temp vm:type-bits)
+    (inst oil y temp vm:base-character-type)))
+;;;
+(define-move-vop move-from-base-character :move
+  (base-character-reg) (any-reg descriptor-reg))
+
+;;; BASE-CHARACTER-MOVE -- VOP.
+;;;
+;;; Move untagged base-character values.
+;;;
+(define-vop (base-character-move)
+  (:args (x :target y
+	    :scs (base-character-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (base-character-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop base-character-move :move
+  (base-character-reg) (base-character-reg))
+
+
+;;; MOVE-BASE-CHARACTER-ARGUMENT -- VOP.
+;;;
+;;; Move untagged base-character arguments/return-values.
+;;;
+(define-vop (move-base-character-argument)
+  (:args (x :target y
+	    :scs (base-character-reg))
+	 (fp :scs (word-pointer-reg)
+	     :load-if (not (sc-is y base-character-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (base-character-reg
+       (move y x))
+      (base-character-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-base-character-argument :move-argument
+  (any-reg base-character-reg) (base-character-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-character
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (base-character-reg) (any-reg descriptor-reg))
+
+
+
+;;;; Other operations:
+
+;;; CHAR-CODE -- VOP.
+;;;
+;;; This assumes it is best to keep characters in their raw representation.
+;;;
+(define-vop (char-code)
+  (:translate char-code)
+  (:policy :fast-safe)
+  (:args (ch :scs (base-character-reg) :target temp))
+  (:arg-types base-character)
+  (:temporary (:scs (base-character-reg)
+		    :from (:argument 0) :to (:result 0)
+		    :target res) temp)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (move temp ch)
+    (inst sl temp 2)
+    (move res temp)))
+
+;;; CODE-CHAR -- VOP.
+;;;
+(define-vop (code-char)
+  (:translate code-char)
+  (:policy :fast-safe)
+  (:args (code :scs (any-reg) :target res))
+  (:arg-types positive-fixnum)
+  (:results (res :scs (base-character-reg)))
+  (:result-types base-character)
+  (:generator 1
+    (move res code)
+    (inst sr res 2)))
+
+
+
+;;; Comparison of base-characters.
+;;;
+(define-vop (base-character-compare pointer-compare)
+  (:args (x :scs (base-character-reg))
+	 (y :scs (base-character-reg)))
+  (:arg-types base-character base-character))
+
+(define-vop (fast-char=/base-character base-character-compare)
+  (:translate char=)
+  (:variant :eq))
+
+(define-vop (fast-char</base-character base-character-compare)
+  (:translate char<)
+  (:variant :lt))
+
+(define-vop (fast-char>/base-character base-character-compare)
+  (:translate char>)
+  (:variant :gt))
diff --git a/compiler/rt/debug.lisp b/compiler/rt/debug.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b300603df4d26e534d7ef325a4ce390258ba5d09
--- /dev/null
+++ b/compiler/rt/debug.lisp
@@ -0,0 +1,99 @@
+;;; -*- Package: RT; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/debug.lisp,v 1.1 1991/02/18 15:07:50 chiles Exp $
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;; Converted to RT by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+(defknown di::current-sp () system-area-pointer (movable flushable))
+(defknown di::current-fp () system-area-pointer (movable flushable))
+(defknown di::stack-ref (system-area-pointer index) t (flushable))
+(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
+(defknown di::lra-code-header (t) t (movable flushable))
+(defknown di::function-code-header (t) t (movable flushable))
+(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
+(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
+
+(define-vop (debug-cur-sp)
+  (:translate di::current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res csp-tn)))
+
+(define-vop (debug-cur-fp)
+  (:translate di::current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res cfp-tn)))
+
+
+(define-system-ref read-control-stack 2 di::stack-ref descriptor-reg *)
+
+(define-system-set write-control-stack 2 di::%set-stack-ref (descriptor-reg) *)
+
+
+(define-vop (code-from-mumble)
+  (:policy :fast-safe)
+  (:args (thing :scs (descriptor-reg) :target code))
+  (:results (code :scs (descriptor-reg)))
+  (:temporary (:scs (sap-reg)) temp)
+  (:variant-vars lowtag)
+  (:generator 5
+    (let ((bogus (gen-label))
+	  (done (gen-label)))
+      (loadw temp thing 0 lowtag)
+      (inst sr temp vm:type-bits)
+      (inst bc :eq bogus)
+      (inst sl temp (1- (integer-length vm:word-bytes)))
+      (unless (= lowtag vm:other-pointer-type)
+	(inst cal temp temp (- lowtag vm:other-pointer-type)))
+      (move code thing)
+      (inst s code temp)
+      (emit-label done)
+      (assemble (*elsewhere*)
+	(emit-label bogus)
+	(inst bx done)
+	(move code null-tn)))))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate di::lra-code-header)
+  (:variant vm:other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate di::function-code-header)
+  (:variant vm:function-pointer-type))
+
+(define-vop (di::make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate di::make-lisp-obj)
+  (:args (value :scs (unsigned-reg) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 1
+    (move result value)))
+
+(define-vop (di::get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate di::get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg) :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result thing)))
diff --git a/compiler/rt/insts.lisp b/compiler/rt/insts.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b9f61b66c986d55d121c0fe2656245594b43a019
--- /dev/null
+++ b/compiler/rt/insts.lisp
@@ -0,0 +1,779 @@
+;;; -*- Package: RT -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; Description of the IBM RT instruction set.
+;;;
+;;; Written by William Lott and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+(use-package "ASSEM")
+(use-package "EXT")
+
+
+
+;;;; Formats.
+
+(define-format (j1 16)
+  (op (byte 4 12))
+  (sub-op (byte 1 11))
+  (n (byte 3 8))
+  (j1 (byte 8 0)))
+
+(define-format (x 16)
+  (op (byte 4 12))
+  (r1 (byte 4 8))
+  (r2 (byte 4 4))
+  (r3 (byte 4 0)))
+
+(define-format (d-short 16)
+  (op (byte 4 12))
+  (i (byte 4 8))
+  (r2 (byte 4 4))
+  (r3 (byte 4 0)))
+
+(define-format (r 16)
+  (op (byte 8 8))
+  (r2 (byte 4 4))
+  (r3 (byte 4 0)))
+
+(define-format (bi 32)
+  (op (byte 8 24))
+  (r2 (byte 4 20))
+  (bi (byte 20 0)))
+
+(define-format (ba 32)
+  (op (byte 8 24))
+  (ba (byte 24 0)))
+
+(define-format (d 32)
+  (op (byte 8 24))
+  (r2 (byte 4 20))
+  (r3 (byte 4 16))
+  (i (byte 16 0)))
+
+
+
+;;;; Special argument types and fixups.
+
+(define-argument-type register
+  :type '(satisfies (lambda (object)
+		      (and (tn-p object)
+			   (or (eq (sc-name (tn-sc object)) 'null)
+			       (eq (sb-name (sc-sb (tn-sc object)))
+				   'registers)))))
+  :function (lambda (tn)
+	      (case (sc-name (tn-sc tn))
+		(null null-offset)
+		(t (tn-offset tn)))))
+
+(defun address-register-p (object)
+  (and (tn-p object)
+       (not (zerop (tn-offset object)))
+       (eq (sb-name (sc-sb (tn-sc object))) 'registers)))
+
+(define-argument-type address-register
+  :type '(satisfies address-register-p)
+  :function tn-offset)
+
+
+;;; LABEL-OFFSET -- Internal.
+;;;
+;;; This uses assem:*current-position* and the label's position to compute
+;;; the bits that an instructions immediate field wants.
+;;;
+(defun label-offset (label)
+  (ash (- (label-position label) *current-position*) -1))
+
+(define-argument-type relative-label
+  :type 'label
+  :function label-offset)
+
+
+(defun jump-condition-value (cond)
+  (ecase cond
+    (:pz #b000)
+    (:lt #b001)
+    (:eq #b010)
+    (:gt #b011)
+    (:c0 #b100)
+    (:ov #b110)
+    (:tb #b111)))
+
+(define-argument-type jump-condition
+  :type '(member :pz :lt :eq :gt :c0 :ov :tb)
+  :function jump-condition-value)
+
+(defun branch-condition-value (cond)
+  (ecase cond
+    (:pz #b1000)
+    (:lt #b1001)
+    (:eq #b1010)
+    (:gt #b1011)
+    (:c0 #b1100)
+    (:ov #b1110)
+    (:tb #b1111)))
+
+(define-argument-type branch-condition
+  :type '(member :pz :lt :eq :gt :c0 :ov :tb)
+  :function branch-condition-value)
+
+
+(define-fixup-type :ba) ;branch-absolute.
+(define-fixup-type :cau)
+(define-fixup-type :cal)
+
+
+
+;;;; Loading and storing.
+
+;;; load-character.
+;;;
+(define-instruction (lc)
+  (d-short (op :constant 4)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   (i :argument (unsigned-byte 4)))
+  (d-short (op :constant 4)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   (i :constant 0))
+  (d (op :constant #xCE)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16))))
+
+;;; store-character.
+;;;
+(define-instruction (stc)
+  (d-short (op :constant 1)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   (i :argument (unsigned-byte 4)))
+  (d-short (op :constant 1)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   (i :constant 0))
+  (d (op :constant #xDE)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16))))
+
+;;; load-half.
+;;;
+(define-instruction (lh)
+  (d (op :constant #xDA)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16)))
+  (r (op :constant #xEB)
+     (r2 :argument register)
+     (r3 :argument register)))
+
+;;; load-half-algebraic.
+;;;
+(define-instruction (lha)
+  (d (op :constant #xCA)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16)))
+  (d-short (op :constant 5)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   ;; We want the instruction to take byte indexes, but we plug the
+	   ;; index into the instruction as a half-word index.
+	   (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+	      :function (lambda (x) (ash x -1)))))
+
+;;; store-half.
+;;;
+(define-instruction (sth)
+  (d-short (op :constant 2)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   ;; We want the instruction to take byte indexes, but we plug the
+	   ;; index into the instruction as a half-word index.
+	   (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+	      :function (lambda (x) (ash x -1))))
+  (d (op :constant #xDC)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16))))
+
+;;; load-word.
+;;;
+(define-instruction (l)
+  (d-short (op :constant 7)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   ;; We want the instruction to take byte indexes, but we plug the
+	   ;; index into the instruction as a word index.
+	   (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60)
+	      :function (lambda (x) (ash x -2))))
+  (d-short (op :constant 7)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   (i :constant 0))
+  (d (op :constant #xCD)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16))))
+
+;;; store-word.
+;;;
+(define-instruction (st)
+  (d-short (op :constant 3)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   ;; We want the instruction to take byte indexes, but we plug the
+	   ;; index into the instruction as a word index.
+	   (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60)
+	      :function (lambda (x) (ash x -2))))
+  (d-short (op :constant 3)
+	   (r2 :argument register)
+	   (r3 :argument address-register)
+	   (i :constant 0))
+  (d (op :constant #xDD)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16))))
+
+
+
+;;;; Address computation.
+
+;;; compute-address-lower-half.
+;;;
+;;; The second format can be used for load-immediate (signed-byte 16).
+;;;
+(define-instruction (cal)
+  (d (op :constant #xC8)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (signed-byte 16)))
+  (d (op :constant #xC8)
+     (r2 :argument register)
+     (r3 :constant 0)
+     (i :argument (signed-byte 16)))
+  (d (op :constant #xC8)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument cal-fixup)))
+
+;;; compute-address-lower-half-16bit.
+;;;
+;;; The second format can be used for load-immediate (unsigned-byte 16).
+;;;
+(define-instruction (cal16)
+  (d (op :constant #xC2)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (unsigned-byte 16)))
+  (d (op :constant #xC2)
+     (r2 :argument register)
+     (r3 :constant 0)
+     (i :argument (unsigned-byte 16))))
+
+;;; compute-address-upper-half.
+;;;
+(define-instruction (cau)
+  (d (op :constant #xD8)
+     (r2 :argument register)
+     (r3 :argument address-register)
+     (i :argument (unsigned-byte 16)))
+  (d (op :constant #xD8)
+     (r2 :argument register)
+     (r3 :constant 0)
+     (i :argument (unsigned-byte 16)))
+  (d (op :constant #xD8)
+     (r2 :argument register)
+     (r3 :constant 0)
+     (i :argument cau-fixup)))
+
+;;; compute-address-short.
+;;;
+;;; Use the second flavor to copy registers.
+;;;
+(define-instruction (cas)
+  (x (op :constant 6)
+     (r1 :argument register)
+     (r2 :argument register)
+     (r3 :argument address-register))
+  (x (op :constant 6)
+     (r1 :argument register)
+     (r2 :argument register)
+     (r3 :constant 0)))
+
+;;; increment.
+;;;
+(define-instruction (inc)
+  (r (op :constant 91)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4))))
+
+;;; decrement
+;;;
+(define-instruction (dec)
+  (r (op :constant 93)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4))))
+
+
+;;; load-immediate-short.
+;;;
+(define-instruction (lis)
+  (r (op :constant #xA4)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4))))
+
+
+
+;;;; Arithmetics.
+
+(macrolet ((define-math-inst (name &key two-regs short-immediate immediate
+				   function (signed t))
+	     `(define-instruction (,name)
+		,@(when two-regs
+		    `((r (op :constant ,two-regs)
+			 (r2 :argument register)
+			 (r3 :argument register))
+		      (r (op :constant ,two-regs)
+			 (r2 :argument register)
+			 (r3 :same-as r2))))
+		,@(when short-immediate
+		    `((r (op :constant ,short-immediate)
+			 (r2 :argument register)
+			 (r3 :argument (unsigned-byte 4)))))
+		,@(when immediate
+		    `((d (op :constant ,immediate)
+			 (r2 :argument register)
+			 (r3 :argument register)
+			 (i :argument
+			    (,(if signed 'signed-byte 'unsigned-byte) 16)
+			    ,@(if function `(:function ,function))))
+		      (d (op :constant ,immediate)
+			 (r2 :argument register)
+			 (r3 :same-as r2)
+			 (i :argument
+			    (,(if signed 'signed-byte 'unsigned-byte) 16)
+			    ,@(if function `(:function ,function)))))))))
+
+  (define-math-inst a :two-regs #xE1 :short-immediate #x90 :immediate #xC1)
+  (define-math-inst ae :two-regs #xF1 :immediate #xD1)
+  (define-math-inst abs :two-regs #xE0)
+  (define-math-inst neg :two-regs #xE4) ;Arithmetic negation (two's complement).
+  (define-math-inst s :two-regs #xE2 :short-immediate #x92
+    :immediate #xC1 :function -)
+  (define-math-inst sf :two-regs #xB2 :immediate #xD2)
+  (define-math-inst se :two-regs #xF2)
+  (define-math-inst d :two-regs #xB6)
+  (define-math-inst m :two-regs #xE6)
+  
+  (define-math-inst exts :two-regs #xB1)
+  
+  (define-math-inst clrbl :short-immediate #x99)
+  (define-math-inst clrbu :short-immediate #x98)
+  (define-math-inst setbl :short-immediate #x9B)
+  (define-math-inst setbu :short-immediate #x9A)
+  
+  (define-math-inst not :two-regs #xF4) ;Logical not.
+  (define-math-inst n :two-regs #xE5)
+  (define-math-inst nilz :immediate #xC5 :signed nil)
+  (define-math-inst nilo :immediate #xC6 :signed nil)
+  (define-math-inst niuz :immediate #xD5 :signed nil)
+  (define-math-inst niuo :immediate #xD6 :signed nil)
+  (define-math-inst o :two-regs #xE3)
+  (define-math-inst oil :immediate #xC4 :signed nil)
+  (define-math-inst oiu :immediate #xC3 :signed nil)
+  (define-math-inst x :two-regs #xE7)
+  (define-math-inst xil :immediate #xC7 :signed nil)
+  (define-math-inst xiu :immediate #xD7 :signed nil)
+
+  (define-math-inst clz :two-regs #xF5)
+
+) ;macrolet
+
+
+;;; compare.
+;;; compare-immediate-short.
+;;; compare-immediate.
+;;;
+(define-instruction (c)
+  (r (op :constant #xB4)
+     (r2 :argument register)
+     (r3 :argument register))
+  (r (op :constant #x94)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4)))
+  (d (op :constant #xD4)
+     (r2 :constant 0)
+     (r3 :argument register)
+     (i :argument (signed-byte 16))))
+
+
+;;; compare-logical.
+;;; compare-logical-immediate.
+;;;
+(define-instruction (cl)
+  (r (op :constant #xB3)
+     (r2 :argument register)
+     (r3 :argument register))
+  (d (op :constant #xD3)
+     (r2 :constant 0)
+     (r3 :argument register)
+     (i :argument (signed-byte 16))))
+
+
+
+;;;; Shifting.
+
+(define-instruction (sr)
+  (r (op :constant #xB8)
+     (r2 :argument register)
+     (r3 :argument register))
+  (r (op :constant #xA8)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4)))
+  (r (op :constant #xA9)
+     (r2 :argument register)
+     (r3 :argument (integer 16 31)
+	 :function (lambda (x) (- x 16)))))
+
+(define-instruction (sl)
+  (r (op :constant #xBA)
+     (r2 :argument register)
+     (r3 :argument register))
+  (r (op :constant #xAA)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4)))
+  (r (op :constant #xAB)
+     (r2 :argument register)
+     (r3 :argument (integer 16 31)
+	 :function (lambda (x) (- x 16)))))
+
+(define-instruction (sar)
+  (r (op :constant #xB0)
+     (r2 :argument register)
+     (r3 :argument register))
+  (r (op :constant #xA0)
+     (r2 :argument register)
+     (r3 :argument (unsigned-byte 4)))
+  (r (op :constant #xA1)
+     (r2 :argument register)
+     (r3 :argument (integer 16 31)
+	 :function (lambda (x) (- x 16)))))
+
+
+
+;;;; Branch instructions.
+
+;;; There are some pseudo-instructions defined after this page that use these
+;;; definitions.
+;;;
+
+(define-instruction (jb)
+  (j1 (op :constant 0)
+      (sub-op :constant 1)
+      (n :argument jump-condition)
+      (j1 :argument relative-label)))
+
+(define-instruction (jnb)
+  (j1 (op :constant 0)
+      (sub-op :constant 0)
+      (n :argument jump-condition)
+      (j1 :argument relative-label)))
+
+(macrolet ((define-branch-inst (name immediate-op register-op)
+	     `(define-instruction (,name)
+		(bi (op :constant ,immediate-op)
+		    (r2 :argument branch-condition)
+		    (bi :argument relative-label))
+		(r (op :constant ,register-op)
+		   (r2 :argument branch-condition)
+		   (r3 :argument register)))))
+
+  ;; branch-on-condition-bit-immediate.
+  ;; branch-on-condition-bit-register.
+  ;;
+  (define-branch-inst bb #x8E #xEE)
+  
+  ;; branch-on-condition-bit-immediate-with-execute.
+  ;; branch-on-condition-bit-register-with-execute.
+  ;;
+  (define-branch-inst bbx #x8F #xEF)
+
+  ;; branch-on-not-condition-bit-immediate.
+  ;; branch-on-not-condition-bit-register.
+  ;;
+  (define-branch-inst bnb #x88 #xE8)
+
+  ;; branch-on-not-condition-bit-immediate-with-execute.
+  ;; branch-on-not-condition-bit-register-with-execute.
+  ;;
+  (define-branch-inst bnbx #x89 #xE9)
+
+) ;MACROLET
+
+(define-instruction (bala)
+  (ba (op :constant #x8A)
+      (ba :argument ba-fixup)))
+
+(define-instruction (balax)
+  (ba (op :constant #x8B)
+      (ba :argument ba-fixup)))
+
+
+
+;;;; Pseudo-instructions
+
+;;; move.
+;;;
+;;; This body is the second format of compute-address-short.
+;;;
+(define-instruction (move)
+  (x (op :constant 6)
+     (r1 :argument register)
+     (r2 :argument register)
+     (r3 :constant 0)))
+
+;;;
+;;; A couple load-immediate pseudo-instructions.
+;;;
+
+;;; load-immediate.
+;;;
+;;; This might affect the condition codes, but it allows for loading 32-bit
+;;; quantities into R0.
+;;;
+(define-pseudo-instruction li 64 (reg value)
+  (etypecase value
+    ((unsigned-byte 4)
+     (inst lis reg value))
+    ((signed-byte 16)
+     (inst cal reg value))
+    ((unsigned-byte 16)
+     (inst cal16 reg value))
+    ((or (signed-byte 32) (unsigned-byte 32))
+     (inst cau reg (ldb (byte 16 16) value))
+     (let ((low (ldb (byte 16 0) value)))
+       (unless (zerop low)
+	 (inst oil reg low))))))
+
+;;; compute-address-immediate.
+;;;
+;;; This basically exists to load 32-bit constants into address-registers, and
+;;; it does not affect condition codes.  Since fixups are always addresses, we
+;;; have the fixup branch here instead of in load-immediate.  We may use the
+;;; other branches since it already exists.
+;;;
+(define-pseudo-instruction cai 64 (reg value)
+  (etypecase value
+    ((unsigned-byte 4)
+     (inst lis reg value))
+    ((signed-byte 16)
+     (inst cal reg value))
+    ((unsigned-byte 16)
+     (inst cal16 reg value))
+    ((or (signed-byte 32) (unsigned-byte 32))
+     (inst cau reg (ldb (byte 16 16) value))
+     (let ((low (ldb (byte 16 0) value)))
+       (unless (zerop low)
+	 (inst cal16 reg reg low))))
+    (fixup
+     (inst cau reg value)
+     (inst cal reg reg value))))
+
+
+;;; branch-unconditional.
+;;;
+(define-pseudo-instruction b 32 (target)
+  (if (and (assem::label-p target)
+	   (<= -128 (label-offset target) 127))
+      (inst jnb :pz target)
+      (inst bnb :pz target)))
+
+;;; branch-unconditional-with-execute.
+;;;
+(define-pseudo-instruction bx 32 (target)
+  (inst bnbx :pz target))
+
+;;; branch-condition.
+;;;
+(define-pseudo-instruction bc 32 (condition target)
+  (if (and (assem::label-p target)
+	   (<= -128 (label-offset target) 127))
+      (inst jb condition target)
+      (inst bb condition target)))
+
+;;; branch-not-condition.
+;;;
+(define-pseudo-instruction bnc 32 (condition target)
+  (if (and (assem::label-p target)
+	   (<= -128 (label-offset target) 127))
+      (inst jnb condition target)
+      (inst bnb condition target)))
+
+;;; branch-condition-with-execute.
+;;; branch-not-condition-with-execute.
+;;;
+;;; We define these, so VOP readers see a consistent naming scheme in branch
+;;; instructions.
+;;;
+(define-pseudo-instruction bcx 32 (condition target)
+  (inst bbx condition target))
+;;;
+(define-pseudo-instruction bncx 32 (condition target)
+  (inst bnbx condition target))
+
+;;; no-op.
+;;;
+;;; This is compute-address-short, adding zero to R0 putting the result in R0.
+;;;
+(define-instruction (no-op)
+  (x (op :constant 6)
+     (r1 :constant 0)
+     (r2 :constant 0)
+     (r3 :constant 0)))
+
+(define-format (word-format 32)
+  (data (byte 32 0)))
+(define-instruction (word)
+  (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32)))))
+
+(define-format (short-format 16)
+  (data (byte 16 0)))
+(define-instruction (short)
+  (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16)))))
+
+(define-format (byte-format 8)
+  (data (byte 8 0)))
+(define-instruction (byte)
+  (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8)))))
+
+
+
+;;;; Breaking.
+
+;;; break.
+;;;
+;;; This is trap-on-condition-immediate.  We use the immediate field to
+;;; stick in a constant value indicating why we're breaking.
+;;;
+(define-instruction (break)
+  (d (op :constant #xCC)
+     (r2 :constant #b0111)
+     (r3 :constant 0)
+     (i :argument (signed-byte 16))))
+
+
+
+;;;; System control.
+
+;;; move-to-multiplier-quotient-system-control-register
+;;;
+(define-instruction (mtmqscr)
+  (r (op :constant #xB5)
+     (r2 :constant 10)
+     (r3 :argument register)))
+
+;;; move-from-multiplier-quotient-system-control-register
+;;;
+(define-instruction (mfmqscr)
+  (r (op :constant #x96)
+     (r2 :constant 10)
+     (r3 :argument register)))
+
+
+
+;;;; Function and LRA Headers emitters and calculation stuff.
+
+(defun header-data (ignore)
+  (declare (ignore ignore))
+  (ash (+ *current-position* (component-header-length)) (- vm:word-shift)))
+
+(define-format (header-object 32)
+  (type (byte 8 0))
+  (data (byte 24 8) :default 0 :function header-data))
+
+(define-instruction (function-header-word)
+  (header-object (type :constant vm:function-header-type)))
+
+(define-instruction (lra-header-word)
+  (header-object (type :constant vm:return-pc-header-type)))
+
+
+;;; DEFINE-COMPUTE-INSTRUCTION -- Internal.
+;;;
+;;; This defines a pseudo-instruction, name, which requires the other specific
+;;; instructions.  When the pseudo-instruction expands, it looks at the current
+;;; value of the calculation to choose between two instruction sequences.
+;;; Later, when the assembler emits the instructions, the :function's run to
+;;; really compute the calculation's value.  This is guaranteed to be lesser in
+;;; magnitude than the original test in the pseudo-instruction since all these
+;;; calculation are relative to the component start, so we can only remove
+;;; instructions in that range, not add them.
+;;;
+(defmacro define-compute-instruction (name calculation)
+  (let ((cal (symbolicate name "-CAL"))
+	(cau (symbolicate name "-CAU")))
+    `(progn
+       ;; This is a special compute-address-lower that takes a label and
+       ;; asserts the type of the immediate value.
+       (defun ,name (label)
+	 (let* ((whole ,calculation)
+		(low (logand whole #xffff))
+		(high (ash whole -16)))
+	   (values (if (logbitp 15 low)
+		       (1+ high)
+		       high)
+		   low)))
+       (define-instruction (,cal)
+	 (d (op :constant #xC8)
+	    (r2 :argument register)
+	    (r3 :argument address-register)
+	    (i :argument label
+	       :function (lambda (label)
+			   (multiple-value-bind (high low) (,name label)
+			     (declare (ignore high))
+			     low)))))
+       (define-instruction (,cau)
+	 (d (op :constant #xD8)
+	    (r2 :argument register)
+	    (r3 :argument address-register)
+	    (i :argument label
+	       :function (lambda (label)
+			   (multiple-value-bind (high low) (,name label)
+			     (declare (ignore low))
+			     high)))))
+       (define-pseudo-instruction ,name 64 (dst src label)
+	 (multiple-value-bind (high low) (,name label)
+	   (declare (ignore low))
+	   (cond ((zerop high)
+		  (inst ,cal dst src label))
+		 (t
+		  (inst ,cal dst src label)
+		  (inst ,cau dst src label))))))))
+
+
+;; code = fn - header - label-offset + other-pointer-tag
+(define-compute-instruction compute-code-from-fn
+			    (- vm:other-pointer-type
+			       (label-position label)
+			       (component-header-length)))
+
+;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
+(define-compute-instruction compute-code-from-lra
+			    (- (+ (label-position label)
+				  (component-header-length))))
+
+;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
+(define-compute-instruction compute-lra-from-code
+			    (+ (label-position label)
+			       (component-header-length)))
diff --git a/compiler/rt/macros.lisp b/compiler/rt/macros.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..74d646506f1cbc5fc2d9b0367c9775a4f45c218b
--- /dev/null
+++ b/compiler/rt/macros.lisp
@@ -0,0 +1,533 @@
+;;; -*- Package: C; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; This file contains various useful macros for generating code for the IBM
+;;; RT.
+;;;
+;;; Written by William Lott, Christopher Hoover, and Rob Maclachlin, and Bill
+;;; Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;; Instruction-like macros.
+
+;;; MOVE -- Interface.
+;;;
+(defmacro move (dst src)
+  "Move src into dst unless they are LOCATION=."
+  (once-only ((n-dst dst)
+	      (n-src src))
+    `(unless (location= ,n-dst ,n-src)
+       (inst move ,n-dst ,n-src))))
+
+;;; LOADW and STOREW -- Interface.
+;;;
+;;; Load and store words.
+;;;
+(macrolet ((def-mem-op (op inst)
+	    `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
+	       `(inst ,',inst ,object ,base
+		      (- (ash ,offset word-shift) ,lowtag)))))
+  (def-mem-op loadw l)
+  (def-mem-op storew st))
+
+;;; LOAD-SYMBOL -- Interface.
+;;;
+(defmacro load-symbol (reg symbol)
+  "Load a pointer to the static symbol into reg."
+  `(inst a ,reg null-tn (static-symbol-offset ,symbol)))
+
+;;; LOAD-SYMBOL-FUNCTION, STORE-SYMBOL-FUNCTION,
+;;; LOAD-SYMBOL-VALUE, STORE-SYMBOL-VALUE		-- interface.
+;;;
+(macrolet
+    ((frob (slot)
+       (let ((loader (intern (concatenate 'simple-string
+					  "LOAD-SYMBOL-"
+					  (string slot))))
+	     (storer (intern (concatenate 'simple-string
+					  "STORE-SYMBOL-"
+					  (string slot))))
+	     (offset (intern (concatenate 'simple-string
+					  "SYMBOL-"
+					  (string slot)
+					  "-SLOT")
+			     (find-package "VM"))))
+	 `(progn
+	    (defmacro ,loader (reg symbol)
+	      `(inst l ,reg null-tn
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))
+	    (defmacro ,storer (reg symbol)
+	      `(inst st ,reg null-tn
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))))))
+  (frob value)
+  (frob function))
+
+;;; LOAD-TYPE -- Interface.
+;;;
+;;; Subtract the low-tag from the pointer and add one less than the address
+;;; units per word to get us to the low byte since the RT is big-endian.
+;;;
+(defmacro load-type (target source &optional (low-tag 0))
+  "Loads the type bits from the source pointer into target, where pointer has
+   the specified low-tag."
+  `(inst lc ,target ,source (- word-bytes 1 ,low-tag)))
+
+
+
+;;;; Call and Return.
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions due to low-tag bits on pointers.
+;;;
+
+;;; LISP-JUMP -- Interface.
+;;;
+(defmacro lisp-jump (function lip)
+  "Jump to the lisp function.  Lip is the lisp interior pointer register
+   used as a temporary."
+  `(progn
+     (inst cal ,lip ,function (- (ash function-header-code-offset
+				      word-shift)
+				 function-pointer-type))
+     (inst bx ,lip)
+     (move code-tn ,function)))
+
+;;; LISP-RETURN -- Interface.
+;;;
+(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+  "Return to return-pc, an LRA.  Lip is the lisp interior pointer register
+   used as a temporary.  Offset is the number of words to skip at the target,
+   and it has to be small enough for whatever instruction used in here."
+  `(progn
+     (inst cal ,lip ,return-pc
+	   (- (ash (1+ ,offset) word-shift) other-pointer-type))
+     ,@(if frob-code
+	  `((inst bx ,lip)
+	    (move code-tn ,return-pc))
+	  `((inst b ,lip)))))
+
+;;; EMIT-RETURN-PC -- Interface.
+;;;
+(defmacro emit-return-pc (label)
+  "Emit a return-pc header word, making sure it is aligned properly for our
+   low-tag bits since there are other-pointers referring to the LRA's.  label
+   is the label to use for this return-pc."
+  `(progn
+     (align lowtag-bits)
+     (emit-label ,label)
+     (inst lra-header-word)))
+
+
+;;;; Stack TN's.
+
+;;; LOAD-STACK-TN, STORE-STACK-TN  --  Interface.
+;;;
+;;; Move a stack TN to a register and vice-versa.  If the VOP is supplied,
+;;; we can load from (or store onto) the number stack also.
+;;;
+(defmacro load-stack-tn (reg stack &optional vop)
+  (once-only ((n-reg reg)
+	      (n-stack stack))
+    `(sc-case ,n-stack
+       (control-stack
+	(loadw ,n-reg cfp-tn (tn-offset ,n-stack)))
+       ,@(when vop
+	   `(((unsigned-stack signed-stack base-character-stack sap-stack)
+	      (loadw ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack))))))))
+;;;
+(defmacro store-stack-tn (reg stack &optional vop)
+  (once-only ((n-reg reg)
+	      (n-stack stack))
+    `(sc-case ,n-stack
+       (control-stack
+	(storew ,n-reg cfp-tn (tn-offset ,n-stack)))
+       ,@(when vop
+	   `(((unsigned-stack signed-stack base-character-stack sap-stack)
+	      (storew ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack))))))))
+
+
+;;; MAYBE-LOAD-STACK-TN  --  Interface.
+;;;
+(defmacro maybe-load-stack-tn (reg reg-or-stack)
+  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
+  (once-only ((n-reg reg)
+	      (n-stack reg-or-stack))
+    `(sc-case ,n-reg
+       ((any-reg descriptor-reg)
+	(sc-case ,n-stack
+	  ((any-reg descriptor-reg)
+	   (move ,n-reg ,n-stack))
+	  ((control-stack)
+	   (loadw ,n-reg fp-tn (tn-offset ,n-stack))))))))
+
+
+
+;;;; Storage allocation:
+
+;;; WITH-FIXED-ALLOCATION -- Internal Interface.
+;;;
+(defmacro with-fixed-allocation ((result-tn header-tn alloc-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.  Header-Tn is any register temp which this uses to hold the
+   header of the allocated object before storing it into the header slot.
+   Alloc-tn is a register to hold the heap pointer, and it can be any register
+   since raw heap pointers look like fixnums (dual-word aligned objects).  The
+   body is placed inside PSEUDO-ATOMIC, and presumably initializes the object."
+  `(pseudo-atomic (,header-tn)
+     (load-symbol-value ,alloc-tn *allocation-pointer*)
+     ;; Take free pointer and make descriptor pointer.
+     ;; Just add in three low-tag bits since alloc ptr is dual-word aligned.
+     (inst cal ,result-tn ,alloc-tn other-pointer-type)
+     (inst cal ,alloc-tn ,alloc-tn (pad-data-block ,size))
+     (store-symbol-value ,alloc-tn *allocation-pointer*)
+     (inst li ,header-tn (logior (ash (1- ,size) type-bits) ,type-code))
+     (storew ,header-tn ,result-tn 0 other-pointer-type)
+     ,@body))
+
+
+
+;;;; Type testing noise.
+
+;;; GEN-RANGE-TEST -- Internal.
+;;;
+;;; Generate code that branches to TARGET iff REG contains one of VALUES.  If
+;;; NOT-P is true, invert the test.  Jumping to DROP-THROUGH is the same as
+;;; falling out the bottom.
+;;;
+(defun gen-range-test (reg target drop-through not-p values
+		       &optional (separation 1) (min 0))
+  (let ((tests nil)
+	(start nil)
+	(end nil)
+	(insts nil))
+    ;; Block off list of values into ranges, so we can test these as intervals
+    ;; instead of individually.
+    (flet ((emit-test ()
+		      (if (= start end)
+			  (push start tests)
+			  (push (cons start end) tests))))
+      (dolist (value values)
+	(cond ((< value min)
+	       (error "~S is less than the specified minimum of ~S"
+		      value min))
+	      ((null start)
+	       (setf start value))
+	      ((> value (+ end separation))
+	       (emit-test)
+	       (setf start value)))
+	(setf end value))
+      (emit-test))
+    ;; Output tests, dealing with not-p.
+    (macrolet ((inst (name &rest args)
+		     `(push (list 'inst ',name ,@args) insts)))
+      (do ((remaining (nreverse tests) (cdr remaining)))
+	  ((null remaining))
+	(let ((test (car remaining))
+	      (last (null (cdr remaining))))
+	  (cond
+	   ((atom test)
+	    (inst c reg test)
+	    (if last
+		(if not-p
+		    ;; We compared for the thing.  If not-p, since it is the
+		    ;; last thing to look for, and we don't want it, then goto
+		    ;; target.
+		    (inst bnc :eq target)
+		    ;; If we do want the thing, and we got it, then goto
+		    ;; target.
+		    (inst bc :eq target))
+		;; If it is not the last thing, and it is not not-p, and we
+		;; have it, then go to target.  If not-p, and we have the thing
+		;; we don't want, then drop through.
+		(inst bc :eq (if not-p drop-through target))))
+	   (t
+	    (let ((start (car test))
+		  (end (cdr test)))
+	      ;; We don't need this code if start is the smallest value we
+	      ;; could possibly have.  We know reg can't be less than start.
+	      (unless (= start min)
+		(inst c reg start)
+		;; If I want the range, and I'm less than the start, then
+		;; drop through.  If I don't want the range, goto target
+		;; because I'm not in the range.
+		(inst bc :lt (if not-p target drop-through)))
+	      ;; We know reg is greater than or equal to start, so see if it
+	      ;; is less than or equal to end.
+	      (inst c reg end)
+	      (if last
+		  (if not-p
+		      ;; If this range is the last test, and I don't
+		      ;; want it, and I'm not in it, then goto target.
+		      (inst bc :gt target)
+		      ;; If this range is the last test, and I want the
+		      ;; range, and I'm in it, then goto target.
+		      (inst bnc :gt target))
+		  (inst bnc :gt (if not-p drop-through target)))))))))
+    (nreverse insts)))
+
+(defconstant type-separation 4)
+(defconstant min-type (+ other-immediate-0-type lowtag-limit))
+
+;;; TEST-TYPE-AUX -- Internal.
+;;;
+(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs)
+  (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
+		       (member odd-fixnum-type lowtags :test #'eql)))
+	 (lowtags (sort (if fixnump
+			    (delete even-fixnum-type
+				    (remove odd-fixnum-type lowtags
+					    :test #'eql)
+				    :test #'eql)
+			    (copy-list lowtags))
+			#'<))
+	 (hdrs (sort hdrs #'<))
+	 (immed (sort immed #'<)))
+    (append
+     (when immed
+       `((inst nilz ,temp ,reg type-mask)
+	 ,@(if (or fixnump lowtags hdrs)
+	       ;; If we're going to output any tests below, fall through to
+	       ;; those tests from these.
+	       (let ((fall-through (gensym)))
+		 `((let (,fall-through (gen-label))
+		     ,@(gen-range-test
+			temp (if not-p drop-through target)
+			fall-through nil immed type-separation)
+		     (emit-label ,fall-through))))
+	       ;; If there are no other tests, drop through to the end of all
+	       ;; these tests.
+	       (gen-range-test temp target drop-through not-p
+			       immed type-separation))))
+     (when fixnump
+       `((inst nilz ,temp ,reg 3)
+	 ,(if (or lowtags hdrs)
+	      ;; If more tests follow this one, fall through to them.
+	      `(inst bc :eq ,(if not-p drop-through target))
+	      ;; If no more tests follow, drop totally out of here.
+	      `(inst ,(if not-p 'bnc 'bc) :eq ,target))))
+     (when (or lowtags hdrs)
+       `((inst nilz ,temp ,reg lowtag-mask)))
+     (when lowtags
+       (if hdrs
+	   ;; If we're going to output any tests below, fall through to
+	   ;; those tests from these.
+	   (let ((fall-through (gensym)))
+	     `((let ((,fall-through (gen-label)))
+		 ,@(gen-range-test temp (if not-p drop-through target)
+				   fall-through nil lowtags)
+		 (emit-label ,fall-through))))
+	   (gen-range-test temp target drop-through not-p lowtags)))
+     (when hdrs
+       `((inst c ,temp other-pointer-type)
+	 (inst bnc :eq ,(if not-p target drop-through))
+	 (load-type ,temp ,reg other-pointer-type)
+	 ,@(gen-range-test temp target drop-through not-p
+			   hdrs type-separation min-type))))))
+
+(defconstant immediate-types
+  (list base-character-type unbound-marker-type))
+
+;;; TEST-TYPE -- Interface.
+;;;
+;;; This is used in type-vops.lisp.
+;;;
+(defmacro test-type (register temp target not-p &rest type-codes)
+  "Register holds a descriptor object that might have one of the types in
+   type-codes.  If it does, goto target; otherwise, fall through.  If not-p is
+   set, goto target when register does not hold one of the types.  Type-codes
+   must be compile-time constants that this evaluates to get numeric codes.
+   Temp is a non-descriptor temporary needed by the code returned by the
+   macro."
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (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)))
+    (unless type-codes
+      (error "Must supply at least on type for test-type."))
+    (when (and headers (member other-pointer-type lowtags))
+      (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
+      (setf headers nil))
+    (when (and immediates
+	       (or (member other-immediate-0-type lowtags)
+		   (member other-immediate-1-type lowtags)))
+      (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
+      (setf immediates nil))
+    (let ((n-reg (gensym))
+	  (n-temp (gensym))
+	  (n-target (gensym))
+	  (drop-through (gensym)))
+      `(let ((,n-reg ,register)
+	     (,n-temp ,temp)
+	     (,n-target ,target)
+	     (,drop-through (gen-label)))
+	 (declare (ignorable ,n-temp))
+	 ,@(if (constantp not-p)
+	       (test-type-aux n-reg n-temp n-target drop-through
+			      (eval not-p) lowtags immediates headers)
+	       `((cond (,not-p
+			,@(test-type-aux n-reg n-temp n-target drop-through t
+					 lowtags immediates headers))
+		       (t
+			,@(test-type-aux n-reg n-temp n-target drop-through nil
+					 lowtags immediates headers)))))
+	 (inst no-op)
+	 (emit-label ,drop-through)))))
+
+
+
+;;;; Error Code
+
+(defvar *adjustable-vectors* nil)
+
+(defmacro with-adjustable-vector ((var) &rest body)
+  `(let ((,var (or (pop *adjustable-vectors*)
+		   (make-array 16
+			       :element-type '(unsigned-byte 8)
+			       :fill-pointer 0
+			       :adjustable t))))
+     (setf (fill-pointer ,var) 0)
+     (unwind-protect
+	 (progn
+	   ,@body)
+       (push ,var *adjustable-vectors*))))
+
+(eval-when (compile load eval)
+  (defun emit-error-break (vop kind code values)
+    (let ((vector (gensym)))
+      `((let ((vop ,vop))
+	  (when vop
+	    (note-this-location vop :internal-error)))
+	(inst break ,kind)
+	(with-adjustable-vector (,vector)
+	  (write-var-integer (error-number-or-lose ',code) ,vector)
+	  ,@(mapcar #'(lambda (tn)
+			`(let ((tn ,tn))
+			   (write-var-integer (make-sc-offset (sc-number
+							       (tn-sc tn))
+							      (tn-offset tn))
+					      ,vector)))
+		    values)
+	  (inst byte (length ,vector))
+	  (dotimes (i (length ,vector))
+	    (inst byte (aref ,vector i))))
+	(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 error-trap error-code values)))
+
+
+;;; CERROR-CALL -- Internal Interface.
+;;;
+;;; Output the error break stuff followed by a branch to the continuable code.
+;;; The break handler can skip the error break data, setting the pc in the
+;;; signal context to our following branch, and if we continue, we're setup.
+;;;
+(defmacro cerror-call (vop label error-code &rest values)
+  "Cause a continuable error.  If the error is continued, execution resumes at
+  LABEL."
+  `(progn
+     ,@(emit-error-break vop cerror-trap error-code values)
+     (inst b ,label)))
+
+(defmacro generate-error-code (vop error-code &rest values)
+  "Generate-Error-Code Error-code Value*
+  Emit code for an error with the specified Error-Code and context Values."
+  `(assemble (*elsewhere*)
+     (let ((start-lab (gen-label)))
+       (emit-label start-lab)
+       (error-call ,vop ,error-code ,@values)
+       start-lab)))
+
+(defmacro generate-cerror-code (vop error-code &rest values)
+  "Generate-CError-Code Error-code Value*
+  Emit code for a continuable error with the specified Error-Code and
+  context Values.  If the error is continued, execution resumes after
+  the GENERATE-CERROR-CODE form."
+  (let ((continue (gensym "CONTINUE-LABEL-"))
+	(error (gensym "ERROR-LABEL-")))
+    `(let ((,continue (gen-label)))
+       (emit-label ,continue)
+       (assemble (*elsewhere*)
+	 (let ((,error (gen-label)))
+	   (emit-label ,error)
+	   (cerror-call ,vop ,continue ,error-code ,@values)
+	   ,error)))))
+
+
+
+;;;; PSEUDO-ATOMIC.
+
+;;; PSEUDO-ATOMIC -- Internal Interface.
+;;;
+(defmacro pseudo-atomic ((ndescr-temp) &rest forms)
+  (let ((label (gensym "LABEL-")))
+    `(let ((,label (gen-label)))
+       (inst li ,ndescr-temp 0)
+       (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*)
+       ;; Note: we just use cfp as some not-zero value.
+       (store-symbol-value cfp-tn lisp::*pseudo-atomic-atomic*)
+       ,@forms
+       (inst li ,ndescr-temp 0)
+       (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-atomic*)
+       (load-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*)
+       (inst c ,ndescr-temp 0)
+       (inst bc :eq ,label)
+       (inst break pending-interrupt-trap)
+       (emit-label ,label))))
+
+
+
+;;;; Other random stuff.
+
+;;; PAD-DATA-BLOCK -- Internal Interface.
+;;;
+;;; This returns a form that returns a dual-word aligned number of bytes when
+;;; given a number of words.
+;;;
+(defmacro pad-data-block (words)
+  `(logandc2 (+ (ash ,words vm:word-shift) lowtag-mask) lowtag-mask))
+
+
+
+(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
+		   &rest identifiers)
+  (let ((results nil)
+	(index 0)
+	(start (eval start))
+	(step (eval step)))
+    (dolist (id identifiers)
+      (when id
+	(multiple-value-bind
+	    (root docs)
+	    (if (consp id)
+		(values (car id) (cdr id))
+		(values id nil))
+	  (push `(defconstant ,(intern (concatenate 'simple-string
+						    (string prefix)
+						    (string root)
+						    (string suffix)))
+		   ,(+ start (* step index))
+		   ,@docs)
+		results)))
+      (incf index))
+    `(eval-when (compile load eval)
+       ,@(nreverse results))))
diff --git a/compiler/rt/memory.lisp b/compiler/rt/memory.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..209840624f20d73d2441661b879e41e9ad256f36
--- /dev/null
+++ b/compiler/rt/memory.lisp
@@ -0,0 +1,182 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/memory.lisp,v 1.1 1991/02/18 15:07:59 chiles Exp $
+;;;
+;;; This file contains the IBM RT definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+;;; CELL-REF -- VOP.
+;;; CELL-SET -- VOP.
+;;; CELL-SETF -- VOP.
+;;; CELL-SETF-FUNCTION -- VOP.
+;;;
+;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the offset to
+;;; be read or written is a property of the VOP used.  CELL-SETF is similar to
+;;; CELL-SET, but delivers the new value as the result.  CELL-SETF-FUNCTION
+;;; takes its arguments as if it were a setf function (new value first, as
+;;; apposed to a setf macro, which takes the new value last).
+;;;
+(define-vop (cell-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (word-pointer-reg descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (loadw value object offset lowtag)))
+;;;
+(define-vop (cell-set)
+  (:args (object :scs (descriptor-reg))
+         (value :scs (word-pointer-reg descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)))
+;;;
+(define-vop (cell-setf)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (word-pointer-reg descriptor-reg any-reg)
+		:target result))
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)
+    (move result value)))
+;;;
+(define-vop (cell-setf-function)
+  (:args (value :scs (word-pointer-reg descriptor-reg any-reg)
+		:target result)
+	 (object :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)
+    (move result value)))
+
+;;; DEFINE-CELL-ACCESSORS  --  Interface.
+;;;
+;;; Define accessor VOPs for some cells in an object.  If the operation name is
+;;; NIL, then that operation isn't defined.  If the translate function is null,
+;;; then we don't define a translation.
+;;;
+(defmacro define-cell-accessors (offset lowtag ref-op ref-trans set-op set-trans)
+  `(progn
+     ,@(when ref-op
+	 `((define-vop (,ref-op cell-ref)
+	     (:variant ,offset ,lowtag)
+	     ,@(when ref-trans
+		 `((:translate ,ref-trans))))))
+     ,@(when set-op
+	 `((define-vop (,set-op cell-setf)
+	     (:variant ,offset ,lowtag)
+	     ,@(when set-trans
+		 `((:translate ,set-trans))))))))
+
+
+;;; SLOT-REF -- VOP.
+;;; SLOT-SET -- VOP.
+;;;
+;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF, where the
+;;; offset is constant at compile time, but varies for different uses.  We add
+;;; in the stardard g-vector overhead.
+;;;
+(define-vop (slot-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (loadw value object (+ base offset) lowtag)))
+;;;
+(define-vop (slot-set)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (storew value object (+ base offset) lowtag)))
+
+
+
+;;;; Indexed references:
+
+(eval-when (compile eval)
+
+;;; 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.
+;;;
+(defmacro define-indexer (name write-p op shift &key gross-hack)
+  `(define-vop (,name)
+     (:args (object :scs (descriptor-reg) :to :eval)
+	    (index :scs (any-reg immediate)
+		   ,@(unless (zerop shift) '(:target temp)))
+	    ,@(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 :from (:argument 1))
+		       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)
+	  (inst ,op value object
+		(- (+ (if (and (sc-is index immediate) (zerop (tn-value index)))
+			  0
+			  (ash (tn-value index) (- word-shift ,shift)))
+		      (ash offset word-shift))
+		   lowtag))
+	  ,@(if write-p
+		'((move result value))))
+	 (t
+	  ,@(if (zerop shift)
+		;; Object must be the last arg to CAS here since it is cannot
+		;; be in R0.
+		`((inst cas lip index object))
+		`((move temp index)
+		  (inst sr temp ,shift)
+		  (inst cas lip temp object)))
+	  (inst ,op value lip (- (ash offset word-shift) lowtag))
+	  ,@(if write-p
+		'((move result value)))))
+       ;; The RT lacks a signed-byte load instruction, so we have to sign
+       ;; extend this case explicitly.  This is gross but obvious and easy.
+       ,@(when gross-hack
+	   '((inst sl value 24)
+	     (inst sar value 24))))))
+
+) ;EVAL-WHEN
+
+(define-indexer word-index-ref nil l 0)
+(define-indexer word-index-set t st 0)
+(define-indexer halfword-index-ref nil lh 1)
+(define-indexer signed-halfword-index-ref nil lha 1)
+(define-indexer halfword-index-set t sth 1)
+(define-indexer byte-index-ref nil lc 2)
+(define-indexer signed-byte-index-ref nil lc 2 :gross-hack t)
+(define-indexer byte-index-set t stc 2)
diff --git a/compiler/rt/move.lisp b/compiler/rt/move.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6dd174d883f777469c4e450513674ce587ecbd42
--- /dev/null
+++ b/compiler/rt/move.lisp
@@ -0,0 +1,353 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/move.lisp,v 1.1 1991/02/18 15:08:01 chiles Exp $
+;;;
+;;; This file contains the IBM RT VM definition of operand loading/saving and the
+;;; Move VOP.
+;;;
+;;; Written by Rob MacLachlan.
+;;; MIPS conversion by William Lott.
+;;; IBM RT conversion by William Lott and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((null immediate)
+   (any-reg word-pointer-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (inst li y (fixnum val)))
+      (null
+       (move y null-tn))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst li y (logior (ash (char-code val) type-bits)
+			  base-character-type))))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((immediate)
+   (signed-reg unsigned-reg))
+  (inst li y (tn-value x)))
+
+(define-move-function (load-base-character 1) (vop x y)
+  ((immediate) (base-character-reg))
+  (inst li y (char-code (tn-value x))))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst li y (sap-int (tn-value x))))
+
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg))
+  (loadw y code-tn (tn-offset x) other-pointer-type))
+
+(define-move-function (load-stack 5) (vop x y)
+  ((control-stack) (any-reg word-pointer-reg descriptor-reg))
+  (load-stack-tn y x))
+
+(define-move-function (load-number-stack 5) (vop x y)
+  ((base-character-stack) (base-character-reg)
+   (sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (load-stack-tn y x vop))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((any-reg word-pointer-reg descriptor-reg) (control-stack))
+  (store-stack-tn x y))
+
+(define-move-function (store-number-stack 5) (vop x y)
+  ((base-character-reg) (base-character-stack)
+   (sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (store-stack-tn x y vop))
+
+(define-move-function (word-pointer-copy 1) (vop x y)
+  ((word-pointer-reg) (any-reg)
+   (any-reg) (word-pointer-reg))
+  (move y x))
+
+
+
+;;;; The Move VOP:
+
+(define-vop (move)
+  (:args (x :target y
+	    :scs (any-reg word-pointer-reg descriptor-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg word-pointer-reg descriptor-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+
+(define-move-vop move :move
+  (any-reg word-pointer-reg descriptor-reg)
+  (any-reg word-pointer-reg descriptor-reg))
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type.  This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;; MOVE-ARGUMENT -- VOP.
+;;;
+;;; This is used for moving descriptor values into another frame for argument
+;;; or known value passing.
+;;;
+(define-vop (move-argument)
+  (:args (x :target y
+	    :scs (any-reg word-pointer-reg descriptor-reg))
+	 (fp :scs (word-pointer-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg word-pointer-reg descriptor-reg)
+       (move y x))
+      (control-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg word-pointer-reg descriptor-reg)
+  (any-reg word-pointer-reg descriptor-reg))
+
+
+
+;;;; ILLEGAL-MOVE
+
+;;; ILLEGAL-MOVE -- VOP.
+;;;
+;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
+;;; legally due to a type error.  An error is signalled before this VOP is so
+;;; we don't need to do anything (not that there would be anything sensible to
+;;; do anyway.)
+;;;
+(define-vop (illegal-move)
+  (:args (x) (type))
+  (:results (y))
+  (:ignore y)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 666
+    (error-call vop object-not-type-error x type)))
+
+
+
+;;;; Moves and coercions:
+
+;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
+;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
+;;; to a tagged bignum or fixnum.
+
+;;; MOVE-TO-WORD/FIXNUM -- VOP.
+;;;
+;;; Arg is a fixnum, so just put it in a non-descriptor register and shift it.
+;;;
+(define-vop (move-to-word/fixnum)
+  (:args (x :scs (any-reg) :target y))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "fixnum untagging")
+  (:generator 2
+    (move y x)
+    (inst sar y 2)))
+;;;
+(define-move-vop move-to-word/fixnum :move
+  (any-reg) (signed-reg unsigned-reg))
+
+;;; MOVE-TO-WORD-C -- VOP.
+;;; 
+;;; Arg is a non-immediate constant, load it.
+;;;
+(define-vop (move-to-word-c)
+  (:args (x :scs (constant)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "constant load")
+  (:generator 1
+    (inst li y (tn-value x))))
+;;;
+(define-move-vop move-to-word-c :move
+  (constant) (signed-reg unsigned-reg))
+
+;;; MOVE-TO-WORD/INTEGER -- VOP.
+;;;
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+;;;
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg) :to :save))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "integer to untagged word coercion")
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 8
+    (let ((done (gen-label)))
+      (inst nilz temp x 3)
+      (move y x)
+      (inst bcx :eq done)
+      (inst sar y 2)
+      ;; If it's a bignum, throw away what we computed in y.
+      (loadw y x bignum-digits-offset other-pointer-type)
+      (emit-label done))))
+;;;
+(define-move-vop move-to-word/integer :move
+  (descriptor-reg) (signed-reg unsigned-reg))
+
+
+;;; MOVE-FROM-WORD/FIXNUM -- VOP.
+;;;
+;;; Since the result is know to be a fixnum, we can shift in the tag bits
+;;; without fear of needing a bignum.
+;;;
+(define-vop (move-from-word/fixnum)
+  (:args (x :scs (signed-reg unsigned-reg) :target temp))
+  (:temporary (:scs (non-descriptor-reg)
+		    :from (:argument 0) :to (:result 0) :target y)
+	      temp)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "fixnum tagging")
+  (:generator 3
+    (move temp x)
+    (inst sl temp 2)
+    (move y temp)))
+;;;
+(define-move-vop move-from-word/fixnum :move
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; MOVE-FROM-SIGNED -- VOP.
+;;;
+;;; Result may be a bignum, so we have to check whether shifting to make room
+;;; for tag bits results in a fixnum.  Use a worst-case cost to make sure
+;;; people know they may be number consing.
+;;;
+(define-vop (move-from-signed)
+  (: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 (:scs (word-pointer-reg)) alloc)
+  (:note "signed word to integer coercion")
+  (:generator 25
+    (move x arg)
+    (let ((fixnum (gen-label))
+	  (done (gen-label)))
+      (move temp x)
+      (inst sar temp 29)
+      (inst bcx :eq fixnum)
+      (inst not temp)
+      (inst bc :eq fixnum)
+      
+      (with-fixed-allocation (y temp alloc bignum-type 2)
+	(storew x y bignum-digits-offset other-pointer-type))
+      (inst b done)
+      
+      (emit-label fixnum)
+      (move y x)
+      (inst sl y 2)
+      (emit-label done))))
+;;;
+(define-move-vop move-from-signed :move
+  (signed-reg) (descriptor-reg))
+
+
+;;; MOVE-FROM-UNSIGNED -- VOP.
+;;;
+;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
+;;; a worst-case cost to make sure people know they may be number consing.
+;;;
+(define-vop (move-from-unsigned)
+  (: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 (:scs (word-pointer-reg)) alloc)
+  (:note "unsigned word to integer coercion")
+  (:generator 21
+    (move x arg)
+    (let ((done (gen-label))
+	  (bignum (gen-label))
+	  (one-word (gen-label)))
+      (move temp x)
+      (inst sar temp 29)
+      (inst bnc :eq bignum)
+      (inst sl x 2)
+      (move y x)
+      (emit-label done)
+
+      (assemble (*elsewhere*)
+	(emit-label bignum)
+	(pseudo-atomic (temp)
+	  (load-symbol-value alloc *allocation-pointer*)
+	  (inst cal y alloc other-pointer-type)
+	  (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset)))
+	  (inst c x 0)
+	  (inst bncx :lt one-word)
+	  (inst li temp (logior (ash 1 type-bits) bignum-type))
+	  (inst cal alloc alloc
+		(- (pad-data-block (+ 2 bignum-digits-offset))
+		   (pad-data-block (1+ bignum-digits-offset))))
+	  (inst li temp (logior (ash 2 type-bits) bignum-type))
+	  (emit-label one-word)
+	  (store-symbol-value alloc *allocation-pointer*)
+	  (storew temp y 0 other-pointer-type)
+	  (storew x y bignum-digits-offset other-pointer-type))
+	(inst b done)))))
+;;;
+(define-move-vop move-from-unsigned :move
+  (unsigned-reg) (descriptor-reg))
+
+
+;;; Move untagged numbers.
+;;;
+(define-vop (word-move)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (signed-reg unsigned-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:note "word integer move")
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop word-move :move
+  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg))
+	 (fp :scs (word-pointer-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note "word integer argument move")
+  (:generator 0
+    (sc-case y
+      ((signed-reg unsigned-reg)
+       (move y x))
+      ((signed-stack unsigned-stack)
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-word-argument :move-argument
+  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/rt/nlx.lisp b/compiler/rt/nlx.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b8a71c0ad75289e850dcf1dfbfb4b2decce9b92d
--- /dev/null
+++ b/compiler/rt/nlx.lisp
@@ -0,0 +1,330 @@
+;;; -*- Package: RT -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/nlx.lisp,v 1.1 1991/02/18 15:08:03 chiles Exp $
+;;;
+;;; This file contains the definitions of VOPs used for non-local exit (throw,
+;;; lexical exit, etc.)
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted to IBM RT by William Lott and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+;;; MAKE-NLX-SP-TN  --  Interface.
+;;;
+;;; Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(def-vm-support-routine make-nlx-sp-tn (env)
+  (environment-live-tn
+   (make-representation-tn *word-pointer-type*
+			   (sc-number-or-lose 'word-pointer-reg *backend*))
+   env))
+
+
+
+;;; Save and restore dynamic environment.
+;;;
+;;;    These VOPs are used in the reentered function to restore the appropriate
+;;; dynamic environment.  Currently we only save the Current-Catch and binding
+;;; stack pointer.  We don't need to save/restore the current unwind-protect,
+;;; since unwind-protects are implicitly processed during unwinding.  If there
+;;; were any additional stacks, then this would be the place to restore the top
+;;; pointers.
+
+
+;;; MAKE-DYNAMIC-STATE-TNS  --  Interface.
+;;;
+;;; Return a list of TNs that can be used to snapshot the dynamic state for use
+;;; with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(def-vm-support-routine make-dynamic-state-tns ()
+  (make-n-tns 5 *fixnum-primitive-type*))
+
+(define-vop (save-dynamic-state)
+  (:results (catch :scs (any-reg))
+	    (special :scs (any-reg))
+	    (nfp :scs (any-reg))
+	    (nsp :scs (any-reg))
+	    (eval :scs (any-reg)))
+  (:vop-var vop)
+  (:generator 13
+    (load-symbol-value catch lisp::*current-catch-block*)
+    (load-symbol-value special *binding-stack-pointer*)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(move nfp cur-nfp)))
+    (move nsp nsp-tn)
+    (load-symbol-value eval lisp::*eval-stack-top*)))
+
+(define-vop (restore-dynamic-state)
+  (:args (catch :scs (any-reg))
+	 (special :scs (any-reg) :to (:eval 1))
+	 (nfp :scs (any-reg))
+	 (nsp :scs (any-reg))
+	 (eval :scs (any-reg)))
+  (:temporary (:scs (descriptor-reg) :from (:eval 0)) symbol value)
+  (:temporary (:scs (word-pointer-reg) :from (:eval 0)) bsp)
+  (:vop-var vop)
+  (:generator 10
+    (let ((done (gen-label))
+	  (skip (gen-label))
+	  (loop (gen-label)))
+
+      (store-symbol-value catch lisp::*current-catch-block*)
+      (store-symbol-value eval lisp::*eval-stack-top*)
+      (let ((cur-nfp (current-nfp-tn vop)))
+	(when cur-nfp
+	  (move cur-nfp nfp)))
+      (move nsp-tn nsp)
+      
+      (load-symbol-value bsp *binding-stack-pointer*)
+      (inst c bsp 0)
+      (inst bc :eq done)
+
+      ;; Unwind shallow dynamic bindings.
+      (emit-label loop)
+      (loadw symbol bsp (- binding-symbol-slot binding-size))
+      (inst c symbol 0)
+      (inst bc :eq skip)
+      (loadw value bsp (- binding-value-slot binding-size))
+      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+      (inst li value 0)
+      (storew value bsp (- binding-symbol-slot binding-size))
+      (emit-label skip)
+      (inst dec bsp (* 2 vm:word-bytes))
+      (inst c bsp special)
+      (inst bnc :eq loop)
+
+      (emit-label done)
+      (store-symbol-value special *binding-stack-pointer*))))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg word-pointer-reg descriptor-reg)))
+  (:generator 1
+    (move res csp-tn)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg word-pointer-reg descriptor-reg)))
+  (:generator 1
+    (load-symbol-value res *binding-stack-pointer*)))
+
+
+
+;;;; Unwind block hackery:
+
+;;; MAKE-UNWIND-BLOCK -- VOP.
+;;;
+;;; Compute the address of the catch block from its TN, then store into the
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
+;;;
+(define-vop (make-unwind-block)
+  (:args (tn))
+  (:info entry-label)
+  (:results (block :scs (word-pointer-reg)))
+  (:temporary (:scs (word-pointer-reg) :target block) block-ptr)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:generator 22
+    (inst cal block-ptr cfp-tn (* (tn-offset tn) vm:word-bytes))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block-ptr vm:unwind-block-current-uwp-slot)
+    (storew cfp-tn block-ptr vm:unwind-block-current-cont-slot)
+    (storew code-tn block-ptr vm:unwind-block-current-code-slot)
+    (inst compute-lra-from-code temp code-tn entry-label)
+    (storew temp block-ptr vm:catch-block-entry-pc-slot)
+    (move block block-ptr)))
+
+
+;;; MAKE-CATCH-BLOCK -- VOP.
+;;;
+;;; Like MAKE-UNWIND-BLOCK, except that we also store in the specified tag, and
+;;; link the block into the Current-Catch list.
+;;;
+(define-vop (make-catch-block)
+  (:args (tn)
+	 (tag :scs (descriptor-reg)))
+  (:info entry-label)
+  (:results (block :scs (word-pointer-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (word-pointer-reg) :target block :to (:result 0)) result)
+  (:generator 44
+    (inst cal 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 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)
+    (storew temp result vm:catch-block-entry-pc-slot)
+
+    (storew tag result vm:catch-block-tag-slot)
+    (load-symbol-value temp lisp::*current-catch-block*)
+    (storew temp result vm:catch-block-previous-catch-slot)
+    (store-symbol-value result lisp::*current-catch-block*)
+
+    (move block result)))
+
+
+;;; SET-UNWIND-PROTECT -- VOP.
+;;;
+;;; Just set the current unwind-protect to TN's address.  This instantiates an
+;;; unwind block as an unwind-protect.
+;;;
+(define-vop (set-unwind-protect)
+  (:args (tn))
+  (:temporary (:scs (descriptor-reg)) new-uwp)
+  (:generator 7
+    (inst cal new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
+    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
+
+;;; UNLINK-CATCH-BLOCK -- VOP.
+;;;
+;;; Remove the catch block from the chain of catches.  This happens when
+;;; we drop out of a catch instead of throwing.
+;;; 
+(define-vop (unlink-catch-block)
+  (:temporary (:scs (word-pointer-reg)) block)
+  (:policy :fast-safe)
+  (:translate %catch-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-catch-block*)
+    (loadw block block vm:catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
+
+;;; UNLINK-UNWIND-PROTECT -- VOP.
+;;;
+;;; Same thing with unwind protects.
+;;; 
+(define-vop (unlink-unwind-protect)
+  (:temporary (:scs (word-pointer-reg)) block)
+  (:policy :fast-safe)
+  (:translate %unwind-protect-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-unwind-protect-block*)
+    (loadw block block vm:unwind-block-current-uwp-slot)
+    (store-symbol-value block lisp::*current-unwind-protect-block*)))
+
+
+;;;; NLX entry VOPs:
+
+
+;;; NLX-ENTRY -- VOP.
+;;;
+;;; We were just thrown to, so load up the results.
+;;; 
+(define-vop (nlx-entry)
+  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
+	      ; would be inserted before the LRA.
+	 (start)
+	 (count))
+  (:results (values :more t))
+  (:temporary (:scs (descriptor-reg)) move-temp)
+  (:info label nvals)
+  (:save-p :force-to-stack)
+  (:generator 30
+    (emit-return-pc label)
+    (cond ((zerop nvals))
+	  ((= nvals 1)
+	   (let ((no-values (gen-label)))
+	     (inst c count 0)
+	     (inst bcx :eq no-values)
+	     (move (tn-ref-tn values) null-tn)
+	     (loadw (tn-ref-tn values) start)
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (inst c count 0)
+	     (do ((i 0 (1+ i))
+		  (tn-ref values (tn-ref-across tn-ref)))
+		 ((null tn-ref))
+	       (let ((default-lab (gen-label))
+		     (tn (tn-ref-tn tn-ref)))
+		 (defaults (cons default-lab tn))
+		 
+		 (inst bc :eq default-lab)
+		 (inst s count (fixnum 1))
+		 (sc-case tn
+		   ((descriptor-reg any-reg)
+		    (loadw tn start i))
+		   (control-stack
+		    (loadw move-temp start i)
+		    (store-stack-tn move-temp tn)))))
+	     
+	     (let ((defaulting-done (gen-label)))
+	       (emit-label defaulting-done)
+	       (assemble (*elsewhere*)
+		 (dolist (def (defaults))
+		   (emit-label (car def))
+		   (let ((tn (cdr def)))
+		     (sc-case tn
+		       ((descriptor-reg any-reg)
+			(move tn null-tn))
+		       (control-stack
+			(store-stack-tn null-tn tn)))))
+		 (inst b defaulting-done))))))
+    (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.  But we know that start and count will
+  ;; be in registers due to the way this vop is used.
+  (:args (top :target dst)
+	 (start :target src)
+	 (count :target num))
+  (:info label)
+  (:temporary (:scs (any-reg) :from (:argument 0)) dst)
+  (:temporary (:scs (any-reg) :from (:argument 1)) src)
+  (:temporary (:scs (any-reg) :from (:argument 2)) num)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:results (new-start) (new-count))
+  (:save-p :force-to-stack)
+  (:generator 30
+    (emit-return-pc label)
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+
+      ;; Copy args.
+      (load-stack-tn dst top)
+      (move src start)
+      (inst a num count 0)
+
+      ;; Establish results.
+      (sc-case new-start
+	((any-reg word-pointer-reg) (move new-start dst))
+	(control-stack (store-stack-tn dst new-start)))
+      (inst bcx :eq done)
+      (sc-case new-count
+	(any-reg (inst move new-count num))
+	(control-stack (store-stack-tn num new-count)))
+
+      ;; Copy stuff on stack.
+      (emit-label loop)
+      (loadw temp src)
+      (inst inc src vm:word-bytes)
+      (storew temp dst)
+      (inst s num num (fixnum 1))
+      (inst bncx :eq loop)
+      (inst inc dst vm:word-bytes)
+
+      (emit-label done)
+      (move csp-tn dst))))
+
+
+;;; This VOP is just to force the TNs used in the cleanup onto the stack.
+;;;
+(define-vop (uwp-entry)
+  (:info label)
+  (:save-p :force-to-stack)
+  (:results (block) (start) (count))
+  (:ignore block start count)
+  (:generator 0
+    (emit-return-pc label)))
+
diff --git a/compiler/rt/params.lisp b/compiler/rt/params.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e271ccb7878aaebfa4da56df29ac79bf369acb4e
--- /dev/null
+++ b/compiler/rt/params.lisp
@@ -0,0 +1,175 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/params.lisp,v 1.1 1991/02/18 15:08:05 chiles Exp $
+;;;
+;;; This file contains some parameterizations of various VM attributes for the
+;;; IBM RT.  This file is separate from other stuff, so we can compile and
+;;; load it earlier.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted to MIPS by William Lott.
+;;; Converted to IBM RT by William Lott and Bill Chiles.
+;;;
+
+(in-package "RT")
+(use-package "C")
+
+(export '(word-bits byte-bits word-shift word-bytes
+	  halt-trap pending-interrupt-trap error-trap cerror-trap))
+
+
+
+;;;; Compiler constants.
+
+(eval-when (compile eval load)
+
+(setf (backend-name *target-backend*) "RT")
+(setf (backend-version *target-backend*) "IBM RT/Mach 0.0")
+(setf (backend-fasl-file-type *target-backend*) "rtf")
+(setf (backend-fasl-file-implementation *target-backend*)
+      rt-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) 1)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :big-endian)
+
+) ;eval-when
+
+
+
+;;;; Machine Architecture parameters:
+
+(eval-when (compile load eval)
+
+(defconstant word-bits 32
+  "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant byte-bits 8
+  "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
+  "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant word-bytes (/ word-bits byte-bits)
+  "Number of bytes in a word.")
+
+(defparameter target-most-positive-fixnum (1- (ash 1 29))
+  "most-positive-fixnum in the target architecture.")
+
+(defparameter target-most-negative-fixnum (ash -1 29)
+  "most-negative-fixnum in the target architecture.")
+
+(defconstant float-sign-shift 31)
+
+;;; The exponent min/max values are wrong, I think.  The denorm, infinity, etc.
+;;; info must go in there somewhere.
+
+(defconstant single-float-bias 126)
+(defconstant single-float-exponent-byte (byte 8 23))
+(defconstant single-float-significand-byte (byte 23 0))
+(defconstant single-float-normal-exponent-min 0)
+(defconstant single-float-normal-exponent-max 255)
+(defconstant single-float-hidden-bit (ash 1 23))
+
+(defconstant double-float-bias 1022)
+(defconstant double-float-exponent-byte (byte 11 20))
+(defconstant double-float-significand-byte (byte 20 0))
+(defconstant double-float-normal-exponent-min 0)
+(defconstant double-float-normal-exponent-max #x7FF)
+(defconstant double-float-hidden-bit (ash 1 20))
+
+(defconstant single-float-digits
+  (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+  (+ (byte-size double-float-significand-byte) word-bits 1))
+
+); eval-when
+
+
+
+
+;;;; Description of the target address space.
+
+;;; Where to put the different spaces.
+;;; 
+(defparameter target-read-only-space-start #x00100000)
+(defparameter target-static-space-start    #x04000000)
+(defparameter target-dynamic-space-start   #x06000000)
+
+
+
+;;;; Other non-type constants.
+
+(defenum (:suffix -trap :start 8)
+  halt
+  pending-interrupt
+  error
+  cerror)
+
+
+
+;;;; Static symbols.
+
+;;; These symbols are loaded into static space directly after NIL so
+;;; that the system can compute their address by adding a constant
+;;; amount to NIL.
+;;;
+;;; The exported static symbols are a subset of the static symbols that get
+;;; exported to the C header file.  NOTE: EXPORTED-STATIC-SYMBOLS IS DEFINED
+;;; AS A FUNCTION OF THE ORDERING OF THIS LIST.
+;;;
+(defparameter static-symbols
+  '(t
+
+    ;; Random stuff needed for initialization.
+    lisp::lisp-environment-list
+    lisp::lisp-command-line-list
+
+    ;; Functions that C needs to call.
+    lisp::%initial-function
+    lisp::maybe-gc
+    kernel::internal-error
+
+    ;; Free Pointers
+    lisp::*read-only-space-free-pointer*
+    lisp::*static-space-free-pointer*
+    lisp::*initial-dynamic-space-free-pointer*
+    rt::*allocation-pointer*
+    rt::*binding-stack-pointer*
+
+    ;; Things needed for non-local-exit.
+    lisp::*current-catch-block*
+    lisp::*current-unwind-protect-block*
+    *eval-stack-top*
+
+    ;; Interrupt Handling
+    lisp::*pseudo-atomic-atomic*
+    lisp::*pseudo-atomic-interrupted*
+    mach::*interrupts-enabled*
+    mach::*interrupt-pending*
+    lisp::*free-interrupt-context-index*
+
+    ;; Static functions.
+    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-=
+    two-arg-<= two-arg->= two-arg-/= %negate two-arg-and two-arg-ior two-arg-xor
+    length two-arg-gcd two-arg-lcm
+    ))
+
+(defparameter exported-static-symbols
+  (subseq static-symbols 0 (1+ (position 'lisp::*free-interrupt-context-index*
+					 static-symbols))))
+
+
+
+;;;; Assembler parameters:
+
+;;; The number of bits per element in the assemblers code vector.
+;;;
+(defparameter *assembly-unit-length* 8)
diff --git a/compiler/rt/pred.lisp b/compiler/rt/pred.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9c8973595c705225f04d1c2d2b648f0c216aef1e
--- /dev/null
+++ b/compiler/rt/pred.lisp
@@ -0,0 +1,53 @@
+;;; -*- Package: C; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/pred.lisp,v 1.1 1991/02/18 15:08:07 chiles Exp $
+;;;
+;;; This file contains the VM definition of predicate VOPs for the IBM RT.
+;;;
+;;; Written by Rob MacLachlan
+;;; Modified by William Lott and Bill Chiles for the IBM RT.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; The Branch VOP.
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination.  Dest is the label where we want to be.
+;;;
+(define-vop (branch)
+  (:info dest)
+  (:generator 5
+    (inst b dest)))
+
+
+
+;;;; Conditional VOPs:
+
+(define-vop (if-eq)
+  (:args (x :scs (any-reg descriptor-reg null))
+	 (y :scs (any-reg descriptor-reg null)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:translate eq)
+  (:generator 3
+    (let ((x-prime (sc-case x
+		     ((any-reg descriptor-reg) x)
+		     (null null-tn)))
+	  (y-prime (sc-case y
+		     ((any-reg descriptor-reg) y)
+		     (null null-tn))))
+      (inst c x-prime y-prime)
+      (if not-p
+	  (inst bnc :eq target)
+	  (inst bc :eq target)))))
diff --git a/compiler/rt/print.lisp b/compiler/rt/print.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..41ce17395c5e2412e6c9c5ef35b8bb66250b786e
--- /dev/null
+++ b/compiler/rt/print.lisp
@@ -0,0 +1,48 @@
+;;; -*- Package: RT -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/print.lisp,v 1.1 1991/02/18 15:08:08 chiles Exp $
+;;;
+;;; This file contains temporary printing utilities and similar noise.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "RT")
+
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:temporary (:sc any-reg :offset nl0-offset) nl0)
+  (:temporary (:sc any-reg :offset lra-offset) lra)
+  (:temporary (:sc any-reg :offset code-offset) code)
+  (:temporary (:scs (sap-reg)) temp)
+  (: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)))
+      (when cur-nfp
+	(store-stack-tn cur-nfp nfp-save))
+      (inst cal nsp-tn nsp-tn -16)
+      (storew object nsp-tn)
+      (inst compute-lra-from-code lra code lra-label)
+      (inst cai nl0 (make-fixup "_debug_print" :foreign))
+      (inst cai temp (make-fixup "call_into_c" :foreign))
+      (inst b temp)
+
+      (align vm:lowtag-bits)
+      (emit-label lra-label)
+      (inst lra-header-word)
+      (inst cal nsp-tn nsp-tn 16)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save))
+      (move result nl0))))
diff --git a/compiler/rt/sap.lisp b/compiler/rt/sap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..605e329644de47cd9c2ae9d4363ac3a568d20f55
--- /dev/null
+++ b/compiler/rt/sap.lisp
@@ -0,0 +1,380 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/sap.lisp,v 1.1 1991/02/18 15:08:09 chiles Exp $
+;;;
+;;; This file contains the IBM RT VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Moves and coercions:
+
+;;; MOVE-TO-SAP -- VOP.
+;;;
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:generator 1
+    (loadw y x vm:sap-pointer-slot vm:other-pointer-type)))
+;;;
+(define-move-vop move-to-sap :move
+  (descriptor-reg) (sap-reg))
+
+
+;;; MOVE-FROM-SAP -- VOP.
+;;;
+;;; Move an untagged SAP to a tagged representation.
+;;;
+(define-vop (move-from-sap)
+  (:args (sap :scs (sap-reg) :to :save))
+  (:temporary (:sc any-reg) header)
+  (:temporary (:sc word-pointer-reg) alloc)
+  (:results (y :scs (descriptor-reg)))
+  (:generator 1
+    (with-fixed-allocation (y header alloc vm:other-pointer-type vm:sap-size)
+      (storew sap y vm:sap-pointer-slot vm:other-pointer-type))))
+;;;
+(define-move-vop move-from-sap :move
+  (sap-reg) (descriptor-reg))
+
+
+;;; SAP-MOVE -- VOP.
+;;;
+;;; Move untagged sap values.
+;;;
+(define-vop (sap-move)
+  (:args (x :target y
+	    :scs (sap-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (sap-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop sap-move :move
+  (sap-reg) (sap-reg))
+
+
+;;; MOVE-SAP-ARGUMENT -- VOP.
+;;;
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+  (:args (x :target y
+	    :scs (sap-reg))
+	 (fp :scs (word-pointer-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move y x))
+      (sap-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+  (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (sap-reg) (descriptor-reg))
+
+
+
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+  (:args (sap :scs (sap-reg) :target int))
+  (:arg-types system-area-pointer)
+  (:results (int :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate sap-int)
+  (:policy :fast-safe) 
+ (:generator 1
+    (move int sap)))
+
+(define-vop (int-sap)
+  (:args (int :scs (unsigned-reg) :target sap))
+  (:arg-types unsigned-num)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate int-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap int)))
+
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg) :target res)
+	 (offset :scs (signed-reg) :to :save))
+  (:arg-types system-area-pointer signed-num)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 2
+    ;; Can't use CAS since offset and ptr may be register 0, so we have to move.
+    (move res ptr)
+    (inst a res offset)))
+;;;
+(define-vop (pointer+-c pointer+)
+  (:args (ptr :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 16)))
+  (:generator 1
+    (inst a res ptr offset)))
+
+(define-vop (pointer-)
+  (:translate sap-)
+  (:args (ptr1 :scs (sap-reg) :target res)
+	 (ptr2 :scs (sap-reg) :to :save))
+  (:arg-types system-area-pointer system-area-pointer)
+  (:policy :fast-safe)
+  (:results (res :scs (signed-reg)))
+  (:result-types signed-num)
+  (:generator 1
+    (move res ptr1)
+    (inst s res ptr2)))
+
+
+
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(eval-when (compile eval)
+
+;;; DEFINE-SYSTEM-REF -- Internal Interface.
+;;;
+;;; Name is the name of a computed system-ref offset, from which we generate a
+;;; <name>-c VOP for immediate constant offsets.  Shift is the multiples of two
+;;; for which we must adjust the offset to make it an index in terms of bytes
+;;; (the machines address units).  Translate and signed-translate are the Lisp
+;;; function calls for which these VOP's are in-line expansions.
+;;;
+(defmacro define-system-ref (name shift 
+				  translate result-sc result-type
+				  &optional
+				  signed-translate signed-result-sc
+				  signed-result-type)
+  (let ((access-form 
+	 (ecase shift
+	   (0 ;want a byte, indexed in bytes.
+	    '((inst lc result base offset)
+	      (when signed
+		(inst sl result 24)
+		(inst sar result 24))))
+	   (1 ;Want 16 bits.  Incoming offset is in 16-bit quantities.
+	      ;Offset here is in bytes.
+	    '((if signed
+		  (inst lha result base offset)
+		  (inst lh result base offset))))
+	   (2 ;Want 32 bits.  Incoming offset is in 32-bit quantities.
+	      ;Offset here is in bytes.
+	    '((loadw result base offset)))))
+	(name-c (symbolicate name "-C")))
+    `(progn
+       (define-vop (,name-c)
+	 (:policy :fast-safe)
+	 (:translate ,translate)
+	 (:args (base :scs (sap-reg)))
+	 (:results (result :scs (,result-sc)))
+	 (:result-types ,result-type)
+	 (:arg-types system-area-pointer
+		     (:constant (signed-byte ,(- 16 shift))))
+	 (:info offset)
+	 (:variant-vars signed)
+	 (:variant nil)
+	 (:generator 5
+	   (let ((offset (ash offset ,shift)))
+	     ,@access-form)))
+       
+       (define-vop (,name)
+	 (:policy :fast-safe)
+	 (:translate ,translate)
+	 (:args (object :scs (sap-reg) :to :eval)
+		(offset :scs (any-reg) :target base))
+	 (:results (result :scs (,result-sc)))
+	 (:arg-types system-area-pointer positive-fixnum)
+	 (:result-types ,result-type)
+	 (:temporary (:scs (sap-reg) :from (:argument 1)) base)
+	 (:variant-vars signed)
+	 (:variant nil)
+	 (:generator 5
+	   (move base offset)
+	   ;;
+	   ;; We shift right because the offset has fixnum lowtag.  Effectively
+	   ;; the index has already been multiplied by 4.
+	   ,@(let ((adj (- 2 shift)))
+	       (unless (zerop adj)
+		 `((inst sr base ,adj))))
+	   (inst a base object)
+	   (let ((offset 0))
+	     ,@access-form)))
+       
+       ,@(when signed-translate
+	   `((define-vop (,(symbolicate "SIGNED-" name-c) ,name-c)
+	       (:translate ,signed-translate)
+	       (:results (result :scs (,signed-result-sc)))
+	       (:result-types ,signed-result-type)
+	       (:variant t))
+	     
+	     (define-vop (,(symbolicate "SIGNED-" name) ,name)
+	       (:translate ,signed-translate)
+	       (:results (result :scs (,signed-result-sc)))
+	       (:result-types ,signed-result-type)
+	       (:variant t)))))))
+
+) ;eval-when
+
+(define-system-ref 8bit-system-ref 0
+  sap-ref-8 unsigned-reg positive-fixnum
+  signed-sap-ref-8 signed-reg tagged-num)
+
+(define-system-ref 16bit-system-ref 1
+  sap-ref-16 unsigned-reg positive-fixnum
+  signed-sap-ref-16 signed-reg tagged-num)
+
+(define-system-ref 32bit-system-ref 2
+  sap-ref-32 unsigned-reg unsigned-num
+  signed-sap-ref-32 signed-reg signed-num)
+
+(define-system-ref sap-system-ref 2
+  sap-ref-sap sap-reg system-area-pointer)
+
+
+(eval-when (compile eval)
+
+;;; DEFINE-SYSTEM-SET -- Internal.
+;;;
+;;; Name is the name of a computed system-ref offset, from which we generate a
+;;; <name>-c VOP for immediate constant offsets.  Shift is the multiples of two
+;;; for which we must adjust the offset to make it an index in terms of bytes
+;;; (the machines address units).  Translate and signed-translate are the Lisp
+;;; function calls for which these VOP's are in-line expansions.
+;;;
+(defmacro define-system-set (name shift translate data-scs data-type)
+  (let ((set-form 
+	 (ecase shift
+	   (0 ;Want a byte.  Incoming offset is in bytes.  No shifting.
+	    '(inst stc data base offset))
+	   (1 ;Want 16 bits.  Incoming offset is in 16-bit quantities.
+	      ;Offset here is in bytes.
+	    '(inst sth data base offset))
+	   (2 ;Want 32 bits.  Incoming offset is in 32-bit quantities.
+	      ;Offset here is in bytes.
+	    '(inst st data base offset))))
+	(name-c (symbolicate name "-C")))
+    `(progn
+       (define-vop (,name-c)
+	 (:policy :fast-safe)
+	 (:translate ,translate)
+	 (:args (base :scs (sap-reg))
+		(data :scs (,@data-scs) :target result :to (:result 0)))
+	 (:arg-types system-area-pointer
+		     ,data-type
+		     (:constant (signed-byte ,(- 16 shift))))
+	 (:results (result :scs (,@data-scs)))
+	 (:result-types ,data-type)
+	 (:info offset)
+	 (:generator 5
+	   (let ((offset (ash offset ,shift)))
+	     ,set-form)
+	   (move result data)))
+       
+       (define-vop (,name)
+	 (:policy :fast-safe)
+	 (:translate ,translate)
+	 (:args (object :scs (sap-reg) :to (:eval 0))
+		(offset :scs (any-reg) :target temp)
+		(data :scs (,@data-scs) :target result
+		      :to (:result 0)))
+	 (:arg-types system-area-pointer positive-fixnum ,data-type)
+	 (:temporary (:scs (sap-reg) :from (:eval 0) :to (:result 0)) base)
+	 (:temporary (:scs (non-descriptor-reg)
+			   :from (:argument 1) :to (:eval 0)) temp)
+	 (:results (result :scs (,@data-scs)))
+	 (:result-types ,data-type)
+	 (:generator 5
+	   (move temp offset)
+	   ;;
+	   ;; We shift right because the offset has fixnum lowtag.  Effectively
+	   ;; the index has already been multiplied by 4.
+	   ,@(let ((adj (- 2 shift)))
+	       (unless (zerop adj)
+		 `((inst sr temp ,adj))))
+	   (inst cas base temp object)
+	   (let ((offset 0))
+	     ,set-form)
+	   (move result data))))))
+
+) ;EVAL-WHEN
+
+(define-system-set 8bit-system-set 0 %set-sap-ref-8
+  (signed-reg unsigned-reg) (:or signed-num unsigned-num))
+
+(define-system-set 16bit-system-set 1 %set-sap-ref-16
+  (signed-reg unsigned-reg) (:or signed-num unsigned-num))
+
+(define-system-set 32bit-system-set 2 %set-sap-ref-32
+  (signed-reg unsigned-reg) (:or signed-num unsigned-num))
+
+(define-system-set sap-system-set 2 %set-sap-ref-sap
+  (sap-reg) system-area-pointer)
+
+
+
+;;;; Noise to convert normal lisp data objects into SAPs.
+
+(define-vop (vector-sap)
+  (:translate vector-sap)
+  (:policy :fast-safe)
+  (:args (vector :scs (descriptor-reg)))
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (inst cal sap vector
+	  (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))))
+
+
+
+;;;; ### Noise to allow old forms to continue to work until they are gone.
+
+(macrolet ((frob (prim func)
+	     `(def-primitive-translator ,prim (&rest args)
+		(warn "Someone used %primitive ~S -- should be ~S."
+		      ',prim ',func)
+		`(,',func ,@args))))
+  (frob 32bit-system-ref sap-ref-32)
+  (frob unsigned-32bit-system-ref sap-ref-32)
+  (frob 16bit-system-ref sap-ref-16)
+  (frob 8bit-system-ref sap-ref-8))
+
+(macrolet ((frob (prim func)
+	     `(def-primitive-translator ,prim (&rest args)
+		(warn "Someone used %primitive ~S -- should be ~S."
+		      ',prim (list 'setf ',func))
+		`(setf ,',func ,@args))))
+  (frob 32bit-system-set sap-ref-32)
+  (frob signed-32bit-system-set sap-ref-32)
+  (frob 16bit-system-set sap-ref-16)
+  (frob 8bit-system-set sap-ref-8))
diff --git a/compiler/rt/static-fn.lisp b/compiler/rt/static-fn.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..60045803a1baf0922acf226cc0df2f3ae962978b
--- /dev/null
+++ b/compiler/rt/static-fn.lisp
@@ -0,0 +1,146 @@
+;;; -*- Package: C; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/static-fn.lisp,v 1.1 1991/02/18 15:08:13 chiles Exp $
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;; Converted by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+(define-vop (static-function-template)
+  (:save-p t)
+  (:policy :safe)
+  (:variant-vars symbol)
+  (:vop-var vop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg)) move-temp)
+  (:temporary (:sc descriptor-reg :offset lra-offset) lra)
+  (:temporary (:sc descriptor-reg :offset cname-offset) cname)
+  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
+
+
+(eval-when (compile load eval)
+
+(defun static-function-template-name (num-args num-results)
+  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+		  num-args num-results)))
+
+(defun moves (dst src)
+  (collect ((moves))
+    (do ((dst dst (cdr dst))
+	 (src src (cdr src)))
+	((or (null dst) (null src)))
+      (moves `(move ,(car dst) ,(car src))))
+    (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+  (assert (and (<= num-args register-arg-count)
+	       (<= num-results register-arg-count))
+	  (num-args num-results)
+	  "Either too many args (~D) or too many results (~D).  Max = ~D"
+	  num-args num-results register-arg-count)
+  (let ((num-temps (max num-args num-results)))
+    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+      (dotimes (i num-results)
+	(let ((result-name (intern (format nil "RESULT-~D" i))))
+	  (result-names result-name)
+	  (results `(,result-name :scs (any-reg descriptor-reg)))))
+      (dotimes (i num-temps)
+	(let ((temp-name (intern (format nil "TEMP-~D" i))))
+	  (temp-names temp-name)
+	  (temps `(:temporary (:sc descriptor-reg
+			       :offset ,(nth i register-arg-offsets)
+			       ,@(when (< i num-args)
+				   `(:from (:argument ,i)))
+			       ,@(when (< i num-results)
+				   `(:to (:result ,i)
+				     :target ,(nth i (result-names)))))
+			      ,temp-name))))
+      (dotimes (i num-args)
+	(let ((arg-name (intern (format nil "ARG-~D" i))))
+	  (arg-names arg-name)
+	  (args `(,arg-name
+		  :scs (any-reg descriptor-reg)
+		  :target ,(nth i (temp-names))))))
+      `(define-vop (,(static-function-template-name num-args num-results)
+		    static-function-template)
+	 (:args ,@(args))
+	 ,@(temps)
+	 (:results ,@(results))
+	 (:generator ,(+ 50 num-args num-results)
+	   (let ((lra-label (gen-label))
+		 (cur-nfp (current-nfp-tn vop)))
+	     ,@(moves (temp-names) (arg-names))
+	     (inst li nargs (fixnum ,num-args))
+	     (load-symbol cname symbol)
+	     (loadw lip cname vm:symbol-raw-function-addr-slot
+		    vm:other-pointer-type)
+	     (when cur-nfp
+	       (store-stack-tn cur-nfp nfp-save))
+	     (move old-fp cfp-tn)
+	     (inst compute-lra-from-code lra code-tn lra-label)
+	     (inst bx lip)
+	     (inst move cfp-tn csp-tn)
+	     (emit-return-pc lra-label)
+	     (note-this-location vop :unknown-return)
+	     ,(collect ((bindings) (links))
+		(do ((temp (temp-names) (cdr temp))
+		     (name 'values (gensym))
+		     (prev nil name)
+		     (i 0 (1+ i)))
+		    ((= i num-results))
+		  (bindings `(,name
+			      (make-tn-ref ,(car temp) nil)))
+		  (when prev
+		    (links `(setf (tn-ref-across ,prev) ,name))))
+		`(let ,(bindings)
+		   ,@(links)
+		   (default-unknown-values
+		       ,(if (zerop num-results) nil 'values)
+		       ,num-results move-temp lra-label)))
+	     (when cur-nfp
+	       (load-stack-tn cur-nfp nfp-save))
+	     ,@(moves (result-names) (temp-names))))))))
+
+) ;EVAL-WHEN (compile load eval)
+
+
+(macrolet ((frob (nargs nres)
+	     (static-function-template-vop nargs nres)))
+  (frob 0 1)
+  (frob 1 1)
+  (frob 2 1))
+  
+(defmacro define-static-function (name args &key (results '(x)) translate
+				       policy cost arg-types result-types)
+  `(define-vop (,name
+		,(static-function-template-name (length args)
+						(length results)))
+     (:variant ',name)
+     (:note ,(format nil "static-function ~@(~S~)" name))
+     ,@(when translate
+	 `((:translate ,translate)))
+     ,@(when policy
+	 `((:policy ,policy)))
+     ,@(when cost
+	 `((:generator-cost ,cost)))
+     ,@(when arg-types
+	 `((:arg-types ,@arg-types)))
+     ,@(when result-types
+	 `((:result-types ,@result-types)))))
diff --git a/compiler/rt/subprim.lisp b/compiler/rt/subprim.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2c9eb7942bd8c0e02813747d899d33ce695775b0
--- /dev/null
+++ b/compiler/rt/subprim.lisp
@@ -0,0 +1,63 @@
+;;; -*- Package: MIPS; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/subprim.lisp,v 1.1 1991/02/18 15:08:16 chiles Exp $
+;;;
+;;; Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;; Converted for IBM RT by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Length
+
+(define-vop (length/list)
+  (:translate length)
+  (: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 (any-reg) :type fixnum :to (:result 0) :target result)
+	      count)
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:policy :fast-safe)
+  (: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)
+      (inst li count 0)
+
+      (emit-label loop)
+
+      (inst c ptr null-tn)
+      (inst bc :eq done)
+
+      (test-type ptr temp not-list t vm:list-pointer-type)
+
+      (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
+      (inst inc count (fixnum 1))
+      (test-type ptr temp loop nil vm:list-pointer-type)
+
+      (cerror-call vop done object-not-list-error ptr)
+
+      (emit-label done)
+      (move result count))))
+       
+
+(define-static-function length (object) :translate length)
+
+
+
diff --git a/compiler/rt/system.lisp b/compiler/rt/system.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b3f3166b13cacf4680a0435906fa320c151c4451
--- /dev/null
+++ b/compiler/rt/system.lisp
@@ -0,0 +1,286 @@
+;;; -*- Package: rt; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/system.lisp,v 1.1 1991/02/18 15:08:18 chiles Exp $
+;;;
+;;; IBM RT VM definitions of various system hacking operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; IBM RT conversion by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Random pointer comparison VOPs
+
+(define-vop (pointer-compare)
+  (:args (x :scs (sap-reg))
+	 (y :scs (sap-reg)))
+  (:arg-types system-area-pointer system-area-pointer)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline comparison")
+  (:variant-vars condition)
+  (:generator 6
+    (inst cl x y)
+    (if not-p
+	(inst bnc condition target)
+	(inst bc condition target))))
+
+(macrolet ((frob (name cond)
+	     `(progn
+		(def-primitive-translator ,name (x y) `(,',name ,x ,y))
+		(defknown ,name (t t) boolean (movable foldable flushable))
+		(define-vop (,name pointer-compare)
+		  (:translate ,name)
+		  (:variant ,cond)))))
+  (frob pointer< :lt)
+  (frob pointer> :gt))
+
+
+
+;;;; Random assertions VOPS.
+
+(define-vop (check-op)
+  (:args (x :scs (any-reg descriptor-reg))
+	 (y :scs (any-reg descriptor-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:policy :fast-safe))
+
+(define-vop (check<= check-op)
+  (:translate check<=)
+  (:generator 6
+    (let ((target (generate-error-code vop not-<=-error x y)))
+      (inst c x y)
+      (inst bc :gt target))))
+
+(define-vop (check= check-op)
+  (:translate check=)
+  (:generator 6
+    (let ((target (generate-error-code vop not-=-error x y)))
+      (inst c x y)
+      (inst bnc :eq target))))
+
+
+
+;;;; Type frobbing VOPs.
+
+(define-vop (get-lowtag)
+  (:translate get-lowtag)
+  (:policy :fast-safe)
+  (:args (object :scs (any-reg descriptor-reg)))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (inst nilz result object lowtag-mask)))
+
+(define-vop (get-type)
+  (:translate get-type)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (let ((other-ptr (gen-label))
+	  (function-ptr (gen-label))
+	  (lowtag-only (gen-label))
+	  (done (gen-label)))
+      (test-type object ndescr other-ptr nil other-pointer-type)
+      (test-type object ndescr function-ptr nil function-pointer-type)
+      (test-type object ndescr lowtag-only nil
+		 even-fixnum-type odd-fixnum-type list-pointer-type
+		 structure-pointer-type)
+      (inst bx done)
+      (inst nilz result object type-mask)
+
+      (emit-label function-ptr)
+      (load-type result object (- function-pointer-type))
+      (inst b done)
+
+      (emit-label lowtag-only)
+      (inst bx done)
+      (inst nilz result object lowtag-mask)
+
+      (emit-label other-ptr)
+      (load-type result object (- other-pointer-type))
+      
+      (emit-label done))))
+
+(define-vop (get-header-data)
+  (:translate get-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 7
+    (loadw res x 0 other-pointer-type)
+    (inst sr res type-bits)))
+
+(define-vop (get-closure-length)
+  (:translate get-closure-length)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 7
+    (loadw res x 0 function-pointer-type)
+    (inst sr res type-bits)))
+
+;;; SET-HEADER-DATA -- VOP.
+;;;
+;;; In the immediate case for data, we use the OIL instruction assuming the
+;;; data fits in the number of bits determined by 16 minus type-bits.  Due to
+;;; known uses of this VOP, which only store single digit tags, the above
+;;; assumption is reasonable, although unnecessarily slimy.
+;;;
+(define-vop (set-header-data)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res)
+	 (data :scs (any-reg immediate) :target t2))
+  (:arg-types * positive-fixnum)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :type random) t1)
+  (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) t2)
+  (:generator 15
+    (loadw t1 x 0 other-pointer-type)
+    (inst nilz t1 type-mask)
+    (sc-case data
+      (any-reg
+       (move t2 data)
+       ;; Since the data is in fixnum format, it is already shifted by 2 bits.
+       (inst sl t2 (- type-bits 2))
+       (inst o t1 t2))
+      (immediate
+       (let ((value (tn-value data)))
+	 (unless (zerop value)
+	   (inst oil t1 (ash value type-bits))))))
+    (storew t1 x 0 other-pointer-type)
+    (move res x)))
+
+;;; MAKE-FIXNUM -- VOP.
+;;;
+;;; This is just used in hashing stuff.  It doesn't necessarily have to
+;;; preserve all the bits in the pointer.  Some code expects a positive number,
+;;; so make sure the right shift is logical.
+;;;
+(define-vop (make-fixnum)
+  (:args (ptr :scs (any-reg descriptor-reg) :target temp))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 3
+    (move temp ptr)
+    (inst sl temp 3)
+    (inst sr temp 1)
+    (move temp res)))
+
+(define-vop (make-other-immediate-type)
+  (:args (val :scs (any-reg descriptor-reg) :target vtemp)
+	 (type :scs (any-reg descriptor-reg immediate)))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) vtemp)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:generator 2
+    (sc-case type
+      (immediate
+       (move vtemp val)
+       (inst sl vtemp type-bits)
+       (inst oil res temp (tn-value type)))
+      (t
+       ;; Type is a fixnum, so lose those lowtag bits.
+       (move temp type)
+       (inst sr temp 2)
+       ;; Val is a fixnum, so we can shift it left two less bits.
+       (move res val)
+       (inst sl res (- type-bits 2))
+       (inst o res temp)))))
+
+
+
+;;;; Allocation
+
+(define-vop (dynamic-space-free-pointer)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate dynamic-space-free-pointer)
+  (:policy :fast-safe)
+  (:generator 6
+    (load-symbol-value int *allocation-pointer*)))
+
+(define-vop (binding-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate binding-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 6
+    (load-symbol-value int *binding-stack-pointer*)))
+
+(define-vop (control-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate control-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int csp-tn)))
+
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+  (:args (code :scs (descriptor-reg) :target sap))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 10
+    (loadw ndescr code 0 other-pointer-type)
+    (inst sr ndescr type-bits)
+    (inst sl ndescr word-shift)
+    (inst s ndescr other-pointer-type)
+    (move sap code)
+    (inst a sap ndescr)))
+
+(define-vop (compute-function)
+  (:args (code :scs (descriptor-reg))
+	 (offset :scs (signed-reg unsigned-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (func :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 10
+    (loadw ndescr code 0 other-pointer-type)
+    (inst sr ndescr type-bits)
+    (inst sl ndescr word-shift)
+    (inst a ndescr offset)
+    (inst a ndescr (- function-pointer-type other-pointer-type))
+    (inst a ndescr code)
+    (move func ndescr)))
+
+
+
+;;;; Other random VOPs.
+
+
+(defknown mach::do-pending-interrupt () (values))
+(define-vop (mach::do-pending-interrupt)
+  (:policy :fast-safe)
+  (:translate mach::do-pending-interrupt)
+  (:generator 1
+    (inst break pending-interrupt-trap)))
+
+
+(define-vop (halt)
+  (:generator 1
+    (inst break halt-trap)))
+
diff --git a/compiler/rt/type-vops.lisp b/compiler/rt/type-vops.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b16e5cbd22a776867181607c7347bdf6c6525846
--- /dev/null
+++ b/compiler/rt/type-vops.lisp
@@ -0,0 +1,468 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/type-vops.lisp,v 1.1 1991/02/18 15:08:21 chiles Exp $
+;;; 
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the IBM RT.
+;;;
+;;; Written by William Lott.
+;;; Converted to IBM RT by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Simple type checking and testing.
+
+;;; These types are represented by a single type code and are easily open-coded
+;;; as a mask and compare.
+;;;
+
+;;; CHECK-TYPE -- VOP.
+;;;
+;;; Type checking VOPs include this.  Instances of this either returns value
+;;; in result, or they jump to error code if the type is wrong.
+;;;
+(define-vop (check-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))
+
+;;; TYPE-PREDICATE -- VOP.
+;;;
+;;; Type predicate VOPs include this.  They jump to target when value is of the
+;;; appropriate type; otherwise, they drop through.  When not-p is true, they
+;;; drop through if value is of the type and jumps to target if not.
+;;;
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:temporary (:scs (non-descriptor-reg)) temp))
+
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) vm: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))))))
+
+); eval-when (compile eval)
+
+
+(def-type-vops fixnump check-fixnum nil object-not-fixnum-error
+  vm:even-fixnum-type vm:odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+  object-not-function-error vm:function-pointer-type)
+
+(def-type-vops listp check-list list
+  object-not-list-error vm:list-pointer-type)
+
+(def-type-vops structurep check-structure structure
+  object-not-structure-error vm:structure-pointer-type)
+
+(def-type-vops bignump check-bigunm bignum
+  object-not-bignum-error vm:bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error vm:ratio-type)
+
+(def-type-vops complexp check-complex complex
+  object-not-complex-error vm:complex-type)
+
+(def-type-vops single-float-p check-single-float nil ;single-float
+  object-not-single-float-error vm:single-float-type)
+
+(def-type-vops double-float-p check-double-float nil ;double-float
+  object-not-double-float-error vm:double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error vm:simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error vm:simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error vm: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
+  vm: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
+  vm: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
+  vm: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
+  vm: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
+  vm: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
+  vm: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
+  vm:simple-array-double-float-type)
+
+(def-type-vops base-char-p check-base-character base-character
+  object-not-base-character-error vm:base-character-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error vm:sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error vm:weak-pointer-type)
+
+(def-type-vops array-header-p nil nil nil
+  vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
+  vm:complex-vector-type vm:complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
+  vm:function-pointer-type vm:symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  vm:simple-string-type vm:complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  vm:simple-bit-vector-type vm:complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil 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)
+
+(def-type-vops simple-array-p check-simple-array nil 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)
+
+(def-type-vops arrayp check-array nil 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)
+
+(def-type-vops numberp check-number nil 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)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  vm:single-float-type vm:double-float-type)
+
+(def-type-vops realp check-real nil 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)
+
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+;;;
+
+(define-vop (signed-byte-32-p 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))
+	;; Is it a fisnum?
+	(inst nilz temp value #x3)
+	(inst bc :eq yep)
+	;; If not, is it an other pointer?
+	(test-type value temp nope t vm:other-pointer-type)
+	;; If so, get the header.
+	(loadw temp value 0 vm:other-pointer-type)
+	;; Is it a bignum of length one?
+	(inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
+	(if not-p
+	    (inst bnc :eq target)
+	    (inst bc :eq target))
+	(emit-label not-target)))))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
+	  (yep (gen-label)))
+      (inst nilz temp value #x3)
+      (inst bc :eq yep)
+      (test-type value temp nope t vm:other-pointer-type)
+      (loadw temp value 0 vm:other-pointer-type)
+      (inst c temp
+	    ;; Header word representing a bignum of length one.
+	    (logior (ash 1 vm:type-bits) vm:bignum-type))
+      (inst bnc :eq nope)
+      (emit-label yep)
+      (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 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 nilz temp value #x3)
+	(inst bcx :eq fixnum)
+	(inst c value 0)
+	;; If not, is it an other pointer?
+	(test-type value temp nope t vm:other-pointer-type)
+	;; Get the header.
+	(loadw temp value 0 vm:other-pointer-type)
+	;; Is it a bignum of length one?
+	(inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
+	(inst bcx :eq single-word)
+	;; If it length is other than two, we can't be an (unsigned-byte 32).
+	(inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type))
+	(inst bncx :eq nope)
+	;; Get the second digit.
+	(loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+	;; All zeros, its an (unsigned-byte 32).
+	(inst c temp 0)
+	(inst bc :eq yep)
+	;; Otherwise, it isn't.
+	(inst b nope)
+	
+	(emit-label single-word)
+	;; Get the single digit.
+	(loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
+	(inst c temp 0)
+
+	;; positive implies (unsigned-byte 32).
+	(emit-label fixnum)
+	(if not-p
+	    (inst bc :lt target)
+	    (inst bnc :lt target))
+
+	(emit-label not-target)))))	  
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((nope
+	   (generate-error-code vop object-not-unsigned-byte-32-error value))
+	  (yep (gen-label))
+	  (fixnum (gen-label))
+	  (single-word (gen-label)))
+      ;; Is it a fixnum?
+      (inst nilz temp value #x3)
+      (inst bcx :eq fixnum)
+      (inst c value 0)
+
+      ;; If not, is it an other pointer?
+      (test-type value temp nope t vm:other-pointer-type)
+      ;; Get the number of digits.
+      (loadw temp value 0 vm:other-pointer-type)
+      ;; Is it one?
+      (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
+      (inst bcx :eq single-word)
+      ;; If it's length is other than two, we can't be an (unsigned-byte 32).
+      (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type))
+      (inst bncx :eq nope)
+      ;; Get the second digit.
+      (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst c temp 0)
+      (inst bc :eq yep)
+      ;; Otherwise, it isn't.
+      (inst bnc :eq nope)
+      
+      (emit-label single-word)
+      ;; Get the single digit.
+      (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
+      ;; positive implies (unsigned-byte 32).
+      (inst c temp 0)
+      
+      (emit-label fixnum)
+      (inst bc :lt nope)
+      
+      (emit-label yep)
+      (move result value))))
+
+
+
+
+;;;; List/symbol types:
+
+;;; SYMBOLP -- VOP.
+;;;
+;;; This is (or symbol (eq nil)).
+;;;
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (let* ((drop-thru (gen-label))
+	   (is-symbol-label (if not-p drop-thru target)))
+      (inst c value null-tn)
+      (inst bc :eq is-symbol-label)
+      (test-type value temp target not-p vm:symbol-header-type)
+      (emit-label drop-thru))))
+;;;
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (let ((drop-thru (gen-label))
+	  (error (generate-error-code vop object-not-symbol-error value)))
+      (inst c value null-tn)
+      (inst bc :eq drop-thru)
+      (test-type value temp error t vm:symbol-header-type)
+      (emit-label drop-thru)
+      (move result value))))
+  
+;;; CONSP -- VOP.
+;;;
+;;; This is (and list (not (eq nil))).
+;;;
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (let* ((drop-thru (gen-label))
+	   (is-not-cons-label (if not-p target drop-thru)))
+      (inst c value null-tn)
+      (inst bc :eq is-not-cons-label)
+      (test-type value temp target not-p vm:list-pointer-type)
+      (emit-label drop-thru))))
+;;;
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst c value null-tn)
+      (inst bc :eq error)
+      (test-type value temp error t vm:list-pointer-type)
+      (move result value))))
+
+
+
+;;;; Function Coercion
+
+;;; If not a function, get the symbol value and test for that being a
+;;; function.  Since we test for a function rather than the unbound
+;;; marker, this works on NIL.
+;;;
+(define-vop (coerce-to-function)
+  (:args (object :scs (descriptor-reg)
+		 :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
+  (:temporary (:scs (descriptor-reg)) saved-object)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (let ((not-function-label (gen-label))
+	  (not-coercable-label (gen-label))
+	  (done-label (gen-label)))
+      (test-type object nd-temp not-function-label t
+		 vm:function-pointer-type)
+      (move result object)
+      (emit-label done-label)
+
+      (assemble (*elsewhere*)
+	(emit-label not-function-label)
+	(test-type object nd-temp not-coercable-label t
+		   vm:symbol-header-type)
+	(move saved-object object)
+	(loadw result object vm:symbol-function-slot vm:other-pointer-type)
+	(test-type result nd-temp done-label nil
+		   vm:function-pointer-type)
+	(error-call vop undefined-symbol-error saved-object)
+	
+	(emit-label not-coercable-label)
+	(error-call vop object-not-coercable-to-function-error object)))))
+
+(define-vop (fast-safe-coerce-to-function)
+  (:args (object :scs (descriptor-reg)
+		 :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
+  (:temporary (:scs (descriptor-reg)) saved-object)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 10
+    (let ((not-function-label (gen-label))
+	  (done-label (gen-label)))
+      (test-type object nd-temp not-function-label t vm:function-pointer-type)
+      (move result object)
+      (emit-label done-label)
+
+      (assemble (*elsewhere*)
+	(emit-label not-function-label)
+	(move saved-object object)
+	(loadw result object vm:symbol-function-slot vm:other-pointer-type)
+	(test-type result nd-temp done-label nil vm:function-pointer-type)
+	(error-call vop undefined-symbol-error saved-object)))))
diff --git a/compiler/rt/values.lisp b/compiler/rt/values.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a7123302b7d7f91ca0d29d2de95e4e19d5239883
--- /dev/null
+++ b/compiler/rt/values.lisp
@@ -0,0 +1,102 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/values.lisp,v 1.1 1991/02/18 15:08:26 chiles Exp $
+;;;
+;;; This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted for IBM RT by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move csp-tn ptr)))
+
+;;; PUSH-VALUES -- VOP.
+;;;
+;;; Push some values onto the stack, returning the start and number of values
+;;; pushed as results.  It is assumed that the Vals are wired to the standard
+;;; argument locations.  Nvals is the number of values to push.
+;;;
+;;; The generator cost is pseudo-random.  We could get it right by defining a
+;;; bogus SC that reflects the costs of the memory-to-memory moves for each
+;;; operand, but this seems unworthwhile.
+;;;
+(define-vop (push-values)
+  (:args
+   (vals :more t))
+  (:results
+   (start :scs (word-pointer-reg))
+   (count :scs (any-reg)))
+  (:info nvals)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg)
+	       :to (:result 0)
+	       :target start)
+	      start-temp)
+  (:generator 20
+    (move start-temp csp-tn)
+    (inst cal csp-tn csp-tn (* nvals word-bytes))
+    (do ((val vals (tn-ref-across val))
+	 (i 0 (1+ i)))
+	((null val))
+      (let ((tn (tn-ref-tn val)))
+	(sc-case tn
+	  (descriptor-reg
+	   (storew tn start-temp i))
+	  (control-stack
+	   (load-stack-tn temp tn)
+	   (storew temp start-temp i)))))
+    (move start start-temp)
+    (inst li count (fixnum nvals))))
+
+
+;;; VALUES-LIST -- VOP.
+;;;
+;;; Push a list of values on the stack, returning Start and Count as used in
+;;; unknown values continuations.
+;;;
+(define-vop (values-list)
+  (:args (arg :scs (descriptor-reg) :target list))
+  (:arg-types list)
+  (:policy :fast-safe)
+  (:results (start :scs (word-pointer-reg))
+	    (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)
+  (: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 c list null-tn)
+      (inst bcx :eq done)
+      (loadw temp list cons-car-slot list-pointer-type)
+      (loadw list list cons-cdr-slot list-pointer-type)
+      (inst cal csp-tn csp-tn word-bytes)
+      (storew temp csp-tn -1)
+      (test-type list ndescr loop nil list-pointer-type)
+      (error-call vop bogus-argument-to-values-list-error list)
+
+      (emit-label done)
+      (move csp-tn count)
+      (inst s count start))))
diff --git a/compiler/rt/vm.lisp b/compiler/rt/vm.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3b2a5d4b465ec2dabfe69906ce902e20ae258e30
--- /dev/null
+++ b/compiler/rt/vm.lisp
@@ -0,0 +1,652 @@
+;;; -*- Package: RT; Log: c.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition for the IBM RT.
+;;;
+;;; Written by William Lott, Rob Maclachlan, and Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+
+;;;; SB and SC definition:
+
+(define-storage-base registers :finite :size 16)
+(define-storage-base 68881-float-registers :finite :size 8)
+(define-storage-base AFPA-float-registers :finite :size 64)
+(define-storage-base FPA-float-registers :finite :size 16)
+(define-storage-base control-stack :unbounded :size 8)
+(define-storage-base non-descriptor-stack :unbounded :size 0)
+;; These are constants in components.
+(define-storage-base constant :non-packed)
+;; Anything I can cookup out of nowhere and store somewhere.
+(define-storage-base immediate-constant :non-packed)
+
+;;;
+;;; Handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class.
+;;; 
+(defmacro define-storage-classes (&rest classes)
+  (do ((forms (list 'progn)
+	      (let* ((class (car classes))
+		     (sc-name (car class))
+		     (constant-name (intern (concatenate 'simple-string
+							 (string sc-name)
+							 "-SC-NUMBER"))))
+		(list* `(define-storage-class ,sc-name ,index
+			  ,@(cdr class))
+		       `(defconstant ,constant-name ,index)
+		       `(export ',constant-name)
+		       forms)))
+       (index 0 (1+ index))
+       (classes classes (cdr classes)))
+      ((null classes)
+       (nreverse forms))))
+
+(define-storage-classes
+
+  ;; Non-immediate contstants in the constant pool
+  (constant constant)
+
+
+  (immediate immediate-constant)
+  (null immediate-constant)
+
+
+  ;; The control stack.  (Scanned by GC)
+  (control-stack control-stack)
+
+  ;; The non-descriptor stack SC's.
+  (signed-stack non-descriptor-stack) ; (signed-byte 32)
+  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
+  (base-character-stack non-descriptor-stack) ; non-descriptor characters.
+  (sap-stack non-descriptor-stack) ; System area pointers.
+  (single-stack non-descriptor-stack) ; single-floats
+  (double-stack non-descriptor-stack :element-size 2) ; double floats.
+
+
+  ;; **** Things that can go in the non-descriptor registers.
+
+  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
+  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
+  (any-reg registers
+   :locations (0 2 3 4 9 10 11 12 13 14)
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Descriptor objects.  Must be seen by GC.
+  (descriptor-reg registers
+   :locations (9 10 11 12 13 14)
+   ;; Immediate (and constant) for moving NULL around (at least).
+   :constant-scs (constant immediate null)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Non-Descriptor characters.
+  (base-character-reg registers
+   :locations (0 2 3 4)
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (base-character-stack))
+
+  ;; Non-Descriptor SAP's (arbitrary pointers into address space).
+  (sap-reg registers
+   ;; Exclude R0 here because the instructions we would like to use with sap
+   ;; TN's use R0 as the constant zero instead of using the contents of R0.
+   :locations (2 3 4)
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (sap-stack))
+
+  ;; Non-Descriptor (signed or unsigned) numbers.
+  (signed-reg registers
+   :locations (0 2 3 4)
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (signed-stack))
+  (unsigned-reg registers
+   :locations (0 2 3 4)
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (unsigned-stack))
+
+  ;; Random objects that must not be seen by GC.  Used only as temporaries.
+  (non-descriptor-reg registers
+   :locations (0 2 3 4))
+
+  ;; Word-aligned pointers that cannot be in R0.  Used only as temporaries.
+  (word-pointer-reg registers
+   :locations (2 3 4 9 10 11 12 13 14)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Pointers to the interior of objects.  Used only as an temporary.
+  (interior-reg registers
+   :locations (15))
+
+
+  ;; **** Things that can go in the floating point registers.
+
+  ;; Non-Descriptor 68881-single-floats.
+  (68881-single-reg 68881-float-registers
+   :locations (0 1 2 3 4 5 6 7)
+   :constant-scs (constant)
+   :save-p t
+   :alternate-scs (single-stack))
+  ;; Non-Descriptor 68881-double-floats.
+  (68881-double-reg 68881-float-registers
+   :locations (0 1 2 3 4 5 6 7)
+   :constant-scs (constant)
+   :save-p t
+   :alternate-scs (double-stack))
+
+  ;; Non-Descriptor FPA-single-floats.
+  (FPA-single-reg FPA-float-registers
+   ;; 14 and 15 are status and exception registers.
+   :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13)
+   :constant-scs (constant)
+   :save-p t
+   :alternate-scs (single-stack))
+  ;; Non-Descriptor FPA-double-floats.
+  (FPA-double-reg FPA-float-registers
+   :locations (0 2 4 6 8 10 12) ;14 and 15 are status and exception registers.
+   :element-size 2
+   :constant-scs (constant)
+   :save-p t
+   :alternate-scs (double-stack))
+
+  ;; Non-Descriptor AFPA-single-floats.
+  (AFPA-single-reg AFPA-float-registers
+   :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
+	       24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
+	       45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63)
+   :constant-scs (constant)
+   :save-p t
+   :alternate-scs (single-stack))
+  ;; Non-Descriptor AFPA-double-floats.
+  (AFPA-double-reg AFPA-float-registers
+   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28
+	       30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62)
+   :element-size 2
+   :constant-scs (constant)
+   :save-p t
+   :alternate-scs (double-stack))
+
+
+  ;; A catch or unwind block.
+  (catch-block control-stack :element-size vm:catch-block-size))
+
+
+
+
+;;;; Primitive Type Definitions
+
+;;; *any-primitive-type*
+;;;
+;;; Other VOP/VM definition files use this when writing interface code for the
+;;; compiler.
+;;;
+(def-primitive-type t (descriptor-reg))
+(defvar *any-primitive-type* (primitive-type-or-lose 't))
+(setf (c:backend-any-primitive-type c:*target-backend*)
+      (c:primitive-type-or-lose 't))
+
+;;; Primitive integer types that fit in registers.
+;;;
+(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
+  :type (unsigned-byte 29))
+(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
+  :type (unsigned-byte 31))
+(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
+  :type (unsigned-byte 32))
+(def-primitive-type fixnum (any-reg signed-reg)
+  :type (signed-byte 30))
+(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
+  :type (signed-byte 32))
+(def-primitive-type word-pointer (word-pointer-reg descriptor-reg)
+  :type fixnum)
+
+
+;;; *word-pointer-type*
+;;;
+(defvar *word-pointer-type* (primitive-type-or-lose 'word-pointer))
+
+
+;;; *fixnum-primitive-type*
+;;;
+;;; Other VOP/VM definition files use this when writing interface code for the
+;;; compiler.
+;;;
+(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
+
+(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
+(def-primitive-type-alias unsigned-num (:or unsigned-byte-32
+					    unsigned-byte-31
+					    positive-fixnum))
+(def-primitive-type-alias signed-num (:or signed-byte-32
+					  fixnum
+					  unsigned-byte-31
+					  positive-fixnum))
+
+;;; Other primitive immediate types.
+(def-primitive-type base-character (base-character-reg any-reg))
+
+;;; Primitive pointer types.
+;;; 
+(def-primitive-type function (descriptor-reg))
+(def-primitive-type list (descriptor-reg))
+(def-primitive-type structure (descriptor-reg))
+
+;;; Primitive other-pointer number types.
+;;; 
+(def-primitive-type bignum (descriptor-reg))
+(def-primitive-type ratio (descriptor-reg))
+(def-primitive-type complex (descriptor-reg))
+(def-primitive-type 68881-single-float (68881-single-reg descriptor-reg))
+(def-primitive-type 68881-double-float (68881-double-reg descriptor-reg))
+(def-primitive-type FPA-single-float (FPA-single-reg descriptor-reg))
+(def-primitive-type FPA-double-float (FPA-double-reg descriptor-reg))
+(def-primitive-type AFPA-single-float (AFPA-single-reg descriptor-reg))
+(def-primitive-type AFPA-double-float (AFPA-double-reg descriptor-reg))
+(def-primitive-type any-single-float (descriptor-reg))
+(def-primitive-type any-double-float (descriptor-reg))
+
+;;; Primitive other-pointer array types.
+;;; 
+(def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
+(def-primitive-type simple-bit-vector (descriptor-reg))
+(def-primitive-type simple-vector (descriptor-reg))
+(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
+  :type (simple-array (unsigned-byte 2) (*)))
+(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
+  :type (simple-array (unsigned-byte 4) (*)))
+(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
+  :type (simple-array (unsigned-byte 8) (*)))
+(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
+  :type (simple-array (unsigned-byte 16) (*)))
+(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
+  :type (simple-array (unsigned-byte 32) (*)))
+(def-primitive-type simple-array-single-float (descriptor-reg)
+  :type (simple-array single-float (*)))
+(def-primitive-type simple-array-double-float (descriptor-reg)
+  :type (simple-array double-float (*)))
+
+;;; Note: The complex array types are not included, because it is pointless to
+;;; restrict VOPs to them.
+
+;;; Other primitive other-pointer types.
+;;; 
+(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
+(def-primitive-type weak-pointer (descriptor-reg))
+
+;;; Random primitive types that don't exist at the LISP level.
+;;; 
+(def-primitive-type random (non-descriptor-reg) :type nil)
+(def-primitive-type interior (interior-reg) :type nil)
+(def-primitive-type catch-block (catch-block) :type nil)
+
+
+
+
+;;;; PRIMITIVE-TYPE-OF and friends.
+
+;;; PRIMITIVE-TYPE-OF  --  Interface.
+;;;
+;;; Return the most restrictive primitive type that contains Object.
+;;;
+(def-vm-support-routine primitive-type-of (object)
+  (let ((type (ctype-of object)))
+    (cond ((not (member-type-p type)) (primitive-type type))
+	  ((equal (member-type-members type) '(nil))
+	   (primitive-type-or-lose 'list))
+	  (t
+	   *any-primitive-type*))))
+
+;;; 
+(defvar *simple-array-primitive-types*
+  '((base-character . simple-string)
+    (string-char . simple-string)
+    (bit . simple-bit-vector)
+    ((unsigned-byte 2) . simple-array-unsigned-byte-2)
+    ((unsigned-byte 4) . simple-array-unsigned-byte-4)
+    ((unsigned-byte 8) . simple-array-unsigned-byte-8)
+    ((unsigned-byte 16) . simple-array-unsigned-byte-16)
+    ((unsigned-byte 32) . simple-array-unsigned-byte-32)
+    (single-float . simple-array-single-float)
+    (double-float . simple-array-double-float)
+    (t . simple-vector))
+  "An a-list for mapping simple array element types to their
+  corresponding primitive types.")
+
+(defvar *target-float-hardware* :MC68881
+  "Describes the target float hardware.  Values are :mc68881, :fpa, :afpa,
+   or :any for the RT.")
+
+;;; PRIMITIVE-TYPE -- Internal Interface.
+;;;
+;;; Return the primitive type corresponding to a type descriptor
+;;; structure. The second value is true when the primitive type is
+;;; exactly equivalent to the argument Lisp type.
+;;;
+;;; In a bootstrapping situation, we should be careful to use the
+;;; correct values for the system parameters.
+;;;
+(def-vm-support-routine primitive-type (type)
+  (declare (type ctype type))
+  (macrolet ((any () '(values *any-primitive-type* nil))
+	     (exactly (type) `(values (primitive-type-or-lose ',type) t))
+	     (part-of (type) `(values (primitive-type-or-lose ',type) nil)))
+    (etypecase type
+      (numeric-type
+       (let ((lo (numeric-type-low type))
+	     (hi (numeric-type-high type)))
+	 (case (numeric-type-complexp type)
+	   (:real
+	    (case (numeric-type-class type)
+	      (integer
+	       (cond ((and hi lo)
+		      (dolist (spec
+			       '((positive-fixnum 0 #.(1- (ash 1 29)))
+				 (unsigned-byte-31 0 #.(1- (ash 1 31)))
+				 (unsigned-byte-32 0 #.(1- (ash 1 32)))
+				 (fixnum #.(ash -1 29) #.(1- (ash 1 29)))
+				 (signed-byte-32 #.(ash -1 31)
+						 #.(1- (ash 1 31))))
+			       (if (or (< hi (ash -1 29))
+				       (> lo (1- (ash 1 29))))
+				   (part-of bignum)
+				   (any)))
+			(let ((type (car spec))
+			      (min (cadr spec))
+			      (max (caddr spec)))
+			  (when (<= min lo hi max)
+			    (return (values (primitive-type-or-lose type)
+					    (and (= lo min) (= hi max))))))))
+		     ((or (and hi (< hi most-negative-fixnum))
+			  (and lo (> lo most-positive-fixnum)))
+		      (part-of bignum))
+		     (t
+		      (any))))
+	      (float
+	       (float-primitive-type lo hi type))
+	      (t
+	       (any))))
+	   (:complex
+	    (part-of complex))
+	   (t
+	    (any)))))
+      (array-type
+       (if (array-type-complexp type)
+	   (any)
+	   (let* ((dims (array-type-dimensions type))
+		  (etype (array-type-specialized-element-type type))
+		  (type-spec (type-specifier etype))
+		  (ptype (cdr (assoc type-spec *simple-array-primitive-types*
+				     :test #'equal))))
+	     (if (and (consp dims) (null (rest dims)) ptype)
+		 (values (primitive-type-or-lose ptype) (eq (first dims) '*))
+		 (any)))))
+      (union-type
+       (if (type= type (specifier-type 'list))
+	   (exactly list)
+	   (let ((types (union-type-types type)))
+	     (multiple-value-bind (res exact)
+				  (primitive-type (first types))
+	       (dolist (type (rest types) (values res exact))
+		 (multiple-value-bind (ptype ptype-exact)
+				      (primitive-type type)
+		   (unless ptype-exact (setq exact nil))
+		   (unless (eq ptype res)
+		     (return (any)))))))))
+      (member-type
+       (let* ((members (member-type-members type))
+	      (res (primitive-type-of (first members))))
+	 (dolist (mem (rest members) (values res nil))
+	   (unless (eq (primitive-type-of mem) res)
+	     (return (values *any-primitive-type* nil))))))
+      (named-type
+       (case (named-type-name type)
+	 ((t bignum ratio complex function system-area-pointer weak-pointer)
+	  (values (primitive-type-or-lose (named-type-name type)) t))
+	 ((character base-character string-char)
+	  (exactly base-character))
+	 (standard-char
+	  (part-of base-character))
+	 (cons
+	  (part-of list))
+	 (t
+	  (any))))
+      (ctype
+       (any)))))
+
+;;; FLOAT-PRIMITIVE-TYPE -- Internal.
+;;;
+(defun float-primitive-type (lo hi type)
+  (let ((exact (and (null lo) (null hi))))
+    (case (numeric-type-format type)
+      ((short-float single-float)
+       (ecase *target-float-hardware*
+	 (:mc68881
+	  (values (primitive-type-or-lose '68881-single-float) exact))
+	 (:fpa
+	  (values (primitive-type-or-lose 'fpa-single-float) exact))
+	 (:afpa
+	  (values (primitive-type-or-lose 'afpa-single-float) exact))
+	 (:any
+	  (values (primitive-type-or-lose 'any-single-float) exact))))
+      ((double-float long-float)
+       (ecase *target-float-hardware*
+	 (:mc68881
+	  (values (primitive-type-or-lose '68881-double-float) exact))
+	 (:fpa
+	  (values (primitive-type-or-lose 'fpa-double-float) exact))
+	 (:afpa
+	  (values (primitive-type-or-lose 'afpa-double-float) exact))
+	 (:any
+	  (values (primitive-type-or-lose 'any-double-float) exact))))
+      (t
+       (values *any-primitive-type* nil)))))
+
+
+
+;;;; Magical Registers
+
+;;; Other VOP/VM definition files use the definitions on this page when writing
+;;; interface code for the compiler.
+;;;
+
+(eval-when (compile eval load)
+  (defconstant nargs-offset 0)
+  (defconstant nsp-offset 1)
+  (defconstant nl0-offset 2)
+  (defconstant ocfp-offset 3)
+  (defconstant nfp-offset 4)
+  (defconstant csp-offset 5)
+  (defconstant cfp-offset 6)
+  (defconstant code-offset 7)
+  (defconstant null-offset 8)
+  (defconstant cname-offset 9)
+  (defconstant lexenv-offset 10)
+  (defconstant lra-offset 11)
+  (defconstant a0-offset 12)
+  (defconstant a1-offset 13)
+  (defconstant a2-offset 14)
+  (defconstant lip-offset 15))
+
+;;; Lisp-interior-pointer register.
+;;;
+(defparameter lip-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'any-reg)
+		  :offset lip-offset))
+
+;;; Nil.
+;;;
+(defparameter null-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'descriptor-reg)
+		  :offset null-offset))
+
+
+;;; Frame Pointer.
+;;;
+(defparameter cfp-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'any-reg)
+		  :offset cfp-offset))
+
+
+;;; Control stack pointer.
+;;;
+(defparameter csp-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'any-reg)
+		  :offset csp-offset))
+
+;;; Number stack pointer.
+;;;
+(defparameter nsp-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'any-reg)
+		  :offset nsp-offset))
+
+;;; Code Pointer.
+;;;
+(defparameter code-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'any-reg)
+		  :offset code-offset))
+
+
+
+;;;; Side-Effect Classes
+
+(def-boolean-attribute vop
+  any)
+
+
+;;;; Constants
+
+;;; IMMEDIATE-CONSTANT-SC  --  Interface.
+;;;
+;;; If value can be represented as an immediate constant, then return the
+;;; appropriate SC number, otherwise return NIL.
+;;;
+(def-vm-support-routine immediate-constant-sc (value)
+  (typecase value
+    ((or fixnum character system-area-pointer)
+     (sc-number-or-lose 'immediate))
+    (null
+     (sc-number-or-lose 'null))
+    (symbol
+     (if (static-symbol-p value)
+	 (sc-number-or-lose 'immediate)
+	 nil))))
+
+
+
+;;;; Function Call Parameters
+
+;;; The SC numbers for register and stack arguments/return values.
+;;;
+;;; Other VOP/VM definition files use this when writing interface code for the
+;;; compiler.
+;;;
+(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
+(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
+(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
+
+
+(eval-when (compile load eval)
+
+;;; Offsets of special stack frame locations.
+;;;
+(defconstant ocfp-save-offset 0)
+(defconstant lra-save-offset 1)
+(defconstant nfp-save-offset 2)
+
+); Eval-When (Compile Load Eval)  
+
+
+(defparameter nargs-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'any-reg)
+		  :offset nargs-offset))
+
+(defparameter ocfp-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'descriptor-reg)
+		  :offset ocfp-offset))
+
+(defparameter lra-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'descriptor-reg)
+		  :offset lra-offset))
+
+
+(eval-when (compile load eval)
+
+;;; The number of arguments/return values passed in registers.
+;;;
+;;; Other VOP/VM definition files use this when writing interface code for the
+;;; compiler.
+;;;
+(defconstant register-arg-count 3)
+
+;;; The offsets within the register-arg SC where we supply values, first value
+;;; first.
+;;;
+;;; Other VOP/VM definition files use this when writing interface code for the
+;;; compiler.
+;;;
+(defconstant register-arg-offsets '(12 13 14))
+
+;;; Names to use for the argument registers.
+;;; 
+(defconstant register-arg-names '(a0 a1 a2))
+
+); Eval-When (Compile Load Eval)
+
+
+;;; A list of TN's describing the register arguments.
+;;;
+(defparameter register-arg-tns
+  (mapcar #'(lambda (n)
+	      (make-random-tn :kind :normal
+			      :sc (sc-or-lose 'descriptor-reg)
+			      :offset n))
+	  register-arg-offsets))
+
+
+
+;;;; LOCATION-PRINT-NAME.
+
+(defconstant register-names #("NARGS" "NSP" "NL0" "OCFP" "NFP"
+			      "CSP" "CFP" "CODE" "NULL" "CNAME" "LEXENV"
+			      "LRA" "A0" "A1" "A2" "LIP"))
+
+;;; LOCATION-PRINT-NAME  --  Interface.
+;;;
+;;; This function is called by debug output routines that want a pretty name
+;;; for a TN's location.  It returns a thing that can be printed with PRINC.
+;;;
+(def-vm-support-routine location-print-name (tn)
+  (declare (type tn tn))
+  (let ((sb (sb-name (sc-sb (tn-sc tn))))
+	(offset (tn-offset tn)))
+    (ecase sb
+      (registers (svref register-names (tn-offset tn)))
+      ((68881-float-registers FPA-float-registers AFPA-float-registers)
+       (format nil "F~D" offset))
+      (control-stack (format nil "CS~D" offset))
+      (non-descriptor-stack (format nil "NS~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed"))))