diff --git a/assembly/hppa/alloc.lisp b/assembly/hppa/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b4dc39007dc0aeb8088fcc44d8b2d9906c09d9dc
--- /dev/null
+++ b/assembly/hppa/alloc.lisp
@@ -0,0 +1,24 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/alloc.lisp,v 1.1 1992/06/12 04:00:00 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle allocation of stuff we don't want to do inline.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "HPPA")
+
+;;; Given that the pseudo-atomic sequence is so short, there is
+;;; nothing that qualifies.  But we want to keep the file around
+;;; in case we decide to add something later.
+
diff --git a/assembly/hppa/arith.lisp b/assembly/hppa/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9a5eee42d02db166a1e2649749db6eef15d62be9
--- /dev/null
+++ b/assembly/hppa/arith.lisp
@@ -0,0 +1,252 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/arith.lisp,v 1.1 1992/06/12 03:59:11 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "HPPA")
+
+
+;;;; Multiplication and Division helping routines.
+
+#+assembler
+(define-assembly-routine
+    multiply
+    ((:arg x (signed-reg) nl0-offset)
+     (:arg y (signed-reg) nl1-offset)
+
+     (:res res (signed-reg) nl2-offset)
+
+     (:temp tmp (unsigned-reg) nl3-offset)
+     (:temp sign (unsigned-reg) nl4-offset))
+
+  ;; Determine the sign of the result.
+  (inst extrs x 0 1 sign :=)
+  (inst sub zero-tn x x)
+  (inst extrs y 0 1 tmp :=)
+  (inst sub zero-tn y y)
+  (inst xor sign tmp sign)
+
+  ;; Make sure X is less then Y.
+  (inst comclr x y tmp :<<)
+  (inst xor x y tmp)
+  (inst xor x tmp x)
+  (inst xor y tmp y)
+  ;; Blow out of here if the result is zero.
+  (inst comb := x zero-tn done)
+  (inst li 0 res)
+
+  LOOP
+  (inst extru x 31 1 zero-tn :ev)
+  (inst add res y res)
+  (inst extru x 30 1 zero-tn :ev)
+  (inst sh1add res y res)
+  (inst extru x 29 1 zero-tn :ev)
+  (inst sh2add res y res)
+  (inst extru x 28 1 zero-tn :ev)
+  (inst sh3add res y res)
+
+  (inst srl x 4 x)
+  (inst comb :<> x zero-tn loop)
+  (inst sll y 4 y)
+
+  DONE
+  (inst xor res sign res)
+  (inst add res sign res))
+
+
+#+assembly
+(define-assembly-routine
+    (truncate)
+    ()
+  ...)
+
+
+
+;;;; Generic arithmetic.
+
+(define-assembly-routine (generic-+
+			  (:cost 10)
+			  (: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 lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst extru x 31 2 zero-tn :<>)
+  (inst b do-static-fun :nullify t)
+  (inst extru y 31 2 zero-tn :<>)
+  (inst b do-static-fun :nullify t)
+  (inst addo x y res)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst ldw (static-function-offset 'two-arg-+) null-tn lip)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst bv lip)
+  (inst move csp-tn cfp-tn))
+
+(define-assembly-routine (generic--
+			  (:cost 10)
+			  (: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 lip interior-reg lip-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst extru x 31 2 zero-tn :<>)
+  (inst b do-static-fun :nullify t)
+  (inst extru y 31 2 zero-tn :<>)
+  (inst b do-static-fun :nullify t)
+  (inst subo x y res)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst ldw (static-function-offset 'two-arg--) null-tn lip)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst bv lip)
+  (inst move csp-tn cfp-tn))
+
+
+
+;;;; Comparison routines.
+
+(macrolet
+    ((define-cond-assem-rtn (name translate static-fn cond)
+       `(define-assembly-routine (,name
+				  (:cost 10)
+				  (:return-style :full-call)
+				  (:policy :safe)
+				  (:translate ,translate)
+				  (:save-p t))
+				 ((:arg x (descriptor-reg any-reg) a0-offset)
+				  (:arg y (descriptor-reg any-reg) a1-offset)
+				  
+				  (:res res descriptor-reg a0-offset)
+				  
+				  (:temp lip interior-reg lip-offset)
+				  (:temp lra descriptor-reg lra-offset)
+				  (:temp nargs any-reg nargs-offset)
+				  (:temp ocfp any-reg ocfp-offset))
+	  (inst extru x 31 2 zero-tn :<>)
+	  (inst b do-static-fn :nullify t)
+	  (inst extru y 31 2 zero-tn :<>)
+	  (inst b do-static-fn :nullify t)
+
+	  (inst comclr x y zero-tn ,cond)
+	  (inst move null-tn res :tr)
+	  (load-symbol res t)
+	  (lisp-return lra :offset 2)
+
+	  DO-STATIC-FN
+	  (inst ldw (static-function-offset ',static-fn) null-tn lip)
+	  (inst li (fixnum 2) nargs)
+	  (inst move ocfp cfp-tn)
+	  (inst bv lip)
+	  (inst move cfp-tn csp-tn))))
+
+  (define-cond-assem-rtn generic-< < two-arg-< :<)
+  (define-cond-assem-rtn generic-> > two-arg-> :>))
+
+
+(define-assembly-routine
+    (generic-eql
+     (:cost 10)
+     (:return-style :full-call)
+     (:policy :safe)
+     (:translate eql)
+     (:save-p t))
+    ((:arg x (descriptor-reg any-reg) a0-offset)
+     (:arg y (descriptor-reg any-reg) a1-offset)
+     
+     (:res res descriptor-reg a0-offset)
+     
+     (:temp lip interior-reg lip-offset)
+     (:temp lra descriptor-reg lra-offset)
+     (:temp nargs any-reg nargs-offset)
+     (:temp ocfp any-reg ocfp-offset))
+
+  (inst comb := x y return-t)
+  (inst extru x 31 2 zero-tn :<>)
+  (inst b return-nil :nullify t)
+  (inst extru y 31 2 zero-tn :=)
+  (inst b do-static-fn :nullify t)
+
+  RETURN-NIL
+  (inst move null-tn res)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst ldw (static-function-offset 'eql) null-tn lip)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst bv lip)
+  (inst move csp-tn cfp-tn)
+
+  RETURN-T
+  (load-symbol res t))
+
+(define-assembly-routine
+    (generic-=
+     (:cost 10)
+     (:return-style :full-call)
+     (:policy :safe)
+     (:translate =)
+     (:save-p t))
+    ((:arg x (descriptor-reg any-reg) a0-offset)
+     (:arg y (descriptor-reg any-reg) a1-offset)
+     
+     (:res res descriptor-reg a0-offset)
+     
+     (:temp lip interior-reg lip-offset)
+     (:temp lra descriptor-reg lra-offset)
+     (:temp nargs any-reg nargs-offset)
+     (:temp ocfp any-reg ocfp-offset))
+
+  (inst comb := x y return-t :nullify t)
+  (inst extru x 31 2 zero-tn :=)
+  (inst b do-static-fn :nullify t)
+  (inst extru y 31 2 zero-tn :=)
+  (inst b do-static-fn :nullify t)
+
+  (inst move null-tn res)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst ldw (static-function-offset 'two-arg-=) null-tn lip)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst bv lip)
+  (inst move csp-tn cfp-tn)
+
+  RETURN-T
+  (load-symbol res t))
+
diff --git a/assembly/hppa/array.lisp b/assembly/hppa/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..bf6699c0bca883abd64687d223bd58d2091b0924
--- /dev/null
+++ b/assembly/hppa/array.lisp
@@ -0,0 +1,111 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/array.lisp,v 1.1 1992/06/12 03:58:40 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+(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 vector descriptor-reg a3-offset))
+  (pseudo-atomic ()
+    (move alloc-tn vector)
+    (inst dep other-pointer-type 31 3 vector)
+    (inst addi (* (1+ vector-data-offset) word-bytes) words ndescr)
+    (inst dep 0 31 3 ndescr)
+    (inst add ndescr alloc-tn alloc-tn)
+    (inst srl type word-shift ndescr)
+    (storew ndescr vector 0 other-pointer-type)
+    (storew length vector vector-length-slot other-pointer-type))
+  (move vector result))
+
+
+
+;;;; Hash primitives
+
+#+assembler
+(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 nl1-offset)
+     (:temp offset non-descriptor-reg nl2-offset))
+
+  (declare (ignore result accum data offset))
+
+  ;; Save the return address.
+  (inst b *sxhash-simple-substring-entry*)
+  (loadw length string vector-length-slot 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 nl1-offset)
+     (:temp offset non-descriptor-reg nl2-offset))
+
+  (emit-label *sxhash-simple-substring-entry*)
+
+  (inst li (- (* vector-data-offset word-bytes) other-pointer-type) offset)
+  (inst b test)
+  (move zero-tn accum)
+
+  LOOP
+  (inst xor accum data accum)
+  (inst shd accum accum 5 accum)
+
+  TEST
+  (inst addib :< (fixnum -4) length loop)
+  (inst ldwx string offset data :modify t)
+
+  (inst addi (fixnum 4) length length)
+  (inst comb := length zero-tn done :nullify t)
+  (inst uaddcm zero-tn length length)
+  (inst sll length 1 length)
+  (inst mtctl length :sar)
+  (inst shd zero-tn data :variable data)
+  (inst xor accum data accum)
+
+  DONE
+
+  (inst sll accum 5 result)
+  (inst srl result 3 result))
diff --git a/assembly/hppa/assem-rtns.lisp b/assembly/hppa/assem-rtns.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..86a519fdf0b974adb163f29ea79314d0e1976b3a
--- /dev/null
+++ b/assembly/hppa/assem-rtns.lisp
@@ -0,0 +1,218 @@
+;;; -*- Package: HPPA -*-
+;;;
+;;; **********************************************************************
+;;; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/assem-rtns.lisp,v 1.1 1992/06/12 03:58:24 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains a handful of random assembly routines.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "HPPA")
+
+
+;;;; Return-multiple with other than one value
+
+#+assembler ;; we don't want a vop for this one.
+(define-assembly-routine
+    (return-multiple
+     (:return-style :none))
+
+     ;; These four are really arguments.
+    ((:temp nvals any-reg nargs-offset)
+     (:temp vals any-reg nl0-offset)
+     (:temp old-fp any-reg nl1-offset)
+     (:temp lra descriptor-reg lra-offset)
+
+     ;; These are just needed to facilitate the transfer
+     (:temp count any-reg nl2-offset)
+     (:temp src any-reg nl3-offset)
+     (:temp dst any-reg nl4-offset)
+     (:temp temp descriptor-reg l0-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)
+     (:temp a3 descriptor-reg a3-offset)
+     (:temp a4 descriptor-reg a4-offset)
+     (:temp a5 descriptor-reg a5-offset))
+
+  (inst movb := nvals count default-a0-and-on :nullify t)
+  (loadw a0 vals 0)
+  (inst addib := (fixnum -1) count default-a1-and-on :nullify t)
+  (loadw a1 vals 1)
+  (inst addib := (fixnum -1) count default-a2-and-on :nullify t)
+  (loadw a2 vals 2)
+  (inst addib := (fixnum -1) count default-a3-and-on :nullify t)
+  (loadw a3 vals 3)
+  (inst addib := (fixnum -1) count default-a4-and-on :nullify t)
+  (loadw a4 vals 4)
+  (inst addib := (fixnum -1) count default-a5-and-on :nullify t)
+  (loadw a5 vals 5)
+
+  ;; Copy the remaining args to the top of the stack.
+  (inst addi (* 6 word-bytes) src vals)
+  (inst addi (* 6 word-bytes) dst cfp-tn)
+
+  LOOP
+  (inst ldwm 4 src temp)
+  (inst addib :< (fixnum -1) count loop)
+  (inst stwm temp 4 dst)
+
+  (inst b done :nullify t)
+
+  DEFAULT-A0-AND-ON
+  (inst move a0 null-tn)
+  DEFAULT-A1-AND-ON
+  (inst move a1 null-tn)
+  DEFAULT-A2-AND-ON
+  (inst move a2 null-tn)
+  DEFAULT-A3-AND-ON
+  (inst move a3 null-tn)
+  DEFAULT-A4-AND-ON
+  (inst move a4 null-tn)
+  DEFAULT-A5-AND-ON
+  (inst move a5 null-tn)
+
+  DONE
+  ;; Clear the stack.
+  (move ocfp-tn cfp-tn)
+  (move cfp-tn old-fp)
+  (inst add ocfp-tn nvals csp-tn)
+  
+  ;; Return.
+  (lisp-return lra))
+
+
+
+;;;; tail-call-variable.
+
+#+assembler ;; no vop for this one either.
+(define-assembly-routine
+    (tail-call-variable
+     (:return-style :none))
+
+    ;; These are really args.
+    ((:temp args any-reg nl0-offset)
+     (:temp lexenv descriptor-reg lexenv-offset)
+
+     ;; We need to compute this
+     (:temp nargs any-reg nargs-offset)
+
+     ;; These are needed by the blitting code.
+     (:temp src any-reg nl1-offset)
+     (:temp dst any-reg nl2-offset)
+     (:temp count any-reg nl3-offset)
+     (:temp temp descriptor-reg l0-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)
+     (:temp a3 descriptor-reg a3-offset)
+     (:temp a4 descriptor-reg a4-offset)
+     (:temp a5 descriptor-reg a5-offset))
+
+
+  ;; Calculate NARGS (as a fixnum)
+  (inst sub csp-tn args nargs)
+     
+  ;; Load the argument regs (must do this now, 'cause the blt might
+  ;; trash these locations)
+  (loadw a0 args 0)
+  (loadw a1 args 1)
+  (loadw a2 args 2)
+  (loadw a3 args 3)
+  (loadw a4 args 4)
+  (loadw a5 args 5)
+
+  ;; Calc SRC, DST, and COUNT
+  (inst addi (fixnum (- register-arg-count)) nargs count)
+  (inst comb :<= count zero-tn done :nullify t)
+  (inst addi (* word-bytes register-arg-count) args src)
+  (inst addi (* word-bytes register-arg-count) dst cfp-tn)
+	
+  LOOP
+  ;; Copy one arg.
+  (inst ldwm 4 src temp)
+  (inst addib :< (fixnum -1) count loop)
+  (inst stwm temp 4 dst)
+	
+  DONE
+  ;; We are done.  Do the jump.
+  (loadw temp lexenv closure-function-slot function-pointer-type)
+  (lisp-jump temp))
+
+
+
+;;;; Non-local exit noise.
+
+#+assembler
+(defparameter *unwind-entry-point* (gen-label))
+
+(define-assembly-routine
+    (unwind
+     (:translate %continue-unwind)
+     (:policy :fast-safe))
+    ((:arg block (any-reg descriptor-reg) a0-offset)
+     (:arg start (any-reg descriptor-reg) ocfp-offset)
+     (:arg count (any-reg descriptor-reg) nargs-offset)
+     (:temp lra descriptor-reg lra-offset)
+     (:temp cur-uwp any-reg nl0-offset)
+     (:temp next-uwp any-reg nl1-offset)
+     (:temp target-uwp any-reg nl2-offset))
+  (declare (ignore start count))
+
+  (emit-label *unwind-entry-point*)
+
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst bc := nil block zero-tn error))
+  
+  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+  (loadw target-uwp block unwind-block-current-uwp-slot)
+  (inst bc :<> nil cur-uwp target-uwp do-uwp)
+      
+  (move block cur-uwp)
+
+  DO-EXIT
+      
+  (loadw cfp-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 :frob-code nil)
+
+  DO-UWP
+
+  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
+  (inst b do-exit)
+  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
+
+
+(define-assembly-routine
+    throw
+    ((:arg target descriptor-reg a0-offset)
+     (:arg start any-reg ocfp-offset)
+     (:arg count any-reg nargs-offset)
+     (:temp catch any-reg a1-offset)
+     (:temp tag descriptor-reg a2-offset))
+  (declare (ignore start count)) ; We just need them in the registers.
+
+  (load-symbol-value catch lisp::*current-catch-block*)
+  
+  LOOP
+  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+    (inst bc := nil catch zero-tn error))
+  (loadw tag catch catch-block-tag-slot)
+  (inst comb :<> tag target loop :nullify t)
+  (loadw catch catch catch-block-previous-catch-slot)
+  
+  (inst b *unwind-entry-point*)
+  (inst move catch target))