diff --git a/assembly/rt/alloc.lisp b/assembly/rt/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7d444709722a1c4807718bf688dabfc80b548cea
--- /dev/null
+++ b/assembly/rt/alloc.lisp
@@ -0,0 +1,93 @@
+;;; -*- 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/assembly/rt/alloc.lisp,v 1.1 1991/02/18 15:43:28 chiles Exp $
+;;;
+;;; Stuff to handle allocating simple objects.
+;;;
+;;; Written by William Lott.
+;;; Converted to the IBM RT by Bill Chiles.
+;;;
+
+(in-package "RT")
+
+
+(define-for-each-primitive-object (obj)
+  (let* ((options (primitive-object-options obj))
+	 (alloc-trans (getf options :alloc-trans))
+	 (alloc-vop (getf options :alloc-vop alloc-trans))
+	 (header (primitive-object-header obj))
+	 (lowtag (primitive-object-lowtag obj))
+	 (size (primitive-object-size obj))
+	 (variable-length (primitive-object-variable-length obj))
+	 (need-unbound-marker nil))
+    (collect ((args) (init-forms))
+      (when (and alloc-vop variable-length)
+	(args 'extra-words))
+      (dolist (slot (primitive-object-slots obj))
+	(let* ((name (slot-name slot))
+	       (offset (slot-offset slot)))
+	  (ecase (getf (slot-options slot) :init :zero)
+	    (:zero)
+	    (:null
+	     (init-forms `(storew null-tn result ,offset ,lowtag)))
+	    (:unbound
+	     (setf need-unbound-marker t)
+	     (init-forms `(storew temp result ,offset ,lowtag)))
+	    (:arg
+	     (args name)
+	     (init-forms `(storew ,name result ,offset ,lowtag))))))
+      (when (and (null alloc-vop) (args))
+	(error "Slots ~S want to be initialized, but there is no alloc vop ~
+	defined for ~S."
+	       (args) (primitive-object-name obj)))
+      (when alloc-vop
+	`(define-assembly-routine
+	     (,alloc-vop
+	      (:cost 35)
+	      ,@(when alloc-trans
+		  `((:translate ,alloc-trans)))
+	      (:policy :fast-safe))
+	     (,@(let ((arg-offsets (cdr register-arg-offsets)))
+		  (mapcar #'(lambda (name)
+			      (unless arg-offsets
+				(error "Too many args in ~S" alloc-vop))
+			      `(:arg ,name (descriptor-reg any-reg)
+				     ,(pop arg-offsets)))
+			  (args)))
+		(:temp alloc non-descriptor-reg nl0-offset)
+		,@(when (or need-unbound-marker header variable-length)
+		    '((:temp temp non-descriptor-reg ocfp-offset)))
+		(:res result descriptor-reg a0-offset))
+	   (pseudo-atomic (alloc)
+	     (load-symbol-value alloc *allocation-pointer*)
+	     (inst cal result alloc ,lowtag)
+	     ,@(cond ((and header variable-length)
+		      `((inst cal temp extra-words (fixnum (1- ,size)))
+			(inst cas alloc temp alloc)
+			(inst sl temp (- type-bits word-shift))
+			(inst oil temp ,header)
+			(storew temp result 0 ,lowtag)
+			(inst cal alloc (+ (fixnum 1) lowtag-mask))
+			(inst li temp (lognot lowtag-mask))
+			(inst n alloc temp)))
+		     (variable-length
+		      (error ":REST-P T with no header in ~S?"
+			     (primitive-object-name obj)))
+		     (header
+		      `((inst cal alloc (pad-data-block ,size))
+			(inst li temp
+			      ,(logior (ash (1- size) type-bits)
+				       (symbol-value header)))
+			(storew temp result 0 ,lowtag)))
+		     (t
+		      `((inst cal alloc (pad-data-block ,size)))))
+	     ,@(when need-unbound-marker
+		 `((inst li temp unbound-marker-type)))
+	     ,@(init-forms)))))))
diff --git a/assembly/rt/arith.lisp b/assembly/rt/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6315420d25a3e3939b47574e6a84fbf498cd9425
--- /dev/null
+++ b/assembly/rt/arith.lisp
@@ -0,0 +1,324 @@
+;;; -*- 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/assembly/rt/arith.lisp,v 1.1 1991/02/18 15:43:31 chiles Exp $
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;; Converted to IBM RT by Bill Chiles.
+
+(in-package "RT")
+
+
+(define-assembly-routine (generic-+
+			  (:cost 25)
+			  (:return-style :full-call)
+			  (:translate +)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res (descriptor-reg any-reg) a0-offset)
+
+			  (:temp temp non-descriptor-reg nl0-offset)
+			  (:temp lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp cname descriptor-reg cname-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  ;; If either arg is not a fixnum, call the static function.
+  (inst n temp x 3)
+  (inst bnc :eq DO-STATIC-FUN)
+  (inst n temp y 3)
+  (inst bnc :eq DO-STATIC-FUN)
+  ;; Use ocfp as a temporary result.
+  (move ocfp x)
+  (inst a ocfp y)
+  (inst bnc :ov fixnum-result)
+  ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits
+  ;; and do the add again.
+  (move ocfp x)
+  (inst sar ocfp 2)
+  (move temp y)
+  (inst sar temp 2)
+  (inst a ocfp temp)
+  ;; Allocate a bignum for sum.
+  (with-fixed-allocation (res temp cname bignum-type
+			      (1+ bignum-digits-offset))
+    (storew ocfp res bignum-digits-offset other-pointer-type))
+  ;; Now get out of here.
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg-+)
+  (inst li nargs (fixnum 2))
+  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
+  (move ocfp cfp-tn)
+  ;; Tail call TWO-ARG-+.
+  (inst bx lip)
+  (move cfp-tn csp-tn)
+
+  FIXNUM-RESULT
+  ;; Ocfp was used for the temporary result.
+  (move res ocfp))
+
+(define-assembly-routine (generic--
+			  (:cost 25)
+			  (:return-style :full-call)
+			  (:translate -)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res (descriptor-reg any-reg) a0-offset)
+
+			  (:temp temp non-descriptor-reg nl0-offset)
+			  (:temp lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp cname descriptor-reg cname-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  ;; If either arg is not a fixnum, call the static function.
+  (inst n temp x 3)
+  (inst bnc :eq DO-STATIC-FUN)
+  (inst n temp y 3)
+  (inst bnc :eq DO-STATIC-FUN)
+  ;; Use ocfp as a temporary result.
+  (move ocfp x)
+  (inst s ocfp y)
+  (inst bnc :ov fixnum-result)
+  ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits
+  ;; and do the subtract again.
+  (move ocfp x)
+  (inst sar ocfp 2)
+  (move temp y)
+  (inst sar temp 2)
+  (inst s ocfp temp)
+  ;; Allocate a bignum for sum.
+  (with-fixed-allocation (res temp cname bignum-type
+			      (1+ bignum-digits-offset))
+    (storew ocfp res bignum-digits-offset other-pointer-type))
+  ;; Now get out of here.
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg--)
+  (inst li nargs (fixnum 2))
+  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
+  (move ocfp cfp-tn)
+  ;; Tail call TWO-ARG-+.
+  (inst bx lip)
+  (move cfp-tn csp-tn)
+
+  FIXNUM-RESULT
+  ;; Ocfp was used for the temporary result.
+  (move res ocfp))
+
+(define-assembly-routine (generic-*
+			  (:cost 70)
+			  (:return-style :full-call)
+			  (:translate *)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res (descriptor-reg any-reg) a0-offset)
+
+			  (:temp temp non-descriptor-reg nl0-offset)
+			  (:temp alloc word-pointer-reg a2-offset)
+			  (:temp lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs/high non-descriptor-reg nargs-offset)
+			  (:temp ocfp/low non-descriptor-reg ocfp-offset)
+			  (:temp cname descriptor-reg cname-offset))
+  ;; If either arg is not a fixnum, call the static function.
+  (inst n temp x 3)
+  (inst bnc :eq DO-STATIC-FUN)
+  (inst n temp y 3)
+  (inst bnc :eq DO-STATIC-FUN)
+
+  ;; Remove the tag from one arg so that the result will have the correct
+  ;; fixnum lowtag.  Without this, the result if off by a factor of 16, but we
+  ;; want it off by a factor of 4 (the fixnum lowtag).
+  (move temp x)
+  (inst sr temp 2)
+  ;; Setup system register for multiply.
+  (inst mtmqscr temp)
+
+  ;; 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 nargs/high nargs/high)
+  (dotimes (i 15)
+    (inst m nargs/high y))
+  (inst mfmqscr res)
+
+  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word is
+  ;; just 32 copies of the sign bit of the low word).
+  (move temp res)
+  (inst sar temp 31)
+  (inst c temp nargs/high)
+  (inst bc :eq DONE)
+  ;; Build two bignum-digits by shifting the double word high:res down two bits
+  ;; into high:low to get rid of the fixnum lowtag.
+  (move ocfp/low res)
+  (inst sr ocfp/low 2)
+  (move temp nargs/high)
+  (inst sl temp 30)
+  (inst o ocfp/low temp)
+  (inst sar nargs/high 2)
+  ;; Allocate a bignum for the result.
+  (pseudo-atomic (temp)
+    (let ((one-word (gen-label)))
+      (load-symbol-value alloc *allocation-pointer*)
+      (inst cal res alloc other-pointer-type)
+      ;; Assume we need one word.
+      (inst cal alloc (pad-data-block (1+ bignum-digits-offset)))
+      ;; Is that correct?
+      (inst sar temp ocfp/low 31)
+      (inst c temp nargs/high)
+      (inst bcx :eq one-word)
+      (inst li temp (logior (ash 1 type-bits) bignum-type))
+      ;; Nope, we need two, so allocate the addition space.
+      (inst cal 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))
+      (storew nargs/high res (1+ bignum-digits-offset) other-pointer-type)
+      (emit-label one-word)
+      (storew alloc *allocation-pointer*)
+      (storew temp res 0 other-pointer-type)
+      (storew ocfp/low res bignum-digits-offset other-pointer-type)))
+  ;; Out of here
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg-*)
+  (inst li nargs/high (fixnum 2))
+  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
+  (move ocfp/low cfp-tn)
+  (inst bx lip)
+  (move cfp-tn csp-tn)
+
+  DONE)
+
+(define-assembly-routine (generic-truncate
+			  (:cost 95)
+			  (:return-style :full-call)
+			  (:translate truncate)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res quo (descriptor-reg any-reg) a0-offset)
+			  (:res rem (descriptor-reg any-reg) a1-offset)
+
+			  (:temp temp1 non-descriptor-reg nl0-offset)
+			  (:temp alloc word-pointer-reg a2-offset)
+			  (:temp lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  ;; High holds the sign of x and becomes the remainder.
+			  (:temp nargs/high non-descriptor-reg nargs-offset)
+			  (:temp cname descriptor-reg cname-offset)
+			  (:temp ocfp/temp2 non-descriptor-reg ocfp-offset))
+  ;; If either arg is not a fixnum, call the static function.
+  (inst n temp1 x 3)
+  (inst bnc :eq DO-STATIC-FUN)
+  (inst n temp1 y 3)
+  (inst bnc :eq DO-STATIC-FUN)
+
+  ;; Make sure y is not 0, 1, or -1.
+  (inst c y 0)
+  (inst bcx :eq zero-divisor)
+  (inst c y (fixnum 1))
+  (inst bcx :eq one-divisor)
+  (inst c y (fixnum -1))
+  (inst bc :eq neg-one-divisor)
+
+  ;; Do the division.
+  (move nargs/high x)
+  (inst sar nargs/high 31)
+  (inst mtmqscr x)
+  (dotimes (i 32)
+    (inst d nargs/high y))
+  ;; Check preliminary remainder by considering signs of high and y.
+  ;; 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 high and y are the same.
+  (inst bc :c0 rem-okay)
+  (inst a nargs/high y)
+  REM-OKAY
+
+  ;; The RT gives us a Common Lisp FLOOR, but we're writing TRUNCATE.
+  ;; The fixup involves adding one to the quotient and subtracting the divisor
+  ;; from the remainder whenever the divisor and dividend had differing signs.
+  ;; Of course, don't diddle anything when the remainder is zero.
+  (inst c nargs/high 0)
+  (inst bc :eq move-results)
+  (move temp1 x)
+  (inst xor temp1 y)
+  (inst bnc :lt move-results)
+  ;; Add 1 to quotient and subtract divisor from remainder.
+  (inst mfmqscr temp1)
+  (inst sl temp1 2)
+  (inst a quo temp1 (fixnum 1))
+  ;; Since rem and y are the same register, this subtracts the divisor from
+  ;; the remainder, putting the result in our rem result register.
+  (inst sf y nargs/high)
+
+  (inst b done)
+
+  MOVE-RESULTS
+  (inst mfmqscr temp1)
+  (inst sl temp1 2)
+  (move quo temp1)
+  ;; The remainder is always on the same order of magnitude as the dividend,
+  ;; so it already has fixnum lowtag bits.
+  (move rem nargs/high)
+  (inst b done)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg-truncate)
+  (inst li nargs/high (fixnum 2))
+  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
+  (move ocfp/temp2 cfp-tn)
+  ;; Get out of here, doing a tail call.
+  (inst bx lip)
+  (move cfp-tn csp-tn)
+
+
+  ZERO-DIVISOR
+  ;; signal an error somehow.
+
+  NEG-ONE-DIVISOR
+  (li rem 0)
+  (inst neg quo x)
+  ;; If quo still fits in a fixnum, go to done.
+  (inst bnc :ov done)
+  ;; Allocate a bignum for quo.
+  (with-fixed-allocation (temp1 ocfp/temp2 alloc bignum-type
+				(+ 2 bignum-digits-offset))
+    ;; If we overflowed quo, then we must have made a positive value from a
+    ;; negative one.  The overflow would be one bit and some zero's for sign.
+    (inst li ocfp/temp2 0)
+    (storew quo temp1 bignum-digits-offset other-pointer-type)
+    (storew ocfp/temp2 temp1 (1+ bignum-digits-offset) other-pointer-type))
+  (move quo temp1)
+
+  (inst b done)
+
+  ONE-DIVISOR
+  (li rem 0)
+  (move quo x)
+
+  DONE)
diff --git a/assembly/rt/array.lisp b/assembly/rt/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..05643241e09eb7377e02f6f4f9fa8e261fca0dae
--- /dev/null
+++ b/assembly/rt/array.lisp
@@ -0,0 +1,114 @@
+;;; -*- 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/assembly/rt/array.lisp,v 1.1 1991/02/18 15:43:32 chiles Exp $
+;;;
+;;; This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "RT")
+
+
+(define-assembly-routine (allocate-vector
+			  (:policy :fast-safe)
+			  (:translate allocate-vector)
+			  (:arg-types positive-fixnum
+				      positive-fixnum
+				      positive-fixnum))
+			 ((:arg type any-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:arg words any-reg a2-offset)
+			  (:res result descriptor-reg a0-offset)
+
+			  (:temp ndescr non-descriptor-reg nl0-offset)
+			  (:temp alloc word-pointer-reg ocfp-offset)
+			  (:temp vector descriptor-reg cname-offset))
+  (pseudo-atomic (ndescr)
+    (load-symbol-value alloc *allocation-pointer*)
+    (inst cal vector alloc vm:other-pointer-type)
+    (inst cal alloc alloc (+ (1- (ash 1 vm:lowtag-bits))
+			     (* vm:vector-data-offset vm:word-bytes)))
+    (inst cal alloc alloc words)
+    (inst li ndescr (lognot vm:lowtag-mask))
+    (inst n alloc ndescr)
+    (move ndescr type)
+    (inst sr ndescr vm:word-shift)
+    (storew ndescr vector 0 vm:other-pointer-type)
+    (storew length vector vm:vector-length-slot vm:other-pointer-type))
+  (move result vector))
+
+
+
+;;;; Hash primitives
+
+(defparameter sxhash-simple-substring-entry (gen-label))
+
+(define-assembly-routine (sxhash-simple-string
+			  (:translate %sxhash-simple-string)
+			  (:policy :fast-safe)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:res result any-reg a0-offset)
+			  (:temp length any-reg a1-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nargs-offset)
+			  (:temp temp non-descriptor-reg ocfp-offset))
+  (declare (ignore result accum data temp offset))
+  (inst b sxhash-simple-substring-entry)
+  (loadw length string vm:vector-length-slot vm:other-pointer-type))
+
+
+(define-assembly-routine (sxhash-simple-substring
+			  (:translate %sxhash-simple-substring)
+			  (:policy :fast-safe)
+			  (:arg-types * positive-fixnum)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:res result any-reg a0-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nargs-offset)
+			  (:temp temp non-descriptor-reg ocfp-offset)
+			  (:temp lip interior-reg lip-offset))
+  (emit-label sxhash-simple-substring-entry)
+  ;; Get a stack slot and save the contents of NFP.
+  (inst inc csp-tn word-bytes)
+  (storew nfp-tn csp-tn (* -1 word-bytes))
+  ;; Save the return-pc in NFP as a byte offset from the component start.
+  (move nfp-tn lip)
+  (inst s nfp-tn code-tn)
+  (inst a lip string (- (* vector-data-offset word-bytes) other-pointer-type))
+  (inst b test)
+  (inst li accum 0)
+  LOOP
+  (inst x accum data)
+  (move temp accum)
+  (inst sl temp 27)
+  (inst sr accum 5)
+  (inst o accum temp)
+  (inst inc lip 4)
+  TEST
+  (inst s length (fixnum 4))
+  (inst bnc :lt loop)
+  (loadw data lip)
+  (inst a length (fixnum 4))
+  (inst bc :eq done)
+  (inst neg length)
+  (inst sl length 1)
+  (inst sr data length)
+  (inst x accum data)
+  DONE
+  (inst sl result accum 5)
+  (inst sr result result 3)
+  (move code-tn lip)
+  (inst a lip nfp-tn)
+  (loadw nft-tn csp-tn (* -1 word-bytes))
+  (inst dec csp-tn word-bytes))
diff --git a/assembly/rt/assem-rtns.lisp b/assembly/rt/assem-rtns.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9a41138e694f6907a380455f2b2f134aa83c5884
--- /dev/null
+++ b/assembly/rt/assem-rtns.lisp
@@ -0,0 +1,296 @@
+;;; -*- 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/assembly/rt/assem-rtns.lisp,v 1.1 1991/02/18 15:43:33 chiles Exp $
+;;;
+
+(in-package "RT")
+
+
+
+;;;; Non-local exit noise.
+
+(define-assembly-routine (unwind (:translate %continue-unwind)
+				 (:policy :fast-safe))
+			 ((:arg block (word-pointer-reg any-reg descriptor-reg)
+				a0-offset)
+			  (:arg start (word-pointer-reg any-reg descriptor-reg)
+				ocfp-offset)
+			  (:arg count (any-reg descriptor-reg) nargs-offset)
+			  (:temp lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp cur-uwp any-reg nl0-offset)
+			  (:temp next-uwp any-reg cname-offset)
+			  (:temp target-uwp any-reg lexenv-offset))
+  (declare (ignore start count))
+
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst c block 0)
+    (inst b :eq error))
+
+  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+  (loadw target-uwp block unwind-block-current-uwp-slot)
+  (inst c cur-uwp target-uwp)
+  (inst bnc :eq do-uwp)
+
+  (move cur-uwp block)
+
+  DO-EXIT
+
+  (loadw fp-tn cur-uwp unwind-block-current-cont-slot)
+  (loadw code-tn cur-uwp unwind-block-current-code-slot)
+  (loadw lra cur-uwp unwind-block-entry-pc-slot)
+  (lisp-return lra lip :frob-code nil)
+
+  DO-UWP
+
+  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
+  (inst bx do-exit)
+  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
+
+(define-assembly-routine throw
+			 ((:arg target descriptor-reg a0-offset)
+			  (:arg start word-pointer-reg ocfp-offset)
+			  (:arg count any-reg nargs-offset)
+			  (:temp catch any-reg a1-offset)
+			  (:temp tag descriptor-reg a2-offset)
+			  (:temp ndescr non-descriptor-reg nl0-offset))
+  
+  (load-symbol-value catch lisp::*current-catch-block*)
+  
+  LOOP
+
+  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+    (inst c catch 0)
+    (inst bc :eq error))
+
+  (loadw tag catch catch-block-tag-slot)
+  (inst c tag target)
+  (inst bc :eq exit)
+  (loadw catch catch catch-block-previous-catch-slot)
+  (inst b loop)
+
+  EXIT
+
+  (move target catch)
+  (inst cai ndescr (make-fixup 'unwind :assembly-routine))
+  (inst b ndescr))
+
+
+
+;;;; Return unknown multiple values (known not to be one value).
+
+(define-assembly-routine really-return-multiple
+			 ((:arg ocfp any-reg nl0-offset)
+			  (:arg lra descriptor-reg lra-offset)
+			  ;; Pointer into cstack, so looks like fixnum.
+			  (:arg src any-reg cname-offset)
+			  (:arg nvals any-reg nargs-offset)
+
+			  (:temp count any-reg ocfp-offset)
+			  ;; Pointer into cstack, so looks like fixnum.
+			  (:temp dst any-reg lexenv-offset)
+			  (:temp a0 descriptor-reg a0-offset)
+			  (:temp a1 descriptor-reg a1-offset)
+			  (:temp a2 descriptor-reg a2-offset))
+  ;;
+  ;; Load the register args, bailing out when we are done.
+  (inst c nvals 0)
+  (inst bc :eq default-a0-and-on)
+  (loadw a0 src 0)
+  (inst c nvals 1)
+  (inst bc :eq default-a1-and-on)
+  (loadw a1 src 1)
+  (inst c nvals 2)
+  (inst bc :eq default-a2-and-on)
+  (loadw a2 src 2)
+  ;;
+  ;; Copy the remaining args to the top of the stack.
+  (inst inc src (* word-bytes register-arg-count))
+  (inst cal dst fp-tn (* word-bytes register-arg-count))
+  (inst s count nvals (fixnum 3))
+  (inst bnc :gt done)
+  LOOP
+  (loadw temp src)
+  (inst inc src word-bytes)
+  (storew temp dst)
+  (inst inc dst word-bytes)
+  (inst s count (fixnum 1))
+  (inst bc :gt loop)
+  (inst b done)
+  ;;
+  ;; Default some number of registers.
+  DEFAULT-A0-AND-ON
+  (move a0 null-tn)
+  DEFAULT-A1-AND-ON
+  (move a1 null-tn)
+  DEFAULT-A2-AND-ON
+  (move a2 null-tn)
+  ;;
+  ;; Clear the stack.
+  DONE
+  (move count cfp-tn) ;Put pointer to the start of values in ocfp.
+  (inst cas csp-tn nargs count) ;Adjust the stack top: <ptr-to-vals>+<nvals>.
+  (move fp-tn ocfp) ;Restore returnee's fp.
+  ;;
+  ;; Return.
+  (lisp-return lra lip))
+
+
+
+;;;; Copying more args on call (known to be at least one more arg.)
+
+;;; REALLY-COPY-MORE-ARGS -- Assembler Routine.
+;;;
+;;; This miscop has weird register usage conventions, since it is called at the
+;;; very beginning of entry to a more-arg XEP.  All of the registers used
+;;; by the full call convention are in use, and must not be trashed, but none
+;;; of the normal local & temporary registers are in use, since we haven't done
+;;; anything yet.  The number of fixed arguments is passed in a3, since we
+;;; can't trash a0..a2.
+;;;
+;;; The VOP COPY-MORE-ARG has allocated some temporaries for us: a3, l0, l1.
+
+;;; The registers we can use are NL1, A3, L0 and L1.  We save L2 and L3 to give
+;;; us some more registers to work with.  The caller saves the function return
+;;; PC in L2 (the now unused NAME) so that it can be used for the miscop return
+;;; PC.
+;;;
+;;; What we do is fairly simple: we copy the incoming more arguments (index >=
+;;; a3) onto the top of the stack.  The loop runs backwards, since we are
+;;; copying args upward on the stack, and the source and destination can
+;;; overlap.
+;;;
+;;; This loop terminates when we either run out of more args to copy or we run
+;;; out of stack arguments.  If we run out of stack arguments before we finish,
+;;; then there are register more args.  In this case, we dispatch off of the
+;;; number of fixed arguments (A3) to determine how many argument registers to
+;;; store.
+;;;
+(define-assembly-routine really-copy-more-args
+			 ;; Fixedargs contains the number of fixed arguments.
+			 ((:arg fixedargs any-reg cname-offset)
+			  (:temp count/src any-reg nfp-offset)
+			  (:temp ocsp any-reg nl0-offset)
+			  ;; Temporaries to get my hands on argument registers.
+			  (:temp a0 any-reg a0-offset)
+			  (:temp a1 any-reg a1-offset)
+			  (:temp a2 any-reg a2-offset)
+			  ;; We save the contents of these registers before
+			  ;; using them.
+			  (:temp srcstart any-reg lexenv-offset)
+			  (:temp dstend any-reg lra-offset)
+			  (:temp temp any-reg ocfp-offset))
+  ;; How many more args are there to copy to the stack?
+  (move count/src nargs-tn)
+  (inst s count/src fixedargs)
+  ;; Save the current stack top as the start of the more args.
+  (move ocsp csp-tn)
+  ;; Bump the stack by the number of more args.
+  (inst cas csp-tn csp-tn count/src)
+  ;; Bump the stack three for the registers we have to save.
+  (inst cal csp-tn csp-tn (* 3 word-bytes))
+
+  ;; Dump the registers to make room for the temporaries we need.
+  (storew srcstart csp-tn -3)
+  (storew dstend csp-tn -2)
+  (storew temp csp-tn -1)
+
+  ;; Compute the source start, but remember we are copying from the end.
+  ;; The start location is the last one we copy.
+  (inst cal srcstart cfp-tn (* register-arg-count word-bytes))
+  ;; Compute the source location of the last more arg.
+  (inst cal count/src cfp-tn nargs-tn)
+  (inst dec count/src word-bytes) ;not an exclusive end.
+  ;; Compute destination end, which is the stack pointer minus three register
+  ;; slots we saved and minus one to make it an inclusive end.
+  (inst cal dstend csp-tn (* -4 word-bytes))
+
+  ;; Copy some args.
+  (inst b cma-test)
+  CMA-LOOP
+  (loadw temp count/src)
+  (storew temp dstend)
+  (inst dec count/src word-bytes)
+  (inst dec dstend word-bytes)
+  CMA-TEST
+  ;; Are we totally done?
+  (inst c dstend ocsp)
+  (inst bc :lt CMA-DONE)
+  ;; Are we done copying stack more args?
+  (inst c count/src srcstart)
+  (inst bnc :lt CMA-LOOP)
+  
+  ;; Figure out which argument registers may be more args.
+  (inst c fixedargs (fixnum 2))
+  (inst bc :eq two-fixed-args)
+  (inst c fixedargs (fixnum 1))
+  (inst bc :eq one-fixed-arg)
+  
+  ;; Copy register more args being careful to stop before running out of args.
+  (storew a0 ocsp)
+  (inst c nargs-tn (fixnum 1))
+  (inst bc :eq CMA-DONE)
+  (inst inc ocsp word-bytes)
+  ONE-FIXED-ARG
+  (storew a1 ocsp)
+  (inst c nargs-tn (fixnum 2))
+  (inst bc :eq CMA-DONE)
+  (inst inc ocsp word-bytes)
+  TWO-FIXED-ARGS
+  (storew a2 ocsp)
+
+  ;; Restore registers we dumped.
+  CMA-DONE
+  (loadw srcstart csp-tn -3)
+  (loadw dstend csp-tn -2)
+  (loadw temp csp-tn -1)
+  (inst b lip-tn))
+
+
+
+;;;; Tail call variable.
+
+(define-assembly-routine (really-tail-call-variable (:return-style :none))
+			 ;; These are really args.
+			 ((:temp args any-reg nl0-offset)
+			  ;; These are needed by the blitting code.
+			  (:temp nargs/src any-reg nargs-offset)
+			  (:temp lexenv/dst any-reg lexenv-offset)
+			  (:temp count any-reg lra-offset)
+			  (:temp temp descriptor-reg cname-offset)
+			  ;; These are needed so we can get at the register args.
+			  (:temp a0 descriptor-reg a0-offset)
+			  (:temp a1 descriptor-reg a1-offset)
+			  (:temp a2 descriptor-reg a2-offset))
+  ;; Calculate NARGS (as a fixnum).
+  (move nargs/src csp-tn)
+  (inst s nargs/src args)
+  ;; Load the argument registers now because the argument moving might trash
+  ;; these locations.
+  (loadw a0 args (* 0 vm:word-bytes))
+  (loadw a1 args (* 1 vm:word-bytes))
+  (loadw a2 args (* 2 vm:word-bytes))
+  ;; Calc SRC, DST, and COUNT.
+  (inst a count nargs/src (fixnum (- register-arg-count)))
+  (inst bnc :gt done)
+  (inst a nargs/src args (* vm:word-bytes register-arg-count))
+  (inst a lexenv/dst cfp-tn (* vm:word-bytes register-arg-count))
+  LOOP
+  ;; Copy one arg.
+  (loadw temp nargs/src)
+  (inst a nargs/src vm:word-bytes)
+  (storew temp lexenv/dst)
+  (inst a count (fixnum -1))
+  (inst bc :gt loop)
+  (inst a lexenv/dst vm:word-bytes)
+  DONE
+  ;; We are done.  Do the jump.
+  (loadw temp lexenv/dst vm:closure-function-slot vm:function-pointer-type)
+  (lisp-jump temp lip-tn))
diff --git a/assembly/rt/support.lisp b/assembly/rt/support.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a414c84d6b82457ee6c03fb90ddd626aefc1ec3e
--- /dev/null
+++ b/assembly/rt/support.lisp
@@ -0,0 +1,61 @@
+;;; -*- 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/assembly/rt/support.lisp,v 1.1 1991/02/18 15:43:35 chiles Exp $
+;;;
+;;; This file contains the machine specific support routines needed by
+;;; the file assembler.
+;;;
+
+(in-package "RT")
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (values
+      `((inst bala (make-fixup ',name :assembly-routine)))
+      nil))
+    (:full-call
+     (let ((nfp-save (make-symbol "NFP-SAVE"))
+	   (lra (make-symbol "LRA")))
+       (values
+	`((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-tn lra-label)
+	    ;; This absolute branch trashes the LIP register, but we don't use
+	    ;; it when calling assembly routines.
+	    (inst bala (make-fixup ',name :assembly-routine))
+	    (emit-return-pc lra-label)
+	    (note-this-location ,vop :unknown-return)
+	    (move csp-tn ocfp-tn)
+	    (inst compute-code-from-lra code-tn code-tn lra-label)
+	    (when cur-nfp
+	      (load-stack-tn cur-nfp ,nfp-save))))
+	`((:temporary (:sc descriptor-reg :offset lra-offset
+			   :from (:eval 0) :to (:eval 1))
+		      ,lra)
+	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
+		      ,nfp-save)))))
+    (:none
+     (values
+      ;; This absolute branch trashes the LIP register, but we don't use it
+      ;; when calling assembly routines.
+      `((inst bala (make-fixup ',name :assembly-routine)))
+      nil))))
+
+
+(def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst b lip-tn)))
+    (:full-call
+     `((lisp-return lra-tn lip-tn :offset 2)))
+    (:none)))