diff --git a/assembly/alpha/alloc.lisp b/assembly/alpha/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..90b0fd30d3835f9b0cfddd6fbe91cfa093888c75
--- /dev/null
+++ b/assembly/alpha/alloc.lisp
@@ -0,0 +1,24 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/alpha/alloc.lisp,v 1.1 1994/04/06 16:58:31 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle allocation of stuff we don't want to do inline.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "ALPHA")
+
+;;; 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/alpha/arith.lisp b/assembly/alpha/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..c4280e214dca76f5cb063b4e1404663164bbfa97
--- /dev/null
+++ b/assembly/alpha/arith.lisp
@@ -0,0 +1,423 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/alpha/arith.lisp,v 1.1 1994/04/06 16:58:32 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;; Conversion by Sean Hallgren
+;;;
+
+(in-package "ALPHA")
+
+
+(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 temp non-descriptor-reg nl0-offset)
+			  (:temp temp2 non-descriptor-reg nl1-offset)
+			  (:temp temp3 non-descriptor-reg nl2-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 and x 3 temp)
+  (inst bne temp DO-STATIC-FUN)
+  (inst and y 3 temp)
+  (inst bne temp DO-STATIC-FUN)
+  (inst addq x y res)
+  
+  ; Check to see if we need a bignum
+  (inst sra res 31 temp)
+  (inst beq temp DONE)
+  (inst not temp temp)
+  (inst beq temp DONE)
+  (inst sra res 2 temp3)
+  
+  ; From move-from-signed
+  (inst li 2 temp2)
+  (inst sra temp3 31 temp)
+  (inst cmoveq temp 1 temp2)
+  (inst not temp temp)
+  (inst cmoveq temp 1 temp2)
+  (inst sll temp2 type-bits temp2)
+  (inst bis temp2 bignum-type temp2)
+  
+  (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+    (inst bis alloc-tn other-pointer-type res)
+    (storew temp2 res 0 other-pointer-type)
+    (storew temp3 res bignum-digits-offset other-pointer-type)
+    (inst srl temp3 32 temp)
+    (storew temp res (1+ bignum-digits-offset) other-pointer-type))
+  DONE
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (inst ldl lip (static-function-offset 'two-arg-+) null-tn)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst move csp-tn cfp-tn)
+  (inst jmp zero-tn lip))
+
+
+(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 temp non-descriptor-reg nl0-offset)
+			  (:temp temp2 non-descriptor-reg nl1-offset)
+			  (:temp temp3 non-descriptor-reg nl2-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 and x 3 temp)
+  (inst bne temp DO-STATIC-FUN)
+  (inst and y 3 temp)
+  (inst bne temp DO-STATIC-FUN)
+  (inst subq x y res)
+  
+  ; Check to see if we need a bignum
+  (inst sra res 31 temp)
+  (inst beq temp DONE)
+  (inst not temp temp)
+  (inst beq temp DONE)
+  (inst sra res 2 temp3)
+  
+  ; From move-from-signed
+  (inst li 2 temp2)
+  (inst sra temp3 31 temp)
+  (inst cmoveq temp 1 temp2)
+  (inst not temp temp)
+  (inst cmoveq temp 1 temp2)
+  (inst sll temp2 type-bits temp2)
+  (inst bis temp2 bignum-type temp2)
+  
+  (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+    (inst bis alloc-tn other-pointer-type res)
+    (storew temp2 res 0 other-pointer-type)
+    (storew temp3 res bignum-digits-offset other-pointer-type)
+    (inst srl temp3 32 temp)
+    (storew temp res (1+ bignum-digits-offset) other-pointer-type))
+  DONE
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (inst ldl lip (static-function-offset 'two-arg--) null-tn)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst move csp-tn cfp-tn)
+  (inst jmp zero-tn lip))
+
+
+(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 lo non-descriptor-reg nl1-offset)
+			  (:temp hi non-descriptor-reg nl2-offset)
+			  (:temp temp2 non-descriptor-reg nl3-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))
+  ;; If either arg is not a fixnum, call the static function.
+  (inst and x 3 temp)
+  (inst bne temp DO-STATIC-FUN)
+  (inst and y 3 temp)
+  (inst bne temp DO-STATIC-FUN)
+
+  ;; Remove the tag from one arg so that the result will have the correct
+  ;; fixnum tag.
+  (inst sra x 2 temp)
+  (inst mulq temp y lo)
+  (inst sra lo 32 hi)
+  (inst sll lo 32 res)
+  (inst sra res 32 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).
+  (inst sra res 31 temp)
+  (inst xor hi temp temp)
+  (inst beq temp DONE)
+  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
+  ;; fixnum tag.
+  (inst srl lo 2 lo)
+  (inst sra lo 32 hi)
+  (inst sll lo 32 lo)
+  (inst sra lo 32 lo)
+
+  ;; Do we need one word or two?  Assume two.
+  (inst sra lo 31 temp)
+  (inst xor temp hi temp)
+  (inst li (logior (ash 2 type-bits) bignum-type) temp2)
+  (inst bne temp two-words)
+
+  ;; Only need one word, fix the header and zero the high-word.
+  (inst li (logior (ash 1 type-bits) bignum-type) temp2)
+  (inst li 0 hi)
+
+  TWO-WORDS
+  (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))
+    (inst bis alloc-tn other-pointer-type res)
+    (storew temp2 res 0 other-pointer-type))
+
+  (storew lo res bignum-digits-offset other-pointer-type)
+  (storew hi res (1+ bignum-digits-offset) other-pointer-type)
+
+  ;; Out of here
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FUN
+  (inst ldl lip (static-function-offset 'two-arg-*) null-tn)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst move csp-tn cfp-tn)
+  (inst jmp zero-tn lip)
+
+  DONE)
+
+
+;;;; Division.
+
+(define-assembly-routine (signed-truncate
+			  (:note "(signed-byte 32) truncate")
+			  (:cost 60)
+			  (:policy :fast-safe)
+			  (:translate truncate)
+			  (:arg-types signed-num signed-num)
+			  (:result-types signed-num signed-num))
+
+			 ((:arg dividend signed-reg nl0-offset)
+			  (:arg divisor signed-reg nl1-offset)
+
+			  (:res quo signed-reg nl2-offset)
+			  (:res rem signed-reg nl3-offset)
+
+			  (:temp quo-sign signed-reg nl5-offset)
+			  (:temp rem-sign signed-reg nargs-offset)
+			  (:temp temp1 non-descriptor-reg nl4-offset))
+  
+  (let ((error (generate-error-code nil division-by-zero-error
+				    dividend divisor)))
+    (inst beq divisor error))
+
+  (inst xor dividend divisor quo-sign)
+  (inst move dividend rem-sign)
+  (let ((label (gen-label)))
+    (inst bge dividend label)
+    (inst subq zero-tn dividend dividend)
+    (emit-label label))
+  (let ((label (gen-label)))
+    (inst bge divisor label)
+    (inst subq zero-tn divisor divisor)
+    (emit-label label))
+  (inst move zero-tn rem)
+  (inst move zero-tn quo)
+  (inst sll dividend 32 dividend)
+
+  (dotimes (i 32)
+    (inst srl dividend 63 temp1)
+    (inst sll rem 1 rem)
+    (inst bis temp1 rem rem)
+    (inst cmple divisor rem temp1)
+    (inst sll quo 1 quo)
+    (inst bis temp1 quo quo)
+    (inst sll dividend 1 dividend)
+    (inst subq temp1 1 temp1)
+    (inst zap divisor temp1 temp1)
+    (inst subq rem temp1 rem))
+
+  (let ((label (gen-label)))
+    ;; If the quo-sign is negative, we need to negate quo.
+    (inst bge quo-sign label)
+    (inst subq zero-tn quo quo)
+    (emit-label label))
+  (let ((label (gen-label)))
+    ;; If the rem-sign is negative, we need to negate rem.
+    (inst bge rem-sign label)
+    (inst subq zero-tn rem rem)
+    (emit-label label)))
+
+
+;;;; Comparison routines.
+
+(macrolet
+    ((define-cond-assem-rtn (name translate static-fn cmp not-p)
+       `(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 temp non-descriptor-reg nl0-offset)
+				  (:temp lip interior-reg lip-offset)
+				  (:temp nargs any-reg nargs-offset)
+				  (:temp ocfp any-reg ocfp-offset))
+	  (inst and x 3 temp)
+	  (inst bne temp DO-STATIC-FN)
+	  (inst and y 3 temp)
+	  (inst beq temp DO-COMPARE)
+	  
+	  DO-STATIC-FN
+	  (inst ldl lip (static-function-offset ',static-fn) null-tn)
+	  (inst li (fixnum 2) nargs)
+	  (inst move cfp-tn ocfp)
+	  (inst move csp-tn cfp-tn)
+	  (inst jmp zero-tn lip)
+	  
+	  DO-COMPARE
+	  ,cmp
+	  (inst move null-tn res)
+	  (inst ,(if not-p 'bne 'beq) temp done)
+	  (load-symbol res t)
+	  DONE)))
+
+  (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil)
+  (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil))
+
+
+(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 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 ocfp any-reg ocfp-offset))
+  (inst cmpeq x y temp)
+  (inst bne temp RETURN-T)
+  (inst and x 3 temp)
+  (inst beq temp RETURN-NIL)
+  (inst and y 3 temp)
+  (inst bne temp DO-STATIC-FN)
+
+  RETURN-NIL
+  (inst move null-tn res)
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FN
+  (inst ldl lip (static-function-offset 'eql) null-tn)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst move csp-tn cfp-tn)
+  (inst jmp zero-tn lip)
+
+  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 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 ocfp any-reg ocfp-offset))
+  (inst and x 3 temp)
+  (inst bne temp DO-STATIC-FN)
+  (inst and y 3 temp)
+  (inst bne temp DO-STATIC-FN)
+  (inst cmpeq x y temp)
+  (inst bne temp RETURN-T)
+
+  (inst move null-tn res)
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FN
+  (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst move csp-tn cfp-tn)
+  (inst jmp zero-tn lip)
+
+  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 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 ocfp any-reg ocfp-offset))
+  (inst and x 3 temp)
+  (inst bne temp DO-STATIC-FN)
+  (inst and y 3 temp)
+  (inst bne temp DO-STATIC-FN)
+  (inst cmpeq x y temp)
+  (inst bne temp RETURN-NIL)
+
+  (load-symbol res t)
+  (lisp-return lra lip :offset 2)
+
+  DO-STATIC-FN
+  (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
+  (inst li (fixnum 2) nargs)
+  (inst move cfp-tn ocfp)
+  (inst move csp-tn cfp-tn)
+  (inst jmp zero-tn lip)
+
+  RETURN-NIL
+  (inst move null-tn res))
diff --git a/assembly/alpha/array.lisp b/assembly/alpha/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e890d0b65cf8f17ac5792b3bad64a00eccb04463
--- /dev/null
+++ b/assembly/alpha/array.lisp
@@ -0,0 +1,184 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/alpha/array.lisp,v 1.1 1994/04/06 16:58:33 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;; Conversion by Sean Hallgren
+;;; 
+(in-package "ALPHA")
+
+(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))
+  ;; This is kinda sleezy, changing words like this.  But we can because
+  ;; the vop thinks it is temporary.
+  (inst addq words (+ (1- (ash 1 lowtag-bits))
+		      (* vector-data-offset word-bytes))
+	words)
+  (inst li (lognot lowtag-mask) ndescr)
+  (inst and words ndescr words)
+  (inst srl type word-shift ndescr)
+
+  (pseudo-atomic ()
+    (inst bis alloc-tn other-pointer-type result)
+    (inst addq alloc-tn words alloc-tn)
+    (storew ndescr result 0 other-pointer-type)
+    (storew length result vector-length-slot other-pointer-type)))
+
+
+;;;; Hash primitives
+
+(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 lip interior-reg lip-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp byte non-descriptor-reg nl2-offset)
+			  (:temp retaddr non-descriptor-reg nl3-offset)
+			  (:temp temp1 non-descriptor-reg nl4-offset))
+
+  ;; These are needed after we jump into sxhash-simple-substring.
+  (progn result lip accum data byte  retaddr)
+
+  (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1)
+  (loadw length string vector-length-slot other-pointer-type)
+  (inst jmp zero-tn temp1
+	(make-fixup 'sxhash-simple-substring :assembly-routine)))
+
+(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 lip interior-reg lip-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp byte non-descriptor-reg nl2-offset)
+			  (:temp retaddr non-descriptor-reg nl3-offset))
+
+  ;; Save the return address
+  (inst subq lip code-tn retaddr)
+
+  ;; Get a pointer to the data.
+  (inst addq string
+	(- (* vector-data-offset word-bytes) other-pointer-type)
+	lip)
+  (move zero-tn accum)
+  (inst br zero-tn test)
+
+  loop
+
+  (inst and data #xff byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+
+  (inst srl data 8 byte)
+  (inst and byte #xff byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+
+  (inst srl data 16 byte)
+  (inst and byte #xff byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+
+  (inst srl data 24 byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+
+  (inst addq lip 4 lip)
+
+  test
+
+  (inst subq length (fixnum 4) length)
+  (inst ldl data 0 lip)
+  (inst bge length loop)
+
+  (inst addq length (fixnum 3) length)
+  (inst beq length one-more)
+  (inst subq length (fixnum 1) length)
+  (inst beq length two-more)
+  (inst bne length done)
+
+  (inst srl data 16 byte)
+  (inst and byte #xff byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+  (inst addq length (fixnum 1) length)
+
+  two-more
+
+  (inst subq length (fixnum 1) length)
+  (inst srl data 8 byte)
+  (inst and byte #xff byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+  (inst addq length (fixnum 1) length)
+
+  one-more
+
+  (inst subq length (fixnum 1) length)
+  (inst and data #xff byte)
+  (inst xor accum byte accum)
+  (inst sll accum 5 byte)
+  (inst srl accum 27 accum)
+  (inst mskll accum 4 accum)
+  (inst bis accum byte accum)
+
+  done
+
+  (inst sll accum 5 result)
+  (inst mskll result 4 result)
+  (inst srl result 3 result)
+
+  ;; Restore the return address.
+  (inst addq code-tn retaddr lip))
diff --git a/assembly/alpha/assem-rtns.lisp b/assembly/alpha/assem-rtns.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7235089d8fa8a09da3da8979f954dd465e8c42f9
--- /dev/null
+++ b/assembly/alpha/assem-rtns.lisp
@@ -0,0 +1,236 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/alpha/assem-rtns.lisp,v 1.1 1994/04/06 16:58:34 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+(in-package "ALPHA")
+
+
+;;;; 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 ocfp any-reg nl1-offset)
+     (:temp lra descriptor-reg lra-offset)
+
+     ;; These are just needed to facilitate the transfer
+     (:temp lip interior-reg lip-offset)
+     (:temp count any-reg nl2-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))
+
+  ;; Note, because of the way the return-multiple vop is written, we can
+  ;; assume that we are never called with nvals == 1 and that a0 has already
+  ;; been loaded.
+  (inst ble nvals default-a0-and-on)
+  (inst ldl a1 (* 1 vm:word-bytes) vals)
+  (inst subq nvals (fixnum 2) count)
+  (inst ble count default-a2-and-on)
+  (inst ldl a2 (* 2 vm:word-bytes) vals)
+  (inst subq nvals (fixnum 3) count)
+  (inst ble count default-a3-and-on)
+  (inst ldl a3 (* 3 vm:word-bytes) vals)
+  (inst subq nvals (fixnum 4) count)
+  (inst ble count default-a4-and-on)
+  (inst ldl a4 (* 4 vm:word-bytes) vals)
+  (inst subq nvals (fixnum 5) count)
+  (inst ble count default-a5-and-on)
+  (inst ldl a5 (* 5 vm:word-bytes) vals)
+  (inst subq nvals (fixnum 6) count)
+  (inst ble count done)
+
+  ;; Copy the remaining args to the top of the stack.
+  (inst addq vals (* 6 vm:word-bytes) vals)
+  (inst addq cfp-tn (* 6 vm:word-bytes) dst)
+
+  LOOP
+  (inst ldl temp 0 vals)
+  (inst addq vals vm:word-bytes vals)
+  (inst stl temp 0 dst)
+  (inst subq count (fixnum 1) count)
+  (inst bne count loop)
+  (inst addq dst vm:word-bytes dst)
+		
+  (inst br zero-tn done)
+
+  DEFAULT-A0-AND-ON
+  (inst move null-tn a0)
+  (inst move null-tn a1)
+  DEFAULT-A2-AND-ON
+  (inst move null-tn a2)
+  DEFAULT-A3-AND-ON
+  (inst move null-tn a3)
+  DEFAULT-A4-AND-ON
+  (inst move null-tn a4)
+  DEFAULT-A5-AND-ON
+  (inst move null-tn a5)
+  DONE
+  
+  ;; Clear the stack.
+  (move cfp-tn ocfp-tn)
+  (move ocfp cfp-tn)
+  (inst addq ocfp-tn nvals csp-tn)
+  
+  ;; Return.
+  (lisp-return lra lip))
+
+
+;;;; 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 cfunc-offset)
+     (:temp temp descriptor-reg l0-offset)
+
+     ;; Needed for the jump
+     (:temp lip interior-reg lip-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 subq csp-tn args nargs)
+     
+  ;; Load the argument regs (must do this now, 'cause the blt might
+  ;; trash these locations)
+  (inst ldl a0 (* 0 vm:word-bytes) args)
+  (inst ldl a1 (* 1 vm:word-bytes) args)
+  (inst ldl a2 (* 2 vm:word-bytes) args)
+  (inst ldl a3 (* 3 vm:word-bytes) args)
+  (inst ldl a4 (* 4 vm:word-bytes) args)
+  (inst ldl a5 (* 5 vm:word-bytes) args)
+
+  ;; Calc SRC, DST, and COUNT
+  (inst subq nargs (fixnum register-arg-count) count)
+  (inst addq args (* vm:word-bytes register-arg-count) src)
+  (inst ble count done)
+  (inst addq cfp-tn (* vm:word-bytes register-arg-count) dst)
+	
+  LOOP
+  ;; Copy one arg.
+  (inst ldl temp 0 src)
+  (inst addq src vm:word-bytes src)
+  (inst stl temp 0 dst)
+  (inst subq count (fixnum 1) count)
+  (inst addq dst vm:word-bytes dst)
+  (inst bgt count loop)
+	
+  DONE
+  ;; We are done.  Do the jump.
+  (progn
+    (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type)
+    (lisp-jump temp lip)))
+
+
+;;;; Non-local exit noise.
+
+(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 lip interior-reg lip-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)
+     (:temp temp1 non-descriptor-reg nl3-offset))
+  (declare (ignore start count))
+
+  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst beq block error))
+  
+  (loadw target-uwp block vm:unwind-block-current-uwp-slot)
+  (inst cmpeq cur-uwp target-uwp temp1)
+  (inst beq temp1 do-uwp)
+      
+  (move block cur-uwp)
+
+  do-exit
+      
+  (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot)
+  (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
+  (progn
+    (loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
+    (lisp-return lra lip :frob-code nil))
+
+  do-uwp
+
+  (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
+  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)
+  (inst br zero-tn do-exit))
+
+
+(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)
+     (:temp temp1 non-descriptor-reg nl0-offset))
+  
+  (progn 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 beq catch error))
+  
+  (loadw tag catch vm:catch-block-tag-slot)
+  (inst cmpeq tag target temp1)
+  (inst bne temp1 exit)
+  (loadw catch catch vm:catch-block-previous-catch-slot)
+  (inst br zero-tn loop)
+  
+  exit
+  
+  (move catch target)
+  (inst li (make-fixup 'unwind :assembly-routine) temp1)
+  (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine)))
diff --git a/assembly/alpha/support.lisp b/assembly/alpha/support.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..175a8a9a70d37e08210657400e5aeda9b3cf4836
--- /dev/null
+++ b/assembly/alpha/support.lisp
@@ -0,0 +1,77 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/alpha/support.lisp,v 1.1 1994/04/06 16:58:36 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the machine specific support routines needed by
+;;; the file assembler.
+;;;
+(in-package "ALPHA")
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (values
+      `((inst li (make-fixup ',name :assembly-routine) temp)
+	(inst jsr lip-tn temp))
+      '((:temporary (:sc non-descriptor-reg) temp))
+     nil))
+    (:full-call
+     (let ((temp (make-symbol "TEMP"))
+	   (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 ,nfp-save cur-nfp))
+	    (inst compute-lra-from-code ,lra code-tn lra-label ,temp)
+	    (note-next-instruction ,vop :call-site)
+	    ; here
+	    (inst li (make-fixup ',name :assembly-routine) temp1)
+	    (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine))
+	    (emit-return-pc lra-label)
+	    (note-this-location ,vop :single-value-return)
+	    (without-scheduling ()
+	      (move ocfp-tn csp-tn)
+	      (inst nop))
+	    (inst compute-code-from-lra code-tn code-tn
+		  lra-label ,temp)
+	    (when cur-nfp
+	      (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1))))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)
+	  (:temporary (:sc descriptor-reg :offset lra-offset
+		       :from (:eval 0) :to (:eval 1))
+		      ,lra)
+	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
+		      ,nfp-save)
+	  (:temporary (:scs (non-descriptor-reg)) temp1)
+	  (:save-p t)))))
+    (:none
+     (values
+      `((inst li (make-fixup ',name :assembly-routine) temp)
+	(inst jsr lip-tn temp (make-fixup ',name :assembly-routine)))
+      '((:temporary (:scs (non-descriptor-reg)) temp))
+      nil))))
+
+
+(def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst ret zero-tn lip-tn)))
+    (:full-call
+     `((lisp-return (make-random-tn :kind :normal
+				    :sc (sc-or-lose
+					 'descriptor-reg)
+				    :offset lra-offset)
+		    lip-tn :offset 2)))
+    (:none)))
diff --git a/code/alpha-vm.lisp b/code/alpha-vm.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..bf09fbb06f563e0812a93cd8d8275e54cbff2672
--- /dev/null
+++ b/code/alpha-vm.lisp
@@ -0,0 +1,223 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/code/alpha-vm.lisp,v 1.1 1994/04/06 17:00:02 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.1 1994/04/06 17:00:02 hallgren Exp $
+;;;
+;;; This file contains the Alpha specific runtime stuff.
+;;;
+(in-package "ALPHA")
+(use-package "SYSTEM")
+(use-package "ALIEN")
+(use-package "C-CALL")
+(use-package "UNIX")
+
+(export '(fixup-code-object internal-error-arguments
+	  sigcontext-program-counter sigcontext-register
+	  sigcontext-float-register sigcontext-floating-point-modes
+	  extern-alien-name sanctify-for-execution))
+
+
+;;;; The sigcontext structure.
+
+(def-alien-type sigcontext
+  (struct nil
+    (sc-onstack unsigned-long)
+    (sc-mask unsigned-long)
+    (sc-pc system-area-pointer)
+    (sc-ps unsigned-long)
+    (sc-regs (array unsigned-long 32))
+    (sc-ownedfp unsigned-long)
+    (sc-fpregs (array unsigned-long 32))
+    (sc-fpcr unsigned-long)
+    (sc-fp-control unsigned-long)
+    (sc-reserved1 unsigned-long)
+    (sc-reserved2 unsigned-long)
+    (sc-reserved3 unsigned-long)
+    (sc-reserved4 unsigned-long)
+    (sc-traparg-a0 unsigned-long)
+    (sc-traparg-a1 unsigned-long)
+    (sc-traparg-a2 unsigned-long)
+    (sc-fp-trap-pc unsigned-long)  ; imprecise pc
+    (sc-fp-trigger-sum unsigned-long)
+    (sc-fp-trigger-inst unsigned-long)))
+
+
+
+;;;; Add machine specific features to *features*
+
+(pushnew :alpha *features*)
+
+
+
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+  "Returns a string describing the type of the local machine."
+  "DECstation")
+
+(defun machine-version ()
+  "Returns a string describing the version of the local machine."
+  "DECstation")
+
+
+
+;;; FIXUP-CODE-OBJECT -- Interface
+;;;
+(defun fixup-code-object (code offset value kind)
+  (unless (zerop (rem offset word-bytes))
+    (error "Unaligned instruction?  offset=#x~X." offset))
+  (system:without-gcing
+   (let ((sap (truly-the system-area-pointer
+			 (%primitive c::code-instructions code))))
+     (ecase kind
+       (:jmp-hint
+	(assert (zerop (ldb (byte 2 0) value)))
+	#+nil
+	(setf (sap-ref-16 sap offset)
+	      (logior (sap-ref-16 sap offset) (ldb (byte 14 0) (ash value -2)))))
+       (:bits-63-48
+	(let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+	       (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
+	       (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
+	  (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value))
+	  (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value))))
+       (:bits-47-32
+	(let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+	       (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
+	  (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value))
+	  (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value))))
+       (:ldah
+	(let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
+	  (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value))
+	  (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value))))
+       (:lda
+	(setf (sap-ref-8 sap offset) (ldb (byte 8 0) value))
+	(setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))))))
+
+
+
+;;;; Internal-error-arguments.
+
+;;; INTERNAL-ERROR-ARGUMENTS -- interface.
+;;;
+;;; Given the sigcontext, extract the internal error arguments from the
+;;; instruction stream.
+;;; 
+(defun internal-error-arguments (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((pc (slot scp 'sc-pc)))
+      (declare (type system-area-pointer pc))
+      (let* ((length (sap-ref-8 pc 4))
+	     (vector (make-array length :element-type '(unsigned-byte 8))))
+	(declare (type (unsigned-byte 8) length)
+		 (type (simple-array (unsigned-byte 8) (*)) vector))
+	(copy-from-system-area pc (* vm:byte-bits 5)
+			       vector (* vm:word-bits
+					 vm:vector-data-offset)
+			       (* length vm:byte-bits))
+	(let* ((index 0)
+	       (error-number (c::read-var-integer vector index)))
+	  (collect ((sc-offsets))
+	    (loop
+	      (when (>= index length)
+		(return))
+	      (sc-offsets (c::read-var-integer vector index)))
+	    (values error-number (sc-offsets))))))))
+
+
+;;;; Sigcontext access functions.
+
+;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
+;;;
+(defun sigcontext-program-counter (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (slot scp 'sc-pc)))
+
+;;; SIGCONTEXT-REGISTER -- Interface.
+;;;
+;;; An escape register saves the value of a register for a frame that someone
+;;; interrupts.  
+;;;
+(defun sigcontext-register (scp index)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (deref (slot scp 'sc-regs) index)))
+
+(defun %set-sigcontext-register (scp index new)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (setf (deref (slot scp 'sc-regs) index) new)
+    new))
+
+(defsetf sigcontext-register %set-sigcontext-register)
+
+
+;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface.
+;;;
+;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
+;;; Format is the type of float to return.
+;;;
+(defun sigcontext-float-register (scp index format)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
+      (ecase format
+	(single-float (system:sap-ref-single sap (* index vm:word-bytes)))
+	(double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
+;;;
+(defun %set-sigcontext-float-register (scp index format new-value)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
+      (ecase format
+	(single-float
+	 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
+	(double-float
+	 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
+;;;
+(defsetf sigcontext-float-register %set-sigcontext-float-register)
+
+
+;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
+;;;
+;;;    Given a sigcontext pointer, return the floating point modes word in the
+;;; same format as returned by FLOATING-POINT-MODES.
+;;;
+(defun sigcontext-floating-point-modes (scp)
+  (declare (type (alien (* sigcontext)) scp))
+   (with-alien ((scp (* sigcontext) scp))
+    (slot scp 'sc-fpcr)))
+
+
+
+;;; EXTERN-ALIEN-NAME -- interface.
+;;;
+;;; The loader uses this to convert alien names to the form they occure in
+;;; the symbol table (for example, prepending an underscore).  On the MIPS,
+;;; we don't do anything.
+;;; 
+(defun extern-alien-name (name)
+  (declare (type simple-base-string name))
+  name)
+
+
+
+;;; SANCTIFY-FOR-EXECUTION -- Interface.
+;;;
+;;; Do whatever is necessary to make the given code component executable.
+;;; 
+(defun sanctify-for-execution (component)
+  (declare (ignore component))
+  nil)
diff --git a/compiler/alpha/alloc.lisp b/compiler/alpha/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..37f43d4d140c5bd2bbf441d75005c6326b0628f7
--- /dev/null
+++ b/compiler/alpha/alloc.lisp
@@ -0,0 +1,187 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/alloc.lisp,v 1.1 1994/04/06 16:53:01 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the Alpha port.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;; 
+
+(in-package "ALPHA")
+
+
+;;;; 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)
+  (:info num)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:generator 0
+    (cond ((zerop num)
+	   (move null-tn result))
+	  ((and star (= num 1))
+	   (move (tn-ref-tn things) result))
+	  (t
+	   (macrolet
+	       ((store-car (tn list &optional (slot cons-car-slot))
+		  `(let ((reg
+			  (sc-case ,tn
+			    ((any-reg descriptor-reg) ,tn)
+			    (zero zero-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 (:extra (* (pad-data-block cons-size)
+					 cons-cells))
+		 (inst bis alloc-tn list-pointer-type res)
+		 (move res ptr)
+		 (dotimes (i (1- cons-cells))
+		   (store-car (tn-ref-tn things) ptr)
+		   (setf things (tn-ref-across things))
+		   (inst lda ptr (pad-data-block cons-size) ptr)
+		   (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 res result))))))))
+
+(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)))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
+  (:generator 100
+    (inst li (lognot lowtag-mask) ndescr)
+    (inst lda boxed (fixnum (1+ code-trace-table-offset-slot))
+	  boxed-arg)
+    (inst and boxed ndescr boxed)
+    (inst srl unboxed-arg word-shift unboxed)
+    (inst lda unboxed lowtag-mask unboxed)
+    (inst and unboxed ndescr unboxed)
+    (inst sll boxed (- type-bits word-shift) ndescr)
+    (inst bis ndescr code-header-type ndescr)
+    
+    (pseudo-atomic ()
+      (inst bis alloc-tn other-pointer-type result)
+      (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)
+      (inst addq alloc-tn boxed alloc-tn)
+      (inst addq alloc-tn unboxed alloc-tn))
+
+    (storew null-tn result code-debug-info-slot other-pointer-type)))
+
+(define-vop (make-fdefn)
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:generator 37
+    (with-fixed-allocation (result temp fdefn-type fdefn-size)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew null-tn result fdefn-function-slot other-pointer-type)
+      (inst li (make-fixup "undefined_tramp" :foreign) temp)
+      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
+
+(define-vop (make-closure)
+  (:args (function :to :save :scs (descriptor-reg)))
+  (:info length)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (let ((size (+ length closure-info-offset)))
+      (inst li (logior (ash (1- size) type-bits) closure-header-type) temp)
+      (pseudo-atomic (:extra (pad-data-block size))
+	(inst bis alloc-tn function-pointer-type result)
+	(storew temp result 0 function-pointer-type))
+      (storew function result closure-function-slot function-pointer-type))))
+
+;;; The compiler likes to be able to directly make value cells.
+;;; 
+(define-vop (make-value-cell)
+  (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (with-fixed-allocation
+	(result temp value-cell-header-type value-cell-size))
+    (storew value result value-cell-value-slot other-pointer-type)))
+
+
+;;;; Automatic allocators for primitive objects.
+
+(define-vop (make-unbound-marker)
+  (:args)
+  (:results (result :scs (any-reg)))
+  (:generator 1
+    (inst li unbound-marker-type result)))
+
+(define-vop (fixed-alloc)
+  (:args)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 4
+    (pseudo-atomic (:extra (pad-data-block words))
+      (inst bis alloc-tn lowtag result)
+      (when type
+	(inst li (logior (ash (1- words) type-bits) type) temp)
+	(storew temp result 0 lowtag)))))
+
+(define-vop (var-alloc)
+  (:args (extra :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (any-reg)) header)
+  (:temporary (:scs (non-descriptor-reg)) bytes)
+  (:generator 6
+    (inst lda bytes (* (1+ words) word-bytes) extra)
+    (inst sll bytes (- type-bits 2) header)
+    (inst lda header (+ (ash -2 type-bits) type) header)
+    (inst srl bytes lowtag-bits bytes)
+    (inst sll bytes lowtag-bits bytes)
+    (pseudo-atomic ()
+      (inst bis alloc-tn lowtag result)
+      (storew header result 0 lowtag)
+      (inst addq alloc-tn bytes alloc-tn))))
diff --git a/compiler/alpha/arith.lisp b/compiler/alpha/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a89d5475c1addf17436a3a9e377dec3869007e9b
--- /dev/null
+++ b/compiler/alpha/arith.lisp
@@ -0,0 +1,808 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/arith.lisp,v 1.1 1994/04/06 16:54:36 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/arith.lisp,v 1.1 1994/04/06 16:54:36 hallgren Exp $
+;;;
+;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted by Sean Hallgren
+;;; 
+
+(in-package "ALPHA")
+
+
+
+;;;; 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 subq zero-tn x res)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (inst subq zero-tn x res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:translate lognot)
+  (:generator 2
+    (inst eqv x zero-tn res)))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (inst not x res)))
+
+
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop)
+  (:args (x :target r :scs (any-reg))
+	 (y :target r :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (: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 :target r :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (: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 :target r :scs (signed-reg)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
+  (:args (x :target r :scs (any-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-signed-c-binop fast-signed-binop)
+  (:args (x :target r :scs (signed-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
+  (:args (x :target r :scs (unsigned-reg)))
+  (:info y)
+  (:arg-types tagged-num (:constant integer)))
+
+(defmacro define-binop (translate cost untagged-cost op
+				  tagged-type untagged-type)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+		  fast-fixnum-binop)
+       (:args (x :target r :scs (any-reg))
+	      (y :target r :scs (any-reg)))
+       (:translate ,translate)
+       (:generator ,(1+ cost)
+	 (inst ,op x y r)))
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+		  fast-signed-binop)
+       (:args (x :target r :scs (signed-reg))
+	      (y :target r :scs (signed-reg)))
+       (:translate ,translate)
+       (:generator ,(1+ untagged-cost)
+	 (inst ,op x y r)))
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-binop)
+       (:args (x :target r :scs (unsigned-reg))
+	      (y :target r :scs (unsigned-reg)))
+       (:translate ,translate)
+       (:generator ,(1+ untagged-cost)
+	 (inst ,op x y r)))
+     ,@(when tagged-type
+	 `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+			fast-fixnum-c-binop)
+		       (:arg-types tagged-num (:constant ,tagged-type))
+	     (:translate ,translate)
+	     (:generator ,cost
+			 (inst ,op x (fixnum y) r)))))
+     ,@(when untagged-type
+	 `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+			fast-signed-c-binop)
+		       (:arg-types signed-num (:constant ,untagged-type))
+	     (:translate ,translate)
+	     (:generator ,untagged-cost
+			 (inst ,op x y r)))
+	   (define-vop (,(symbolicate "FAST-" translate
+				      "-C/UNSIGNED=>UNSIGNED")
+			fast-unsigned-c-binop)
+		       (:arg-types unsigned-num (:constant ,untagged-type))
+	     (:translate ,translate)
+	     (:generator ,untagged-cost
+			 (inst ,op x y r)))))))
+
+(define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8))
+(define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
+(define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
+
+
+;;; Shifting
+
+
+(define-vop (fast-ash)
+  (:note "inline ASH")
+  (:args (number :scs (signed-reg unsigned-reg) :to :save)
+	 (amount :scs (signed-reg)))
+  (:arg-types (:or signed-num unsigned-num) signed-num)
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:sc non-descriptor-reg) ndesc)
+  (:temporary (:sc non-descriptor-reg :to :eval) temp)
+  (:generator 3
+    (inst bge amount positive)
+    (inst subq zero-tn amount ndesc)
+    (inst cmplt ndesc 31 temp)
+    (sc-case number
+      (signed-reg (inst sra number ndesc result))
+      (unsigned-reg (inst srl number ndesc result)))
+    (inst bne temp done)
+    (sc-case number
+      (signed-reg (inst sra number 31 result))
+      (unsigned-reg (inst srl number 31 result)))
+    (inst br zero-tn done)
+      
+    POSITIVE
+    ;; The result-type assures us that this shift will not overflow.
+    (inst sll number amount result)
+      
+    DONE))
+
+(define-vop (fast-ash-c)
+  (:policy :fast-safe)
+  (:translate ash)
+  (:note nil)
+  (:args (number :scs (signed-reg unsigned-reg)))
+  (:info count)
+  (:arg-types (:or signed-num unsigned-num) (:constant integer))
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:generator 1
+    (cond ((< count 0)
+	   ;; It is a right shift.
+	   (sc-case number
+	     (signed-reg (inst sra number (- count) result))
+	     (unsigned-reg (inst srl number (- count) result))))
+	  ((> count 0)
+	   ;; It is a left shift.
+	   (inst sll number count result))
+	  (t
+	   ;; Count=0?  Shouldn't happen, but it's easy:
+	   (move number result)))))
+
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note "inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg) :to (:argument 1)))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
+  (:generator 30
+    (inst not arg shift)
+    (inst cmovge arg arg shift)
+    (inst subq zero-tn 4 res)
+    (inst sll shift 1 shift)
+    LOOP
+    (inst addq res (fixnum 1) res)
+    (inst srl shift 1 shift)
+    (inst bne shift loop)))
+
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note "inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg) :target num))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
+		    :target res) num)
+  (:temporary (:scs (non-descriptor-reg)) mask temp)
+  (:generator 30
+    (inst li #x55555555 mask)
+    (inst srl arg 1 temp)
+    (inst and arg mask num)
+    (inst and temp mask temp)
+    (inst addq num temp num)
+    (inst li #x33333333 mask)
+    (inst srl num 2 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst addq num temp num)
+    (inst li #x0f0f0f0f mask)
+    (inst srl num 4 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst addq num temp num)
+    (inst li #x00ff00ff mask)
+    (inst srl num 8 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst addq num temp num)
+    (inst li #x0000ffff mask)
+    (inst srl num 16 temp)
+    (inst and num mask num)
+    (inst and temp mask temp)
+    (inst addq num temp res)))
+
+
+;;; Multiply
+
+(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:translate *)
+  (:generator 4
+    (inst sra y 2 temp)
+    (inst mulq x temp r)))
+
+(define-vop (fast-*/signed=>signed fast-signed-binop)
+  (:translate *)
+  (:generator 3
+    (inst mulq x y r)))
+
+(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
+  (:translate *)
+  (:generator 3
+    (inst mulq x y r)))
+
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:policy :fast-safe))
+
+(deftype integer-with-a-bite-out (s bite)
+  (cond ((eq s '*) 'integer)
+	((and (integerp s) (> s 1))
+	 (let ((bound (ash 1 s)))
+	   `(integer 0 ,(- bound bite 1))))
+	(t
+	 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(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)))
+  (:arg-types tagged-num (:constant (integer-with-a-bite-out 6 4)))
+  (: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 (integer-with-a-bite-out 8 1)))
+  (: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 (integer-with-a-bite-out 8 1)))
+  (: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)))
+			    (declare (optimize (inhibit-warnings 3)))
+			    ,@generator)))))
+	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+	       '(3 2 5 4 5 4)
+	       '(t t t t nil nil))))
+
+(define-conditional-vop <
+  (cond ((and signed (eql y 0))
+	 (if not-p
+	     (inst bge x target)
+	     (inst blt x target)))
+	(t
+	 (if signed
+	     (inst cmplt x y temp)
+	     (inst cmpult x y temp))
+	 (if not-p
+	     (inst beq temp target)
+	     (inst bne temp target)))))
+
+(define-conditional-vop >
+  (cond ((and signed (eql y 0))
+	 (if not-p
+	     (inst ble x target)
+	     (inst bgt x target)))
+	((integerp y)
+	 (let ((y (+ y (if -c/fixnum (fixnum 1) 1))))
+	   (if signed
+	       (inst cmplt x y temp)
+	       (inst cmpult x y temp))
+	   (if not-p
+	       (inst bne temp target)
+	       (inst beq temp target))))
+	(t
+	 (if signed
+	     (inst cmplt y x temp)
+	     (inst cmpult y x temp))
+	 (if not-p
+	     (inst beq temp target)
+	     (inst bne temp target)))))
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+(define-conditional-vop eql
+  (declare (ignore signed))
+  (when (integerp y)
+    (inst li y temp)
+    (setf y temp))
+  (inst cmpeq x y temp)
+  (if not-p
+      (inst beq temp target)
+      (inst bne temp target)))
+
+;;; These versions specify a fixnum restriction on their first arg.  We have
+;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
+;;; the first arg and a higher cost.  The reason for doing this is to prevent
+;;; fixnum specific operations from being used on word integers, spuriously
+;;; consing the argument.
+;;;
+(define-vop (fast-eql/fixnum fast-conditional)
+  (:args (x :scs (any-reg))
+	 (y :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison")
+  (:translate eql)
+  (:generator 3
+    (cond ((equal y zero-tn)
+	   (if not-p
+	       (inst bne x target)
+	       (inst beq x target)))
+	  (t
+	   (inst cmpeq x y temp)
+	   (if not-p
+	       (inst beq temp target)
+	       (inst bne temp target))))))
+
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+  (:args (x :scs (any-reg descriptor-reg))
+	 (y :scs (any-reg)))
+  (:arg-types * tagged-num)
+  (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg)))
+  (:arg-types tagged-num (:constant (signed-byte 6)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 2
+    (let ((y (cond ((eql y 0) zero-tn)
+		   (t
+		    (inst li (fixnum y) temp)
+		    temp))))
+      (inst cmpeq x y temp)
+      (if not-p
+	  (inst beq temp target)
+	  (inst bne temp target)))))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:arg-types * (:constant (signed-byte 6)))
+  (:variant-cost 6))
+  
+
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits)
+  (:translate merge-bits)
+  (:args (shift :scs (signed-reg unsigned-reg))
+	 (prev :scs (unsigned-reg))
+	 (next :scs (unsigned-reg)))
+  (:arg-types tagged-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst srl next shift res)
+      (inst beq shift done)
+      (inst subq zero-tn shift temp)
+      (inst sll prev temp temp)
+      (inst bis res temp res)
+      (emit-label done)
+      (move res result))))
+
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (: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 x r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (inst and x y r)))
+
+(deftransform 32bit-logical-nand ((x y) (* *))
+  '(32bit-logical-not (32bit-logical-and x y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+  (:translate 32bit-logical-or)
+  (:generator 1
+    (inst bis x y r)))
+
+(define-vop (32bit-logical-nor 32bit-logical)
+  (:translate 32bit-logical-nor)
+  (:generator 1
+    (inst ornot x y r)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+  (:translate 32bit-logical-xor)
+  (:generator 1
+    (inst xor x y r)))
+
+(deftransform 32bit-logical-eqv ((x y) (* *))
+  '(32bit-logical-not (32bit-logical-xor x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+  '(32bit-logical-and (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-andc2 ((x y) (* *))
+  '(32bit-logical-and x (32bit-logical-not y)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+  '(32bit-logical-or (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-orc2 ((x y) (* *))
+  '(32bit-logical-or x (32bit-logical-not y)))
+
+
+(define-vop (shift-towards-someplace)
+  (:policy :fast-safe)
+  (:args (num :scs (unsigned-reg))
+	 (amount :scs (signed-reg)))
+  (:arg-types unsigned-num tagged-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (shift-towards-start shift-towards-someplace)
+  (:translate shift-towards-start)
+  (:note "SHIFT-TOWARDS-START")
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:generator 1
+    (inst and amount #x1f temp)
+    (inst srl num temp r)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+  (:translate shift-towards-end)
+  (:note "SHIFT-TOWARDS-END")
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:generator 1
+    (inst and amount #x1f temp)
+    (inst sll num temp r)))
+
+
+
+;;;; 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-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-set #+gengc nil)
+
+(define-vop (digit-0-or-plus)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:conditional)
+  (:info target not-p)
+  (:generator 2
+    (inst sll digit 32 temp)
+    (if not-p
+	(inst blt temp target)
+	(inst bge temp target))))
+
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg) :from :load)
+	    (carry :scs (unsigned-reg) :from :eval))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 5
+    (inst addq a b result)
+    (inst addq result c result)
+    (inst sra result 32 carry)
+    (inst mskll result 4 result)))
+
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg) :from :load)
+	    (borrow :scs (unsigned-reg) :from :eval))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 4
+    (inst xor c 1 result)
+    (inst subq a result result)
+    (inst subq result b result)
+    (inst srl result 63 borrow)
+    (inst xor borrow 1 borrow)
+    (inst mskll result 4 result)))
+
+(define-vop (bignum-mult-and-add-3-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg))
+	 (carry-in :scs (unsigned-reg) :to :save))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 6
+    (inst mulq x y lo)
+    (inst addq lo carry-in lo)
+    (inst sra lo 32 hi)
+    (inst mskll lo 4 lo)))
+
+
+(define-vop (bignum-mult-and-add-4-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg))
+	 (prev :scs (unsigned-reg))
+	 (carry-in :scs (unsigned-reg) :to :save))
+  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 9
+    (inst mulq x y lo)
+    (inst addq lo prev lo)
+    (inst addq lo carry-in lo)
+    (inst sra lo 32 hi)
+    (inst mskll lo 4 lo)))
+
+(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 (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 3
+    (inst mulq x y lo)
+    (inst srl lo 32 hi)
+    (inst mskll lo 4 lo)))
+
+(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 x r)
+    (inst mskll r 4 r)))
+
+(define-vop (fixnum-to-digit)
+  (:translate bignum::%fixnum-to-digit)
+  (:policy :fast-safe)
+  (:args (fixnum :scs (any-reg)))
+  (:arg-types tagged-num)
+  (:results (digit :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst sra fixnum 2 digit)))
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (num-high :scs (unsigned-reg))
+	 (num-low :scs (unsigned-reg))
+	 (denom-arg :scs (unsigned-reg) :target denom))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom)
+  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
+  (:results (quo :scs (unsigned-reg) :from (:eval 0))
+	    (rem :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 325 ; number of inst assuming targeting works.
+    (inst sll num-high 32 rem)
+    (inst bis rem num-low rem)
+    (inst sll denom-arg 32 denom)
+    (inst cmpule denom rem quo)
+    (inst beq quo shift1)
+    (inst subq rem denom rem)
+    SHIFT1
+    (dotimes (i 32)
+      (let ((shift2 (gen-label)))
+	(inst srl denom 1 denom)
+	(inst cmpule denom rem temp)
+	(inst sll quo 1 quo)
+	(inst beq temp shift2)
+	(inst subq rem denom rem)
+	(inst bis quo 1 quo)
+	(emit-label shift2)))))
+
+(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 (any-reg signed-reg)))
+  (:result-types signed-num)
+  (:generator 2
+    (sc-case res
+      (any-reg
+       (inst sll digit 34 res)
+       (inst sra res 32 res))
+      (signed-reg
+       (inst sll digit 32 res)
+       (inst sra res 32 res)))))
+
+
+(define-vop (digit-ashr)
+  (:translate bignum::%ashr)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg))
+	 (count :scs (unsigned-reg)))
+  (:arg-types unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst sll digit 32 result)
+    (inst sra result count result)
+    (inst srl result 32 result)))
+
+(define-vop (digit-lshr digit-ashr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:generator 1
+    (inst srl digit count result)))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 1
+    (inst sll digit count result)))
+
+
+;;;; 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/alpha/array.lisp b/compiler/alpha/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a015df740001baa7cc7303ad68379be0ca31f84e
--- /dev/null
+++ b/compiler/alpha/array.lisp
@@ -0,0 +1,443 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/array.lisp,v 1.1 1994/04/06 16:54:37 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the Alpha definitions for array operations.
+;;;
+;;; Written by William Lott
+;;; Conversion by Sean Hallgren
+;;;
+(in-package "ALPHA")
+
+
+;;;; Allocator for the array header.
+
+(define-vop (make-array-header)
+  (:policy :fast-safe)
+  (:translate make-array-header)
+  (:args (type :scs (any-reg))
+	 (rank :scs (any-reg)))
+  (:arg-types positive-fixnum positive-fixnum)
+  (:temporary (:scs (any-reg)) bytes)
+  (:temporary (:scs (non-descriptor-reg)) header)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 13
+    (inst addq rank (+ (* array-dimensions-offset word-bytes)
+		       lowtag-mask)
+	  bytes)
+    (inst li (lognot lowtag-mask) header)
+    (inst and bytes header bytes)
+    (inst addq rank (fixnum (1- array-dimensions-offset)) header)
+    (inst sll header type-bits header)
+    (inst bis header type header)
+    (inst srl header 2 header)
+    (pseudo-atomic ()
+      (inst bis alloc-tn other-pointer-type result)
+      (storew header result 0 other-pointer-type)
+      (inst addq alloc-tn bytes alloc-tn))))
+
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t index) index
+  (flushable))
+(defknown lisp::%set-array-dimension (t index index) index
+  ())
+
+(define-full-reffer %array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%set-array-dimension #+gengc nil)
+
+
+(defknown lisp::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+  (:translate lisp::%array-rank)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 6
+    (loadw temp x 0 other-pointer-type)
+    (inst sra temp type-bits temp)
+    (inst subq temp (1- array-dimensions-offset) temp)
+    (inst sll temp 2 res)))
+
+
+
+;;;; 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)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (let ((error (generate-error-code vop invalid-array-index-error
+				      array bound index)))
+      (inst cmpult index bound temp)
+      (inst beq temp error)
+      (move index result))))
+
+
+
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(eval-when (compile eval)
+
+(defmacro def-full-data-vector-frobs (type element-type &rest scs)
+  `(progn
+     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       vector-data-offset other-pointer-type
+       ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
+       ,element-type
+       data-vector-ref)
+     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-set #+gengc ,(if (member 'descriptor-reg scs) t nil))))
+
+(defmacro def-partial-data-vector-frobs
+	  (type element-type size signed &rest scs)
+  `(progn
+     (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       ,size ,signed vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-ref)
+     (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       ,size vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-set)))
+
+); eval-when (compile eval)
+
+(def-full-data-vector-frobs simple-vector *
+  descriptor-reg any-reg null zero)
+
+(def-partial-data-vector-frobs simple-string base-char :byte nil
+  base-char-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+  :byte nil unsigned-reg signed-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+  :short nil unsigned-reg signed-reg)
+
+(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+  unsigned-reg)
+
+
+
+;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;; 
+
+(defmacro def-small-data-vector-frobs (type bits)
+  (let* ((elements-per-word (floor word-bits bits))
+	 (bit-shift (1- (integer-length elements-per-word))))
+    `(progn
+       (define-vop (,(symbolicate 'data-vector-ref/ type))
+	 (: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
+	   (inst srl index ,bit-shift temp)
+	   (inst sll temp 2 temp)
+	   (inst addq object temp lip)
+	   (inst ldl result
+		 (- (* vector-data-offset word-bytes)
+		    other-pointer-type)
+		  lip)
+	   (inst and index ,(1- elements-per-word) temp)
+	   ,@(when (eq (backend-byte-order *backend*) :big-endian)
+	       `((inst xor temp ,(1- elements-per-word) temp)))
+	   ,@(unless (= bits 1)
+	       `((inst sll temp ,(1- (integer-length bits)) temp)))
+	   (inst srl result temp result)
+	   (inst and result ,(1- (ash 1 bits)) result)
+	   (inst sll result 2 value)))
+       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:arg-types ,type
+		     (:constant
+		      (integer 0
+			       ,(1- (* (1+ (- (floor (+ #x7fff
+							other-pointer-type)
+						     word-bytes)
+					      vector-data-offset))
+				       elements-per-word)))))
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:generator 15
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     ,@(when (eq (backend-byte-order *backend*) :big-endian)
+		 `((setf extra (logxor extra (1- ,elements-per-word)))))
+	     (loadw result object (+ word vector-data-offset) 
+		    other-pointer-type)
+	     (unless (zerop extra)
+	       (inst srl result (* extra ,bits) result))
+	     (unless (= extra ,(1- elements-per-word))
+	       (inst and result ,(1- (ash 1 bits)) result)))))
+       (define-vop (,(symbolicate 'data-vector-set/ type))
+	 (:note "inline array store")
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg) :target shift)
+		(value :scs (unsigned-reg zero immediate) :target result))
+	 (:arg-types ,type positive-fixnum positive-fixnum)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:temporary (:scs (non-descriptor-reg)) temp old)
+	 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+	 (:generator 25
+	   (inst srl index ,bit-shift temp)
+	   (inst sll temp 2 temp)
+	   (inst addq object temp lip)
+	   (inst ldl old
+		 (- (* vector-data-offset word-bytes)
+		    other-pointer-type)
+		 lip)
+	   (inst and index ,(1- elements-per-word) shift)
+	   ,@(when (eq (backend-byte-order *backend*) :big-endian)
+	       `((inst xor shift ,(1- elements-per-word) shift)))
+	   ,@(unless (= bits 1)
+	       `((inst sll shift ,(1- (integer-length bits)) shift)))
+	   (unless (and (sc-is value immediate)
+			(= (tn-value value) ,(1- (ash 1 bits))))
+	     (inst li ,(1- (ash 1 bits)) temp)
+	     (inst sll temp shift temp)
+	     (inst not temp temp)
+	     (inst and old temp old))
+	   (unless (sc-is value zero)
+	     (sc-case value
+	       (immediate
+		(inst li (logand (tn-value value) ,(1- (ash 1 bits))) temp))
+	       (unsigned-reg
+		(inst and value ,(1- (ash 1 bits)) temp)))
+	     (inst sll temp shift temp)
+	     (inst bis old temp old))
+	   (inst stl old
+		 (- (* vector-data-offset word-bytes)
+		    other-pointer-type)
+		 lip)
+	   (sc-case value
+	     (immediate
+	      (inst li (tn-value value) result))
+	     (zero
+	      (move zero-tn result))
+	     (unsigned-reg
+	      (move value result)))))
+       (define-vop (,(symbolicate 'data-vector-set-c/ type))
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs (unsigned-reg zero immediate) :target result))
+	 (:arg-types ,type
+		     (:constant
+		      (integer 0
+			       ,(1- (* (1+ (- (floor (+ #x7fff
+							other-pointer-type)
+						     word-bytes)
+					      vector-data-offset))
+				       elements-per-word))))
+		     positive-fixnum)
+	 (: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)
+	     ,@(when (eq (backend-byte-order *backend*) :big-endian)
+		 `((setf extra (logxor extra (1- ,elements-per-word)))))
+	     (inst ldl object
+		   (- (* (+ word vector-data-offset) word-bytes)
+		      other-pointer-type)
+		    old)
+	     (unless (and (sc-is value immediate)
+			  (= (tn-value value) ,(1- (ash 1 bits))))
+	       (cond ((= extra ,(1- elements-per-word))
+		      (inst sll old ,bits old)
+		      (inst srl old ,bits old))
+		     (t
+		      (inst li
+			    (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits)))
+			    temp)
+		      (inst and old temp old))))
+	     (sc-case value
+	       (zero)
+	       (immediate
+		(let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
+				  (* extra ,bits))))
+		  (cond ((< value #x10000)
+			 (inst bis old value old))
+			(t
+			 (inst li value temp)
+			 (inst bis old temp old)))))
+	       (unsigned-reg
+		(inst sll value (* extra ,bits) temp)
+		(inst bis old temp old)))
+	     (inst stl old
+		   (- (* (+ word vector-data-offset) word-bytes)
+		      other-pointer-type)
+		    object)
+	     (sc-case value
+	       (immediate
+		(inst li (tn-value value) result))
+	       (zero
+		(move zero-tn result))
+	       (unsigned-reg
+		(move value result)))))))))
+
+(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)
+
+
+;;; And the float variants.
+;;; 
+
+(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 addq object index lip)
+    (inst lds value
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type)
+	   lip)))
+
+(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 addq object index lip)
+    (inst sts value
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type)
+	  lip)
+    (unless (location= result value)
+      (inst fmove value result))))
+
+(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 addq object index lip)
+    (inst addq lip index lip)
+    (inst ldt value
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type)
+	  lip)))
+
+(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 addq object index lip)
+    (inst addq lip index lip)
+    (inst stt value
+	  (- (* vector-data-offset word-bytes)
+	     other-pointer-type) lip)
+    (unless (location= result value)
+      (inst fmove value result))))
+
+
+;;; These VOPs are used for implementing float slots in structures (whose raw
+;;; data is an unsigned-32 vector.
+;;;
+(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-single data-vector-set/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+;;;
+(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-double data-vector-set/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;; 
+
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
+  %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+  unsigned-num %set-raw-bits #+gengc nil)
+
+
+
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
diff --git a/compiler/alpha/c-call.lisp b/compiler/alpha/c-call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2a7af29790584e5d3707133599a021d72e364ffe
--- /dev/null
+++ b/compiler/alpha/c-call.lisp
@@ -0,0 +1,180 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/c-call.lisp,v 1.1 1994/04/06 16:54:38 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+(in-package "ALPHA")
+(use-package "ALIEN")
+(use-package "ALIEN-INTERNALS")
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
+		 (sc-number-or-lose sc-name *backend*)
+		 offset))
+
+(defstruct arg-state
+  (stack-frame-size 0))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (multiple-value-bind
+	(ptype reg-sc stack-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-64 'signed-reg 'signed-stack)
+	    (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack))
+      (if (< stack-frame-size 4)
+	  (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset))
+	  (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4)))))))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (if (< stack-frame-size 4)
+	(my-make-wired-tn 'system-area-pointer
+			  'sap-reg
+			  (+ stack-frame-size nl0-offset))
+	(my-make-wired-tn 'system-area-pointer
+			  'sap-stack
+			  (* 2 (- stack-frame-size 4))))))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (if (< stack-frame-size 6)
+	(my-make-wired-tn 'double-float
+			  'double-reg
+			  (+ stack-frame-size nl0-offset))
+	(my-make-wired-tn 'double-float
+			  'double-stack
+			  (* 2 (- stack-frame-size 6))))))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (if (< stack-frame-size 6)
+	(my-make-wired-tn 'single-float
+			  'single-reg
+			  (+ stack-frame-size nl0-offset))
+	(my-make-wired-tn 'single-float
+			  'single-stack
+			  (* 2 (- stack-frame-size 6))))))
+
+
+
+(def-alien-type-method (integer :result-tn) (type state)
+  (declare (ignore state))
+  (multiple-value-bind
+      (ptype reg-sc)
+      (if (alien-integer-type-signed type)
+	  (values 'signed-byte-64 'signed-reg)
+	  (values 'unsigned-byte-64 'unsigned-reg))
+    (my-make-wired-tn ptype reg-sc lip-offset)))
+
+(def-alien-type-method (system-area-pointer :result-tn) (type state)
+  (declare (ignore type state))
+  (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset))
+    
+(def-alien-type-method (double-float :result-tn) (type state)
+  (declare (ignore type state))
+  (my-make-wired-tn 'double-float 'double-reg lip-offset))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+  (declare (ignore type state))
+  (my-make-wired-tn 'single-float 'single-reg lip-offset))
+
+(def-alien-type-method (values :result-tn) (type state)
+  (let ((values (alien-values-type-values type)))
+    (when (cdr values)
+      (error "Too many result values from c-call."))
+    (when values
+      (invoke-alien-type-method :result-tn (car values) state))))
+
+(def-vm-support-routine make-call-out-tns (type)
+  (let ((arg-state (make-arg-state)))
+    (collect ((arg-tns))
+      (dolist (arg-type (alien-function-type-arg-types type))
+	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+      (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
+	      (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
+	      (arg-tns)
+	      (invoke-alien-type-method :result-tn
+					(alien-function-type-result-type type)
+					nil)))))
+
+
+(define-vop (foreign-symbol-address)
+  (:translate foreign-symbol-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (inst li (make-fixup foreign-symbol :foreign) res)))
+
+(define-vop (call-out)
+  (:args (function :scs (sap-reg) :target cfunc)
+	 (args :more t))
+  (:results (results :more t))
+  (:ignore args results)
+  (:save-p t)
+  (:temporary (:sc any-reg :offset cfunc-offset
+		   :from (:argument 0) :to (:result 0)) cfunc)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:vop-var vop)
+  (:generator 0
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (move function cfunc)
+      (inst li (make-fixup "call_into_c" :foreign) temp)
+      (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
+      (when cur-nfp
+	(maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))))
+
+(define-vop (alloc-number-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 7) 7)))
+	(cond ((< delta (ash 1 15))
+	       (inst lda nsp-tn (- delta) nsp-tn))
+	      (t
+	       (inst li delta temp)
+	       (inst subq nsp-tn temp nsp-tn)))))
+    (move nsp-tn result)))
+
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:policy :fast-safe)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 7) 7)))
+	(cond ((< delta (ash 1 15))
+	       (inst lda nsp-tn delta nsp-tn))
+	      (t
+	       (inst li delta temp)
+	       (inst addq nsp-tn temp nsp-tn)))))))
diff --git a/compiler/alpha/call.lisp b/compiler/alpha/call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..531253ad7efa8c68029c454d7d6032f11cbc0594
--- /dev/null
+++ b/compiler/alpha/call.lisp
@@ -0,0 +1,1301 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/call.lisp,v 1.1 1994/04/06 16:54:39 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of function call for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted for the Alpha by Sean Hallgren
+;;;
+(in-package :alpha)
+
+
+;;;; 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.
+;;;
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  #+gengc (declare (ignore standard))
+  #-gengc
+  (if standard
+      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
+      (make-restricted-tn *any-primitive-type* register-arg-scn))
+  #+gengc
+  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ra-offset))
+
+;;; Make-Old-FP-Passing-Location  --  Interface
+;;;
+;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in.  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.
+;;;
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (if standard
+      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
+      (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
+;;;
+;;;    Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function.  We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+(def-vm-support-routine make-old-fp-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
+   (make-wired-tn *fixnum-primitive-type*
+		  control-stack-arg-scn
+		  ocfp-save-offset)))
+;;;
+(def-vm-support-routine make-return-pc-save-location (env)
+  (let ((ptype #-gengc *any-primitive-type*
+	       #+gengc *fixnum-primitive-type*))
+    (specify-save-tn
+     (environment-debug-live-tn (make-normal-tn ptype) env)
+     (make-wired-tn ptype control-stack-arg-scn
+		    #-gengc lra-save-offset #+gengc ra-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 *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-stack-pointer-tn ()
+  (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-number-stack-pointer-tn ()
+  (make-normal-tn *fixnum-primitive-type*))
+
+;;; Make-Unknown-Values-Locations  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+;;;
+(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:
+
+;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
+;;;
+;;; Return the number of bytes needed for the current non-descriptor stack
+;;; frame.  Non-descriptor stack frames must be multiples of 8 bytes on
+;;; the PMAX.
+;;; 
+(defun bytes-needed-for-non-descriptor-stack-frame ()
+  (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
+     word-bytes))
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+  (:results (val :scs (any-reg)))
+  (:generator 1
+    (move cfp-tn val)))
+
+;;; Used for computing the caller's NFP for use in known-values return.  Only
+;;; works assuming there is no variable size stuff on the nstack.
+;;;
+(define-vop (compute-old-nfp)
+  (:results (val :scs (any-reg)))
+  (:vop-var vop)
+  (:generator 1
+    (let ((nfp (current-nfp-tn vop)))
+      (when nfp
+	(inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val)))))
+
+
+(define-vop (xep-allocate-frame)
+  (:info start-lab)
+  (:vop-var vop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 1
+    ;; Make sure the function is aligned, and drop a label pointing to this
+    ;; function header.
+    (align lowtag-bits)
+    (trace-table-entry trace-table-function-prologue)
+    (emit-label start-lab)
+    ;; Allocate function header.
+    (inst function-header-word)
+    (dotimes (i (1- function-code-offset))
+      (inst lword 0))
+    ;; The start of the actual code.
+    ;; Compute CODE from the address of this entry point.
+    (let ((entry-point (gen-label)))
+      (emit-label entry-point)
+      (inst compute-code-from-fn code-tn lip-tn entry-point temp)
+      ;; ### We should also save it on the stack so that the garbage collector
+      ;; won't forget about us if we call anyone else.
+      )
+    ;; Build our stack frames.
+    (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) cfp-tn)
+    (let ((nfp (current-nfp-tn vop)))
+      (when nfp
+	(inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame)
+	      nsp-tn)
+	(move nsp-tn nfp)))
+    (trace-table-entry trace-table-normal)))
+
+(define-vop (allocate-frame)
+  (:results (res :scs (any-reg))
+	    (nfp :scs (any-reg)))
+  (:info callee)
+  (:generator 2
+    (trace-table-entry trace-table-function-prologue)
+    (move csp-tn res)
+    (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) csp-tn)
+    (when (ir2-environment-number-stack-p callee)
+      (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame)
+	    nsp-tn)
+      (move nsp-tn nfp))
+    (trace-table-entry trace-table-normal)))
+
+;;; 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.
+;;;
+(define-vop (allocate-full-call-frame)
+  (:info nargs)
+  (:results (res :scs (any-reg)))
+  (:generator 2
+    (when (> nargs register-arg-count)
+      (move csp-tn res)
+      (inst lda csp-tn (* nargs word-bytes) csp-tn))))
+
+
+
+;;; Default-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return-point from an unknown-values call for a
+;;; 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 TN used as a temporary.
+;;;
+;;;    This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 8, 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:
+#|
+	b regs-defaulted		; Skip if MVs
+	nop
+
+	move a1 null-tn			; Default register values
+	...
+	loadi nargs 1			; Force defaulting of stack values
+	move ocfp csp			; Set up args for SP resetting
+
+regs-defaulted
+	subu temp nargs register-arg-count
+
+	bltz temp default-value-7	; jump to default code
+        addu temp temp -1
+	loadw move-temp ocfp-tn 6	; Move value to correct location.
+	store-stack-tn val4-tn move-temp
+
+	bltz temp default-value-8
+        addu temp temp -1
+	loadw move-temp ocfp-tn 7
+	store-stack-tn val5-tn move-temp
+
+	...
+
+defaulting-done
+	move sp ocfp			; Reset SP.
+<end of code>
+
+<elsewhere>
+default-value-7
+	store-stack-tn val4-tn null-tn	; Nil out 7'th value. (first on stack)
+
+default-value-8
+	store-stack-tn val5-tn null-tn	; Nil out 8'th value.
+
+	...
+
+	br defaulting-done
+        nop
+|#
+;;;
+(defun default-unknown-values (vop values nvals move-temp temp lra-label)
+  (declare (type (or tn-ref null) values)
+	   (type unsigned-byte nvals) (type tn move-temp temp))
+  (if (<= nvals 1)
+      (progn
+	;; Note that this is a single-value return point.  This is actually
+	;; the multiple-value entry point for a single desired value, but
+	;; the code location has to be here, or the debugger backtrace
+	;; gets confused.
+	(without-scheduling ()
+	  (note-this-location vop :single-value-return)
+	  (move ocfp-tn csp-tn)
+	  (inst nop))
+	(when lra-label
+	  #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+	  #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)))
+      (let ((regs-defaulted (gen-label))
+	    (defaulting-done (gen-label))
+	    (default-stack-vals (gen-label)))
+	(without-scheduling ()
+	  ;; Note that this is an unknown-values return point.
+	  (note-this-location vop :unknown-return)
+	  ;; If there are no stack results, clear the stack now.
+	  (if (> nvals register-arg-count)
+	      (inst subq nargs-tn (fixnum register-arg-count) temp)
+	      (move ocfp-tn csp-tn))
+	  ;; Branch off to the MV case.
+	  (inst br zero-tn regs-defaulted))
+	
+	;; Do the single value calse.
+	(do ((i 1 (1+ i))
+	     (val (tn-ref-across values) (tn-ref-across val)))
+	    ((= i (min nvals register-arg-count)))
+	  (move null-tn (tn-ref-tn val)))
+	(when (> nvals register-arg-count)
+	  (move csp-tn ocfp-tn)
+	  (inst br zero-tn default-stack-vals))
+	
+	(emit-label regs-defaulted)
+	
+	(when (> nvals register-arg-count)
+	  ;; If there are stack results, we have to default them
+	  ;; and clear the stack.
+	  (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 blt temp default-lab)
+		(inst ldl move-temp (* i word-bytes) ocfp-tn)
+		(inst subq temp (fixnum 1) temp)
+		(store-stack-tn tn move-temp)))
+	    
+	    (emit-label defaulting-done)
+	    (move ocfp-tn csp-tn)
+	    
+	    (let ((defaults (defaults)))
+	      (assert defaults)
+	      (assemble (*elsewhere*)
+		(emit-label default-stack-vals)
+		(do ((remaining defaults (cdr remaining)))
+		    ((null remaining))
+		  (let ((def (car remaining)))
+		    (emit-label (car def))
+		    (when (null (cdr remaining))
+		      (inst br zero-tn defaulting-done))
+		    (store-stack-tn (cdr def) null-tn)))))))
+
+	(when lra-label
+	  #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+	  #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))))
+  (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 temp)
+  (declare (type tn args nargs start count temp))
+  (let ((variable-values (gen-label))
+	(done (gen-label)))
+    (without-scheduling ()
+      (inst br zero-tn variable-values)
+      (inst nop))
+
+    (when lra-label
+      #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+      #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))
+    (inst addq csp-tn 4 csp-tn)
+    (storew (first register-arg-tns) csp-tn -1)
+    (inst subq csp-tn 4 start)
+    (inst li (fixnum 1) count)
+    
+    (emit-label done)
+    
+    (assemble (*elsewhere*)
+      (emit-label variable-values)
+      (when lra-label
+	#-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+	#+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))
+      (do ((arg register-arg-tns (rest arg))
+	   (i 0 (1+ i)))
+	  ((null arg))
+	(storew (first arg) args i))
+      (move args start)
+      (move nargs count)
+      (inst br zero-tn done)))
+  (undefined-value))
+
+
+;;; VOP that can be inherited by unknown values receivers.  The main thing this
+;;; handles is allocation of the result temporaries.
+;;;
+(define-vop (unknown-values-receiver)
+  (:results
+   (start :scs (any-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)
+  (:temporary (:scs (non-descriptor-reg)) temp))
+
+
+
+;;;; 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.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (call-local)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:results (values :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info arg-locs callee target nvals)
+  (:vop-var vop)
+  (:temporary (:scs (descriptor-reg) :from :eval) move-temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp)
+  (:ignore arg-locs args ocfp)
+  (:generator 5
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(maybe-load-stack-nfp-tn callee-nfp nfp temp))
+      (maybe-load-stack-tn cfp-tn fp)
+      (trace-table-entry trace-table-call-site)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst br zero-tn target)
+      (trace-table-entry trace-table-normal)
+      (emit-return-pc label)
+      (default-unknown-values vop values nvals move-temp temp label)
+      (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))
+
+
+;;; 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.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (multiple-call-local unknown-values-receiver)
+  (:args (fp)
+	 (nfp)
+	 (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)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 20
+    (let ((label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(maybe-load-stack-nfp-tn callee-nfp nfp temp))
+      (maybe-load-stack-tn cfp-tn fp)
+      (trace-table-entry trace-table-call-site)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst bsr zero-tn target)
+      (trace-table-entry trace-table-normal)
+      (emit-return-pc label)
+      (note-this-location vop :unknown-return)
+      (receive-unknown-values values-start nvals start count label temp)
+      (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))
+
+
+;;;; 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.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-call-local)
+  (:args (fp)
+	 (nfp)
+	 (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)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 5
+    (let (#-gengc (label (gen-label))
+	  (cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (let ((callee-nfp (callee-nfp-tn callee)))
+	(maybe-load-stack-nfp-tn callee-nfp nfp temp))
+      (maybe-load-stack-tn cfp-tn fp)
+      (trace-table-entry trace-table-call-site)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst bsr zero-tn target)
+      (trace-table-entry trace-table-normal)
+      (emit-return-pc label)
+      (note-this-location vop :known-return)
+      (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))
+
+;;; 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.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-return)
+  (:args (ocfp :target ocfp-temp)
+	 (return-pc :target return-pc-temp)
+	 (vals :more t))
+  (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
+  (:temporary (:sc #-gengc descriptor-reg #+gengc any-reg :from (:argument 1))
+	      return-pc-temp)
+  #-gengc (:temporary (:scs (interior-reg)) lip)
+  (:move-args :known-return)
+  (:info val-locs)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    (maybe-load-stack-tn ocfp-temp ocfp)
+    (maybe-load-stack-tn return-pc-temp return-pc)
+    (move cfp-tn csp-tn)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+	      nsp-tn)))
+    (inst subq return-pc-temp (- other-pointer-type word-bytes) lip)
+    (move ocfp-temp cfp-tn)
+    (inst ret zero-tn lip 1)
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; 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 Ocfp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument.  If Variable is false, then the passing locations are
+;;; 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.
+;;;
+;;; 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.
+;;;
+(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 (any-reg) :to :eval)))
+
+      ,(if named
+	   '(name :target name-pass)
+	   '(arg-fun :target lexenv))
+      
+      ,@(when (eq return :tail)
+	  '((ocfp :target ocfp-pass)
+	    (return-pc :target return-pc-pass)))
+      
+      ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+     ,@(when (eq return :fixed)
+	 '((:results (values :more t))))
+   
+     (:save-p ,(if (eq return :tail) :compute-only t))
+
+     ,@(unless (or (eq return :tail) 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 #+gengc ,@(unless (eq return :tail) '(return-pc-pass))
+	      ,@(unless (or variable (eq return :tail)) '(arg-locs))
+	      ,@(unless variable '(args)))
+
+     (:temporary (:sc descriptor-reg
+		  :offset ocfp-offset
+		  :from (:argument 1)
+		  ,@(unless (eq return :fixed)
+		      '(:to :eval)))
+		 ocfp-pass)
+
+     (:temporary (:sc descriptor-reg
+		  :offset #-gengc lra-offset #+gengc ra-offset
+		  :from (:argument ,(if (eq return :tail) 2 1))
+		  :to :eval)
+		 return-pc-pass)
+
+     ,@(if named
+	 `((:temporary (:sc descriptor-reg :offset fdefn-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)
+	   #-gengc
+	   (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+		       function)))
+
+     (:temporary (:sc any-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 (:scs (non-descriptor-reg)) temp)
+	   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+
+     (:temporary (:sc interior-reg :offset lip-offset) entry-point)
+
+     (: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))))
+	      (filler
+	       (remove nil
+		       (list :load-nargs
+			     ,@(if (eq return :tail)
+				   '((unless (location= ocfp ocfp-pass)
+				       :load-ocfp)
+				     (unless (location= return-pc
+							return-pc-pass)
+				       :load-return-pc)
+				     (when cur-nfp
+				       :frob-nfp))
+				   '(#-gengc
+				     :comp-lra
+				     (when cur-nfp
+				       :frob-nfp)
+				     :save-fp
+				     :load-fp))))))
+	 (flet ((do-next-filler ()
+		  (let* ((next (pop filler))
+			 (what (if (consp next) (car next) next)))
+		    (ecase what
+		      (:load-nargs
+		       ,@(if variable
+			     `((inst subq csp-tn new-fp nargs-pass)
+			       ,@(let ((index -1))
+				   (mapcar #'(lambda (name)
+					       `(inst ldl ,name
+						      ,(ash (incf index)
+							    word-shift)
+						      new-fp))
+					   register-arg-names)))
+			     '((inst li (fixnum nargs) nargs-pass))))
+		      ,@(if (eq return :tail)
+			    '((:load-ocfp
+			       (sc-case ocfp
+				 (any-reg
+				  (inst move ocfp ocfp-pass))
+				 (control-stack
+				  (inst ldl ocfp-pass
+					(ash (tn-offset ocfp)
+					     word-shift)
+					cfp-tn))))
+			      (:load-return-pc
+			       (sc-case return-pc
+				 (#-gengc descriptor-reg #+gengc any-reg
+				  (inst move return-pc return-pc-pass))
+				 (control-stack
+				  (inst ldl return-pc-pass
+					(ash (tn-offset return-pc)
+					     word-shift)
+					 cfp-tn))))
+			      (:frob-nfp
+			       (inst addq cur-nfp
+				     (bytes-needed-for-non-descriptor-stack-frame)
+				     nsp-tn)))
+			    `(#-gengc
+			      (:comp-lra
+			       (inst compute-lra-from-code
+				     return-pc-pass code-tn lra-label temp))
+			      (:frob-nfp
+			       (store-stack-tn nfp-save cur-nfp))
+			      (:save-fp
+			       (inst move cfp-tn ocfp-pass))
+			      (:load-fp
+			       ,(if variable
+				    '(move new-fp cfp-tn)
+				    '(if (> nargs register-arg-count)
+					 (move new-fp cfp-tn)
+					 (move csp-tn cfp-tn)))
+			       (trace-table-entry trace-table-call-site))))
+		      ((nil))))))
+
+	   ,@(if named
+		 `((sc-case name
+		     (descriptor-reg (move name name-pass))
+		     (control-stack
+		      (inst ldl name-pass
+			    (ash (tn-offset name) word-shift) cfp-tn)
+		      (do-next-filler))
+		     (constant
+		      (inst ldl name-pass
+			    (- (ash (tn-offset name) word-shift)
+			       other-pointer-type) code-tn)
+		      (do-next-filler)))
+		   (inst ldl entry-point
+			 (- (ash fdefn-raw-addr-slot word-shift)
+			    other-pointer-type) name-pass)
+		   (do-next-filler))
+		 `((sc-case arg-fun
+		     (descriptor-reg (move arg-fun lexenv))
+		     (control-stack
+		      (inst ldl lexenv
+			    (ash (tn-offset arg-fun) word-shift) cfp-tn)
+		      (do-next-filler))
+		     (constant
+		      (inst ldl lexenv
+			    (- (ash (tn-offset arg-fun) word-shift)
+			       other-pointer-type) code-tn)
+		      (do-next-filler)))
+		   #-gengc
+		   (inst ldl function
+			 (- (ash closure-function-slot word-shift)
+			    function-pointer-type) lexenv)
+		   #-gengc
+		   (do-next-filler)
+		   #-gengc
+		   (inst addq function
+			 (- (ash function-code-offset word-shift)
+			    function-pointer-type) entry-point)
+		   #+gengc
+		   (inst ldl entry-point
+			 (- (ash closure-entry-point-slot word-shift)
+			    function-pointer-type) lexenv)
+		   #+gengc
+		   (do-next-filler)))
+	   (loop
+	     (if (cdr filler)
+		 (do-next-filler)
+		 (return)))
+	   
+	   (note-this-location vop :call-site)
+	   (do-next-filler)
+	   (inst jsr zero-tn entry-point))
+
+	 ,@(ecase return
+	     (:fixed
+	      '((trace-table-entry trace-table-normal)
+		(emit-return-pc lra-label)
+		(default-unknown-values vop values nvals
+					move-temp temp lra-label)
+		(maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
+	     (:unknown
+	      '((trace-table-entry trace-table-normal)
+		(emit-return-pc lra-label)
+		(note-this-location vop :unknown-return)
+		(receive-unknown-values values-start nvals start count
+					lra-label temp)
+		(maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
+	     (:tail))))))
+
+
+(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 (any-reg) :target args)
+   (function-arg :scs (descriptor-reg) :target lexenv)
+   (ocfp-arg :scs (any-reg) :target ocfp)
+   (lra-arg :scs (#-gengc descriptor-reg #+gengc any-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)) ocfp)
+  (:temporary (:sc any-reg :offset #-gengc lra-offset #+gengc ra-offset
+		   :from (:argument 3)) lra)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+
+  (:vop-var vop)
+
+  (:generator 75
+
+    ;; Move these into the passing locations if they are not already there.
+    (move args-arg args)
+    (move function-arg lexenv)
+    (move ocfp-arg ocfp)
+    (move lra-arg lra)
+
+    ;; Clear the number stack if anything is there.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+	      nsp-tn)))
+
+    ;; And jump to the assembly-routine that does the bliting.
+    (inst li (make-fixup 'tail-call-variable :assembly-routine) temp)
+    (inst jmp zero-tn temp)))
+
+
+;;;; Unknown values return:
+
+;;; Return a single value using the unknown-values convention.
+;;; 
+(define-vop (return-single)
+  (:args (ocfp :scs (any-reg))
+	 #-gengc (return-pc :scs (descriptor-reg))
+	 #+gengc (return-pc :scs (any-reg) :target ra)
+	 (value))
+  (:ignore value)
+  #-gengc (:temporary (:scs (interior-reg)) lip)
+  #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
+  #+gengc (:temporary (:scs (any-reg) :from (:argument 1)) temp)
+  (:vop-var vop)
+  (:generator 6
+    ;; Clear the number stack.
+    (trace-table-entry trace-table-function-epilogue)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+	      nsp-tn)))
+    ;; Clear the control stack, and restore the frame pointer.
+    (move cfp-tn csp-tn)
+    (move ocfp cfp-tn)
+    ;; Out of here.
+    #-gengc (lisp-return return-pc lip :offset 2)
+    #+gengc
+    (progn
+      (inst addq return-pc (* 2 word-bytes) temp)
+      (unless (location= ra return-pc)
+	(inst move ra return-pc))
+      (inst ret zero-tn temp 1))
+    (trace-table-entry trace-table-normal)))
+
+
+;;; 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 + 8.
+;;;
+;;; 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 (ocfp :scs (any-reg))
+	 (return-pc :scs (#-gengc descriptor-reg #+gengc any-reg) :to (:eval 1)
+		    #+gengc :target #+gengc ra)
+	 (values :more t))
+  (:ignore values)
+  (:info nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
+  (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
+  (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
+  (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
+  (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
+  (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+  #-gengc (:temporary (:scs (interior-reg)) lip)
+  #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:eval 1)) ra)
+  (:vop-var vop)
+  (:generator 6
+    ;; Clear the number stack.
+    (trace-table-entry trace-table-function-epilogue)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+	      nsp-tn)))
+    ;; Establish the values pointer and values count.
+    (move cfp-tn val-ptr)
+    (inst li (fixnum nvals) nargs)
+    ;; restore the frame pointer and clear as much of the control
+    ;; stack as possible.
+    (move ocfp cfp-tn)
+    (inst addq val-ptr (* nvals word-bytes) csp-tn)
+    ;; pre-default any argument register that need it.
+    (when (< nvals register-arg-count)
+      (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+	(move null-tn reg)))
+    ;; And away we go.
+    (lisp-return return-pc lip)
+    (trace-table-entry trace-table-normal)))
+
+;;; 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 code that calls an assembly-routine.
+;;;
+(define-vop (return-multiple)
+  (:args (ocfp-arg :scs (any-reg) :target ocfp)
+	 #-gengc (lra-arg :scs (descriptor-reg) :target lra)
+	 #+gengc (return-pc :scs (any-reg) :target ra)
+	 (vals-arg :scs (any-reg) :target vals)
+	 (nvals-arg :scs (any-reg) :target nvals))
+
+  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
+  #-gengc
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
+  #+gengc
+  (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
+  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  #-gengc (:temporary (:scs (interior-reg)) lip)
+  #+gengc (:temporary (:scs (any-reg) :from (:argument 0)) temp)
+
+  (:vop-var vop)
+
+  (:generator 13
+    (trace-table-entry trace-table-function-epilogue)
+    (let ((not-single (gen-label)))
+      ;; Clear the number stack.
+      (let ((cur-nfp (current-nfp-tn vop)))
+	(when cur-nfp
+	  (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+		nsp-tn)))
+
+      ;; Check for the single case.
+      (inst li (fixnum 1) a0)
+      (inst cmpeq nvals-arg a0 temp)
+      (inst ldl a0 0 vals-arg)
+      (inst beq temp not-single)
+
+      ;; Return with one value.
+      (move cfp-tn csp-tn)
+      (move ocfp-arg cfp-tn)
+      (lisp-return lra-arg lip :offset 2)
+		
+      ;; Nope, not the single case.
+      (emit-label not-single)
+      (move ocfp-arg ocfp)
+      (move lra-arg lra)
+      (move vals-arg vals)
+      (move nvals-arg nvals)
+      (inst li (make-fixup 'return-multiple :assembly-routine) temp)
+      (inst jmp zero-tn temp))
+    (trace-table-entry trace-table-normal)))
+
+
+
+;;;; XEP hackery:
+
+
+;;; We don't need to do anything special for regular functions.
+;;;
+(define-vop (setup-environment)
+  (:info label)
+  (:ignore label)
+  (:generator 0
+    ;; Don't bother doing anything.
+    ))
+
+;;; Get the lexical environment from it's passing location.
+;;;
+(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)
+  (:ignore label)
+  (:generator 6
+    ;; Get result.
+    (move lexenv closure)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments. 
+;;;
+(define-vop (copy-more-arg)
+  (:temporary (:sc any-reg :offset nl0-offset) result)
+  (:temporary (:sc any-reg :offset nl1-offset) count)
+  (:temporary (:sc any-reg :offset nl2-offset) src)
+  (:temporary (:sc any-reg :offset nl4-offset) dst)
+  (:temporary (:sc descriptor-reg :offset l0-offset) temp)
+  (:info fixed)
+  (:generator 20
+    (let ((loop (gen-label))
+	  (do-regs (gen-label))
+	  (done (gen-label)))
+      (when (< fixed register-arg-count)
+	;; Save a pointer to the results so we can fill in register args.
+	;; We don't need this if there are more fixed args than reg args.
+	(move csp-tn result))
+      ;; Allocate the space on the stack.
+      (cond ((zerop fixed)
+	     (inst addq csp-tn nargs-tn csp-tn)
+	     (inst beq nargs-tn done))
+	    (t
+	     (inst subq nargs-tn (fixnum fixed) count)
+	     (inst ble count done)
+	     (inst addq csp-tn count csp-tn)))
+      (when (< fixed register-arg-count)
+	;; We must stop when we run out of stack args, not when we run out of
+	;; more args.
+	(inst subq nargs-tn (fixnum register-arg-count) count))
+      ;; Initialize dst to be end of stack.
+      (move csp-tn dst)
+      ;; Everything of interest in registers.
+      (inst ble count do-regs)
+      ;; Initialize src to be end of args.
+      (inst addq cfp-tn nargs-tn src)
+
+      (emit-label loop)
+      ;; *--dst = *--src, --count
+      (inst subq src word-bytes src)
+      (inst subq count (fixnum 1) count)
+      (loadw temp src)
+      (inst subq dst word-bytes dst)
+      (storew temp dst)
+      (inst bgt count loop)
+
+      (emit-label do-regs)
+      (when (< fixed register-arg-count)
+	;; Now we have to deposit any more args that showed up in registers.
+	;; We know there is at least one more arg, otherwise we would have
+	;; branched to done up at the top.
+	(inst subq nargs-tn (fixnum (1+ fixed)) count)
+	(do ((i fixed (1+ i)))
+	    ((>= i register-arg-count))
+	  ;; Store it relative to the pointer saved at the start.
+	  (storew (nth i register-arg-tns) result (- i fixed))
+	  ;; Is this the last one?
+	  (inst beq count done)
+	  ;; Decrement count.
+	  (inst subq count (fixnum 1) count)))
+      (emit-label done))))
+
+
+;;; 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-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %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 (any-reg) :from (:argument 0)) context)
+  (:temporary (:scs (any-reg) :from (:argument 1)) count)
+  (:temporary (:scs (descriptor-reg) :from :eval) temp dst)
+  (: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-arg context)
+      (move count-arg count)
+      ;; Check to see if there are any arguments.
+      (move null-tn result)
+      (inst beq count done)
+
+      ;; We need to do this atomically.
+      (pseudo-atomic ()
+	;; Allocate a cons (2 words) for each item.
+	(inst bis alloc-tn list-pointer-type result)
+	(move result dst)
+	(inst sll count 1 temp)
+	(inst addq alloc-tn temp alloc-tn)
+	(inst br zero-tn enter)
+
+	;; Store the current cons in the cdr of the previous cons.
+	(emit-label loop)
+	(inst addq dst (* 2 word-bytes) dst)
+	(storew dst dst -1 list-pointer-type)
+
+	(emit-label enter)
+	;; Grab one value.
+	(loadw temp context)
+	(inst addq context word-bytes context)
+
+	;; Store the value in the car (in delay slot)
+	(storew temp dst 0 list-pointer-type)
+
+	;; Dec count, and if != zero, go back for more.
+	(inst subq count (fixnum 1) count)
+	(inst bne count loop)
+
+	;; NIL out the last cons.
+	(storew null-tn dst 1 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)
+  (:policy :fast-safe)
+  (:translate c::%more-arg-context)
+  (:args (supplied :scs (any-reg)))
+  (:arg-types tagged-num (:constant fixnum))
+  (:info fixed)
+  (:results (context :scs (descriptor-reg))
+	    (count :scs (any-reg)))
+  (:result-types t tagged-num)
+  (:note "more-arg-context")
+  (:generator 5
+    (inst subq supplied (fixnum fixed) count)
+    (inst subq csp-tn count context)))
+
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+(define-vop (verify-argument-count)
+  (:policy :fast-safe)
+  (:translate c::%verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum (:constant t))
+  (:temporary (:scs (any-reg) :type fixnum) temp)
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (cond ((zerop count)
+	     (inst bne nargs err-lab))
+	    (t
+	     (inst subq nargs (fixnum count) temp)
+	     (inst bne temp err-lab))))))
+
+;;; Various other error signalers.
+;;;
+(macrolet ((frob (name error translate &rest args)
+	     `(define-vop (,name)
+		,@(when translate
+		    `((:policy :fast-safe)
+		      (:translate ,translate)))
+		(: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
+    c::%argument-count-error nargs)
+  (frob type-check-error object-not-type-error c::%type-check-error
+    object type)
+  (frob layout-invalid-error layout-invalid-error c::%layout-invalid-error
+    object layout)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error
+    c::%odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error
+    c::%unknown-keyword-argument-error key)
+  (frob nil-function-returned-error nil-function-returned-error nil fun))
diff --git a/compiler/alpha/cell.lisp b/compiler/alpha/cell.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8a656abcc6a9dfb06471bf72f1ba108512137beb
--- /dev/null
+++ b/compiler/alpha/cell.lisp
@@ -0,0 +1,391 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/cell.lisp,v 1.1 1994/04/06 16:54:39 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of various primitive memory access
+;;; VOPs for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Sean Hallgren
+;;; 
+
+(in-package "ALPHA")
+
+
+;;;; Data object ref/set stuff.
+
+(define-vop (slot)
+  (:args (object :scs (descriptor-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 1
+    (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg null zero)))
+  (:info name offset lowtag #+gengc remember)
+  (:ignore name)
+  (:results)
+  (:generator 1
+    #+gengc
+    (if remember
+	(storew-and-remember-slot value object offset lowtag)
+	(storew value object offset lowtag))
+    #-gengc
+    (storew value object offset lowtag)))
+
+
+;;;; Symbol hacking VOPs:
+
+;;; The compiler likes to be able to directly SET symbols.
+;;;
+(define-vop (set cell-set)
+  (:variant symbol-value-slot other-pointer-type))
+
+;;; 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 (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
+
+;;; With Symbol-Value, we check that the value isn't the trap object.  So
+;;; Symbol-Value of NIL is NIL.
+;;;
+(define-vop (symbol-value checked-cell-ref)
+  (:translate symbol-value)
+  (:generator 9
+    (move object obj-temp)
+    (loadw value obj-temp symbol-value-slot other-pointer-type)
+    (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+      (inst xor value unbound-marker-type temp)
+      (inst beq temp err-lab))))
+
+;;; 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 (:scs (non-descriptor-reg)) temp))
+
+(define-vop (boundp boundp-frob)
+  (:translate boundp)
+  (:generator 9
+    (loadw value object symbol-value-slot other-pointer-type)
+    (inst xor value unbound-marker-type temp)
+    (if not-p
+	(inst beq temp target)
+	(inst bne temp target))))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant symbol-value-slot other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+
+
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (fdefn-function cell-ref)
+  (:variant fdefn-function-slot other-pointer-type))
+
+(define-vop (safe-fdefn-function)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 10
+    (move object obj-temp)
+    (loadw value obj-temp fdefn-function-slot other-pointer-type)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+      (inst cmpeq value null-tn temp)
+      (inst bne temp err-lab))))
+
+(define-vop (set-fdefn-function)
+  (:policy :fast-safe)
+  (:translate (setf fdefn-function))
+  (:args (function :scs (descriptor-reg) :target result)
+	 (fdefn :scs (descriptor-reg)))
+  (:temporary (:scs (interior-reg)) lip)
+  (:temporary (:scs (non-descriptor-reg)) type)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (let ((normal-fn (gen-label)))
+      (load-type type function (- function-pointer-type))
+      (inst xor type function-header-type type)
+      (inst addq function
+	    (- (ash function-code-offset word-shift) function-pointer-type)
+	    lip)
+      (inst beq type normal-fn)
+      (inst li (make-fixup "closure_tramp" :foreign) lip)
+      (emit-label normal-fn)
+      (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
+      (storew function fdefn fdefn-function-slot other-pointer-type)
+      (move function result))))
+          
+
+(define-vop (fdefn-makunbound)
+  (:policy :fast-safe)
+  (:translate fdefn-makunbound)
+  (:args (fdefn :scs (descriptor-reg) :target result))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (storew null-tn fdefn fdefn-function-slot other-pointer-type)
+    (inst li (make-fixup "undefined_tramp" :foreign) temp)
+    (move fdefn result)
+    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)))
+
+
+
+;;;; 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)
+  (:generator 5
+    (loadw temp symbol symbol-value-slot other-pointer-type)
+    (inst addq bsp-tn (* 2 word-bytes) bsp-tn)
+    (storew temp bsp-tn (- binding-value-slot binding-size))
+    (storew symbol bsp-tn (- binding-symbol-slot binding-size))
+    (#+gengc storew-and-remember-slot #-gengc storew
+	     val symbol symbol-value-slot other-pointer-type)))
+
+
+(define-vop (unbind)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:generator 0
+    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+    (loadw value bsp-tn (- binding-value-slot binding-size))
+    (#+gengc storew-and-remember-slot #-gengc storew
+	     value symbol symbol-value-slot other-pointer-type)
+    (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (inst subq bsp-tn (* 2 word-bytes) bsp-tn)))
+
+
+(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 (non-descriptor-reg)) temp)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (skip (gen-label))
+	  (done (gen-label)))
+      (move arg where)
+      (inst cmpeq where bsp-tn temp)
+      (inst bne temp done)
+
+      (emit-label loop)
+      (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+      (loadw value bsp-tn (- binding-value-slot binding-size))
+      (inst beq symbol skip)
+      (#+gengc storew-and-remember-slot #-gengc storew
+	       value symbol symbol-value-slot other-pointer-type)
+      (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+
+      (emit-label skip)
+      (inst subq bsp-tn (* 2 word-bytes) bsp-tn)
+      (inst cmpeq where bsp-tn temp)
+      (inst beq temp loop)
+
+      (emit-label done))))
+
+
+
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+  closure-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %funcallable-instance-info)
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+  (:variant funcallable-instance-lexenv-slot function-pointer-type))
+
+(define-vop (closure-ref slot-ref)
+  (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+  (:variant closure-info-offset function-pointer-type))
+
+
+;;;; Value Cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+  (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+  (:variant value-cell-value-slot other-pointer-type))
+
+
+
+;;;; Instance hackery:
+
+(define-vop (instance-length)
+  (:policy :fast-safe)
+  (:translate %instance-length)
+  (:args (struct :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (loadw res struct 0 instance-pointer-type)
+    (inst srl res type-bits res)))
+
+(define-vop (instance-ref slot-ref)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:policy :fast-safe)
+  (:translate %instance-ref)
+  (:arg-types instance (:constant index)))
+
+(define-vop (instance-set slot-set)
+  (:policy :fast-safe)
+  (:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) *))
+
+(define-full-reffer instance-index-ref * instance-slots-offset
+  instance-pointer-type (descriptor-reg any-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+  instance-pointer-type (descriptor-reg any-reg null zero) * %instance-set)
+
+
+
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-type
+  (descriptor-reg any-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-type
+  (descriptor-reg any-reg null zero) * code-header-set)
+
+
+
+;;;; Mutator accessing.
+
+#+gengc (progn
+
+(define-vop (mutator-ub32-ref)
+  (:policy :fast-safe)
+  (:args)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:variant-vars slot)
+  (:generator 2
+    (loadw res mutator-tn slot)))
+
+(define-vop (mutator-descriptor-ref mutator-ub32-ref)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:result-types *))
+
+(define-vop (mutator-sap-ref mutator-ub32-ref)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer))
+
+
+(define-vop (mutator-ub32-set)
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg) :target res))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:variant-vars slot)
+  (:generator 2
+    (storew arg mutator-tn slot)
+    (move res arg)))
+
+(define-vop (mutator-descriptor-set mutator-ub32-set)
+  (:args (arg :scs (any-reg descriptor-reg null zero) :target res))
+  (:arg-types *)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:result-types *))
+
+(define-vop (mutator-sap-set mutator-ub32-set)
+  (:args (arg :scs (sap-reg) :target res))
+  (:arg-types system-area-pointer)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer))
+
+
+(eval-when (compile eval)
+  (defmacro define-mutator-accessors (slot type writable)
+    (let ((ref (symbolicate "MUTATOR-" slot "-REF"))
+	  (set (and writable (symbolicate "MUTATOR-" slot "-SET")))
+	  (offset (symbolicate "MUTATOR-" slot "-SLOT"))
+	  (fn
+	   (let ((*package* (find-package :kernel)))
+	     (symbolicate "MUTATOR-" slot))))
+      (multiple-value-bind
+	  (lisp-type ref-vop set-vop)
+	  (ecase type
+	    (:des
+	     (values t 'mutator-descriptor-ref 'mutator-descriptor-set))
+	    (:ub32
+	     (values '(unsigned-byte 32) 'mutator-ub32-ref 'mutator-ub32-set))
+	    (:sap
+	     (values 'system-area-pointer 'mutator-sap-ref 'mutator-sap-set)))
+      `(progn
+	 (export ',fn :kernel)
+	 (defknown ,fn () ,lisp-type (flushable))
+	 (define-vop (,ref ,ref-vop)
+	   (:translate ,fn)
+	   (:variant ,offset))
+	 ,@(when writable
+	     `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type (unsafe))
+	       (define-vop (,set ,set-vop)
+		 (:translate (setf ,fn))
+		 (:variant ,offset)))))))))
+
+(define-mutator-accessors thread :des t)
+(define-mutator-accessors suspends-disabled-count :ub32 t)
+(define-mutator-accessors suspend-pending :ub32 t)
+(define-mutator-accessors control-stack-base :sap nil)
+(define-mutator-accessors control-stack-end :sap nil)
+(define-mutator-accessors current-unwind-protect :sap nil)
+(define-mutator-accessors current-catch-block :sap nil)
+(define-mutator-accessors binding-stack-base :sap nil)
+(define-mutator-accessors binding-stack-end :sap nil)
+(define-mutator-accessors number-stack-base :sap nil)
+(define-mutator-accessors number-stack-end :sap nil)
+(define-mutator-accessors eval-stack :des t)
+(define-mutator-accessors eval-stack-top :ub32 t)
+(define-mutator-accessors nursery-start :sap nil)
+(define-mutator-accessors nursery-end :sap nil)
+(define-mutator-accessors storebuf-start :sap nil)
+(define-mutator-accessors storebuf-end :sap nil)
+(define-mutator-accessors words-consed :ub32 nil)
+
+); #+gengc progn
diff --git a/compiler/alpha/char.lisp b/compiler/alpha/char.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3d0635e7e799aff762e3755535cf35e0eff9b331
--- /dev/null
+++ b/compiler/alpha/char.lisp
@@ -0,0 +1,149 @@
+;;; -*- 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/char.lisp,v 1.1 1994/04/06 16:54:40 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/char.lisp,v 1.1 1994/04/06 16:54:40 hallgren Exp $
+;;; 
+;;; This file contains the RT VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the Alpha by Sean Hallgren.
+;;;
+(in-package "ALPHA")
+
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-char)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (base-char-reg)))
+  (:generator 1
+    (inst srl x vm:type-bits y)))
+;;;
+(define-move-vop move-to-base-char :move
+  (any-reg descriptor-reg) (base-char-reg))
+
+
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-char)
+  (:args (x :scs (base-char-reg)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (inst sll x vm:type-bits y)
+    (inst bis y vm:base-char-type y)))
+;;;
+(define-move-vop move-from-base-char :move
+  (base-char-reg) (any-reg descriptor-reg))
+
+;;; Move untagged base-char values.
+;;;
+(define-vop (base-char-move)
+  (:args (x :target y
+	    :scs (base-char-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (base-char-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move x y)))
+;;;
+(define-move-vop base-char-move :move
+  (base-char-reg) (base-char-reg))
+
+
+;;; Move untagged base-char arguments/return-values.
+;;;
+(define-vop (move-base-char-argument)
+  (:args (x :target y
+	    :scs (base-char-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y base-char-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (base-char-reg
+       (move x y))
+      (base-char-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-base-char-argument :move-argument
+  (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (base-char-reg) (any-reg descriptor-reg))
+
+
+
+;;;; Other operations:
+
+(define-vop (char-code)
+  (:translate char-code)
+  (:policy :fast-safe)
+  (:args (ch :scs (base-char-reg) :target res))
+  (:arg-types base-char)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (inst sll ch 2 res)))
+
+(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-char-reg)))
+  (:result-types base-char)
+  (:generator 1
+    (inst srl code 2 res)))
+
+
+;;; Comparison of base-chars.
+;;;
+(define-vop (base-char-compare)
+  (:args (x :scs (base-char-reg))
+	 (y :scs (base-char-reg)))
+  (:arg-types base-char base-char)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline comparison")
+  (:variant-vars cond)
+  (:generator 3
+    (ecase cond
+      (:eq (inst cmpeq x y temp))
+      (:lt (inst cmplt x y temp))
+      (:gt (inst cmplt y x temp)))
+    (if not-p
+	(inst beq temp target)
+	(inst bne temp target))))
+
+(define-vop (fast-char=/base-char base-char-compare)
+  (:translate char=)
+  (:variant :eq))
+
+(define-vop (fast-char</base-char base-char-compare)
+  (:translate char<)
+  (:variant :lt))
+
+(define-vop (fast-char>/base-char base-char-compare)
+  (:translate char>)
+  (:variant :gt))
diff --git a/compiler/alpha/debug.lisp b/compiler/alpha/debug.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a3de7eee2011e98e7d9e068fd44c796d675bba5f
--- /dev/null
+++ b/compiler/alpha/debug.lisp
@@ -0,0 +1,165 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/debug.lisp,v 1.1 1994/04/06 16:54:41 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;; 
+(in-package "ALPHA")
+
+
+(define-vop (debug-cur-sp)
+  (:translate current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move csp-tn res)))
+
+(define-vop (debug-cur-fp)
+  (:translate current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move cfp-tn res)))
+
+(define-vop (read-control-stack)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg) :target sap)
+	 (offset :scs (any-reg)))
+  (:arg-types system-area-pointer positive-fixnum)
+  (:temporary (:scs (sap-reg) :from :eval) sap)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst addq object offset sap)
+    (inst ldl result 0 sap)))
+
+(define-vop (read-control-stack-c)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 14)))
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 4
+    (inst ldl result (* offset word-bytes) object)))
+
+(define-vop (write-control-stack)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (sap-reg) :target sap)
+	 (offset :scs (any-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:arg-types system-area-pointer positive-fixnum *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
+  (:generator 2
+    (inst addq object offset sap)
+    (inst stl value 0 sap)
+    (move value result)))
+
+(define-vop (write-control-stack-c)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 1
+    (inst stl value (* offset word-bytes) sap)
+    (move value result)))
+
+
+(define-vop (code-from-mumble)
+  (:policy :fast-safe)
+  (:args (thing :scs (descriptor-reg)))
+  (:results (code :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:variant-vars lowtag)
+  (:generator 5
+    (let ((bogus (gen-label))
+	  (done (gen-label)))
+      (loadw temp thing 0 lowtag)
+      (inst srl temp vm:type-bits temp)
+      (inst beq temp bogus)
+      (inst sll temp (1- (integer-length vm:word-bytes)) temp)
+      (unless (= lowtag vm:other-pointer-type)
+	(inst subq temp (- vm:other-pointer-type lowtag) temp))
+      (inst subq thing temp code)
+      (emit-label done)
+      (assemble (*elsewhere*)
+	(emit-label bogus)
+	(move null-tn code)
+	(inst br zero-tn done)))))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate lra-code-header)
+  (:variant vm:other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate function-code-header)
+  (:variant vm:function-pointer-type))
+
+(define-vop (make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate make-lisp-obj)
+  (:args (value :scs (unsigned-reg) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 1
+    (move value result)))
+
+(define-vop (get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg) :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move thing result)))
+
+(define-vop (function-word-offset)
+  (:policy :fast-safe)
+  (:translate function-word-offset)
+  (:args (fun :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (loadw res fun 0 function-pointer-type)
+    (inst srl res vm:type-bits res)))
+
+
+
+
+
+(defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer
+  (movable foldable flushable))
+
+(define-vop (make-number-stack-pointer)
+  (:policy :fast-safe)
+  (:translate make-number-stack-pointer)
+  (:args (arg :scs (unsigned-reg) :to (:argument 1)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (sap-reg) :from (:argument 0)))
+  (:result-types system-area-pointer)
+  (:generator 5
+    (inst mskll nsp-tn 0 res)
+    (inst bis res arg res)))
diff --git a/compiler/alpha/float.lisp b/compiler/alpha/float.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8fc4fd5ceb55457e963c28305d46f1446025b31d
--- /dev/null
+++ b/compiler/alpha/float.lisp
@@ -0,0 +1,531 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/float.lisp,v 1.1 1994/04/06 16:54:42 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains floating point support for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;; Conversion by Sean Hallgren
+;;;
+(in-package "ALPHA")
+
+
+;;;; Move functions:
+
+(define-move-function (load-fp-zero 1) (vop x y)
+  ((fp-single-zero) (single-reg)
+   (fp-double-zero) (double-reg))
+  (inst fmove x y))
+
+(define-move-function (load-single 1) (vop x y)
+  ((single-stack) (single-reg))
+  (inst lds y (* (tn-offset x) word-bytes) (current-nfp-tn vop)))
+
+(define-move-function (store-single 1) (vop x y)
+  ((single-reg) (single-stack))
+  (inst sts x (* (tn-offset y) word-bytes) (current-nfp-tn vop)))
+
+
+(define-move-function (load-double 2) (vop x y)
+  ((double-stack) (double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) word-bytes)))
+    (inst ldt y offset nfp)))
+
+(define-move-function (store-double 2) (vop x y)
+  ((double-reg) (double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) word-bytes)))
+    (inst stt x offset nfp)))
+
+
+
+;;;; Move VOPs:
+
+(macrolet ((frob (vop sc)
+	     `(progn
+		(define-vop (,vop)
+		  (:args (x :scs (,sc)
+			    :target y
+			    :load-if (not (location= x y))))
+		  (:results (y :scs (,sc)
+			       :load-if (not (location= x y))))
+		  (:note "float move")
+		  (:generator 0
+		    (unless (location= y x)
+		      (inst fmove x y))))
+		(define-move-vop ,vop :move (,sc) (,sc)))))
+  (frob single-move single-reg)
+  (frob double-move double-reg))
+
+
+(define-vop (move-from-float)
+  (:args (x :to :save))
+  (:results (y))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:variant-vars double-p size type data)
+  (:note "float to pointer coercion")
+  (:generator 13
+    (with-fixed-allocation (y ndescr type size)
+      (if double-p
+	  (inst stt x (- (* data word-bytes) other-pointer-type) y)
+	  (inst sts x (- (* data word-bytes) other-pointer-type) y)))))
+
+(macrolet ((frob (name sc &rest args)
+	     `(progn
+		(define-vop (,name move-from-float)
+		  (:args (x :scs (,sc) :to :save))
+		  (:results (y :scs (descriptor-reg)))
+		  (:variant ,@args))
+		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
+  (frob move-from-single single-reg
+    nil single-float-size single-float-type single-float-value-slot)
+  (frob move-from-double double-reg
+    t double-float-size double-float-type double-float-value-slot))
+
+(macrolet ((frob (name sc double-p value)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:note "pointer to float coercion")
+		  (:generator 2
+                    ,@(if double-p
+			  `((inst ldt y (- (* ,value word-bytes)
+					   other-pointer-type)
+				  x))
+			  `((inst lds y (- (* ,value word-bytes)
+					  other-pointer-type)
+				 x)))))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+  (frob move-to-single single-reg nil single-float-value-slot)
+  (frob move-to-double double-reg t double-float-value-slot))
+
+
+(macrolet ((frob (name sc stack-sc double-p)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (nfp :scs (any-reg)
+			      :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note "float argument move")
+		  (:generator ,(if double-p 2 1)
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+			 (inst fmove x y)))
+		      (,stack-sc
+		       (let ((offset (* (tn-offset y) word-bytes)))
+			 ,@(if double-p
+			       '((inst stt x offset nfp))
+			       '((inst sts x offset nfp))))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-single-float-argument single-reg single-stack nil)
+  (frob move-double-float-argument double-reg double-stack t))
+
+
+(define-move-vop move-argument :move-argument
+  (single-reg double-reg) (descriptor-reg))
+
+
+;;;; Arithmetic VOPs:
+
+(define-vop (float-op)
+  (:args (x) (y))
+  (:results (r))
+  (:policy :fast-safe)
+  (:note "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(macrolet ((frob (name sc ptype)
+	     `(define-vop (,name float-op)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+		(:results (r :scs (,sc)))
+		(:arg-types ,ptype ,ptype)
+		(:result-types ,ptype))))
+  (frob single-float-op single-reg single-float)
+  (frob double-float-op double-reg double-float))
+
+(macrolet ((frob (op sinst sname scost dinst dname dcost)
+	     `(progn
+		(define-vop (,sname single-float-op)
+		  (:translate ,op)
+		  (:variant-cost ,scost)
+		  (:generator ,scost
+                    (inst ,sinst x y r)))
+		(define-vop (,dname double-float-op)
+		  (:translate ,op)
+		  (:variant-cost ,dcost)
+		  (:generator ,dcost
+		    (inst ,dinst x y r))))))
+  (frob + adds +/single-float 2 addt +/double-float 2)
+  (frob - subs -/single-float 2 subt -/double-float 2)
+  (frob * muls */single-float 4 mult */double-float 5)
+  (frob / divs //single-float 12 divt //double-float 19))
+
+(macrolet ((frob (name inst translate sc type)
+	     `(define-vop (,name)
+		(:args (x :scs (,sc) :target y))
+		(:results (y :scs (,sc)))
+		(:translate ,translate)
+		(:policy :fast-safe)
+		(:arg-types ,type)
+		(:result-types ,type)
+		(:note "inline float arithmetic")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1
+		  (note-this-location vop :internal-error)
+		  (inst ,inst x y)))))
+  (frob abs/single-float fabs abs single-reg single-float)
+  (frob abs/double-float fabs abs double-reg double-float)
+  (frob %negate/single-float fneg %negate single-reg single-float)
+  (frob %negate/double-float fneg %negate double-reg double-float))
+
+
+;;;; Comparison:
+
+(define-vop (float-compare)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:variant-vars eq complement)
+  (:temporary (:scs (single-reg)) temp)
+  (:policy :fast-safe)
+  (:note "inline float comparison")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (note-this-location vop :internal-error)
+    (if eq
+	(inst cmpteq x y temp)
+	(if complement
+	    (inst cmptle x y temp)
+	    (inst cmptlt x y temp)))
+    (if (if complement (not not-p) not-p)
+	(inst fbeq temp target)
+	(inst fbne temp target))))
+
+(macrolet ((frob (name sc ptype)
+	     `(define-vop (,name float-compare)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+		(:arg-types ,ptype ,ptype))))
+  (frob single-float-compare single-reg single-float)
+  (frob double-float-compare double-reg double-float))
+
+(macrolet ((frob (translate complement sname dname eq)
+	     `(progn
+		(define-vop (,sname single-float-compare)
+		  (:translate ,translate)
+		  (:variant ,eq ,complement))
+		(define-vop (,dname double-float-compare)
+		  (:translate ,translate)
+		  (:variant ,eq ,complement)))))
+  (frob < nil </single-float </double-float nil)
+  (frob > t >/single-float >/double-float nil)
+  (frob = nil =/single-float =/double-float t))
+
+
+;;;; Conversion:
+
+(macrolet ((frob (name translate inst ld-inst to-sc to-type &optional single)
+             `(define-vop (,name)
+                (:args (x :scs (signed-reg) :target temp
+                          :load-if (not (sc-is x signed-stack))))
+                (:temporary (:scs (single-stack)) temp)
+                (:results (y :scs (,to-sc)))
+                (:arg-types signed-num)
+                (:result-types ,to-type)
+                (:policy :fast-safe)
+                (:note "inline float coercion")
+                (:translate ,translate)
+                (:vop-var vop)
+                (:save-p :compute-only)
+                (:generator 5
+                  (let ((stack-tn
+                         (sc-case x
+                           (signed-reg
+                            (inst stl x
+                                  (* (tn-offset temp) vm:word-bytes)
+				  (current-nfp-tn vop))
+                            temp)
+                           (signed-stack
+                            x))))
+                    (inst ,ld-inst y
+			  (* (tn-offset stack-tn) vm:word-bytes)
+			  (current-nfp-tn vop))
+                    (note-this-location vop :internal-error)
+		    ,@(when single
+			`((inst cvtlq y y)))
+                    (inst ,inst y y))))))
+  (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
+  (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
+
+(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
+             `(define-vop (,name)
+                (:args (x :scs (,from-sc)))
+                (:results (y :scs (,to-sc)))
+                (:arg-types ,from-type)
+                (:result-types ,to-type)
+                (:policy :fast-safe)
+                (:note "inline float coercion")
+                (:translate ,translate)
+                (:vop-var vop)
+                (:save-p :compute-only)
+                (:generator 2
+                  (note-this-location vop :internal-error)
+		  (inst ,inst x y)))))
+  (frob %single-float/double-float %single-float cvtts
+    double-reg double-float single-reg single-float)
+  (frob %double-float/single-float %double-float fmove
+    single-reg single-float double-reg double-float))
+
+(macrolet ((frob (trans from-sc from-type inst &optional single)
+             `(define-vop (,(symbolicate trans "/" from-type))
+                (:args (x :scs (,from-sc) :target temp))
+                (:temporary (:from (:argument 0) :sc single-reg) temp)
+                (:temporary (:scs (signed-stack)) stack-temp)
+                (:results (y :scs (signed-reg)
+                             :load-if (not (sc-is y signed-stack))))
+                (:arg-types ,from-type)
+                (:result-types signed-num)
+                (:translate ,trans)
+                (:policy :fast-safe)
+                (:note "inline float truncate")
+                (:vop-var vop)
+                (:save-p :compute-only)
+                (:generator 5
+                  (note-this-location vop :internal-error)
+                  (inst ,inst x temp)
+                  (sc-case y
+                    (signed-stack
+                     (inst stt temp
+                           (* (tn-offset y) vm:word-bytes)
+			    (current-nfp-tn vop)))
+                    (signed-reg
+                     (inst stt temp
+			   (* (tn-offset stack-temp) vm:word-bytes)
+			   (current-nfp-tn vop))
+                     (inst ldq y
+			   (* (tn-offset stack-temp) vm:word-bytes)
+			   (current-nfp-tn vop))))))))
+  (frob %unary-truncate single-reg single-float cvttq/c t)
+  (frob %unary-truncate double-reg double-float cvttq/c)
+  (frob %unary-round single-reg single-float cvttq t)
+  (frob %unary-round double-reg double-float cvttq))
+
+(define-vop (make-single-float)
+  (:args (bits :scs (signed-reg) :target res
+	       :load-if (not (sc-is bits signed-stack))))
+  (:results (res :scs (single-reg)
+		 :load-if (not (sc-is res single-stack))))
+  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:scs (signed-stack)) stack-temp)
+  (:arg-types signed-num)
+  (:result-types single-float)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case bits
+      (signed-reg
+       (sc-case res
+	 (single-reg
+	  (inst stl bits
+		(* (tn-offset stack-temp) vm:word-bytes)
+		(current-nfp-tn vop))
+	  (inst lds res
+		(* (tn-offset stack-temp) vm:word-bytes)
+		(current-nfp-tn vop)))
+	 (single-stack
+	  (inst stl bits
+		(* (tn-offset res) vm:word-bytes)
+		(current-nfp-tn vop)))))
+      (signed-stack
+       (sc-case res
+	 (single-reg
+	  (inst lds res
+		(* (tn-offset bits) vm:word-bytes)
+		(current-nfp-tn vop)))
+	 (single-stack
+	  (unless (location= bits res)
+	    (inst ldl temp
+		  (* (tn-offset bits) vm:word-bytes)
+		  (current-nfp-tn vop))
+	    (inst stl temp
+		  (* (tn-offset res) vm:word-bytes)
+		  (current-nfp-tn vop)))))))))
+
+(define-vop (make-double-float)
+  (:args (hi-bits :scs (signed-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (double-reg)
+		 :load-if (not (sc-is res double-stack))))
+  (:temporary (:scs (double-stack)) temp)
+  (:arg-types signed-num unsigned-num)
+  (:result-types double-float)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (let ((stack-tn (sc-case res
+		      (double-stack res)
+		      (double-reg temp))))
+      (inst stl hi-bits
+	    (* (1+ (tn-offset stack-tn)) vm:word-bytes)
+	    (current-nfp-tn vop))
+      (inst stl lo-bits
+	    (* (tn-offset stack-tn) vm:word-bytes)
+	    (current-nfp-tn vop)))
+    (when (sc-is res double-reg)
+      (inst ldt res
+	    (* (tn-offset temp) vm:word-bytes)
+	    (current-nfp-tn vop)))))
+
+(define-vop (single-float-bits)
+  (:args (float :scs (single-reg descriptor-reg)
+		:load-if (not (sc-is float single-stack))))
+  (:results (bits :scs (signed-reg)
+		  :load-if (or (sc-is float descriptor-reg single-stack)
+			       (not (sc-is bits signed-stack)))))
+  (:temporary (:scs (signed-stack)) stack-temp)
+  (:arg-types single-float)
+  (:result-types signed-num)
+  (:translate single-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case bits
+      (signed-reg
+       (sc-case float
+	 (single-reg
+	  (inst sts float
+		(* (tn-offset stack-temp) vm:word-bytes)
+		(current-nfp-tn vop))
+	  (inst ldl bits
+		(* (tn-offset stack-temp) vm:word-bytes)
+		(current-nfp-tn vop)))
+	 (single-stack
+	  (inst ldl bits
+		(* (tn-offset float) vm:word-bytes)
+		(current-nfp-tn vop)))
+	 (descriptor-reg
+	  (loadw bits float vm:single-float-value-slot vm:other-pointer-type))))
+      (signed-stack
+       (sc-case float
+	 (single-reg
+	  (inst sts float
+		(* (tn-offset bits) vm:word-bytes)
+		(current-nfp-tn vop))))))))
+
+(define-vop (double-float-high-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (hi-bits :scs (signed-reg)
+		     :load-if (or (sc-is float descriptor-reg double-stack)
+				  (not (sc-is hi-bits signed-stack)))))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types double-float)
+  (:result-types signed-num)
+  (:translate double-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (double-reg
+        (inst stt float
+	      (* (tn-offset stack-temp) vm:word-bytes)
+	      (current-nfp-tn vop))
+        (inst ldl hi-bits
+	      (* (1+ (tn-offset stack-temp)) vm:word-bytes)
+	      (current-nfp-tn vop)))
+      (double-stack
+        (inst ldl hi-bits
+	      (* (1+ (tn-offset float)) vm:word-bytes)
+	      (current-nfp-tn vop)))
+      (descriptor-reg
+        (loadw hi-bits float (1+ vm:double-float-value-slot)
+	       vm:other-pointer-type)))))
+
+(define-vop (double-float-low-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (lo-bits :scs (unsigned-reg)
+		     :load-if (or (sc-is float descriptor-reg double-stack)
+				  (not (sc-is lo-bits unsigned-stack)))))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types double-float)
+  (:result-types unsigned-num)
+  (:translate double-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (double-reg
+        (inst stt float
+	      (* (tn-offset stack-temp) vm:word-bytes)
+	      (current-nfp-tn vop))
+	(inst ldl lo-bits
+	      (* (tn-offset stack-temp) vm:word-bytes)
+	      (current-nfp-tn vop)))
+      (double-stack
+       (inst ldl lo-bits
+	     (* (tn-offset float) vm:word-bytes)
+	     (current-nfp-tn vop)))
+      (descriptor-reg
+       (loadw lo-bits float vm:double-float-value-slot
+	      vm:other-pointer-type)))
+    (inst mskll lo-bits 4 lo-bits)))
+
+
+;;;; Float mode hackery:
+
+(deftype float-modes () '(unsigned-byte 24))
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+  float-modes)
+
+(define-vop (floating-point-modes)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate floating-point-modes)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:sc unsigned-stack) temp)
+  (:temporary (:sc single-reg) temp1)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop)))
+      (inst mf_fpcr temp1 temp1 temp1)
+      (inst sts temp1 (* word-bytes (tn-offset temp)) nfp)
+      (loadw res nfp (tn-offset temp)))))
+
+(define-vop (set-floating-point-modes)
+  (:args (new :scs (unsigned-reg) :target res))
+  (:results (res :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:result-types unsigned-num)
+  (:translate (setf floating-point-modes))
+  (:policy :fast-safe)
+  (:temporary (:sc unsigned-stack) temp)
+  (:temporary (:sc single-reg) temp1)
+  (:vop-var vop)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop)))
+      (storew new nfp (tn-offset temp))
+      (inst lds temp1 (* word-bytes (tn-offset temp)) nfp)
+      (inst mt_fpcr temp1 temp1 temp1)
+      (move res new))))
diff --git a/compiler/alpha/insts.lisp b/compiler/alpha/insts.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..61a0e0394ef981970b42d63c5303a1d85970f2bc
--- /dev/null
+++ b/compiler/alpha/insts.lisp
@@ -0,0 +1,598 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/insts.lisp,v 1.1 1994/04/06 16:54:42 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the instruction set definition for the Alpha.
+;;;
+;;; Written by Sean Hallgren.
+;;;
+
+(in-package :alpha)
+
+(use-package :new-assem)
+
+(def-assembler-params
+  :scheduler-p nil)
+
+
+;;;; Utility functions.
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn)
+           (values (unsigned-byte 5)))
+  (sc-case tn
+    (zero zero-offset)
+    (null null-offset)
+    (t
+     (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+     (tn-offset tn))))
+
+(defun fp-reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (sc-case tn
+    (fp-single-zero (tn-offset fp-single-zero-tn))
+    (fp-double-zero (tn-offset fp-double-zero-tn))
+    (t
+     (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
+       (error "~S isn't a floating-point register." tn))
+     (tn-offset tn))))
+
+
+;;;; Initial disassembler setup.
+
+(disassem:set-disassem-params :instruction-alignment 32)
+
+(defvar *disassem-use-lisp-reg-names* t)
+
+(defparameter reg-symbols
+  (map 'vector
+       #'(lambda (name)
+           (cond ((null name) nil)
+                 (t (make-symbol (concatenate 'string "$" name)))))
+       *register-names*))
+
+(disassem:define-argument-type reg
+  :printer #'(lambda (value stream dstate)
+               (declare (stream stream) (fixnum value))
+               (let ((regname (aref reg-symbols value)))
+                 (princ regname stream)
+                 (disassem:maybe-note-associated-storage-ref
+                  value
+                  'registers
+                  regname
+                  dstate))))
+
+(defparameter float-reg-symbols
+  (coerce
+   (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n)))
+   'vector))
+
+(disassem:define-argument-type fp-reg
+  :printer #'(lambda (value stream dstate)
+               (declare (stream stream) (fixnum value))
+               (let ((regname (aref float-reg-symbols value)))
+                 (princ regname stream)
+                 (disassem:maybe-note-associated-storage-ref
+                  value
+                  'float-registers
+                  regname
+                  dstate))))
+
+(disassem:define-argument-type relative-label
+  :sign-extend t
+  :use-label #'(lambda (value dstate)
+		 (declare (type (signed-byte 21) value)
+			  (type disassem:disassem-state dstate))
+		 (+ (ash value 2) (disassem:dstate-cur-addr dstate))))
+
+
+
+;;;; Define-instruction-formats for disassembler.
+(disassem:define-instruction-format
+    (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")"))
+  (op   :field (byte 6 26))
+  (ra   :field (byte 5 21) :type 'reg)
+  (rb   :field (byte 5 16) :type 'reg)
+  (disp :field (byte 16 0) :sign-extend t))
+
+(disassem:define-instruction-format
+    (jump 32 :default-printer '(:name :tab ra ",(" rb ")," hint))
+  (op    :field (byte 6 26))
+  (ra    :field (byte 5 21) :type 'reg)
+  (rb    :field (byte 5 16) :type 'reg)
+  (subop :field (byte 2 14))
+  (hint  :field (byte 14 0)))
+
+(disassem:define-instruction-format
+    (branch 32 :default-printer '(:name :tab ra "," disp))
+  (op   :field (byte 6 26))
+  (ra   :field (byte 5 21) :type 'reg)
+  (disp :field (byte 21 0) :type 'relative-label))
+
+(disassem:define-instruction-format
+    (reg-operate 32 :default-printer '(:name :tab ra "," rb "," rc))
+  (op  :field (byte 6 26))
+  (ra  :field (byte 5 21) :type 'reg)
+  (rb  :field (byte 5 16) :type 'reg)
+  (sbz :field (byte 3 13))
+  (f   :field (byte 1 12) :value 0)
+  (fn  :field (byte 7 5))
+  (rc  :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (lit-operate 32 :default-printer '(:name :tab ra "," lit "," rc))
+  (op  :field (byte 6 26))
+  (ra  :field (byte 5 21) :type 'reg)
+  (lit :field (byte 8 13))
+  (f   :field (byte 1 12) :value 1)
+  (fn  :field (byte 7 5))
+  (rc  :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (fp-operate 32 :default-printer '(:name :tab fa "," fb "," fc))
+  (op :field (byte 6 26))
+  (fa :field (byte 5 21) :type 'fp-reg)
+  (fb :field (byte 5 16) :type 'fp-reg)
+  (fn :field (byte 11 5))
+  (fc :field (byte 5 0) :type 'fp-reg))
+
+(disassem:define-instruction-format
+    (call-pal 32 :default-printer '('call_pal :tab 'pal_ :name))
+  (op      :field (byte 6 26) :value 0)
+  (palcode :field (byte 26 0)))
+
+
+;;;; Emitters.
+(define-emitter emit-word 16
+  (byte 16 0))
+
+(define-emitter emit-lword 32
+  (byte 32 0))
+
+(define-emitter emit-qword 64
+  (byte 64 0))
+
+(define-emitter emit-memory 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
+
+(define-emitter emit-branch 32
+  (byte 6 26) (byte 5 21) (byte 21 0))
+
+(define-emitter emit-reg-operate 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5)
+  (byte 5 0))
+
+(define-emitter emit-lit-operate 32
+  (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0))
+
+(define-emitter emit-fp-operate 32
+  (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0))
+
+(define-emitter emit-pal 32
+  (byte 6 26) (byte 26 0))
+
+
+;;;; Macros for instructions.
+(defmacro define-memory (name op &optional fixup float)
+  `(define-instruction ,name (segment ra disp rb ,@(if fixup
+						       '(&optional type)))
+     (:declare (type tn ra rb)
+	       ,@(if fixup    ; ### unsigned-byte 16 bad idea?
+		     '((type (or (unsigned-byte 16) (signed-byte 16) fixup)
+			     disp))
+		     '((type (or (unsigned-byte 16) (signed-byte 16)) disp))))
+     (:printer memory ((op ,op)))
+     (:emitter
+      ,@(when fixup
+	  `((when (fixup-p disp)
+	      (note-fixup segment (or type ,fixup) disp)
+	      (setf disp 0))))
+      (emit-memory segment ,op ,@(if float
+				     '((fp-reg-tn-encoding ra))
+				     '((reg-tn-encoding ra)))
+		   (reg-tn-encoding rb)
+		   disp))))
+
+(defmacro define-jump (name subop)
+  `(define-instruction ,name (segment ra rb &optional (hint 0))
+     (:declare (type tn ra rb)
+	       (type (or (unsigned-byte 14) fixup) hint))
+     (:printer jump ((op #x1a) (subop ,subop)))
+     (:emitter
+      (when (fixup-p hint)
+	(note-fixup segment :jmp-hint hint)
+	(setf hint 0))
+      (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb)
+		   (logior (ash ,subop 14) hint)))))
+
+(defmacro define-branch (name op &optional (float nil))
+  `(define-instruction ,name (segment ra target)
+     (:declare (type tn ra)
+	       (type label target))
+     (:printer branch ((op ,op)
+		       ,@(when float
+			   '((ra nil :type 'fp-reg)))))
+     (:emitter
+      (emit-back-patch segment 4
+		       #'(lambda (segment posn)
+			   (emit-branch segment ,op
+					,@(if float
+					      '((fp-reg-tn-encoding ra))
+					      '((reg-tn-encoding ra)))
+					(ash (- (label-position target)
+						(+ posn 4))
+					     -2)))))))
+
+(defmacro define-operate (name op fn)
+  `(define-instruction ,name (segment ra rb rc)
+     (:declare (type tn ra rc)
+	       (type (or tn (unsigned-byte 8)) rb))
+     (:printer reg-operate ((op ,op) (fn ,fn)))
+     (:printer lit-operate ((op ,op) (fn ,fn)))
+     ,@(when (and (= op #x11) (= fn #x20))
+	 `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31))
+		     '('move :tab rb "," rc))
+	   (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31))
+		     '('nop))))
+     (:emitter
+      (etypecase rb
+	(tn
+	 (emit-reg-operate segment ,op (reg-tn-encoding ra)
+			   (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc)))
+	(number
+	 (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn
+		       (reg-tn-encoding rc)))))))
+
+(defmacro define-fp-operate (name op fn &optional (args 3))
+  `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc)
+     (:declare (type tn ,@(when (= args 3) '(fa)) fb fc))
+     (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31))))
+	       ,@(when (= args 2)
+		   '('(:name :tab fb "," fc))))
+     ,@(when (and (= op #x17) (= fn #x20))
+	 `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31))
+		     '('fabs :tab fb "," fc))))
+     (:emitter
+      (emit-fp-operate segment ,op ,@(if (= args 3)
+					 '((fp-reg-tn-encoding fa))
+					 '(31))
+		       (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc)))))
+
+
+;;;; Instructions.
+(define-memory lda   #x08 :lda)
+(define-memory ldah  #x09 :ldah)
+(define-memory ldl   #x28)
+(define-memory ldq   #x29)
+(define-memory ldl_l #x2a)
+(define-memory ldq_q #x2b)
+(define-memory ldq_u #x0b)
+(define-memory stl   #x2c)
+(define-memory stq   #x2d)
+(define-memory stl_c #x2e)
+(define-memory stq_c #x2f)
+(define-memory stq_u #x0f)
+(define-memory ldf   #x20 nil t)
+(define-memory ldg   #x21 nil t)
+(define-memory lds   #x22 nil t)
+(define-memory ldt   #x23 nil t)
+(define-memory stf   #x24 nil t)
+(define-memory stg   #x25 nil t)
+(define-memory sts   #x26 nil t)
+(define-memory stt   #x27 nil t)
+
+(define-jump jmp 0)
+(define-jump jsr 1)
+(define-jump ret 2)
+(define-jump jsr-coroutine 3)
+
+(define-branch br   #x30)
+(define-branch bsr  #x34)
+(define-branch blbc #x38)
+(define-branch blbs #x3c)
+(define-branch fbeq #x31 t)
+(define-branch fbne #x35 t)
+(define-branch beq  #x39)
+(define-branch bne  #x3d)
+(define-branch fblt #x32 t)
+(define-branch fbge #x36 t)
+(define-branch blt  #x3a)
+(define-branch bge  #x3e)
+(define-branch fble #x33 t)
+(define-branch fbgt #x37 t)
+(define-branch ble  #x3b)
+(define-branch bgt  #x3f)
+
+(define-operate addl   #x10 #x00)
+(define-operate addl/v #x10 #x40)
+(define-operate addq   #x10 #x20)
+(define-operate addq/v #x10 #x60)
+(define-operate cmpule #x10 #x3d)
+(define-operate cmpbge #x10 #x0f)
+(define-operate subl   #x10 #x09)
+(define-operate subl/v #x10 #x49)
+(define-operate subq   #x10 #x29)
+(define-operate subq/v #x10 #x69)
+(define-operate cmpeq  #x10 #x2d)
+(define-operate cmplt  #x10 #x4d)
+(define-operate cmple  #x10 #x6d)
+(define-operate cmpult #x10 #x1d)
+(define-operate s4addl #x10 #x02)
+(define-operate s4addq #x10 #x22)
+(define-operate s4subl #x10 #x0b)
+(define-operate s4subq #x10 #x2b)
+(define-operate s8addl #x10 #x12)
+(define-operate s8addq #x10 #x32)
+(define-operate s8subl #x10 #x1b)
+(define-operate s8subq #x10 #x3b)
+
+(define-operate and     #x11 #x00)
+(define-operate bic     #x11 #x08)
+(define-operate cmoveq  #x11 #x24)
+(define-operate cmovne  #x11 #x26)
+(define-operate cmovlbs #x11 #x14)
+(define-operate bis     #x11 #x20)
+(define-operate ornot   #x11 #x28)
+(define-operate cmovlt  #x11 #x44)
+(define-operate cmovge  #x11 #x46)
+(define-operate cmovlbc #x11 #x16)
+(define-operate xor     #x11 #x40)
+(define-operate eqv     #x11 #x48)
+(define-operate cmovle  #x11 #x64)
+(define-operate cmovgt  #x11 #x66)
+
+(define-operate sll    #x12 #x39)
+(define-operate extbl  #x12 #x06)
+(define-operate extwl  #x12 #x16)
+(define-operate extll  #x12 #x26)
+(define-operate extql  #x12 #x36)
+(define-operate extwh  #x12 #x5a)
+(define-operate extlh  #x12 #x6a)
+(define-operate extqh  #x12 #x7a)
+(define-operate sra    #x12 #x3c)
+(define-operate insbl  #x12 #x0b)
+(define-operate inswl  #x12 #x1b)
+(define-operate insll  #x12 #x2b)
+(define-operate insql  #x12 #x3b)
+(define-operate inswh  #x12 #x57)
+(define-operate inslh  #x12 #x67)
+(define-operate insqh  #x12 #x77)
+(define-operate srl    #x12 #x34)
+(define-operate mskbl  #x12 #x02)
+(define-operate mskwl  #x12 #x12)
+(define-operate mskll  #x12 #x22)
+(define-operate mskql  #x12 #x32)
+(define-operate mskwh  #x12 #x52)
+(define-operate msklh  #x12 #x62)
+(define-operate mskqh  #x12 #x72)
+(define-operate zap    #x12 #x30)
+(define-operate zapnot #x12 #x31)
+
+(define-operate mull   #x13 #x00)
+(define-operate mulq/v #x13 #x60)
+(define-operate mull/v #x13 #x40)
+(define-operate umulh  #x13 #x30)
+(define-operate mulq   #x13 #x20)
+
+(define-fp-operate cpys     #x17 #x020)
+(define-fp-operate mf_fpcr  #x17 #x025)
+(define-fp-operate cpysn    #x17 #x021)
+(define-fp-operate mt_fpcr  #x17 #x024)
+(define-fp-operate cpyse    #x17 #x022)
+(define-fp-operate cvtql/sv #x17 #x530 2)
+(define-fp-operate cvtlq    #x17 #x010 2)
+(define-fp-operate cvtql    #x17 #x030 2)
+(define-fp-operate cvtql/v  #x17 #x130 2)
+(define-fp-operate fcmoveq  #x17 #x02a)
+(define-fp-operate fcmovne  #x17 #x02b)
+(define-fp-operate fcmovlt  #x17 #x02c)
+(define-fp-operate fcmovge  #x17 #x02d)
+(define-fp-operate fcmovle  #x17 #x02e)
+(define-fp-operate fcmovgt  #x17 #x02f)
+
+(define-fp-operate cvtqs #x16 #x0bc 2)
+(define-fp-operate cvtqt #x16 #x0be 2)
+(define-fp-operate cvtts #x16 #x0ac 2)
+(define-fp-operate cvttq #x16 #x0af 2)
+(define-fp-operate cvttq/c #x16 #x02f 2)
+(define-fp-operate cmpteq #x16 #x5a5)
+(define-fp-operate cmptlt #x16 #x5a6)
+(define-fp-operate cmptle #x16 #x5a7)
+(define-fp-operate cmptun #x16 #x5a4)
+(define-fp-operate adds #x16 #x080)
+(define-fp-operate addt #x16 #x0a0)
+(define-fp-operate divs #x16 #x083)
+(define-fp-operate divt #x16 #x0a3)
+(define-fp-operate muls #x16 #x082)
+(define-fp-operate mult #x16 #x0a2)
+(define-fp-operate subs #x16 #x081)
+(define-fp-operate subt #x16 #x0a1)
+
+(define-instruction gentrap (segment code)
+  (:printer call-pal ((palcode #xaa0000)))
+  (:emitter
+   (emit-pal segment 0 #x0000aa)
+   (emit-lword segment code)))
+
+(define-instruction-macro move (src dst)
+  `(inst bis zero-tn ,src ,dst))
+
+(define-instruction-macro not (src dst)
+  `(inst ornot zero-tn ,src ,dst))
+
+(define-instruction-macro fmove (src dst)
+  `(inst cpys ,src ,src ,dst))
+
+(define-instruction-macro fabs (src dst)
+  `(inst cpys fp-single-zero-tn ,src ,dst))
+
+(define-instruction-macro fneg (src dst)
+  `(inst cpysn ,src ,src ,dst))
+
+(define-instruction-macro nop ()
+  `(inst bis zero-tn zero-tn zero-tn))
+
+(defun %li (value reg)
+  (etypecase value
+    ((signed-byte 16)
+     (inst lda reg value zero-tn))
+    ((signed-byte 32)
+     (flet ((se (x n)
+	      (let ((x (logand x (lognot (ash -1 n)))))
+		(if (logbitp (1- n) x)
+		    (logior (ash -1 (1- n)) x)
+		    x))))
+       (let* ((value (se value 32))
+	      (low (ldb (byte 16 0) value))
+	      (tmp1 (- value (se low 16)))
+	      (high (ldb (byte 16 16) tmp1))
+	      (tmp2 (- tmp1 (se (ash high 16) 32)))
+	      (extra 0))
+	 (unless (= tmp2 0)
+	   (setf extra #x4000)
+	   (setf tmp1 (- tmp1 #x40000000))
+	   (setf high (ldb (byte 16 16) tmp1)))
+	 (inst lda reg low zero-tn)
+	 (unless (= extra 0)
+	   (inst ldah reg extra reg))
+	 (unless (= high 0)
+	   (inst ldah reg high reg)))))
+    ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
+     (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
+	    (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1))
+	    (value3 (if (logbitp 47 value) (+ value (ash 1 48)) value2)))
+       (inst lda reg (ldb (byte 16 32) value2) zero-tn)
+       (unless (= value3 0)
+	 (inst ldah reg (ldb (byte 16 48) value3) reg))
+       (unless (and (= value2 0) (= value3 0))
+	 (inst sll reg 32 reg))
+       (unless (= value 0)
+	 (inst lda reg (ldb (byte 16 0) value) reg))
+       (unless (= value1 0)
+	 (inst ldah reg (ldb (byte 16 16) value1) reg))))
+    (fixup
+     (inst lda reg value zero-tn :bits-47-32)
+     (inst ldah reg value reg :bits-63-48)
+     (inst sll reg 32 reg)
+     (inst lda reg value reg)
+     (inst ldah reg value reg))))
+  
+(define-instruction-macro li (value reg)
+  `(%li ,value ,reg))
+
+
+;;;;
+
+(define-instruction lword (segment lword)
+  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
+  (:cost 0)
+  (:emitter
+   (emit-lword segment lword)))
+
+(define-instruction short (segment word)
+  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
+  (:cost 0)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction byte (segment byte)
+  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
+  (:cost 0)
+  (:emitter
+   (emit-byte segment byte)))
+
+(defun emit-header-data (segment type)
+  (emit-back-patch
+   segment 4
+   #'(lambda (segment posn)
+       (emit-lword segment
+		  (logior type
+			  (ash (+ posn (component-header-length))
+			       (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+  (:cost 0)
+  (:emitter
+   (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+  (:cost 0)
+  (:emitter
+   (emit-header-data segment return-pc-header-type)))
+
+(defun emit-compute-inst (segment vop dst src label temp calc)
+  (declare (ignore temp))
+  (emit-chooser
+   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
+   segment 12 3
+   #'(lambda (segment posn delta-if-after)
+       (let ((delta (funcall calc label posn delta-if-after)))
+	  (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
+	    (emit-back-patch segment 4
+			     #'(lambda (segment posn)
+				 (assemble (segment vop)
+					   (inst lda dst
+						 (funcall calc label posn 0)
+						 src))))
+	    t)))
+   #'(lambda (segment posn)
+       (assemble (segment vop)
+	 (flet ((se (x n)
+		  (let ((x (logand x (lognot (ash -1 n)))))
+		    (if (logbitp (1- n) x)
+			(logior (ash -1 (1- n)) x)
+			x))))
+	   (let* ((value (se (funcall calc label posn 0) 2))
+		  (low (ldb (byte 16 0) value))
+		  (tmp1 (- value (se low 16)))
+		  (high (ldb (byte 16 16) tmp1))
+		  (tmp2 (- tmp1 (se (ash high 16) 32)))
+		  (extra 0))
+	     (unless (= tmp2 0)
+	       (setf extra #x4000)
+	       (setf tmp1 (- tmp1 #x40000000))
+	       (setf high (ldb (byte 16 16) tmp1)))
+	     (inst lda dst low src)
+	     (inst ldah dst extra dst)
+	     (inst ldah dst high dst)))))))
+
+;; code = fn - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-fn (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (- other-pointer-type
+			     (label-position label posn delta-if-after)
+			     (component-header-length))))))
+
+;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
+;;      = lra - (header + label-offset)
+(define-instruction compute-code-from-lra (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (- (+ (label-position label posn delta-if-after)
+				(component-header-length)))))))
+
+;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
+(define-instruction compute-lra-from-code (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (+ (label-position label posn delta-if-after)
+			     (component-header-length))))))
diff --git a/compiler/alpha/macros.lisp b/compiler/alpha/macros.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fe30491f32e5a61434912f51dbde769b3c65bfa3
--- /dev/null
+++ b/compiler/alpha/macros.lisp
@@ -0,0 +1,540 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/macros.lisp,v 1.1 1994/04/06 16:54:43 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains various useful macros for generating Alpha code.
+;;;
+;;; Written by William Lott and Christopher Hoover.
+;;; Alpha conversion by Sean Hallgren.
+;;; 
+
+(in-package :alpha)
+
+;;; Handy macro for defining top-level forms that depend on the compile
+;;; environment.
+
+(defmacro expand (expr)
+  (let ((gensym (gensym)))
+    `(macrolet
+	 ((,gensym ()
+	    ,expr))
+       (,gensym))))
+
+
+;;; Instruction-like macros.
+
+(defmacro move (src dst)
+  "Move SRC into DST unless they are location=."
+  (once-only ((src src) (dst dst))
+    `(unless (location= ,src ,dst)
+       (inst move ,src ,dst))))
+
+(defmacro loadw (result base &optional (offset 0) (lowtag 0))
+  (once-only ((result result) (base base))
+    `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro loadq (result base &optional (offset 0) (lowtag 0))
+  (once-only ((result result) (base base))
+    `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro storew (value base &optional (offset 0) (lowtag 0))
+  (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
+    `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro storeq (value base &optional (offset 0) (lowtag 0))
+  (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
+    `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro load-symbol (reg symbol)
+  (once-only ((reg reg) (symbol symbol))
+    `(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))
+
+(defmacro load-symbol-value (reg symbol)
+  `(inst ldl ,reg
+	 (+ (static-symbol-offset ',symbol)
+	    (ash symbol-value-slot word-shift)
+	    (- other-pointer-type))
+	 null-tn))
+
+(defmacro store-symbol-value (reg symbol)
+  `(inst stl ,reg
+	 (+ (static-symbol-offset ',symbol)
+	    (ash symbol-value-slot word-shift)
+	    (- other-pointer-type))
+	 null-tn))
+
+(defmacro load-type (target source &optional (offset 0))
+  "Loads the type bits of a pointer into target independent of
+  byte-ordering issues."
+  (once-only ((n-target target)
+	      (n-source source)
+	      (n-offset offset))
+     `(progn
+	(inst ldl ,n-target ,n-offset ,n-source)
+	(inst and ,n-target #xff ,n-target))))
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions. 
+
+(defmacro lisp-jump (function lip)
+  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
+  `(progn
+     (inst lda ,lip (- (ash vm:function-code-offset vm:word-shift)
+			     vm:function-pointer-type)
+	    ,function)
+     (move ,function code-tn)
+     (inst jsr zero-tn ,lip 1)))
+
+(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+  "Return to RETURN-PC.  LIP is an interior-reg temporary."
+  `(progn
+     (inst lda ,lip  
+	   (- (* (1+ ,offset) word-bytes) other-pointer-type)
+	    ,return-pc)
+     ,@(when frob-code
+	 `((move ,return-pc code-tn)))
+     (inst ret zero-tn ,lip 1)))
+
+
+(defmacro emit-return-pc (label)
+  "Emit a return-pc header word.  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.
+;;;
+(defmacro load-stack-tn (reg stack)
+  `(let ((reg ,reg)
+	 (stack ,stack))
+     (let ((offset (tn-offset stack)))
+       (sc-case stack
+	 ((control-stack)
+	  (loadw reg cfp-tn offset))))))
+
+(defmacro store-stack-tn (stack reg)
+  `(let ((stack ,stack)
+	 (reg ,reg))
+     (let ((offset (tn-offset stack)))
+       (sc-case stack
+	 ((control-stack)
+	  (storew reg cfp-tn offset))))))
+
+
+;;; 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-stack ,n-reg))
+	  ((control-stack)
+	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+
+;;; MAYBE-LOAD-STACK-NFP-TN -- Interface
+;;;
+(defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
+  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
+  (once-only ((n-reg reg)
+	      (n-stack reg-or-stack))
+     `(when ,reg
+	(sc-case ,n-reg
+	 ((any-reg descriptor-reg)
+	  (sc-case ,n-stack
+	   ((any-reg descriptor-reg)
+	    (move ,n-stack ,n-reg))
+	   ((control-stack)
+	    (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
+	    (inst mskll nsp-tn 0 ,temp)
+	    (inst bis ,temp ,n-reg ,n-reg))))))))
+
+
+
+;;;; Storage allocation:
+
+(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+				 &body body)
+  "Do stuff to allocate an other-pointer object of fixed Size with a single
+   word header having the specified Type-Code.  The result is placed in
+   Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
+   descriptor temp (which may be randomly used by the body.)  The body is
+   placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
+  `(pseudo-atomic (:extra (pad-data-block ,size))
+     (inst bis alloc-tn other-pointer-type ,result-tn)
+     (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
+     (storew ,temp-tn ,result-tn 0 other-pointer-type)
+     ,@body))
+
+
+
+;;;; 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 gentrap ,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)))
+
+
+(defmacro cerror-call (vop label error-code &rest values)
+  "Cause a continuable error.  If the error is continued, execution resumes at
+  LABEL."
+  `(progn
+     (inst br zero-tn ,label)
+     ,@(emit-error-break vop cerror-trap error-code values)))
+
+(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 -- Handy macro for making sequences look atomic.
+;;;
+(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
+  `(progn
+     (inst addq alloc-tn 1 alloc-tn)
+     ,@forms
+     (inst lda alloc-tn (1- ,extra) alloc-tn)
+     (inst stl zero-tn 0 alloc-tn)))
+
+
+
+;;;; Memory accessor vop generators
+
+(deftype load/store-index (scale lowtag min-offset
+				 &optional (max-offset min-offset))
+  `(integer ,(- (truncate (+ (ash 1 16)
+			     (* min-offset word-bytes)
+			     (- lowtag))
+			  scale))
+	    ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+			  (* max-offset word-bytes))
+		       scale)))
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type
+				   &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg)))
+       (:arg-types ,type tagged-num)
+       (:temporary (:scs (interior-reg)) lip)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 5
+	 (inst addq object index lip)
+	 (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip)
+	 ,@(when (equal scs '(unsigned-reg))
+	     '((inst mskll value 4 value)))))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
+						,(eval offset))))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4
+	 (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag)
+	       object)
+	 ,@(when (equal scs '(unsigned-reg))
+	     '((inst mskll value 4 value)))))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type
+				   &optional translate #+gengc (remember t))
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type tagged-num ,el-type)
+       (:temporary (:scs (interior-reg)) lip)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 2
+	 (inst addq index object lip)
+	 (inst stl value (- (* ,offset word-bytes) ,lowtag) lip)
+	 (move value result)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs))
+       (:info index)
+       (:arg-types ,type
+		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
+						,(eval offset)))
+		   ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 1
+	 (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag)
+	       object)
+	 (move value result)))))
+
+
+(defmacro define-partial-reffer (name type size signed offset lowtag scs
+				      el-type &optional translate)
+  (let ((scale (ecase size (:byte 1) (:short 2))))
+    `(progn
+       (define-vop (,name)
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (value :scs ,scs))
+	 (:result-types ,el-type)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:temporary (:sc non-descriptor-reg) temp)
+	 (:temporary (:sc non-descriptor-reg) temp1)
+	 (:generator 5
+	   (inst addq object index lip)
+	   ,@(when (eq size :short)
+	       '((inst addq index lip lip)))
+	   ,@(ecase size
+	       (:byte
+		(if signed
+		    `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+			    lip)
+		      (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag))
+			    lip)
+		      (inst extqh temp temp1 temp)
+		      (inst sra temp 56 value))
+		    `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip)
+		      (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
+					  lip)
+		      (inst extbl temp temp1 value))))
+	       (:short
+		(if signed
+		    `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+			    lip)
+		      (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
+			    lip)
+		      (inst extwl temp temp1 temp)
+		      (inst sll temp 48 temp)
+		      (inst sra temp 48 value))
+		    `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+			    lip)
+		      (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+		      (inst extwl temp temp1 value)))))))
+       (define-vop (,(symbolicate name "-C"))
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:info index)
+	 (:arg-types ,type
+		     (:constant (load/store-index ,scale
+						  ,(eval lowtag)
+						  ,(eval offset))))
+	 (:results (value :scs ,scs))
+	 (:result-types ,el-type)
+	 (:temporary (:sc non-descriptor-reg) temp)
+	 (:temporary (:sc non-descriptor-reg) temp1)
+	 (:generator 5
+	   ,@(ecase size
+	       (:byte
+		(if signed
+		    `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+					     (* index ,scale)) ,lowtag)
+			    object)
+		      (inst lda temp1 (1+ (- (+ (* ,offset word-bytes)
+						(* index ,scale)) ,lowtag))
+			    object)
+		      (inst extqh temp temp1 temp)
+		      (inst sra temp 56 value))
+		    `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+					     (* index ,scale)) ,lowtag)
+			    object)
+		      (inst lda temp1 (- (+ (* ,offset word-bytes)
+					    (* index ,scale)) ,lowtag)
+			    object)
+		      (inst extbl temp temp1 value))))
+	       (:short
+		(if signed
+		    `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+					     (* index ,scale)) ,lowtag)
+			    object)
+		      (inst lda temp1  (- (+ (* ,offset word-bytes)
+					     (* index ,scale)) ,lowtag))
+		      (inst extwl temp temp1 temp)
+		      (inst sll temp 48 temp)
+		      (inst sra temp 48 value))
+		    `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+					     (* index ,scale)) ,lowtag)
+			    object)
+		      (inst lda temp1 (- (+ (* ,offset word-bytes)
+					    (* index ,scale)) ,lowtag)
+			    object)
+		      (inst extwl temp temp1 value))))))))))
+
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+				      &optional translate)
+  (let ((scale (ecase size (:byte 1) (:short 2))))
+    `(progn
+       (define-vop (,name)
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg))
+		(value :scs ,scs :target result))
+	 (:arg-types ,type positive-fixnum ,el-type)
+	 (:temporary (:scs (interior-reg)) lip)
+	 (:temporary (:sc non-descriptor-reg) temp)
+	 (:temporary (:sc non-descriptor-reg) temp1)
+	 (:temporary (:sc non-descriptor-reg) temp2)
+	 (:results (result :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (inst addq object index lip)
+	   ,@(when (eq size :short)
+	       '((inst addq lip index lip)))
+	   ,@(ecase size
+	       (:byte
+		`((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
+		  (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+		  (inst insbl value  temp temp2)
+		  (inst mskbl temp1 temp temp1)
+		  (inst bis temp1 temp2 temp1)
+		  (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)))
+	       (:short
+		`((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
+		  (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+		  (inst mskwl temp1 temp temp1)
+		  (inst inswl value temp temp2)
+		  (inst bis temp1 temp2 temp)
+		  (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip))))
+	   (move value result)))
+       (define-vop (,(symbolicate name "-C"))
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs ,scs :target result))
+	 (:info index)
+	 (:arg-types ,type
+		     (:constant (load/store-index ,scale
+						  ,(eval lowtag)
+						  ,(eval offset)))
+		     ,el-type)
+	 (:temporary (:sc non-descriptor-reg) temp)
+	 (:temporary (:sc non-descriptor-reg) temp1)
+	 (:temporary (:sc non-descriptor-reg) temp2)
+	 (:results (result :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   ,@(ecase size
+	       (:byte
+		`((inst lda temp (- (* ,offset word-bytes)
+				    (* index ,scale) ,lowtag)
+			object)
+		  (inst ldq_u temp1 (- (* ,offset word-bytes) 
+				       (* index ,scale) ,lowtag)
+			object)
+		  (inst insbl value temp temp2)
+		  (inst mskbl temp1 temp temp1)
+		  (inst bis temp1 temp2 temp1)
+		  (inst stq_u temp1 (- (* ,offset word-bytes)
+				       (* index ,scale) ,lowtag) object)))
+	       (:short
+		`((inst lda temp (- (* ,offset word-bytes)
+				    (* index ,scale) ,lowtag)
+			object)
+		  (inst ldq_u temp1 (- (* ,offset word-bytes)
+				       (* index ,scale) ,lowtag)
+			object)
+		  (inst mskwl temp1 temp temp1)
+		  (inst inswl value temp temp2)
+		  (inst bis temp1 temp2 temp)
+		  (inst stq_u temp (- (* ,offset word-bytes)
+				      (* index ,scale) ,lowtag) object))))
+	   (move value result))))))
diff --git a/compiler/alpha/memory.lisp b/compiler/alpha/memory.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..90854c52c527bd20cef1121414586be2db03d0df
--- /dev/null
+++ b/compiler/alpha/memory.lisp
@@ -0,0 +1,62 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/memory.lisp,v 1.1 1994/04/06 16:54:44 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the Alpha definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Sean Hallgren.
+;;; 
+
+(in-package "ALPHA")
+
+
+;;; 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.
+;;;
+(define-vop (cell-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (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 (descriptor-reg any-reg null zero)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)))
+
+;;; 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 null zero)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (storew value object (+ base offset) lowtag)))
diff --git a/compiler/alpha/move.lisp b/compiler/alpha/move.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..eeacad3c106bd3e81370bb496030d2e1f1e11d1d
--- /dev/null
+++ b/compiler/alpha/move.lisp
@@ -0,0 +1,347 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/move.lisp,v 1.1 1994/04/06 16:54:45 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the MIPS VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by Rob MacLachlan.
+;;; Conversion by Sean Hallgren.
+;;;
+(in-package "ALPHA")
+
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((null zero immediate)
+   (any-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (inst li (fixnum val) y))
+      (null
+       (move null-tn y))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst li (logior (ash (char-code val) type-bits) base-char-type)
+	     y)))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((zero immediate)
+   (signed-reg unsigned-reg))
+  (inst li (tn-value x) y))
+
+(define-move-function (load-base-char 1) (vop x y)
+  ((immediate) (base-char-reg))
+  (inst li (char-code (tn-value x)) y))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst li (sap-int (tn-value x)) y))
+
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg any-reg))
+  (loadw y code-tn (tn-offset x) other-pointer-type))
+
+(define-move-function (load-stack 5) (vop x y)
+  ((control-stack) (any-reg descriptor-reg))
+  (load-stack-tn y x))
+
+(define-move-function (load-number-stack 5) (vop x y)
+  ((base-char-stack) (base-char-reg))
+  (let ((nfp (current-nfp-tn vop)))
+    (loadw y nfp (tn-offset x))))
+
+(define-move-function (load-number-stack-64 5) (vop x y)
+  ((sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (let ((nfp (current-nfp-tn vop)))
+    (loadq y nfp (tn-offset x))))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((any-reg descriptor-reg null zero) (control-stack))
+  (store-stack-tn y x))
+
+(define-move-function (store-number-stack 5) (vop x y)
+  ((base-char-reg) (base-char-stack))
+  (let ((nfp (current-nfp-tn vop)))
+    (storew x nfp (tn-offset y))))
+
+(define-move-function (store-number-stack-64 5) (vop x y)
+  ((sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (let ((nfp (current-nfp-tn vop)))
+    (storeq x nfp (tn-offset y))))
+
+
+;;;; The Move VOP:
+;;;
+(define-vop (move)
+  (:args (x :target y
+	    :scs (any-reg descriptor-reg zero null)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg descriptor-reg control-stack)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (unless (location= x y)
+      (sc-case y
+	((any-reg descriptor-reg)
+	 (inst move x y))
+	(control-stack
+	 (store-stack-tn y x))))))
+
+(define-move-vop move :move
+  (any-reg descriptor-reg zero null)
+  (any-reg descriptor-reg))
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type.  This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;;    The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+(define-vop (move-argument)
+  (:args (x :target y
+	    :scs (any-reg descriptor-reg null zero))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg descriptor-reg)
+       (move x y))
+      (control-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg descriptor-reg null zero)
+  (any-reg descriptor-reg))
+
+
+
+;;;; ILLEGAL-MOVE
+
+;;; 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.
+
+;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
+;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
+;;;
+(define-vop (move-to-word/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:arg-types tagged-num)
+  (:note "fixnum untagging")
+  (:generator 1
+    (inst sra x 2 y)))
+;;;
+(define-move-vop move-to-word/fixnum :move
+  (any-reg descriptor-reg) (signed-reg unsigned-reg))
+
+;;; 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 (tn-value x) y)))
+;;;
+(define-move-vop move-to-word-c :move
+  (constant) (signed-reg unsigned-reg))
+
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "integer to untagged word coercion")
+  (:temporary (:sc non-descriptor-reg) header)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 3
+    (inst and x 3 temp)
+    (inst sra x 2 y)
+    (inst beq temp done)
+
+    (loadw header x 0 other-pointer-type)
+    (inst srl header (1+ type-bits) header)
+    (loadw y x bignum-digits-offset other-pointer-type)
+    (inst beq header one)
+
+    (loadw header x (1+ bignum-digits-offset) other-pointer-type)
+    (inst sll header 32 header)
+    (inst mskll y 4 y)
+    (inst bis header y y)
+    (inst br zero-tn done)
+    ONE
+    (when (sc-is y unsigned-reg)
+      (inst mskll y 4 y))
+    DONE))
+;;;
+(define-move-vop move-to-word/integer :move
+  (descriptor-reg) (signed-reg unsigned-reg))
+
+
+;;; Result is a fixnum, so we can just shift.  We need the result type
+;;; restriction because of the control-stack ambiguity noted above.
+;;;
+(define-vop (move-from-word/fixnum)
+  (:args (x :scs (signed-reg unsigned-reg)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "fixnum tagging")
+  (:generator 1
+    (inst sll x 2 y)))
+;;;
+(define-move-vop move-from-word/fixnum :move
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; Result may be a bignum, so we have to check.  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 (:sc non-descriptor-reg) header)
+  (:note "signed word to integer coercion")
+  (:generator 18
+    (move arg x)
+    (inst sra x 29 temp)
+    (inst sll x 2 y)
+    (inst beq temp done)
+    (inst not temp temp)
+    (inst beq temp done)
+
+    (inst li 2 header)
+    (inst sra x 31 temp)
+    (inst cmoveq temp 1 header)
+    (inst not temp temp)
+    (inst cmoveq temp 1 header)
+    (inst sll header type-bits header)
+    (inst bis header bignum-type header)
+      
+    (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+      (inst bis alloc-tn other-pointer-type y)
+      (storew header y 0 other-pointer-type)
+      (storew x y bignum-digits-offset other-pointer-type)
+      (inst srl x 32 temp)
+      (storew temp y (1+ bignum-digits-offset) other-pointer-type))
+    DONE))
+      
+;;;
+(define-move-vop move-from-signed :move
+  (signed-reg) (descriptor-reg))
+
+
+;;; 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 (:sc non-descriptor-reg) temp1)
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    (move arg x)
+    (inst srl x 29 temp)
+    (inst sll x 2 y)
+    (inst beq temp done)
+      
+    (inst li 3 temp)
+    (inst cmovge x 2 temp)
+    (inst srl x 31 temp1)
+    (inst cmoveq temp1 1 temp)
+    (inst sll temp type-bits temp)
+    (inst bis temp bignum-type temp)
+
+    (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+      (inst bis alloc-tn other-pointer-type y)
+      (storew temp y 0 other-pointer-type)
+      (storew x y bignum-digits-offset other-pointer-type)
+      (inst srl x 32 temp)
+      (storew temp y (1+ bignum-digits-offset) other-pointer-type))
+    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 x y)))
+;;;
+(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 (any-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 x y))
+      ((signed-stack unsigned-stack)
+       (storeq 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/alpha/nlx.lisp b/compiler/alpha/nlx.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..deba971bd16fe56b58285fdae6620fe881f15a6c
--- /dev/null
+++ b/compiler/alpha/nlx.lisp
@@ -0,0 +1,290 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/nlx.lisp,v 1.1 1994/04/06 16:54:46 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the definitions of VOPs used for non-local exit
+;;; (throw, lexical exit, etc.)
+;;;
+;;; Written by Rob MacLachlan
+;;; Conversion by Sean Hallgren
+;;;
+(in-package "ALPHA")
+
+;;; 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 *fixnum-primitive-type* immediate-arg-scn)
+   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 ()
+  (list (make-normal-tn *any-primitive-type*)
+	(make-normal-tn *any-primitive-type*)
+	(make-normal-tn *any-primitive-type*)
+	(make-normal-tn *any-primitive-type*)))
+
+(define-vop (save-dynamic-state)
+  (:results (catch :scs (descriptor-reg))
+	    (nfp :scs (descriptor-reg))
+	    (nsp :scs (descriptor-reg))
+	    (eval :scs (descriptor-reg)))
+  (:vop-var vop)
+  (:generator 13
+    (load-symbol-value catch lisp::*current-catch-block*)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst mskll cur-nfp 4 nfp)))
+    (inst mskll nsp-tn 4 nsp)
+    (load-symbol-value eval lisp::*eval-stack-top*)))
+
+(define-vop (restore-dynamic-state)
+  (:args (catch :scs (descriptor-reg))
+	 (nfp :scs (descriptor-reg))
+	 (nsp :scs (descriptor-reg))
+	 (eval :scs (descriptor-reg)))
+  (:vop-var vop)
+  (:temporary (:sc any-reg) temp)
+  (:generator 10
+    (store-symbol-value catch lisp::*current-catch-block*)
+    (store-symbol-value eval lisp::*eval-stack-top*)
+    (inst mskll nsp-tn 0 temp)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst bis nfp temp cur-nfp)))
+    (inst bis nsp temp nsp-tn)))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move csp-tn res)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move bsp-tn res)))
+
+
+
+;;;; Unwind block hackery:
+
+;;; 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 (any-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 22
+    (inst lda block (* (tn-offset tn) vm:word-bytes) cfp-tn)
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block vm:unwind-block-current-uwp-slot)
+    (storew cfp-tn block vm:unwind-block-current-cont-slot)
+    (storew code-tn block vm:unwind-block-current-code-slot)
+    (inst compute-lra-from-code temp code-tn entry-label ndescr)
+    (storew temp block vm:catch-block-entry-pc-slot)))
+
+
+;;; 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 (any-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 44
+    (inst lda result (* (tn-offset tn) vm:word-bytes) cfp-tn)
+    (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 ndescr)
+    (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 result block)))
+
+
+;;; 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 lda new-uwp (* (tn-offset tn) vm:word-bytes) cfp-tn)
+    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
+
+
+(define-vop (unlink-catch-block)
+  (:temporary (:scs (any-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*)))
+
+(define-vop (unlink-unwind-protect)
+  (:temporary (:scs (any-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:
+
+
+(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)
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:info label nvals)
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)
+    (cond ((zerop nvals))
+	  ((= nvals 1)
+	   (let ((no-values (gen-label)))
+	     (move null-tn (tn-ref-tn values))
+	     (inst beq count no-values)
+	     (loadw (tn-ref-tn values) start)
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (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 move count temp)
+		 (inst lda count (fixnum -1) count)
+		 (inst beq temp default-lab)
+		 (sc-case tn
+			  ((descriptor-reg any-reg)
+			   (loadw tn start i))
+			  (control-stack
+			   (loadw move-temp start i)
+			   (store-stack-tn tn move-temp)))))
+	     
+	     (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 null-tn tn))
+			      (control-stack
+			       (store-stack-tn tn null-tn)))))
+		 (inst br zero-tn defaulting-done))))))
+    (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+  (:args (top :target dst) (start :target src) (count :target num))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (: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)
+  (:vop-var vop)
+  (:generator 30
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+
+      ;; Copy args.
+      (load-stack-tn dst top)
+      (move start src)
+      (move count num)
+
+      ;; Establish results.
+      (sc-case new-start
+	(any-reg (move dst new-start))
+	(control-stack (store-stack-tn new-start dst)))
+      (sc-case new-count
+	(any-reg (inst move num new-count))
+	(control-stack (store-stack-tn new-count num)))
+      (inst beq num done)
+
+      ;; Copy stuff on stack.
+      (emit-label loop)
+      (loadw temp src)
+      (inst lda src vm:word-bytes src)
+      (storew temp dst)
+      (inst lda num (fixnum -1) num)
+      (inst lda dst vm:word-bytes dst)
+      (inst bne num loop)
+
+      (emit-label done)
+      (inst move dst csp-tn))))
+
+
+;;; 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)
+  (:vop-var vop)
+  (:generator 0
+    (emit-return-pc label)
+    (note-this-location vop :non-local-entry)))
diff --git a/compiler/alpha/parms.lisp b/compiler/alpha/parms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3e025139d08f4cc0da0d4005837395f147bd0a4b
--- /dev/null
+++ b/compiler/alpha/parms.lisp
@@ -0,0 +1,214 @@
+;;; -*- Package: alpha -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/parms.lisp,v 1.1 1994/04/06 16:54:47 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains some parameterizations of various VM
+;;; attributes for the Apha.  This file is separate from other stuff so 
+;;; that it can be compiled and loaded earlier. 
+;;;
+;;; Written by William Lott.
+;;; Alpha conversion by Sean Hallgren.
+;;;
+
+(in-package :alpha)
+(use-package :c)
+
+
+;;;; Compiler constants.
+
+(eval-when (compile eval load)
+
+(setf (backend-name *target-backend*) "ALPHA")
+(setf (backend-version *target-backend*) "Alpha")
+(setf (backend-fasl-file-type *target-backend*) "axpf")
+(setf (backend-fasl-file-implementation *target-backend*)
+      alpha-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) 2)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :little-endian)
+(setf (backend-page-size *target-backend*) 8192)
+
+); eval-when
+
+
+;;;; Machine Architecture parameters:
+
+(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+
+	  single-float-bias single-float-exponent-byte
+	  single-float-significand-byte single-float-normal-exponent-min
+	  single-float-normal-exponent-max single-float-hidden-bit
+	  single-float-trapping-nan-bit single-float-digits
+
+	  double-float-bias double-float-exponent-byte
+	  double-float-significand-byte double-float-normal-exponent-min
+	  double-float-normal-exponent-max double-float-hidden-bit
+	  double-float-trapping-nan-bit double-float-digits
+
+	  float-underflow-trap-bit float-overflow-trap-bit
+	  float-imprecise-trap-bit float-invalid-trap-bit
+	  float-divide-by-zero-trap-bit))
+
+	  
+
+(eval-when (compile load eval)
+
+(defconstant word-bits 32
+  "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.")
+
+(defconstant float-sign-shift 31)
+
+(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 1)
+(defconstant single-float-normal-exponent-max 254)
+(defconstant single-float-hidden-bit (ash 1 23))
+(defconstant single-float-trapping-nan-bit (ash 1 22))
+
+(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 1)
+(defconstant double-float-normal-exponent-max #x7FE)
+(defconstant double-float-hidden-bit (ash 1 20))
+(defconstant double-float-trapping-nan-bit (ash 1 19))
+
+(defconstant single-float-digits
+  (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+  (+ (byte-size double-float-significand-byte) word-bits 1))
+
+(defconstant float-inexact-trap-bit (ash 1 0))
+(defconstant float-underflow-trap-bit (ash 1 1))
+(defconstant float-overflow-trap-bit (ash 1 2))
+(defconstant float-divide-by-zero-trap-bit (ash 1 3))
+(defconstant float-invalid-trap-bit (ash 1 4))
+
+(defconstant float-round-to-nearest 0)
+(defconstant float-round-to-zero 1)
+(defconstant float-round-to-positive 2)
+(defconstant float-round-to-negative 3)
+
+(defconstant float-rounding-mode (byte 2 7))
+(defconstant float-sticky-bits (byte 5 27))
+(defconstant float-traps-byte (byte 5 0))
+(defconstant float-exceptions-byte (byte 5 27))
+(defconstant float-condition-bit (ash 1 26))
+(defconstant float-fast-bit 0)			  ; No fast mode on HPPA.
+
+); eval-when
+
+
+
+;;;; Description of the target address space.
+
+(export '(target-read-only-space-start
+	  target-static-space-start
+	  target-dynamic-space-start))
+
+;;; Where to put the different spaces.
+;;; 
+(defparameter target-read-only-space-start #x20000000)
+(defparameter target-static-space-start    #x28000000)
+(defparameter target-dynamic-space-start   #x30000000)
+
+;; The space-register holding the lisp heap.
+(defconstant lisp-heap-space 4)
+
+;; The space-register holding the C text segment.
+(defconstant c-text-space 4)
+
+
+;;;; Other random constants.
+
+(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
+	  breakpoint-trap function-end-breakpoint-trap single-step-breakpoint
+	  trace-table-normal trace-table-call-site
+	  trace-table-function-prologue trace-table-function-epilogue))
+
+(defenum (:suffix -trap :start 8)
+  halt
+  pending-interrupt
+  error
+  cerror
+  breakpoint
+  function-end-breakpoint
+  single-step-breakpoint)
+
+(defenum (:prefix trace-table-)
+  normal
+  call-site
+  function-prologue
+  function-epilogue)
+
+
+
+;;;; Static symbols.
+
+(export '(static-symbols static-functions))
+
+;;; 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 fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols.  That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
+;;;
+(defparameter static-symbols
+  '(t
+
+    ;; The C startup code must fill these in.
+    lisp::lisp-environment-list
+    lisp::lisp-command-line-list
+    lisp::*initial-fdefn-objects*
+
+    ;; Functions that the C code needs to call
+    lisp::%initial-function
+    lisp::maybe-gc
+    kernel::internal-error
+    di::handle-breakpoint
+    di::handle-function-end-breakpoint
+    lisp::fdefinition-object
+
+    ;; Free Pointers.
+    lisp::*read-only-space-free-pointer*
+    lisp::*static-space-free-pointer*
+    lisp::*initial-dynamic-space-free-pointer*
+
+    ;; Things needed for non-local-exit.
+    lisp::*current-catch-block*
+    lisp::*current-unwind-protect-block*
+    *eval-stack-top*
+
+    ;; Interrupt Handling
+    lisp::*free-interrupt-context-index*
+    unix::*interrupts-enabled*
+    unix::*interrupt-pending*
+    ))
+
+(defparameter static-functions
+  '(length
+    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql
+    %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm
+    ))
diff --git a/compiler/alpha/pred.lisp b/compiler/alpha/pred.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e5a47067c9dd5b886a5b59b60c3e5110f6a44229
--- /dev/null
+++ b/compiler/alpha/pred.lisp
@@ -0,0 +1,49 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/pred.lisp,v 1.1 1994/04/06 16:54:48 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of predicate VOPs for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Sean Hallgren.
+;;; 
+
+(in-package "ALPHA")
+
+
+;;;; The Branch VOP.
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination.  Dest is the continuation we transfer control to.
+;;;
+(define-vop (branch)
+  (:info dest)
+  (:generator 5
+    (inst br zero-tn dest)))
+
+
+;;;; Conditional VOPs:
+
+(define-vop (if-eq)
+  (:args (x :scs (any-reg descriptor-reg zero null))
+	 (y :scs (any-reg descriptor-reg zero null)))
+  (:conditional)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:translate eq)
+  (:generator 3
+    (inst cmpeq x y temp)
+    (if not-p
+	(inst beq temp target)
+	(inst bne temp target))))
diff --git a/compiler/alpha/print.lisp b/compiler/alpha/print.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..998f28edb6db87b4a6e404323596a06df6dfbce1
--- /dev/null
+++ b/compiler/alpha/print.lisp
@@ -0,0 +1,42 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/print.lisp,v 1.1 1994/04/06 16:54:48 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains temporary printing utilities and similar noise.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+
+(in-package "ALPHA")
+
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg) :target a0))
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
+	      cfunc)
+  (:temporary (:sc descriptor-reg :offset nl0-offset :from (:argument 0)) a0)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:vop-var vop)
+  (:generator 0
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (move object a0)
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (inst li (make-fixup "debug_print" :foreign) cfunc)
+      (inst li (make-fixup "call_into_c" :foreign) temp)
+      (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
+      (when cur-nfp
+	(maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
+      (move cfunc result))))
diff --git a/compiler/alpha/sap.lisp b/compiler/alpha/sap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b07a4fed59382bacc489df40c96eb5d9dc8a5965
--- /dev/null
+++ b/compiler/alpha/sap.lisp
@@ -0,0 +1,389 @@
+;;; -*- Package: VM; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/sap.lisp,v 1.1 1994/04/06 16:54:51 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the Alpha VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;; Alpha conversion by Sean Hallgren.
+;;;
+(in-package "ALPHA")
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+
+(define-vop (move-to-sap)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:note "system area pointer indirection")
+  (:generator 1
+    (loadq y x sap-pointer-slot other-pointer-type)))
+
+;;;
+(define-move-vop move-to-sap :move
+  (descriptor-reg) (sap-reg))
+
+
+;;; Move an untagged SAP to a tagged representation.
+;;;
+(define-vop (move-from-sap)
+  (:args (x :scs (sap-reg) :target sap))
+  (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (y :scs (descriptor-reg)))
+  (:note "system area pointer allocation")
+  (:generator 20
+    (move x sap)
+    (with-fixed-allocation (y ndescr sap-type sap-size)
+      (storeq sap y sap-pointer-slot other-pointer-type))))
+;;;
+(define-move-vop move-from-sap :move
+  (sap-reg) (descriptor-reg))
+
+
+;;; Move untagged sap values.
+;;;
+(define-vop (sap-move)
+  (:args (x :target y
+	    :scs (sap-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (sap-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move x y)))
+;;;
+(define-move-vop sap-move :move
+  (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+  (:args (x :target y
+	    :scs (sap-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move x y))
+      (sap-stack
+       (storeq 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 sap int)))
+
+(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 int sap)))
+
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg))
+	 (offset :scs (signed-reg immediate)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (sc-case offset
+      (signed-reg
+       (inst addq offset ptr res))
+      (immediate
+       (inst lda res (tn-value offset) ptr)))))
+
+(define-vop (pointer-)
+  (:translate sap-)
+  (:args (ptr1 :scs (sap-reg))
+	 (ptr2 :scs (sap-reg)))
+  (:arg-types system-area-pointer system-area-pointer)
+  (:policy :fast-safe)
+  (:results (res :scs (signed-reg)))
+  (:result-types signed-num)
+  (:generator 1
+    (inst subq ptr1 ptr2 res)))
+
+
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(eval-when (compile eval)
+
+(defmacro def-system-ref-and-set
+	  (ref-name set-name sc type size &optional signed)
+  (let ((ref-name-c (symbolicate ref-name "-C"))
+	(set-name-c (symbolicate set-name "-C")))
+    `(progn
+       (define-vop (,ref-name)
+		   (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg) :target sap)
+		(offset :scs (unsigned-reg)))
+	 (:arg-types system-area-pointer unsigned-num)
+	 ,@(when (or (eq size :byte) (eq size :short))
+	     `((:temporary (:sc non-descriptor-reg) temp)
+	       (:temporary (:sc non-descriptor-reg) temp1)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+	 (:generator 5
+           (inst addq object offset sap)
+	   ,@(ecase size
+	       (:byte
+		(if signed
+		    '((inst ldq_u temp 0 sap)
+		      (inst lda temp1 1 sap)
+		      (inst extqh temp temp1 temp)
+		      (inst sra temp 56 result))
+		    '((inst ldq_u temp 0 sap)
+		      (inst lda temp1 0 sap)
+		      (inst extbl temp temp1 result))))
+	       (:short
+		(if signed
+		    '((inst ldq_u temp 0 sap)
+		      (inst lda temp1 0 sap)
+		      (inst extwl temp temp1 temp)
+		      (inst sll temp 48 temp)
+		      (inst sra temp 48 result))
+		    '((inst ldq_u temp 0 sap)
+		      (inst lda temp1 0 sap)
+		      (inst extwl temp temp1 result))))
+	       (:long
+		`((inst ldl result 0 sap)
+		  ,@(unless signed
+		      '((inst mskll result 4 result)))))
+	       (:quad
+		'((inst ldq result 0 sap)))
+	       (:single
+		'((inst lds result 0 sap)))
+	       (:double
+		'((inst ldt result 0 sap))))))
+       (define-vop (,ref-name-c)
+		   (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg)))
+	 (:arg-types system-area-pointer
+		     (:constant ,(if (eq size :double)
+				     ;; We need to be able to add 4.
+				     `(integer ,(- (ash 1 16))
+					       ,(- (ash 1 16) 5))
+				     '(signed-byte 16))))
+	 ,@(when (or (eq size :byte) (eq size :short))
+	     `((:temporary (:scs (non-descriptor-reg)) temp)
+	       (:temporary (:sc non-descriptor-reg) temp1)))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+           ,@(ecase size
+	       (:byte
+		(if signed
+		    '((inst ldq_u temp offset object)
+		      (inst lda temp1 (1+ offset) object)
+		      (inst extqh temp temp1 temp)
+		      (inst sra temp 56 result))
+		    '((inst ldq_u temp offset object)
+		      (inst lda temp1 offset object)
+		      (inst extbl temp temp1 result))))
+	       (:short
+		(if signed
+		    '((inst ldq_u temp offset object)
+		      (inst lda temp1 offset object)
+		      (inst extwl temp temp1 temp)
+		      (inst sll temp 48 temp)
+		      (inst sra temp 48 result))
+		    '((inst ldq_u temp offset object)
+		      (inst lda temp1 offset object)
+		      (inst extwl temp temp1 result))))
+	       (:long
+		`((inst ldl result offset object)
+		  ,@(unless signed
+		      '((inst mskll result 4 result)))))
+	       (:quad
+		'((inst ldq result offset object)))
+	       (:single
+		'((inst lds result offset object)))
+	       (:double
+		'((inst ldt result (+ offset word-bytes) object))))))
+       (define-vop (,set-name)
+		   (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg) :target sap)
+		(offset :scs (unsigned-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer unsigned-num ,type)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+	 ,@(when (or (eq size :byte) (eq size :short))
+	     `((:temporary (:sc non-descriptor-reg) temp)
+	       (:temporary (:sc non-descriptor-reg) temp1)
+	       (:temporary (:sc non-descriptor-reg) temp2)))
+	 (:generator 5
+           (inst addq object offset sap)
+	   ,@(ecase size
+	       (:byte
+		'((inst lda temp 0 sap)
+		  (inst ldq_u temp1 0 sap)
+		  (inst insbl value temp temp2)
+		  (inst mskbl temp1 temp temp1)
+		  (inst bis temp1 temp2 temp1)
+		  (inst stq_u temp1 0 sap)
+		  (inst move value result)))
+	       (:short
+		'((inst lda temp 0 sap)
+		  (inst ldq_u temp1 0 sap)
+		  (inst mskwl temp1 temp temp1)
+		  (inst inswl value temp temp2)
+		  (inst bis temp1 temp2 temp)
+		  (inst stq_u temp 0 sap)
+		  (inst move value result)))
+	       (:long
+		'((inst stl value 0 sap)
+		  (move value result)))
+	       (:quad
+		'((inst stq value 0 sap)
+		  (move value result)))
+	       (:single
+		'((unless (location= result value)
+		    (inst fmove value result))
+		  (inst sts value 0 sap)))
+	       (:double
+		'((unless (location= result value)
+		    (inst fmove value result))
+		  (inst stt value 0 sap))))))
+       (define-vop (,set-name-c)
+		   (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (object :scs (sap-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer
+		     (:constant ,(if (eq size :double)
+				     ;; We need to be able to add 4.
+				     `(integer ,(- (ash 1 16))
+					       ,(- (ash 1 16) 5))
+				     '(signed-byte 16)))
+		     ,type)
+	 ,@(when (or (eq size :byte) (eq size :short))
+	     `((:temporary (:sc non-descriptor-reg) temp)
+	       (:temporary (:sc non-descriptor-reg) temp1)
+	       (:temporary (:sc non-descriptor-reg) temp2)))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+           ,@(ecase size
+	       (:byte
+		'((inst lda temp offset object)
+		  (inst ldq_u temp1 offset object)
+		  (inst insbl value temp temp2)
+		  (inst mskbl temp1 temp temp1)
+		  (inst bis temp1 temp2 temp1)
+		  (inst stq_u temp1 offset object)
+		  (inst move value result)))
+	       (:short
+		'((inst lda temp offset object)
+		  (inst ldq_u temp1 offset object)
+		  (inst mskwl temp1 temp temp1)
+		  (inst inswl value temp temp2)
+		  (inst bis temp1 temp2 temp)
+		  (inst stq_u temp offset object)
+		  (inst move value result)))
+	       (:long
+		'((inst stl value offset object)
+		  (move value result)))
+	       (:quad
+		'((inst stq value offset object)
+		  (move value result)))
+	       (:single
+		'((unless (location= result value)
+		    (inst fmove value result))
+		  (inst sts value offset object)))
+	       (:double
+		'((unless (location= result value)
+		    (inst fmove value result))
+		  (inst stt value offset object)))))))))
+
+); eval-when (compile eval)
+
+(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+  unsigned-reg positive-fixnum :byte nil)
+(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+  signed-reg tagged-num :byte t)
+(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+  unsigned-reg positive-fixnum :short nil)
+(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+  signed-reg tagged-num :short t)
+(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+  unsigned-reg unsigned-num :long nil)
+(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+  signed-reg signed-num :long t)
+(def-system-ref-and-set sap-ref-64 %set-sap-ref-64
+  unsigned-reg unsigned-num :quad nil)
+(def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
+  signed-reg signed-num :quad t)
+(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+  sap-reg system-area-pointer :quad)
+(def-system-ref-and-set sap-ref-single %set-sap-ref-single
+  single-reg single-float :single)
+(def-system-ref-and-set sap-ref-double %set-sap-ref-double
+  double-reg double-float :double)
+
+
+;;; 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 lda sap
+	  (- (* vector-data-offset word-bytes) other-pointer-type)
+	  vector)))
diff --git a/compiler/alpha/static-fn.lisp b/compiler/alpha/static-fn.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a508806a14f04e4be716e1dec95d6dee8b54da41
--- /dev/null
+++ b/compiler/alpha/static-fn.lisp
@@ -0,0 +1,148 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/static-fn.lisp,v 1.1 1994/04/06 16:54:52 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+(in-package "ALPHA")
+
+
+
+(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 interior-reg :offset lip-offset) entry-point)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
+  (: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 (src dst)
+  (collect ((moves))
+    (do ((dst dst (cdr dst))
+	 (src src (cdr src)))
+	((or (null dst) (null src)))
+      (moves `(move ,(car src) ,(car dst))))
+    (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 null zero)
+		  :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 (arg-names) (temp-names))
+	     (inst li (fixnum ,num-args) nargs)
+	     (inst ldl entry-point (static-function-offset symbol) null-tn)
+	     (when cur-nfp
+	       (store-stack-tn nfp-save cur-nfp))
+	     (inst move cfp-tn ocfp)
+	     (inst compute-lra-from-code lra code-tn lra-label temp)
+	     (note-this-location vop :call-site)
+	     (inst move csp-tn cfp-tn)
+	     (inst jsr zero-tn entry-point)
+	     (emit-return-pc lra-label)
+	     ,(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 vop
+		       ,(if (zerop num-results) nil 'values)
+		       ,num-results move-temp temp lra-label)))
+	     (when cur-nfp
+	       (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
+	     ,@(moves (temp-names) (result-names))))))))
+
+
+) ; eval-when (compile load eval)
+
+
+(expand
+ (collect ((templates (list 'progn)))
+   (dotimes (i register-arg-count)
+     (templates (static-function-template-vop i 1)))
+   (templates)))
+
+
+(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/alpha/subprim.lisp b/compiler/alpha/subprim.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..4ec7ef5b0bc489939c53950dfbce7b70aac9d2d4
--- /dev/null
+++ b/compiler/alpha/subprim.lisp
@@ -0,0 +1,64 @@
+;;; -*- Package: ALPHA; 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 or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/subprim.lisp,v 1.1 1994/04/06 16:54:56 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;; 
+(in-package "ALPHA")
+
+
+
+;;;; 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)) 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
+    (move object ptr)
+    (move zero-tn count)
+    
+    LOOP
+    
+    (inst cmpeq ptr null-tn temp)
+    (inst bne temp done)
+    
+    (inst and ptr lowtag-mask temp)
+    (inst xor temp list-pointer-type temp)
+    (inst bne temp not-list)
+    
+    (loadw ptr ptr cons-cdr-slot list-pointer-type)
+    (inst addq count (fixnum 1) count)
+    (inst br zero-tn loop)
+    
+    NOT-LIST
+    (cerror-call vop done object-not-list-error ptr)
+    
+    DONE
+    (move count result)))
+       
+
+(define-static-function length (object) :translate length)
+
+
+
diff --git a/compiler/alpha/system.lisp b/compiler/alpha/system.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d85af3406729d52a9092490c7a2254d66a1bdd1c
--- /dev/null
+++ b/compiler/alpha/system.lisp
@@ -0,0 +1,254 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/system.lisp,v 1.1 1994/04/06 16:54:57 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Alpha VM definitions of various system hacking operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Mips conversion by William Lott and Christopher Hoover.
+;;; Alpha conversion by Sean Hallgren.
+;;;
+(in-package "ALPHA")
+
+
+;;;; 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 and object lowtag-mask result)))
+
+(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
+    ;; Pick off objects with headers.
+    (inst and object lowtag-mask result)
+    (inst cmpeq result other-pointer-type ndescr)
+    (inst bne ndescr other-ptr)
+    (inst cmpeq result function-pointer-type ndescr)
+    (inst bne ndescr function-ptr)
+
+    ;; Pick off structure and list pointers.
+    (inst blbs object done)
+
+    ;; Pick off fixnums.
+    (inst and object 3 result)
+    (inst beq result done)
+
+    ;; Must be an other immediate.
+    (inst and object type-mask result)
+    (inst br zero-tn done)
+
+    FUNCTION-PTR
+    (load-type result object (- function-pointer-type))
+    (inst br zero-tn done)
+
+    OTHER-PTR
+    (load-type result object (- other-pointer-type))
+      
+    DONE))
+
+(define-vop (function-subtype)
+  (:translate function-subtype)
+  (:policy :fast-safe)
+  (:args (function :scs (descriptor-reg)))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (load-type result function (- function-pointer-type))))
+
+(define-vop (set-function-subtype)
+  (:translate (setf function-subtype))
+  (:policy :fast-safe)
+  (:args (type :scs (unsigned-reg) :target result)
+	 (function :scs (descriptor-reg)))
+  (:arg-types positive-fixnum *)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (inst ldl temp (- function-pointer-type) function)
+    (inst and temp #xff temp)
+    (inst bis type temp temp)
+    (inst stl temp (- function-pointer-type) function)
+    (move type result)))
+
+
+(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 6
+    (loadw res x 0 other-pointer-type)
+    (inst srl res type-bits res)))
+
+(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 6
+    (loadw res x 0 function-pointer-type)
+    (inst srl res type-bits res)))
+
+(define-vop (set-header-data)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res)
+	 (data :scs (any-reg immediate zero)))
+  (:arg-types * positive-fixnum)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) t1 t2)
+  (:generator 6
+    (loadw t1 x 0 other-pointer-type)
+    (inst and t1 type-mask t1)
+    (sc-case data
+      (any-reg
+       (inst sll data (- type-bits 2) t2)
+       (inst bis t1 t2 t1))
+      (immediate
+       (let ((c (ash (tn-value data) type-bits)))
+	 (cond ((<= 0 c (1- (ash 1 8)))
+		(inst bis t1 c t1))
+	       (t
+		(inst li c t2)
+		(inst bis t1 t2 t1)))))
+      (zero))
+    (storew t1 x 0 other-pointer-type)
+    (move x res)))
+
+(define-vop (c::make-fixnum)
+  (:args (ptr :scs (any-reg descriptor-reg)))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    ;;
+    ;; Some code (the hash table code) depends on this returning a
+    ;; positive number so make sure it does.
+    (inst sll ptr 35 res)
+    (inst srl res 33 res)))
+
+(define-vop (c::make-other-immediate-type)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (type :scs (any-reg descriptor-reg immediate)
+	       :target temp))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 2
+    (sc-case type
+      ((immediate)
+       (inst sll val type-bits temp)
+       (inst bis temp (tn-value type) res))
+      (t
+       (inst sra type 2 temp)
+       (inst sll val (- type-bits 2) res)
+       (inst bis res temp res)))))
+
+
+;;;; 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 1
+    (move alloc-tn int)))
+
+(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 1
+    (move bsp-tn int)))
+
+(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 csp-tn int)))
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+  (:translate code-instructions)
+  (:policy :fast-safe)
+  (:args (code :scs (descriptor-reg)))
+  (: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 srl ndescr type-bits ndescr)
+    (inst sll ndescr word-shift ndescr)
+    (inst subq ndescr other-pointer-type ndescr)
+    (inst addq code ndescr sap)))
+
+(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 srl ndescr type-bits ndescr)
+    (inst sll ndescr word-shift ndescr)
+    (inst addq ndescr offset ndescr)
+    (inst subq ndescr (- other-pointer-type function-pointer-type) ndescr)
+    (inst addq code ndescr func)))
+
+
+;;;; Other random VOPs.
+
+
+(defknown unix::do-pending-interrupt () (values))
+(define-vop (unix::do-pending-interrupt)
+  (:policy :fast-safe)
+  (:translate unix::do-pending-interrupt)
+  (:generator 1
+    (inst gentrap pending-interrupt-trap)))
+
+
+(define-vop (halt)
+  (:generator 1
+    (inst gentrap halt-trap)))
+
+
+;;;; Dynamic vop count collection support
+
+(define-vop (count-me)
+  (:args (count-vector :scs (descriptor-reg)))
+  (:info index)
+  (:temporary (:scs (non-descriptor-reg)) count)
+  (:generator 1
+    (let ((offset
+	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
+      (inst ldl count offset count-vector)
+      (inst addq count 1 count)
+      (inst stl count offset count-vector))))
diff --git a/compiler/alpha/type-vops.lisp b/compiler/alpha/type-vops.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5222dbc0c821e236946fa7ceef6ffbb4c09ad398
--- /dev/null
+++ b/compiler/alpha/type-vops.lisp
@@ -0,0 +1,545 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/type-vops.lisp,v 1.1 1994/04/06 16:54:57 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the MIPS.
+;;;
+;;; Written by William Lott
+;;; Earlier versions by Rob MacLachlan and Christopher Hoover.
+;;; Alpha conversion by Sean Hallgren
+;;;
+(in-package "ALPHA")
+
+
+
+;;;; Test generation utilities.
+
+(eval-when (compile eval)
+
+(defparameter immediate-types
+  (list unbound-marker-type base-char-type))
+
+(defparameter function-header-types
+  (list funcallable-instance-header-type dylan-function-header-type
+	byte-code-function-type byte-code-closure-type
+	function-header-type closure-function-header-type
+	closure-header-type))
+
+(defun canonicalize-headers (headers)
+  (collect ((results))
+    (let ((start nil)
+	  (prev nil)
+	  (delta (- other-immediate-1-type other-immediate-0-type)))
+      (flet ((emit-test ()
+	       (results (if (= start prev)
+			    start
+			    (cons start prev)))))
+	(dolist (header (sort headers #'<))
+	  (cond ((null start)
+		 (setf start header)
+		 (setf prev header))
+		((= header (+ prev delta))
+		 (setf prev header))
+		(t
+		 (emit-test)
+		 (setf start header)
+		 (setf prev header))))
+	(emit-test)))
+    (results)))
+
+(defmacro test-type (value temp target not-p &rest type-codes)
+  ;; Determine what interesting combinations we need to test for.
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (fixnump (and (member even-fixnum-type type-codes)
+		       (member odd-fixnum-type type-codes)
+		       t))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended immediate-types :test #'eql))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p (if (intersection headers function-header-types)
+			 (if (subsetp headers function-header-types)
+			     t
+			     (error "Can't test for mix of function subtypes ~
+				     and normal header types."))
+			 nil)))
+    (unless type-codes
+      (error "Must supply at least on type for test-type."))
+    (cond
+     (fixnump
+      (when (remove-if #'(lambda (x)
+			   (or (= x even-fixnum-type)
+			       (= x odd-fixnum-type)))
+		       lowtags)
+	(error "Can't mix fixnum testing with other lowtags."))
+      (when function-p
+	(error "Can't mix fixnum testing with function subtype testing."))
+      (when immediates
+	(error "Can't mix fixnum testing with other immediates."))
+      (if headers
+	  `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
+				     ',(canonicalize-headers headers))
+	  `(%test-fixnum ,value ,temp ,target ,not-p)))
+     (immediates
+      (when headers
+	(error "Can't mix testing of immediates with testing of headers."))
+      (when lowtags
+	(error "Can't mix testing of immediates with testing of lowtags."))
+      (when (cdr immediates)
+	(error "Can't test multiple immediates at the same time."))
+      `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
+     (lowtags
+      (when (cdr lowtags)
+	(error "Can't test multiple lowtags at the same time."))
+      (if headers
+	  `(%test-lowtag-and-headers
+	    ,value ,temp ,target ,not-p ,(car lowtags)
+	    ,function-p ',(canonicalize-headers headers))
+	  `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
+     (headers
+      `(%test-headers ,value ,temp ,target ,not-p ,function-p
+		      ',(canonicalize-headers headers)))
+     (t
+      (error "Nothing to test?")))))
+
+); eval-when (compile eval)
+
+(defun %test-fixnum (value temp target not-p)
+  (assemble ()
+    (inst and value 3 temp)
+    (if not-p
+	(inst bne temp target)
+	(inst beq temp target))))
+
+(defun %test-fixnum-and-headers (value temp target not-p headers)
+  (let ((drop-through (gen-label)))
+    (assemble ()
+      (inst and value 3 temp)
+      (inst beq temp (if not-p drop-through target)))
+    (%test-headers value temp target not-p nil headers drop-through)))
+
+(defun %test-immediate (value temp target not-p immediate)
+  (assemble ()
+    (inst and value 255 temp)
+    (inst xor temp immediate temp)
+    (if not-p
+	(inst bne temp target)
+	(inst beq temp target))))
+
+(defun %test-lowtag (value temp target not-p lowtag)
+  (assemble ()
+    (inst and value lowtag-mask temp)
+    (inst xor temp lowtag temp)
+    (if not-p
+	(inst bne temp target)
+	(inst beq temp target))))
+
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+				       function-p headers)
+  (let ((drop-through (gen-label)))
+    (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
+    (%test-headers value temp target not-p function-p headers drop-through)))
+
+(defun %test-headers (value temp target not-p function-p headers
+			    &optional (drop-through (gen-label)))
+  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+    (multiple-value-bind
+	(when-true when-false)
+	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
+	;; we know it's true and when we know it's false respectively.
+	(if not-p
+	    (values drop-through target)
+	    (values target drop-through))
+      (assemble ()
+	(%test-lowtag value temp when-false t lowtag)
+	(load-type temp value (- lowtag))
+	(let ((delta 0))
+	  (do ((remaining headers (cdr remaining)))
+	      ((null remaining))
+	    (let ((header (car remaining))
+		  (last (null (cdr remaining))))
+	      (cond
+	       ((atom header)
+		(inst subq temp (- header delta) temp)
+		(setf delta header)
+		(if last
+		    (if not-p
+			(inst bne temp target)
+			(inst beq temp target))
+		    (inst beq temp when-true)))
+	       (t
+		(let ((start (car header))
+		      (end (cdr header)))
+		  (unless (= start bignum-type)
+		    (inst subq temp (- start delta) temp)
+		    (setf delta start)
+		    (inst blt temp when-false))
+		  (inst subq temp (- end delta) temp)
+		  (setf delta end)
+		  (if last
+		      (if not-p
+			  (inst bgt temp target)
+			  (inst ble temp target))
+		      (inst ble temp when-true))))))))
+	(emit-label drop-through)))))
+
+
+
+;;;; Type checking and testing:
+
+(define-vop (check-type)
+  (:args (value :target result :scs (any-reg descriptor-reg)))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe))
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+				   &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value temp target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value temp err-lab t ,@type-codes)
+		   (move value result))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+); eval-when (compile eval)
+
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+  even-fixnum-type odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+  object-not-function-error function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+  list-pointer-type)
+
+(def-type-vops %instancep check-instance instance object-not-instance-error
+  instance-pointer-type)
+
+(def-type-vops bignump check-bignum bignum
+  object-not-bignum-error bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error ratio-type)
+
+(def-type-vops complexp check-complex complex
+  object-not-complex-error complex-type)
+
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+  check-simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-2
+  object-not-simple-array-unsigned-byte-2-error
+  simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+  check-simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-4
+  object-not-simple-array-unsigned-byte-4-error
+  simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+  check-simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-8
+  object-not-simple-array-unsigned-byte-8-error
+  simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+  check-simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-16
+  object-not-simple-array-unsigned-byte-16-error
+  simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+  check-simple-array-unsigned-byte-32
+  simple-array-unsigned-byte-32
+  object-not-simple-array-unsigned-byte-32-error
+  simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+  simple-array-single-float object-not-simple-array-single-float-error
+  simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+  simple-array-double-float object-not-simple-array-double-float-error
+  simple-array-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  #-gengc 0 #+gengc scavenger-hook-type)
+
+(def-type-vops code-component-p nil nil nil
+  code-header-type)
+
+(def-type-vops lra-p nil nil nil
+  #-gengc return-pc-header-type #+gengc 0)
+
+(def-type-vops fdefn-p nil nil nil
+  fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+  funcallable-instance-header-type)
+
+(def-type-vops dylan::dylan-function-p nil nil nil
+  dylan-function-header-type)
+
+(def-type-vops array-header-p nil nil nil
+  simple-array-type complex-string-type complex-bit-vector-type
+  complex-vector-type complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil
+  object-not-function-or-symbol-error
+  function-pointer-type symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  simple-string-type complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  simple-bit-vector-type complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  simple-string-type simple-bit-vector-type simple-vector-type
+  simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+  simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+  simple-array-unsigned-byte-32-type simple-array-single-float-type
+  simple-array-double-float-type complex-string-type
+  complex-bit-vector-type complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type
+  complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  even-fixnum-type odd-fixnum-type bignum-type ratio-type
+  single-float-type double-float-type complex-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  single-float-type double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type
+  single-float-type double-float-type)
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(defun signed-byte-32-test (value temp temp1 not-p target not-target)
+  (multiple-value-bind
+      (yep nope)
+      (if not-p
+	  (values not-target target)
+	  (values target not-target))
+    (assemble ()
+      (inst and value 3 temp)
+      (inst beq temp yep)
+      (inst and value lowtag-mask temp)
+      (inst xor temp other-pointer-type temp)
+      (inst bne temp nope)
+      (loadw temp value 0 other-pointer-type)
+      (inst li (+ (ash 1 type-bits) bignum-type) temp1)
+      (inst xor temp temp1 temp)
+      (if not-p
+	  (inst bne temp target)
+	  (inst beq temp target))))
+  (undefined-value))
+
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:temporary (:scs (non-descriptor-reg)) temp1)
+  (:generator 45
+    (signed-byte-32-test value temp temp1 not-p target not-target)
+    NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:temporary (:scs (non-descriptor-reg)) temp1)
+  (:generator 45
+    (let ((loose (generate-error-code vop object-not-signed-byte-32-error
+				      value)))
+      (signed-byte-32-test value temp temp1 t loose okay))
+    OKAY
+    (move value result)))
+
+;;; 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.
+
+(defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
+  (multiple-value-bind (yep nope)
+		       (if not-p
+			   (values not-target target)
+			   (values target not-target))
+    (assemble ()
+      ;; Is it a fixnum?
+      (inst and value 3 temp1)
+      (inst move value temp)
+      (inst beq temp1 fixnum)
+
+      ;; If not, is it an other pointer?
+      (inst and value lowtag-mask temp)
+      (inst xor temp other-pointer-type temp)
+      (inst bne temp nope)
+      ;; Get the header.
+      (loadw temp value 0 other-pointer-type)
+      ;; Is it one?
+      (inst li  (+ (ash 1 type-bits) bignum-type) temp1)
+      (inst xor temp temp1 temp)
+      (inst beq temp single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 32)
+      (inst li (logxor (+ (ash 1 type-bits) bignum-type)
+		       (+ (ash 2 type-bits) bignum-type))
+	    temp1)
+      (inst xor temp temp1 temp)
+      (inst bne temp nope)
+      ;; Get the second digit.
+      (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst beq temp yep)
+      (inst br zero-tn nope)
+	
+      SINGLE-WORD
+      ;; Get the single digit.
+      (loadw temp value bignum-digits-offset other-pointer-type)
+
+      ;; positive implies (unsigned-byte 32).
+      FIXNUM
+      (if not-p
+	  (inst blt temp target)
+	  (inst bge temp target))))
+  (undefined-value))
+
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:temporary (:scs (non-descriptor-reg)) temp1)
+  (:generator 45
+    (unsigned-byte-32-test value temp temp1 not-p target not-target)
+    NOT-TARGET))
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:temporary (:scs (non-descriptor-reg)) temp1)
+  (:generator 45
+    (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
+				      value)))
+      (unsigned-byte-32-test value temp temp1 t loose okay))
+    OKAY
+    (move value result)))
+
+
+
+;;;; List/symbol types:
+;;; 
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 12
+    (inst cmpeq value null-tn temp)
+    (inst bne temp (if not-p drop-thru target))
+    (test-type value temp target not-p symbol-header-type)
+    DROP-THRU))
+
+(define-vop (check-symbol check-type)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 12
+    (inst cmpeq value null-tn temp)
+    (inst bne temp drop-thru)
+    (let ((error (generate-error-code vop object-not-symbol-error value)))
+      (test-type value temp error t symbol-header-type))
+    DROP-THRU
+    (move value result)))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 8
+    (inst cmpeq value null-tn temp)
+    (inst bne temp (if not-p target drop-thru))
+    (test-type value temp target not-p list-pointer-type)
+    DROP-THRU))
+
+(define-vop (check-cons check-type)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst cmpeq value null-tn temp)
+      (inst bne temp error)
+      (test-type value temp error t list-pointer-type))
+    (move value result)))
diff --git a/compiler/alpha/values.lisp b/compiler/alpha/values.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6ecfd7880cdec9cb66959e77ea0ae57fdb71cb99
--- /dev/null
+++ b/compiler/alpha/values.lisp
@@ -0,0 +1,133 @@
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/values.lisp,v 1.1 1994/04/06 16:54:58 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted to the Alpha by Sean Hallgren.
+;;; 
+
+(in-package "ALPHA")
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move ptr csp-tn)))
+
+
+;;; 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 (any-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 csp-tn start-temp)
+    (inst lda csp-tn (* nvals word-bytes) csp-tn)
+    (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-temp start)
+    (inst li (fixnum nvals) count)))
+
+
+;;; 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 (any-reg))
+	    (count :scs (any-reg)))
+  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (move arg list)
+    (move csp-tn start)
+    
+    LOOP
+    (inst cmpeq list null-tn temp)
+    (inst bne temp done)
+    (loadw temp list cons-car-slot list-pointer-type)
+    (loadw list list cons-cdr-slot list-pointer-type)
+    (inst lda csp-tn word-bytes csp-tn)
+    (storew temp csp-tn -1)
+    (inst and list lowtag-mask ndescr)
+    (inst xor ndescr list-pointer-type ndescr)
+    (inst beq ndescr loop)
+    (error-call vop bogus-argument-to-values-list-error list)
+    
+    DONE
+    (inst subq csp-tn start count)))
+
+;;; Copy the more arg block to the top of the stack so we can use them
+;;; as function arguments.
+;;;
+(define-vop (%more-arg-values)
+  (:args (context :scs (descriptor-reg any-reg) :target src)
+         (skip :scs (any-reg zero immediate))
+         (num :scs (any-reg) :target count))
+  (:arg-types * positive-fixnum positive-fixnum)
+  (:temporary (:sc any-reg :from (:argument 0)) src)
+  (:temporary (:sc any-reg :from (:argument 2)) dst)
+  (:temporary (:sc descriptor-reg :from (:argument 1)) temp)
+  (:temporary (:sc non-descriptor-reg) temp1)
+  (:results (start :scs (any-reg))
+            (count :scs (any-reg)))
+  (:generator 20
+    (sc-case skip
+      (zero
+       (move context src))
+      (immediate
+       (inst lda src (* (tn-value skip) word-bytes) context))
+      (any-reg
+       (inst addq context skip src)))
+    (move num count)
+    (inst move csp-tn start)
+    (inst beq num done)
+    (inst move csp-tn dst)
+    (inst addq csp-tn count csp-tn)
+    LOOP
+    (inst ldl temp 0 src)
+    (inst addq src 4 src)
+    (inst addq dst 4 dst)
+    (inst stl temp -4 dst)
+    (inst cmpeq dst csp-tn temp1)
+    (inst beq temp1 loop)
+    DONE))
diff --git a/compiler/alpha/vm.lisp b/compiler/alpha/vm.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e31b3405efc61fd09eba97a48639113eee7fb298
--- /dev/null
+++ b/compiler/alpha/vm.lisp
@@ -0,0 +1,363 @@
+;;; -*- Package: alpha -*-
+;;;
+;;; **********************************************************************
+;;; 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/compiler/alpha/vm.lisp,v 1.1 1994/04/06 16:54:59 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition for the Alpha.
+;;;
+;;; Written by William Lott.
+;;; Alpha conversion by Sean Hallgren.
+;;;
+
+(in-package "ALPHA")
+
+
+;;;; Define the registers
+
+(eval-when (compile eval)
+
+(defmacro defreg (name offset)
+  (let ((offset-sym (symbolicate name "-OFFSET")))
+    `(eval-when (compile eval load)
+       (defconstant ,offset-sym ,offset)
+       (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+
+(defmacro defregset (name &rest regs)
+  `(eval-when (compile eval load)
+     (defconstant ,name
+       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
+
+); eval-when (compile eval)
+
+
+(eval-when (compile load eval)
+
+(defvar *register-names* (make-array 32 :initial-element nil))
+
+); eval-when (compile load eval)
+
+
+;; Ra
+(defreg lip 0)
+;; Caller saved 0-7
+(defreg a0 1)
+(defreg a1 2)
+(defreg a2 3)
+(defreg a3 4)
+(defreg a4 5)
+(defreg a5 6)
+(defreg l0 7)
+(defreg nargs 8)
+;; Callee saved 0-6
+(defreg csp 9)
+(defreg cfp 10)
+(defreg ocfp 11)
+(defreg bsp 12)
+(defreg lexenv 13)
+(defreg code 14)
+(defreg null 15)
+;; Arg 0-5
+(defreg nl0 16)
+(defreg nl1 17)
+(defreg nl2 18)
+(defreg nl3 19)
+(defreg nl4 20)
+(defreg nl5 21)
+;; Caller saved 8-11
+(defreg alloc 22)
+(defreg fdefn 23)
+(defreg cfunc 24)
+(defreg nfp 25)
+;; Ra
+(defreg lra 26)
+;; Caller saved 12
+(defreg l1 27)
+;; Assembler temp (at)
+(defreg l2 28)
+;; Global pointer (gp)
+(defreg gp 29)
+;; Stack pointer
+(defreg nsp 30)
+;; Wired zero
+(defreg zero 31)
+
+(defregset non-descriptor-regs
+  nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
+
+(defregset descriptor-regs
+  fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
+
+(defregset register-arg-offsets
+  a0 a1 a2 a3 a4 a5)
+
+
+(define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 64)
+(define-storage-base control-stack :unbounded :size 8)
+(define-storage-base non-descriptor-stack :unbounded :size 0)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+
+;;;
+;;; 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)
+
+  ;; ZERO and NULL are in registers.
+  (zero immediate-constant)
+  (null immediate-constant)
+  (fp-single-zero immediate-constant)
+  (fp-double-zero immediate-constant)
+
+  ;; Anything else that can be an immediate.
+  (immediate immediate-constant)
+
+
+  ;; **** The stacks.
+
+  ;; The control stack.  (Scanned by GC)
+  (control-stack control-stack)
+
+  ;; The non-descriptor stacks.
+  (signed-stack non-descriptor-stack
+		:element-size 2 :alignment 2) ; (signed-byte 64)
+  (unsigned-stack non-descriptor-stack
+		  :element-size 2 :alignment 2) ; (unsigned-byte 64)
+  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
+  (sap-stack non-descriptor-stack
+	     :element-size 2 :alignment 2) ; System area pointers.
+  (single-stack non-descriptor-stack) ; single-floats
+  (double-stack non-descriptor-stack
+		:element-size 2 :alignment 2) ; double floats.
+
+
+  ;; **** Things that can go in the integer registers.
+
+  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
+  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
+  (any-reg
+   registers
+   :locations #.(append non-descriptor-regs descriptor-regs)
+   :constant-scs (zero immediate)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Pointer descriptor objects.  Must be seen by GC.
+  (descriptor-reg registers
+   :locations #.descriptor-regs
+   :constant-scs (constant null immediate)
+   :save-p t
+   :alternate-scs (control-stack))
+
+  ;; Non-Descriptor characters
+  (base-char-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (base-char-stack))
+
+  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
+  (sap-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (immediate)
+   :save-p t
+   :alternate-scs (sap-stack))
+
+  ;; Non-Descriptor (signed or unsigned) numbers.
+  (signed-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (zero immediate)
+   :save-p t
+   :alternate-scs (signed-stack))
+  (unsigned-reg registers
+   :locations #.non-descriptor-regs
+   :constant-scs (zero 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 #.non-descriptor-regs)
+
+  ;; Pointers to the interior of objects.  Used only as an temporary.
+  (interior-reg registers
+   :locations (#.lip-offset))
+
+
+  ;; **** Things that can go in the floating point registers.
+
+  ;; Non-Descriptor single-floats.
+  (single-reg float-registers
+   :locations #.(loop for i from 4 to 31 collect i)
+   :constant-scs (fp-single-zero)
+   :save-p t
+   :alternate-scs (single-stack))
+
+  ;; Non-Descriptor double-floats.
+  (double-reg float-registers
+   :locations #.(loop for i from 4 to 31 collect i)
+   :constant-scs (fp-double-zero)
+   :save-p t
+   :alternate-scs (double-stack))
+
+  ;; A catch or unwind block.
+  (catch-block control-stack :element-size vm:catch-block-size))
+
+
+;;;; Make some random tns for important registers.
+
+(eval-when (compile eval)
+
+(defmacro defregtn (name sc)
+  (let ((offset-sym (symbolicate name "-OFFSET"))
+	(tn-sym (symbolicate name "-TN")))
+    `(defparameter ,tn-sym
+       (make-random-tn :kind :normal
+		       :sc (sc-or-lose ',sc)
+		       :offset ,offset-sym))))
+
+); eval-when (compile eval)
+
+;; These, we access by foo-TN only
+
+(defregtn zero any-reg)
+(defregtn null descriptor-reg)
+(defregtn code descriptor-reg)
+(defregtn alloc any-reg)
+(defregtn bsp any-reg)
+(defregtn csp any-reg)
+(defregtn cfp any-reg)
+(defregtn nsp any-reg)
+
+;; These alias regular locations, so we have to make sure we don't bypass
+;; the register allocator when using them.
+(defregtn nargs any-reg)
+(defregtn ocfp any-reg)
+(defregtn lip interior-reg)
+
+;; And some floating point values.
+(defparameter fp-single-zero-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'single-reg)
+		  :offset 31))
+(defparameter fp-double-zero-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'double-reg)
+		  :offset 31))
+
+
+;;; 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
+    ((integer 0 0)
+     (sc-number-or-lose 'zero *backend*))
+    (null
+     (sc-number-or-lose 'null *backend*))
+    ((or fixnum system-area-pointer character)
+     (sc-number-or-lose 'immediate *backend*))
+    (symbol
+     (if (static-symbol-p value)
+	 (sc-number-or-lose 'immediate *backend*)
+	 nil))
+    (single-float
+     (if (zerop value)
+	 (sc-number-or-lose 'fp-single-zero *backend*)
+	 nil))
+    (double-float
+     (if (zerop value)
+	 (sc-number-or-lose 'fp-double-zero *backend*)
+	 nil))))
+
+;;;; Function Call Parameters
+
+;;; The SC numbers for register and stack arguments/return values.
+;;;
+(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)
+
+;;; The number of arguments/return values passed in registers.
+;;;
+(defconstant register-arg-count 6)
+
+;;; Names to use for the argument registers.
+;;; 
+(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5))
+
+); 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))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(export 'single-value-return-byte-offset)
+(defconstant single-value-return-byte-offset 4)
+
+
+;;; 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 (or (svref *register-names* offset)
+		     (format nil "R~D" offset)))
+      (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"))))