diff --git a/src/assembly/sparcv9/alloc.lisp b/src/assembly/sparcv9/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..dc87046ae126a9b9cd174df5fea2d117a3f07bd9
--- /dev/null
+++ b/src/assembly/sparcv9/alloc.lisp
@@ -0,0 +1,19 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/assembly/sparc/alloc.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle allocating simple objects.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "SPARC")
+
+;;; But we do everything inline now that we have a better pseudo-atomic.
diff --git a/src/assembly/sparcv9/arith.lisp b/src/assembly/sparcv9/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a49b1c1fe5c3c7dcb90bc54308ed426ec4d5d8a9
--- /dev/null
+++ b/src/assembly/sparcv9/arith.lisp
@@ -0,0 +1,364 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/assembly/sparc/arith.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "SPARC")
+
+
+
+;;;; Addition and subtraction.
+
+(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 lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst andcc zero-tn x fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FUN)
+  (inst andcc zero-tn y fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FUN)
+  (inst nop)
+  (inst addcc temp x y)
+  (inst b :vc done)
+  (inst nop)
+
+  (inst sra temp x fixnum-tag-bits)
+  (inst sra temp2 y fixnum-tag-bits)
+  (inst add temp2 temp)
+  (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset))
+    (storew temp2 res bignum-digits-offset other-pointer-type))
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst ld code-tn null-tn (static-function-offset 'two-arg-+))
+  (inst li nargs (fixnumize 2))
+  (inst move ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst move cfp-tn csp-tn)
+
+  DONE
+  (move res temp))
+
+
+(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 lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst andcc zero-tn x fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FUN)
+  (inst andcc zero-tn y fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FUN)
+  (inst nop)
+  (inst subcc temp x y)
+  (inst b :vc done)
+  (inst nop)
+
+  (inst sra temp x fixnum-tag-bits)
+  (inst sra temp2 y fixnum-tag-bits)
+  (inst sub temp2 temp temp2)
+  (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset))
+    (storew temp2 res bignum-digits-offset other-pointer-type))
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst ld code-tn null-tn (static-function-offset 'two-arg--))
+  (inst li nargs (fixnumize 2))
+  (inst move ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst move cfp-tn csp-tn)
+
+  DONE
+  (move res temp))
+
+
+
+;;;; Multiplication
+
+
+(define-assembly-routine (generic-*
+			  (:cost 50)
+			  (: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 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 andcc zero-tn x fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FUN)
+  (inst andcc zero-tn y fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FUN)
+  (inst nop)
+
+  ;; Remove the tag from one arg so that the result will have the correct
+  ;; fixnum tag.
+  (inst sra temp x fixnum-tag-bits)
+  ;; Compute the produce temp * y and return the double-word product
+  ;; in hi:lo.
+  (cond ((backend-featurep :sparc-64)
+	 ;; Sign extend y to a full 64-bits.  temp was already
+	 ;; sign-extended by the sra instruction above.
+	 (inst sra y 0)
+	 (inst mulx hi temp y)
+	 (inst move lo hi)
+	 (inst srax hi 32))
+	((or (backend-featurep :sparc-v8)
+	     (backend-featurep :sparc-v9))
+	 (inst smul lo temp y)
+	 (inst rdy hi))
+	(t
+	 (let ((MULTIPLIER-POSITIVE (gen-label)))
+	   (inst wry temp)
+	   (inst andcc hi zero-tn)
+	   (inst nop)
+	   (inst nop)
+	   (dotimes (i 32)
+	     (inst mulscc hi y))
+	   (inst mulscc hi zero-tn)
+	   (inst cmp x)
+	   (inst b :ge MULTIPLIER-POSITIVE)
+	   (inst nop)
+	   (inst sub hi y)
+	   (emit-label MULTIPLIER-POSITIVE)
+	   (inst rdy lo))))
+
+  ;; 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 temp lo 31)
+  (inst xorcc temp hi)
+  (inst b :eq LOW-FITS-IN-FIXNUM)
+  ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
+  (inst sll temp hi 30)
+  (inst srl lo fixnum-tag-bits)
+  (inst or lo temp)
+  (inst sra hi fixnum-tag-bits)
+  ;; Allocate a BIGNUM for the result. We always allocate 2 words for
+  ;; the bignum result, even if we only need one.  The copying GC will
+  ;; take care of the extra word if it isn't needed.
+  (with-fixed-allocation
+      (res temp bignum-type (+ 2 bignum-digits-offset))
+    (let ((one-word (gen-label)))
+      ;; We start out assuming that we need one word.  Is that correct?
+      (inst sra temp lo 31)
+      (inst xorcc temp hi)
+      (inst b :eq one-word)
+      (inst li temp (logior (ash 1 type-bits) bignum-type))
+      ;; Need 2 words.  Set the header appropriately, and save the
+      ;; high and low parts.
+      (inst li temp (logior (ash 2 type-bits) bignum-type))
+      (storew hi res (1+ bignum-digits-offset) other-pointer-type)
+      (emit-label one-word)
+      (storew temp res 0 other-pointer-type)
+      (storew lo res bignum-digits-offset other-pointer-type)))
+  ;; Out of here
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (inst ld code-tn null-tn (static-function-offset 'two-arg-*))
+  (inst li nargs (fixnumize 2))
+  (inst move ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst move cfp-tn csp-tn)
+
+  LOW-FITS-IN-FIXNUM
+  (move res lo))
+
+
+;;;; Comparison
+
+(macrolet
+    ((define-cond-assem-rtn (name translate static-fn cmp)
+       `(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 nargs any-reg nargs-offset)
+				  (:temp ocfp any-reg ocfp-offset))
+	  (inst andcc zero-tn x fixnum-tag-mask)
+	  (inst b :ne DO-STATIC-FN)
+	  (inst andcc zero-tn y fixnum-tag-mask)
+	  (inst b :eq DO-COMPARE)
+	  (inst cmp x y)
+	  
+	  DO-STATIC-FN
+	  (inst ld code-tn null-tn (static-function-offset ',static-fn))
+	  (inst li nargs (fixnumize 2))
+	  (inst move ocfp cfp-tn)
+	  (inst j code-tn
+		(- (* function-code-offset word-bytes) function-pointer-type))
+	  (inst move cfp-tn csp-tn)
+	  
+	  DO-COMPARE
+	  (inst b ,cmp done)
+	  (load-symbol res t)
+	  (inst move res null-tn)
+	  DONE)))
+
+  (define-cond-assem-rtn generic-< < two-arg-< :lt)
+  (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
+  (define-cond-assem-rtn generic-> > two-arg-> :gt)
+  (define-cond-assem-rtn generic->= >= two-arg->= :ge))
+
+
+(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 lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst cmp x y)
+  (inst b :eq RETURN-T)
+  (inst andcc zero-tn x fixnum-tag-mask)
+  (inst b :eq RETURN-NIL)
+  (inst andcc zero-tn y fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FN)
+  (inst nop)
+
+  RETURN-NIL
+  (inst move res null-tn)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst ld code-tn null-tn (static-function-offset 'eql))
+  (inst li nargs (fixnumize 2))
+  (inst move ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst move cfp-tn csp-tn)
+
+  RETURN-T
+  (load-symbol res t))
+
+(define-assembly-routine (generic-=
+			  (:cost 10)
+			  (:return-style :full-call)
+			  (:policy :safe)
+			  (:translate =)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res descriptor-reg a0-offset)
+
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst andcc zero-tn x fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FN)
+  (inst andcc zero-tn y fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FN)
+  (inst cmp x y)
+  (inst b :eq RETURN-T)
+  (inst nop)
+
+  (inst move res null-tn)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst ld code-tn null-tn (static-function-offset 'two-arg-=))
+  (inst li nargs (fixnumize 2))
+  (inst move ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst move cfp-tn csp-tn)
+
+  RETURN-T
+  (load-symbol res t))
+
+(define-assembly-routine (generic-/=
+			  (:cost 10)
+			  (:return-style :full-call)
+			  (:policy :safe)
+			  (:translate /=)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res descriptor-reg a0-offset)
+
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst cmp x y)
+  (inst b :eq RETURN-NIL)
+  (inst andcc zero-tn x fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FN)
+  (inst andcc zero-tn y fixnum-tag-mask)
+  (inst b :ne DO-STATIC-FN)
+  (inst nop)
+
+  (load-symbol res t)
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FN
+  (inst ld code-tn null-tn (static-function-offset 'two-arg-=))
+  (inst li nargs (fixnumize 2))
+  (inst move ocfp cfp-tn)
+  (inst j code-tn
+	(- (* function-code-offset word-bytes) function-pointer-type))
+  (inst move cfp-tn csp-tn)
+
+  RETURN-NIL
+  (inst move res null-tn))
diff --git a/src/assembly/sparcv9/array.lisp b/src/assembly/sparcv9/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..21a5b4a9801eefb1e3ef53f5c6efc6de5dfe4f62
--- /dev/null
+++ b/src/assembly/sparcv9/array.lisp
@@ -0,0 +1,169 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/assembly/sparc/array.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/assembly/sparc/array.lisp $
+;;;
+;;;    This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "SPARC")
+
+
+(define-assembly-routine (allocate-vector
+			  (:policy :fast-safe)
+			  (:translate allocate-vector)
+			  (:arg-types positive-fixnum
+				      positive-fixnum
+				      positive-fixnum))
+			 ((:arg type any-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:arg words any-reg a2-offset)
+			  (:res result descriptor-reg a0-offset)
+
+			  (:temp ndescr non-descriptor-reg nl0-offset)
+			  (:temp gc-temp non-descriptor-reg nl1-offset)
+			  (:temp vector descriptor-reg a3-offset))
+  (pseudo-atomic ()
+    (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
+    (inst andn ndescr vm:lowtag-mask)
+    (allocation vector ndescr other-pointer-type :temp-tn gc-temp)
+    #+gencgc
+    (progn
+      ;; ndescr points to one word past the end of the allocated
+      ;; space.  Fill the last word with a zero.
+      (inst add ndescr vector)
+      (storew zero-tn ndescr -1 vm:other-pointer-type))
+    (inst srl ndescr type vm:word-shift)
+    (storew ndescr vector 0 vm:other-pointer-type)
+    (storew length vector vm:vector-length-slot vm:other-pointer-type))
+  ;; This makes sure the zero byte at the end of a string is paged in so
+  ;; the kernel doesn't bitch if we pass it the string.
+  ;;
+  ;; This used to write to the word after the last allocated word.  I
+  ;; (RLT) made it write to the last allocated word, which is where
+  ;; the zero-byte of the string is.  Look at the deftransform for
+  ;; make-array in array-tran.lisp.  For strings we always allocate
+  ;; enough space to hold the zero-byte.
+  #-gencgc
+  (storew zero-tn alloc-tn -1)
+  (move result vector))
+
+
+
+;;;; Hash primitives
+
+#+assembler
+(defparameter sxhash-simple-substring-entry (gen-label))
+
+(define-assembly-routine (sxhash-simple-string
+			  (:translate %sxhash-simple-string)
+			  (:policy :fast-safe)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:res result any-reg a0-offset)
+
+			  (:temp length any-reg a1-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp temp non-descriptor-reg nl2-offset)
+			  (:temp offset non-descriptor-reg nl3-offset))
+
+  (declare (ignore result accum data temp offset))
+
+  (inst b sxhash-simple-substring-entry)
+  (loadw length string vm:vector-length-slot vm:other-pointer-type))
+
+
+;; Implement the one-at-a-time algorithm designed by Bob Jenkins
+;; (see <http://burtleburtle.net/bob/hash/doobs.html> for some
+;; more information).
+;;
+;; For completeness, here is the hash function, in C, from that web
+;; page.  ub4 is an unsigned 32-bit integer.
+
+#||
+ub4 one_at_a_time(char *key, ub4 len)
+{
+  ub4   hash, i;
+  for (hash=0, i=0; i<len; ++i)
+  {
+    hash += key[i];
+    hash += (hash << 10);
+    hash ^= (hash >> 6);
+  }
+  hash += (hash << 3);
+  hash ^= (hash >> 11);
+  hash += (hash << 15);
+  return (hash & mask);
+} 
+
+||#
+
+
+(define-assembly-routine (sxhash-simple-substring
+			  (:translate %sxhash-simple-substring)
+			  (:policy :fast-safe)
+			  (:arg-types * positive-fixnum)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:res result any-reg a0-offset)
+
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp temp non-descriptor-reg nl2-offset)
+			  (:temp offset non-descriptor-reg nl3-offset))
+  (emit-label sxhash-simple-substring-entry)
+
+  #+unicode
+  (inst sll length 1)		  ; Number of bytes = twice the length
+  
+  (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type))
+  (inst b test)
+  (move accum zero-tn)
+
+  LOOP
+
+  ;; hash += key[i]
+  (inst add accum data)
+  ;; hash += (hash << 10)
+  (inst slln temp accum 10)
+  (inst add accum temp)
+  ;; hash ^= (hash >> 6)
+  (inst srln temp accum 6)
+  (inst xor accum temp)
+  (inst add offset 1)
+  
+  TEST
+
+  (inst subcc length (fixnumize 1))
+  (inst b :ge loop)
+  (inst ldub data string offset)
+
+  ;; hash += (hash << 3)
+  (inst slln temp accum 3)
+  (inst add accum temp)
+  ;; hash ^= (hash >> 11)
+  (inst srln temp accum 11)
+  (inst xor accum temp)
+  ;; hash += (hash << 15)
+  (inst slln temp accum 15)
+  (inst add accum temp)
+  
+  ;;(inst li temp most-positive-fixnum)
+  ;;(inst and accum temp)
+  ;; Make it a fixnum result
+
+  ;; Make the result a positive fixnum.  Shifting it left, then right
+  ;; does what we want, and extracts the bits we need.
+  (inst slln accum (1+ vm:fixnum-tag-bits))
+  (inst srln result accum 1))
diff --git a/src/assembly/sparcv9/assem-rtns.lisp b/src/assembly/sparcv9/assem-rtns.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9fe07c2cbcc68237d0516292ccf9c755eaf760e4
--- /dev/null
+++ b/src/assembly/sparcv9/assem-rtns.lisp
@@ -0,0 +1,311 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/assembly/sparc/assem-rtns.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/assembly/sparc/assem-rtns.lisp $
+;;;
+;;;
+(in-package "SPARC")
+
+
+;;;; 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 count any-reg nl2-offset)
+     (:temp src any-reg nl3-offset)
+     (:temp dst any-reg nl4-offset)
+     (:temp temp descriptor-reg cname-offset)
+
+     ;; These are needed so we can get at the register args.
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset)
+     (:temp a2 descriptor-reg a2-offset)
+     (: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 cmp nvals)
+  (inst b :le default-a0-and-on)
+  (inst cmp nvals (fixnumize 2))
+  (inst b :le default-a2-and-on)
+  (inst ld a1 vals (* 1 vm:word-bytes))
+  (inst cmp nvals (fixnumize 3))
+  (inst b :le default-a3-and-on)
+  (inst ld a2 vals (* 2 vm:word-bytes))
+  (inst cmp nvals (fixnumize 4))
+  (inst b :le default-a4-and-on)
+  (inst ld a3 vals (* 3 vm:word-bytes))
+  (inst cmp nvals (fixnumize 5))
+  (inst b :le default-a5-and-on)
+  (inst ld a4 vals (* 4 vm:word-bytes))
+  (inst cmp nvals (fixnumize 6))
+  (inst b :le done)
+  (inst ld a5 vals (* 5 vm:word-bytes))
+
+  ;; Copy the remaining args to the top of the stack.
+  (inst add src vals (* 6 vm:word-bytes))
+  (inst add dst cfp-tn (* 6 vm:word-bytes))
+  (inst subcc count nvals (fixnumize 6))
+
+  LOOP
+  (inst ld temp src)
+  (inst add src vm:word-bytes)
+  (inst st temp dst)
+  (inst add dst vm:word-bytes)
+  (inst b :gt loop)
+  (inst subcc count (fixnumize 1))
+		
+  (inst b done)
+  (inst nop)
+
+  DEFAULT-A0-AND-ON
+  (inst move a0 null-tn)
+  (inst move a1 null-tn)
+  DEFAULT-A2-AND-ON
+  (inst move a2 null-tn)
+  DEFAULT-A3-AND-ON
+  (inst move a3 null-tn)
+  DEFAULT-A4-AND-ON
+  (inst move a4 null-tn)
+  DEFAULT-A5-AND-ON
+  (inst move a5 null-tn)
+  DONE
+  
+  ;; Clear the stack.
+  (move ocfp-tn cfp-tn)
+  (move cfp-tn ocfp)
+  (inst add csp-tn ocfp-tn nvals)
+  
+  ;; Return.
+  (lisp-return lra))
+
+
+
+;;;; tail-call-variable.
+
+#+assembler ;; no vop for this one either.
+(define-assembly-routine
+    (tail-call-variable
+     (:return-style :none))
+
+    ;; These are really args.
+    ((:temp args any-reg nl0-offset)
+     (:temp lexenv descriptor-reg lexenv-offset)
+
+     ;; We need to compute this
+     (:temp nargs any-reg nargs-offset)
+
+     ;; These are needed by the blitting code.
+     (:temp src any-reg nl1-offset)
+     (:temp dst any-reg nl2-offset)
+     (:temp count any-reg nl3-offset)
+     (:temp temp descriptor-reg cname-offset)
+
+     ;; These are needed so we can get at the register args.
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset)
+     (:temp a2 descriptor-reg a2-offset)
+     (:temp a3 descriptor-reg a3-offset)
+     (:temp a4 descriptor-reg a4-offset)
+     (:temp a5 descriptor-reg a5-offset))
+
+
+  ;; Calculate NARGS (as a fixnum)
+  (inst sub nargs csp-tn args)
+     
+  ;; Load the argument regs (must do this now, 'cause the blt might
+  ;; trash these locations)
+  (inst ld a0 args (* 0 vm:word-bytes))
+  (inst ld a1 args (* 1 vm:word-bytes))
+  (inst ld a2 args (* 2 vm:word-bytes))
+  (inst ld a3 args (* 3 vm:word-bytes))
+  (inst ld a4 args (* 4 vm:word-bytes))
+  (inst ld a5 args (* 5 vm:word-bytes))
+
+  ;; Calc SRC, DST, and COUNT
+  (inst addcc count nargs (fixnumize (- register-arg-count)))
+  (inst b :le done)
+  (inst add src args (* vm:word-bytes register-arg-count))
+  (inst add dst cfp-tn (* vm:word-bytes register-arg-count))
+	
+  LOOP
+  ;; Copy one arg.
+  (inst ld temp src)
+  (inst add src src vm:word-bytes)
+  (inst st temp dst)
+  (inst addcc count (fixnumize -1))
+  (inst b :gt loop)
+  (inst add dst dst vm:word-bytes)
+	
+  DONE
+  ;; We are done.  Do the jump.
+  (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type)
+  (lisp-jump temp))
+
+
+
+;;;; Non-local exit noise.
+
+(define-assembly-routine (unwind
+			  (:return-style :none)
+			  (:translate %continue-unwind)
+			  (:policy :fast-safe))
+			 ((:arg block (any-reg descriptor-reg) a0-offset)
+			  (:arg start (any-reg descriptor-reg) ocfp-offset)
+			  (:arg count (any-reg descriptor-reg) nargs-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp cur-uwp any-reg nl0-offset)
+			  (:temp next-uwp any-reg nl1-offset)
+			  (:temp target-uwp any-reg nl2-offset))
+  (declare (ignore start count))
+
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst cmp block)
+    (inst b :eq error))
+  
+  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+  (loadw target-uwp block vm:unwind-block-current-uwp-slot)
+  (inst cmp cur-uwp target-uwp)
+  (inst b :ne do-uwp)
+  (inst nop)
+      
+  (move cur-uwp block)
+
+  DO-EXIT
+      
+  (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot)
+  (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
+  (loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
+  (lisp-return lra :frob-code nil)
+
+  DO-UWP
+
+  (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
+  (inst b do-exit)
+  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
+
+
+(define-assembly-routine (throw
+			  (:return-style :none))
+			 ((: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 temp non-descriptor-reg nl0-offset))
+  
+  (declare (ignore start count))
+
+  (load-symbol-value catch lisp::*current-catch-block*)
+  
+  loop
+  
+  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+    (inst cmp catch)
+    (inst b :eq error)
+    (inst nop))
+  
+  (loadw tag catch vm:catch-block-tag-slot)
+  (inst cmp tag target)
+  (inst b :eq exit)
+  (inst nop)
+  (loadw catch catch vm:catch-block-previous-catch-slot)
+  (inst b loop)
+  (inst nop)
+  
+  exit
+  
+  (move target catch)
+  (inst li temp (make-fixup 'unwind :assembly-routine))
+  (inst j temp)
+  (inst nop))
+
+
+
+
+;; Assembly routines for undefined_tramp and closure_tramp
+
+#+assembler
+(define-assembly-routine (closure-tramp-function-alignment
+			  (:return-style :none))
+                         ()
+  ;; Align to a dualword and put in the magic function header stuff so
+  ;; that closure-tramp looks like a normal function with a function
+  ;; tag.
+  (align vm:lowtag-bits)
+  (inst byte 0))
+
+#+assembler
+(define-assembly-routine (closure-tramp
+			  (:return-style :none))
+                         ()
+  (inst byte 0)
+  (inst byte 0)
+  (inst byte vm:function-header-type)
+  ;; This is supposed to be closure-tramp, not 0.
+  (inst word 0)
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+
+  (loadw lexenv-tn cname-tn fdefn-function-slot other-pointer-type)
+  (loadw code-tn lexenv-tn closure-function-slot function-pointer-type)
+  (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))
+  (inst nop)
+  ;; Make sure following routine is dual-word aligned
+  (align vm:lowtag-bits))
+
+#+assembler
+(define-assembly-routine (undefined-tramp-function-alignment
+			  (:return-style :none))
+                         ()
+  ;; Align to a dualword and put in the magic function header stuff so
+  ;; that closure-tramp looks like a normal function with a function
+  ;; tag.
+  (align vm:lowtag-bits)
+  (inst byte 0))
+
+#+assembler
+(define-assembly-routine (undefined-tramp
+			  (:return-style :none))
+                         ()
+  (inst byte 0)
+  (inst byte 0)
+  (inst byte vm:function-header-type)
+  ;; This is supposed to be undefined-tramp, not 0.
+  (inst word 0)
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+
+  (let ((error (generate-cerror-code nil undefined-symbol-error cname-tn)))
+    (inst b error)
+    (inst nop)
+    ;; I don't think we ever return from the undefined-symbol-error
+    ;; handler, but the assembly code did this so we'll do it too.
+    (loadw code-tn cname-tn fdefn-raw-addr-slot other-pointer-type)
+    (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))
+    (inst nop)))
diff --git a/src/assembly/sparcv9/support.lisp b/src/assembly/sparcv9/support.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8940f23d50986a7b55c67a3bb963c1e37bc9202b
--- /dev/null
+++ b/src/assembly/sparcv9/support.lisp
@@ -0,0 +1,78 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/assembly/sparc/support.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+(in-package "SPARC")
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (let ((temp (make-symbol "TEMP"))
+	   (lip (make-symbol "LIP")))
+       (values 
+	`((inst jali ,lip ,temp (make-fixup ',name :assembly-routine))
+	  (inst nop))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)
+	  (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1))
+		      ,lip)))))
+    (: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)
+	    (inst ji ,temp (make-fixup ',name :assembly-routine))
+	    (inst nop)
+	    (emit-return-pc lra-label)
+	    (note-this-location ,vop :single-value-return)
+	    (without-scheduling ()
+	      (move csp-tn ocfp-tn)
+	      (inst nop))
+	    (inst compute-code-from-lra code-tn code-tn
+		  lra-label ,temp)
+	    (when cur-nfp
+	      (load-stack-tn cur-nfp ,nfp-save))))
+	`((: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)
+	  (:save-p :compute-only)))))
+    (:none
+     (let ((temp (make-symbol "TEMP")))
+       (values 
+	`((inst ji ,temp (make-fixup ',name :assembly-routine))
+	  (inst nop))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)))))))
+
+(def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst j
+	     (make-random-tn :kind :normal
+			     :sc (sc-or-lose 'interior-reg *backend*)
+			     :offset lip-offset)
+	     8)
+       (inst nop)))
+    (:full-call
+     `((lisp-return (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'descriptor-reg *backend*)
+				    :offset lra-offset)
+		    :offset 2)))
+    (:none)))
diff --git a/src/compiler/sparcv9/alloc.lisp b/src/compiler/sparcv9/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0a448da923d62dc25f965c52c85e97cd7391d3b9
--- /dev/null
+++ b/src/compiler/sparcv9/alloc.lisp
@@ -0,0 +1,214 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/alloc.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the SPARC port.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+;;;; Dynamic-Extent.
+
+;;;
+;;; Take an arg where to move the stack pointer instead of returning
+;;; it via :results, because the former generates a single move.
+;;;
+(define-vop (%dynamic-extent-start)
+  (:args (saved-stack-pointer :scs (any-reg control-stack)))
+  (:results)
+  (:policy :safe)
+  (:generator 0
+    (sc-case saved-stack-pointer
+      (control-stack
+       (let ((offset (tn-offset saved-stack-pointer)))
+	 (storew csp-tn cfp-tn offset)))
+      (any-reg
+       (move saved-stack-pointer csp-tn)))))
+
+(define-vop (%dynamic-extent-end)
+  (:args (saved-stack-pointer :scs (any-reg control-stack)))
+  (:results)
+  (:policy :safe)
+  (:generator 0
+    (sc-case saved-stack-pointer
+      (control-stack
+       (let ((offset (tn-offset saved-stack-pointer)))
+	 (loadw csp-tn cfp-tn offset)))
+      (any-reg
+       (move csp-tn saved-stack-pointer)))))
+
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+  (:args (things :more t))
+  (:temporary (:scs (descriptor-reg) :type list) ptr)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
+	      res)
+  (:temporary (:scs (non-descriptor-reg)) alloc-temp)
+  (:info num dynamic-extent)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:generator 0
+    (cond ((zerop num)
+	   (move result null-tn))
+	  ((and star (= num 1))
+	   (move result (tn-ref-tn things)))
+	  (t
+	   (macrolet
+	       ((maybe-load (tn)
+		  (once-only ((tn tn))
+		    `(sc-case ,tn
+		       ((any-reg descriptor-reg zero null)
+			,tn)
+		       (control-stack
+			(load-stack-tn temp ,tn)
+			temp)))))
+	     (let* ((cons-cells (if star (1- num) num))
+		    (alloc (* (pad-data-block cons-size) cons-cells)))
+	       (pseudo-atomic ()
+		 (allocation res alloc list-pointer-type
+			     :stack-p dynamic-extent
+			     :temp-tn alloc-temp)
+		 (move ptr res)
+		 (dotimes (i (1- cons-cells))
+		   (storew (maybe-load (tn-ref-tn things)) ptr
+			   cons-car-slot list-pointer-type)
+		   (setf things (tn-ref-across things))
+		   (inst add ptr ptr (pad-data-block cons-size))
+		   (storew ptr ptr
+			   (- cons-cdr-slot cons-size)
+			   list-pointer-type))
+		 (storew (maybe-load (tn-ref-tn things)) ptr
+			 cons-car-slot list-pointer-type)
+		 (storew (if star
+			     (maybe-load (tn-ref-tn (tn-ref-across things)))
+			     null-tn)
+			 ptr cons-cdr-slot list-pointer-type))
+	       (move result res)))))))
+
+(define-vop (list list-or-list*)
+  (:variant nil))
+
+(define-vop (list* list-or-list*)
+  (:variant t))
+
+
+;;;; Special purpose inline allocators.
+
+(define-vop (allocate-code-object)
+  (:args (boxed-arg :scs (any-reg))
+	 (unboxed-arg :scs (any-reg)))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:scs (non-descriptor-reg)) size)
+  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
+  (:generator 100
+    (inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot)))
+    (inst and boxed (lognot lowtag-mask))
+    (inst srln unboxed unboxed-arg word-shift)
+    (inst add unboxed lowtag-mask)
+    (inst and unboxed (lognot lowtag-mask))
+    (pseudo-atomic ()
+      ;; Figure out how much space we really need and allocate it.
+      (inst add size boxed unboxed)
+      (allocation result size other-pointer-type :temp-tn ndescr)
+      (inst slln ndescr boxed (- type-bits word-shift))
+      (inst or ndescr code-header-type)
+      (storew ndescr result 0 other-pointer-type)
+      (storew unboxed result code-code-size-slot other-pointer-type)
+      (storew null-tn result code-entry-points-slot other-pointer-type)
+      (storew null-tn result code-debug-info-slot other-pointer-type))))
+
+(define-vop (make-fdefn)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:generator 37
+    (with-fixed-allocation (result temp fdefn-type fdefn-size)
+      ;; For the linkage-table stuff, we need to look up the address
+      ;; of undefined_tramp from the linkage table instead of using
+      ;; the address directly.
+      (inst li temp (make-fixup 'undefined-tramp
+				:assembly-routine))
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew null-tn result fdefn-function-slot other-pointer-type)
+      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
+
+
+(define-vop (make-closure)
+  (:args (function :to :save :scs (descriptor-reg)))
+  (:info length dynamic-extent)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (let ((size (+ length closure-info-offset)))
+      (with-fixed-allocation (result temp closure-header-type size
+				     :lowtag function-pointer-type
+				     :stack-p dynamic-extent)
+	(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)))
+  (: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 result unbound-marker-type)))
+
+(define-vop (fixed-alloc)
+  (:args)
+  (:info name words type lowtag dynamic-extent)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 4
+    (with-fixed-allocation (result temp type words :lowtag lowtag :stack-p dynamic-extent)
+      )))
+
+(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)) bytes)
+  (:temporary (:scs (non-descriptor-reg)) header)
+  (:temporary (:scs (any-reg)) temp)
+  (:generator 6
+    (inst add bytes extra (* (1+ words) word-bytes))
+    (inst slln header bytes (- type-bits vm:fixnum-tag-bits)) ; because bytes is already a fixnum
+    (inst add header header (+ (ash -2 type-bits) type))
+    (inst and bytes (lognot lowtag-mask))
+    (pseudo-atomic ()
+      ;; Need to be careful if the lowtag and the pseudo-atomic flag
+      ;; are not compatible
+      (allocation result bytes lowtag :temp-tn temp)
+      (storew header result 0 lowtag))))
diff --git a/src/compiler/sparcv9/arith.lisp b/src/compiler/sparcv9/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a4d36f6da81d910c4579f60cdbb0915fb96653b6
--- /dev/null
+++ b/src/compiler/sparcv9/arith.lisp
@@ -0,0 +1,2590 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/arith.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition arithmetic VOPs for the SPARC.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;;
+;;; Enhancements/debugging by Raymond Toy 1999, 2000
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;;; Unary operations.
+
+(define-vop (fast-safe-arith-op)
+  (:policy :fast-safe)
+  (:effects)
+  (:affected))
+
+
+(define-vop (fixnum-unop fast-safe-arith-op)
+  (:args (x :scs (any-reg)))
+  (:results (res :scs (any-reg)))
+  (:note _N"inline fixnum arithmetic")
+  (:arg-types tagged-num)
+  (:result-types tagged-num))
+
+(define-vop (signed-unop fast-safe-arith-op)
+  (:args (x :scs (signed-reg)))
+  (:results (res :scs (signed-reg)))
+  (:note _N"inline (signed-byte 32) arithmetic")
+  (:arg-types signed-num)
+  (:result-types signed-num))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+  (:translate %negate)
+  (:generator 1
+    (inst neg res x)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (inst neg res x)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:translate lognot)
+  (:generator 2
+    (inst xor res x (fixnumize -1))))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (inst not res x)))
+
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg zero))
+	 (y :target r :scs (any-reg zero)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note _N"inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero))
+	 (y :target r :scs (unsigned-reg zero)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note _N"inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg zero))
+	 (y :target r :scs (signed-reg zero)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note _N"inline (signed-byte 32) arithmetic"))
+
+(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg zero)))
+  (:info y)
+  (:arg-types tagged-num
+	      (:constant (and (signed-byte #.(- 13 vm:fixnum-tag-bits)) (not (integer 0 0)))))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note _N"inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero)))
+  (:info y)
+  (:arg-types unsigned-num
+	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note _N"inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg zero)))
+  (:info y)
+  (:arg-types signed-num
+	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note _N"inline (signed-byte 32) arithmetic"))
+
+(eval-when (compile load eval)
+
+(defmacro define-binop (translate untagged-penalty op
+			&optional arg-swap restore-fixnum-mask)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+		   fast-fixnum-binop)
+       (:translate ,translate)
+       ,@(when restore-fixnum-mask
+	       `((:temporary (:sc non-descriptor-reg) temp)))
+       (:generator 2
+	 ,(if arg-swap
+	      `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
+	      `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
+	 ,@(when restore-fixnum-mask
+		 ``(inst andn r temp fixnum-tag-mask))))
+     ,@(unless arg-swap
+	       `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+			       fast-fixnum-binop-c)
+		   (:translate ,translate)
+		   ,@(when restore-fixnum-mask
+			   `((:temporary (:sc non-descriptor-reg) temp)))
+		   (:generator 1
+		     (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y))
+		     ,@(when restore-fixnum-mask
+			     `((inst andn r temp fixnum-tag-mask)))))))
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+		  fast-signed-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 ,(if arg-swap
+	      `(inst ,op r y x)
+	      `(inst ,op r x y))))
+     ,@(unless arg-swap
+	       `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+			       fast-signed-binop-c)
+		   (:translate ,translate)
+		   (:generator ,untagged-penalty
+		     (inst ,op r x y)))))
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 ,(if arg-swap
+	      `(inst ,op r y x)
+	      `(inst ,op r x y))))
+     ,@(unless arg-swap
+	       `((define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
+			       fast-unsigned-binop-c)
+		   (:translate ,translate)
+		   (:generator ,untagged-penalty
+		     (inst ,op r x y)))))))
+
+); eval-when
+
+(define-binop + 4 add)
+(define-binop - 4 sub)
+(define-binop logand 2 and)
+(define-binop logandc1 2 andn t)
+(define-binop logandc2 2 andn)
+(define-binop logior 2 or)
+(define-binop logorc1 2 orn t t)
+(define-binop logorc2 2 orn nil t)
+(define-binop logxor 2 xor)
+(define-binop logeqv 2 xnor nil t)
+
+;;; Special logand cases: (logand signed unsigned) => unsigned
+
+(define-vop (fast-logand/signed-unsigned=>unsigned
+	     fast-logand/unsigned=>unsigned)
+    (:args (x :scs (signed-reg))
+	   (y :target r :scs (unsigned-reg)))
+  (:arg-types signed-num unsigned-num))
+
+(define-vop (fast-logand/unsigned-signed=>unsigned
+	     fast-logand/unsigned=>unsigned)
+    (:args (x :target r :scs (unsigned-reg))
+	   (y :scs (signed-reg)))
+  (:arg-types unsigned-num signed-num))
+
+;; This vop is intended to handle the case (logand x #xffffffff) when
+;; x is a (signed-byte 32).  We can just do a register move instead of
+;; and'ing with #xffffffff.  Some other special cases are handled too
+;; when the constant can fit inside the immediate operaand of the and
+;; instruction.
+(define-vop (fast-logand-c/signed-unsigned=>unsigned fast-unsigned-binop-c)
+  (:args (x :scs (signed-reg)))
+  (:translate logand)
+  (:arg-types signed-num
+	      (:constant (or (and (unsigned-byte 12) (not (integer 0 0)))
+			     (integer #xfffff000 #xffffffff))))
+  (:generator 2				; Needs to be low to give this vop a chance.
+    (cond ((= y #xffffffff)
+	   (move r x))
+	  ((typep y '(unsigned-byte 13))
+	   (inst and r x y))
+	  (t
+	   ;; The constant operand is really a (signed-byte 13), so convert it
+	   ;; to a negative number so the immediate operand gets
+	   ;; signed extended to the right bits.
+	   (inst and r x (- y #x100000000))
+	   ))))
+
+(define-vop (fast-abs/signed fast-safe-arith-op)
+  (:args (x :scs (signed-reg)))
+  (:arg-types signed-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate abs)
+  (:note _N"inline 32-bit abs")
+  (:temporary (:scs (signed-reg)) y)
+  (:generator 1
+    ;; From Hacker's Delight
+    ;;
+    ;; abs(x) = (x ^ y) - y, where y = x >> 31 (signed shift)
+    (inst sran y x (1- vm:word-bits))
+    (inst xor r y x)
+    (inst sub r y)))
+
+;;; Special case fixnum + and - that trap on overflow.  Useful when we
+;;; don't know that the output type is a fixnum.
+
+;;; I (toy@rtp.ericsson.se) took these out.  They don't seem to be
+;;; used anywhere at all.
+#+nil
+(progn
+(define-vop (+/fixnum fast-+/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note _N"safe inline fixnum arithmetic")
+  (:generator 4
+    (inst taddcctv r x y)))
+
+(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note _N"safe inline fixnum arithmetic")
+  (:generator 3
+    (inst taddcctv r x (fixnumize y))))
+
+(define-vop (-/fixnum fast--/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note _N"safe inline fixnum arithmetic")
+  (:generator 4
+    (inst tsubcctv r x y)))
+
+(define-vop (--c/fixnum fast---c/fixnum=>fixnum)
+  (:policy :safe)
+  (:results (r :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note _N"safe inline fixnum arithmetic")
+  (:generator 3
+    (inst tsubcctv r x (fixnumize y))))
+
+)
+
+;;; Truncate
+
+;; This doesn't work for some reason.
+#+nil
+(define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (any-reg))
+	 (y :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:results (quo :scs (any-reg))
+	    (rem :scs (any-reg)))
+  (:result-types tagged-num tagged-num)
+  (:note _N"inline fixnum arithmetic")
+  (:temporary (:scs (any-reg) :target quo) q)
+  (:temporary (:scs (any-reg)) r)
+  (:temporary (:scs (signed-reg)) y-int)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 12
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y zero-tn)
+      (inst b :eq zero)
+      ;; Extend the sign of X into the Y register
+        (inst sra r x 31)
+      (inst wry r)
+      ;; Remove tag bits so Q and R will be tagged correctly.
+      (inst sra y-int y fixnum-tag-bits)
+      (inst nop)
+      (inst nop)
+
+      (inst sdiv q x y-int)		; Q is tagged.
+      ;; We have the quotient so we need to compute the remainder
+      (inst smul r q y-int)		; R is tagged
+      (inst sub rem x r)
+      (unless (location= quo q)
+	(move quo q)))))
+
+(define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (signed-reg))
+	 (y :scs (signed-reg)))
+  (:arg-types signed-num signed-num)
+  (:results (quo :scs (signed-reg))
+	    (rem :scs (signed-reg)))
+  (:result-types signed-num signed-num)
+  (:note _N"inline (signed-byte 32) arithmetic")
+  (:temporary (:scs (signed-reg) :target quo) q)
+  (:temporary (:scs (signed-reg)) r)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 12
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y zero-tn)
+      (inst b :eq zero #+sparc-v9 :pn)
+      ;; Extend the sign of X into the Y register
+        (inst sra r x 31)
+      (inst wry r)
+      (inst nop)
+      (inst nop)
+      (inst nop)
+
+      (inst sdiv q x y)
+      ;; We have the quotient so we need to compue the remainder
+      (inst smul r q y)		; rem
+      (inst sub rem x r)
+      (unless (location= quo q)
+	(move quo q)))))
+
+(define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:note _N"inline (unsigned-byte 32) arithmetic")
+  (:temporary (:scs (unsigned-reg) :target quo) q)
+  (:temporary (:scs (unsigned-reg)) r)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 8
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y zero-tn)
+      (inst b :eq zero #+sparc-v9 :pn)
+        (inst wry zero-tn)		; Clear out high part
+      (inst nop)
+      (inst nop)
+      (inst nop)
+      
+      (inst udiv q x y)
+      ;; Compute remainder
+      (inst umul r q y)
+      (inst sub rem x r)
+      (unless (location= quo q)
+	(inst move quo q)))))
+
+(define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (signed-reg))
+	 (y :scs (signed-reg)))
+  (:arg-types signed-num signed-num)
+  (:results (quo :scs (signed-reg))
+	    (rem :scs (signed-reg)))
+  (:result-types signed-num signed-num)
+  (:note _N"inline (signed-byte 32) arithmetic")
+  (:temporary (:scs (signed-reg) :target quo) q)
+  (:temporary (:scs (signed-reg)) r)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:guard (backend-featurep :sparc-64))
+  (:generator 8
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y zero-tn)
+      (inst b :eq zero :pn)
+      ;; Sign extend the numbers, just in case.
+        (inst signx x)
+      (inst signx y)
+      (inst sdivx q x y)
+      ;; Compute remainder
+      (inst mulx r q y)
+      (inst sub rem x r)
+      (unless (location= quo q)
+	(inst move quo q)))))
+
+#+nil
+(define-vop (fast-v9-truncate/signed64=>signed64 fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (signed64-reg))
+	 (y :scs (signed64-reg)))
+  (:arg-types signed64-num signed64-num)
+  (:results (quo :scs (signed64-reg))
+	    (rem :scs (signed64-reg)))
+  (:result-types signed64-num signed64-num)
+  (:note _N"inline (signed-byte 32) arithmetic")
+  (:temporary (:scs (signed64-reg) :target quo) q)
+  (:temporary (:scs (signed64-reg)) r)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 8
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y zero-tn)
+      (inst b :eq zero :pn :xcc)
+      (inst nop)
+
+      (inst sdivx q x y)
+      ;; Compute remainder
+      (inst mulx r q y)
+      (inst sub rem x r)
+      (unless (location= quo q)
+	(inst move quo q)))))
+
+(define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (unsigned-reg))
+	 (y :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:note _N"inline (unsigned-byte 32) arithmetic")
+  (:temporary (:scs (unsigned-reg) :target quo) q)
+  (:temporary (:scs (unsigned-reg)) r)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:guard (backend-featurep :sparc-64))
+  (:generator 8
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y zero-tn)
+      (inst b :eq zero :pn)
+      ;; Zap the higher 32 bits, just in case
+        (inst clruw x)
+      (inst clruw y)
+      (inst udivx q x y)
+      ;; Compute remainder
+      (inst mulx r q y)
+      (inst sub rem x r)
+      (unless (location= quo q)
+	(inst move quo q)))))
+
+;;; Shifting
+
+(define-vop (fast-ash/signed=>signed)
+  (:note _N"inline (signed-byte 32) ASH")
+  (:args (number :scs (signed-reg) :to :save)
+	 (amount :scs (signed-reg immediate) :to :save))
+  (:arg-types signed-num signed-num)
+  (:results (result :scs (signed-reg)))
+  (:result-types signed-num)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:sc non-descriptor-reg) ndesc)
+  (:generator 5
+    (sc-case amount
+      (signed-reg
+       (cond ((backend-featurep :sparc-v9)
+	      (let ((done (gen-label)))
+		(inst cmp amount)
+		(inst b :ge done)
+		;; The result-type assures us that this shift will not
+		;; overflow.
+		(inst slln result number amount)
+		(inst neg ndesc amount)
+		;; ndesc = max(-amount, 31)
+		(inst cmp ndesc 31)
+		(inst cmove :ge ndesc 31)
+		(inst sran result number ndesc)
+		(emit-label done)))
+	     (t
+	      (let ((done (gen-label)))
+		(inst cmp amount)
+		(inst b :ge done)
+		;; The result-type assures us that this shift will not overflow.
+		(inst slln result number amount)
+
+		;; Handle right shifts here.
+		(inst neg ndesc amount)
+		(inst cmp ndesc 31)
+		(inst b :le done)
+		(inst sran result number ndesc)
+		;; Right shift of greater than 31 bits is the same as a shift
+		;; of 31 bits for signed 32-bit numbers.
+		(inst sran result number 31)
+
+		(emit-label done)))))
+
+	(immediate
+	 (let ((amount (tn-value amount)))
+	   (cond ((< amount -31)
+		  (inst li result -1))
+		 ((< amount 0)
+		  (inst sran result number (- amount)))
+		 ((> amount 0)
+		  (inst slln result number amount))
+		 (t
+		  ;; amount = 0.  Shouldn't happen because of a
+		  ;; deftransform, but it's easy.
+		  (move result number))))))))
+
+(define-vop (fast-ash/unsigned=>unsigned)
+  (:note _N"inline (unsigned-byte 32) ASH")
+  (:args (number :scs (unsigned-reg) :to :save)
+	 (amount :scs (signed-reg immediate) :to :save))
+  (:arg-types unsigned-num signed-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:sc non-descriptor-reg) ndesc)
+  (:generator 5
+    (sc-case amount
+      (signed-reg
+       (cond ((backend-featurep :sparc-v9)
+	      (let ((done (gen-label)))
+		(inst cmp amount)
+		(inst b :ge done)
+		;; The result-type assures us that this shift will not
+		;; overflow.
+		(inst slln result number amount)
+		(inst neg ndesc amount)
+		;; A right shift of 32 or more results in zero.
+		(inst cmp ndesc 32)
+		(inst srln result number ndesc)
+		(inst cmove :ge result zero-tn)
+		(emit-label done)))
+	     (t
+	      (let ((done (gen-label)))
+		(inst cmp amount)
+		(inst b :ge done)
+		;; The result-type assures us that this shift will not
+		;; overflow.
+		(inst slln result number amount)
+		(inst neg ndesc amount)
+		(inst cmp ndesc 32)
+		(inst b :lt done)
+		(inst srln result number ndesc)
+		;; Right shift of 32 or more is the same as zero for unsigned
+		;; 32-bit numbers.
+		(move result zero-tn)
+
+		(emit-label done)))))
+
+      (immediate
+       (let ((amount (tn-value amount)))
+	 (cond ((< amount -31)
+		(move result zero-tn))
+	       ((< amount 0)
+		(inst srln result number (- amount)))
+	       ((> amount 0)
+		(inst slln result number amount))
+	       (t
+		;; amount = 0.  Shouldn't happen because of a
+		;; deftransform, but it's easy.
+		(move result number))))))))
+
+(define-vop (fast-ash-c/unsigned=>unsigned)
+  (:note _N"inline constant ASH")
+  (:args (number :scs (unsigned-reg)))
+  (:info count)
+  (:arg-types unsigned-num (:constant integer))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:generator 4
+    (cond
+      ((< count -31) (move result zero-tn))
+      ((< count 0) (inst srl result number (min (- count) 31)))
+      ((> count 0) (inst sll result number (min count 31)))
+      (t (error (intl:gettext "identity ASH not transformed away"))))))
+
+;; Some special cases where we know we want a left shift.  Just do the
+;; shift, instead of checking for the sign of the shift.
+(macrolet
+    ((frob (name sc-type type result-type cost)
+       `(define-vop (,name)
+	 (:note _N"inline ASH")
+	 (:translate ash)
+	 (:args (number :scs (,sc-type))
+	        (amount :scs (signed-reg unsigned-reg immediate)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (result :scs (,result-type)))
+	 (:result-types ,type)
+	 (:policy :fast-safe)
+	 (:generator ,cost
+	  ;; The result-type assures us that this shift will not
+	  ;; overflow. And for fixnum's, the zero bits that get
+	  ;; shifted in are just fine for the fixnum tag.
+	  (sc-case amount
+	   ((signed-reg unsigned-reg)
+	    (inst slln result number amount))
+	   (immediate
+	    (let ((amount (tn-value amount)))
+	      (assert (>= amount 0))
+	      (inst slln result number amount))))))))
+  (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
+  (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
+  (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
+
+;; Constant left shift
+(macrolet
+    ((frob (name sc-type type result-type cost)
+       `(define-vop (,name)
+	  (:note _N"inline ASH")
+	  (:translate ash)
+	  (:args (number :scs (,sc-type)))
+	  (:info amount)
+	  (:arg-types ,type
+		      (:constant (integer 0 31)))
+	  (:results (result :scs (,result-type)))
+	  (:result-types ,type)
+	  (:policy :fast-safe)
+	  (:generator ,cost
+	    ;; The result-type assures us that this shift will not
+	    ;; overflow. And for fixnum's, the zero bits that get
+	    ;; shifted in are just fine for the fixnum tag.
+	    (if (zerop amount)
+		(move result number)
+		(inst slln result number amount))))))
+  (frob fast-ash-left-c/signed=>signed signed-reg signed-num signed-reg 3)
+  (frob fast-ash-left-c/fixnum=>fixnum any-reg tagged-num any-reg 2)
+  (frob fast-ash-left-c/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
+
+;;#+sparc-v9
+#+nil
+(define-vop (fast-ash-left/signed64=>signed64)
+    (:note _N"inline ASH")
+  (:translate ash)
+  (:args (number :scs (signed64-reg))
+	 (amount :scs (signed-reg unsigned-reg immediate)))
+  (:arg-types signed64-num positive-fixnum)
+  (:results (result :scs (signed64-reg)))
+  (:result-types ,type)
+  (:policy :fast-safe)
+  (:generator ,cost
+    ;; The result-type assures us that this shift will not
+    ;; overflow. And for fixnum's, the zero bits that get shifted in
+    ;; are just fine for the fixnum tag.
+    (sc-case amount
+      ((signed-reg unsigned-reg)
+       (inst sllx result number amount))
+      (immediate
+       (let ((amount (tn-value amount)))
+	 (assert (>= amount 0))
+	 (inst sllx result number amount))))))
+    
+#-(and sparc-v9 sparc-v8plus)
+(defknown ash-right-signed ((signed-byte #.vm:word-bits)
+			    (and fixnum unsigned-byte))
+  (signed-byte #.vm:word-bits)
+  (movable foldable flushable))
+
+#-(and sparc-v9 sparc-v8plus)
+(defknown ash-right-unsigned ((unsigned-byte #.vm:word-bits)
+			      (and fixnum unsigned-byte))
+  (unsigned-byte #.vm:word-bits)
+  (movable foldable flushable))
+
+#+(and sparc-v9 sparc-v8plus)
+(defknown ash-right-signed ((signed-byte #.(* 2 vm:word-bits))
+			    (and fixnum unsigned-byte))
+  (signed-byte #.(* 2 vm:word-bits))
+  (movable foldable flushable))
+
+#+(and sparc-v9 sparc-v8plus)
+(defknown ash-right-unsigned ((unsigned-byte #.(* 2 vm:word-bits))
+			      (and fixnum unsigned-byte))
+  (unsigned-byte #.(* 2 vm:word-bits))
+  (movable foldable flushable))
+
+
+
+;; Some special cases where we want a right shift.  Just do the shift.
+;; (Needs appropriate deftransforms to call these, though.)
+
+(macrolet
+    ((frob (trans name sc-type type shift-inst cost)
+       `(define-vop (,name)
+	 (:note _N"inline right ASH")
+	 (:translate ,trans)
+	 (:args (number :scs (,sc-type))
+	        (amount :scs (signed-reg unsigned-reg immediate)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (result :scs (,sc-type)))
+	 (:result-types ,type)
+	 (:policy :fast-safe)
+	 (:generator ,cost
+	    (sc-case amount
+	     ((signed-reg unsigned-reg)
+		(inst ,shift-inst result number amount))
+	     (immediate
+	      (let ((amt (tn-value amount)))
+		(inst ,shift-inst result number amt))))))))
+  (frob ash-right-signed fast-ash-right/signed=>signed
+	signed-reg signed-num sra 3)
+  (frob ash-right-unsigned fast-ash-right/unsigned=>unsigned
+	unsigned-reg unsigned-num srl 3)
+  #+(and sparc-v9 sparc-v8plus)
+  (frob ash-right-signed fast-ash-right/signed64=>signed64
+	signed64-reg signed64-num srax 3)
+  #+(and sparc-v9 sparc-v8plus)
+  (frob ash-right-unsigned fast-ash-right/unsigned64=>unsigned64
+	unsigned64-reg unsigned64-num srlx 3)
+  )
+
+;; Constant right shift.
+(macrolet
+    ((frob (trans name sc-type type shift-inst cost max-shift)
+       `(define-vop (,name)
+	 (:note _N"inline right ASH")
+	 (:translate ,trans)
+	 (:args (number :target result :scs (,sc-type)))
+	 (:info amount)
+	 (:arg-types ,type
+		     (:constant (integer 0 ,max-shift)))
+	 (:results (result :scs (,sc-type)))
+	 (:result-types ,type)
+	 (:policy :fast-safe)
+	 (:generator ,cost
+	   (if (zerop amount)
+	       (move result number)
+	       (inst ,shift-inst result number amount))))))
+  (frob ash-right-signed fast-ash-right-c/signed=>signed
+	signed-reg signed-num sra 1 31)
+  (frob ash-right-unsigned fast-ash-right-c/unsigned=>unsigned
+	unsigned-reg unsigned-num srl 1 31)
+  #+(and sparc-v9 sparc-v8plus)
+  (frob ash-right-signed fast-ash-right-c/signed64=>signed64
+	signed64-reg signed64-num srax 1 63)
+  #+(and sparc-v9 sparc-v8plus)
+  (frob ash-right-unsigned fast-ash-right-c/unsigned64=>unsigned64
+	unsigned64-reg unsigned64-num srlx 1 63)
+  )
+
+#+nil
+(define-vop (fash-ash-right-c/signed=>signed fast-signed-binop-c)
+  (:args (x :target r :scs (signed-reg zero)))
+  (:arg-types signed-num
+	      (:constant (integer 0 31)))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:translate ash-right-signed)
+  (:note _N"inline (signed-byte 32) arithmetic")
+  (:generator 1
+    (if (zerop y)
+	(move r x)
+	(inst srln r x y))))
+
+  
+(define-vop (fast-ash-right/fixnum=>fixnum)
+    (:note _N"inline right ASH")
+  (:translate ash-right-signed)
+  (:args (number :scs (any-reg))
+	 (amount :scs (signed-reg unsigned-reg immediate)))
+  (:arg-types tagged-num positive-fixnum)
+  (:results (result :scs (any-reg)))
+  (:result-types tagged-num)
+  (:temporary (:sc non-descriptor-reg :target result) temp)
+  (:policy :fast-safe)
+  (:generator 2
+    ;; Shift the fixnum right by the desired amount.  Then zap out the
+    ;; 2 LSBs to make it a fixnum again.  (Those bits are junk.)
+    (sc-case amount
+      ((signed-reg unsigned-reg)
+       (inst sran temp number amount))
+      (immediate
+       (inst sran temp number (tn-value amount))))
+    (inst andn result temp fixnum-tag-mask)))
+    
+
+
+
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note _N"inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg) :target shift))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
+  (:generator 30
+    (let ((loop (gen-label))
+	  (test (gen-label)))
+      (inst addcc shift zero-tn arg)
+      (inst b :ge test)
+      (move res zero-tn)
+      (inst b test)
+      (inst not shift)
+
+      (emit-label loop)
+      (inst add res (fixnumize 1))
+      
+      (emit-label test)
+      (inst cmp shift)
+      (inst b :ne loop)
+      (inst srln shift 1))))
+
+(define-vop (unsigned-byte-32-len)
+  (:translate integer-length)
+  (:note _N"inline (unsigned-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg) :target shift))
+  (:arg-types unsigned-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
+  (:generator 30
+    (let ((loop (gen-label))
+	  (test (gen-label)))
+      (move shift arg)
+      (inst b test)
+      (move res zero-tn)
+
+      (emit-label loop)
+      (inst add res (fixnumize 1))
+      
+      (emit-label test)
+      (inst cmp shift)
+      (inst b :ne loop)
+      (inst srln shift 1))))
+
+
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note _N"inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) mask temp)
+  (:generator 35
+      (move res arg)
+
+      (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f)
+		       (8 #x00ff00ff) (16 #x0000ffff)))
+	(destructuring-bind (shift bit-mask)
+	    stuff
+	  ;; Set mask
+	  (inst li mask bit-mask)
+
+	  (inst and temp res mask)
+	  (inst srln res shift)
+	  (inst and res mask)
+	  (inst add res temp)))))
+
+
+;;; Multiply and Divide.
+
+(define-vop (fast-v8-*/fixnum=>fixnum fast-fixnum-binop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:translate *)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 2
+    ;; The cost here should be less than the cost for
+    ;; */signed=>signed.  Why?  A fixnum product using signed=>signed
+    ;; has to convert both args to signed-nums.  But using this, we
+    ;; don't have to and that saves an instruction.
+    (inst sran temp y fixnum-tag-bits)
+    (inst smul r x temp)))
+
+;; Multiplication by a constant.
+(define-vop (fast-v8-*-c/unsigned=>unsigned fast-unsigned-binop-c)
+  (:translate *)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 2
+    (inst umul r x y)))
+
+(define-vop (fast-v8-*-c/signed=>signed fast-signed-binop-c)
+  (:translate *)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 2
+    (inst smul r x y)))
+
+(define-vop (fast-v8-*-c/fixnum=>fixnum fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg zero)))
+  (:info y)
+  (:arg-types tagged-num
+	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note _N"inline fixnum arithmetic")
+  (:translate *)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 1
+    (inst smul r x y)))
+
+
+(define-vop (fast-v8-*/signed=>signed fast-signed-binop)
+  (:translate *)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 3
+    (inst smul r x y)))
+
+(define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop)
+  (:translate *)
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 3
+    (inst umul r x y)))
+
+;; The smul and umul instructions are deprecated on the Sparc V9.  Use
+;; mulx instead.
+(define-vop (fast-v9-*/fixnum=>fixnum fast-fixnum-binop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:translate *)
+  (:guard (backend-featurep :sparc-64))
+  (:generator 4
+    (inst sran temp y fixnum-tag-bits)
+    (inst mulx r x temp)))
+
+(define-vop (fast-v9-*/signed=>signed fast-signed-binop)
+  (:translate *)
+  (:guard (backend-featurep :sparc-64))
+  (:generator 3
+    (inst mulx r x y)))
+
+(define-vop (fast-v9-*/unsigned=>unsigned fast-unsigned-binop)
+  (:translate *)
+  (:guard (backend-featurep :sparc-64))
+  (:generator 3
+    (inst mulx r x y)))
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(deftype integer-with-a-bite-out (s bite)
+  (cond ((eq s '*) 'integer)
+	((and (integerp s) (> s 1))
+	 (let ((bound (ash 1 (1- s))))
+	   `(integer ,(- bound) ,(- bound bite 1))))
+	(t
+	 (error (intl:gettext "Bad size specified for SIGNED-BYTE type specifier: ~S.") s))))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+  (:args (x :scs (any-reg zero))
+	 (y :scs (any-reg zero)))
+  (:arg-types tagged-num tagged-num)
+  (:note _N"inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg zero)))
+  (:arg-types tagged-num (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits))))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+  (:args (x :scs (signed-reg zero))
+	 (y :scs (signed-reg zero)))
+  (:arg-types signed-num signed-num)
+  (:note _N"inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+  (:args (x :scs (signed-reg zero)))
+  (:arg-types signed-num (:constant (signed-byte 13)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+  (:args (x :scs (unsigned-reg zero))
+	 (y :scs (unsigned-reg zero)))
+  (:arg-types unsigned-num unsigned-num)
+  (:note _N"inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+  (:args (x :scs (unsigned-reg zero)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 12)))
+  (:info target not-p y))
+
+
+(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
+  `(progn
+     ,@(mapcar #'(lambda (suffix cost signed)
+		   (unless (and (member suffix '(/fixnum -c/fixnum))
+				(eq tran 'eql))
+		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+						    tran suffix))
+				   ,(intern
+				     (format nil "~:@(FAST-CONDITIONAL~A~)"
+					     suffix)))
+			(:translate ,tran)
+			(:generator ,cost
+			  (inst cmp x
+				,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))
+			  (inst b (if not-p
+				      ,(if signed not-cond not-unsigned)
+				      ,(if signed cond unsigned))
+				target)
+			  (inst nop)))))
+	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+	       '(4 3 6 5 6 5)
+	       '(t t t t nil nil))))
+
+(define-conditional-vop < :lt :ltu :ge :geu)
+
+(define-conditional-vop > :gt :gtu :le :leu)
+
+(define-conditional-vop eql :eq :eq :ne :ne)
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+;;; 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 descriptor-reg zero))
+	 (y :scs (any-reg zero)))
+  (:arg-types tagged-num tagged-num)
+  (:note _N"inline fixnum comparison")
+  (:translate eql)
+  (:generator 4
+    (inst cmp x y)
+    (inst b (if not-p :ne :eq) target)
+    (inst nop)))
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+  (:arg-types * tagged-num)
+  (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg descriptor-reg zero)))
+  ;; This is a signed-byte 11 because after fixnum shifting, we get a
+  ;; 13-bit number, and that's the largest immediate allowed.
+  (:arg-types tagged-num (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits))))
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 2
+    (inst cmp x (fixnumize y))
+    (inst b (if not-p :ne :eq) target)
+    (inst nop)))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+  ;; This is a signed-byte 11 because after fixnum shifting, we get a
+  ;; 13-bit number, and that's the largest immediate allowed.
+  (:arg-types * (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits))))
+  (: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 cmp shift)
+      (inst b :eq done)
+      (inst srln res next shift)
+      (inst sub temp zero-tn shift)
+      (inst slln temp prev temp)
+      (inst or res temp)
+      (emit-label done)
+      (move result res))))
+
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg zero))
+	 (y :scs (unsigned-reg zero)))
+  (: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 zero)))
+  (:arg-types unsigned-num)
+  (:generator 1
+    (inst not r x)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (inst and r x y)))
+
+(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 or r x y)))
+
+(deftransform 32bit-logical-nor ((x y) (* *))
+  '(32bit-logical-not (32bit-logical-or x y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+  (:translate 32bit-logical-xor)
+  (:generator 1
+    (inst xor r x y)))
+
+(define-vop (32bit-logical-eqv 32bit-logical)
+  (:translate 32bit-logical-eqv)
+  (:generator 1
+    (inst xnor r x y)))
+
+(define-vop (32bit-logical-orc2 32bit-logical)
+  (:translate 32bit-logical-orc2)
+  (:generator 1
+    (inst orn r x y)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+  '(32bit-logical-orc2 y x))
+
+(define-vop (32bit-logical-andc2 32bit-logical)
+  (:translate 32bit-logical-andc2)
+  (:generator 1
+    (inst andn r x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+  '(32bit-logical-andc2 y x))
+
+
+(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 _N"shift-towards-start")
+  (:generator 1
+    (inst slln r num amount)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+  (:translate shift-towards-end)
+  (:note _N"shift-towards-end")
+  (:generator 1
+    (inst srln r num amount)))
+
+
+
+
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+  (:translate bignum::%bignum-length)
+  (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+  (:translate bignum::%bignum-set-length)
+  (:policy :fast-safe))
+
+(define-vop (bignum-ref word-index-ref)
+  (:variant vm:bignum-digits-offset vm:other-pointer-type)
+  (:translate bignum::%bignum-ref)
+  (:results (value :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (bignum-set word-index-set)
+  (:variant vm:bignum-digits-offset vm:other-pointer-type)
+  (:translate bignum::%bignum-set)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg immediate zero))
+	 (value :scs (unsigned-reg)))
+  (:arg-types t positive-fixnum unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (digit-0-or-plus)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:guard (not (backend-featurep :sparc-v9)))
+  (:generator 3
+    (let ((done (gen-label)))
+      (inst cmp digit)
+      (inst b :lt done)
+      (move result null-tn)
+      (load-symbol result t)
+      (emit-label done))))
+
+(define-vop (v9-digit-0-or-plus-cmove)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 3
+    (inst cmp digit)
+    (load-symbol result t)
+    (inst cmove :lt result null-tn)))
+
+;; This doesn't work?
+#+nil
+(define-vop (v9-digit-0-or-plus-movr)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 2
+    (load-symbol temp t)
+    (inst movr result null-tn digit :lz)
+    (inst movr result temp digit :gez)))
+
+
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (any-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg))
+	    (carry :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 3
+    (inst addcc zero-tn c -1)
+    (inst addxcc result a b)
+    (inst addx carry zero-tn zero-tn)))
+
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg))
+	 (b :scs (unsigned-reg))
+	 (c :scs (any-reg)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg))
+	    (borrow :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 4
+    (inst subcc zero-tn c 1)
+    (inst subxcc result a b)
+    (inst addx borrow zero-tn zero-tn)
+    (inst xor borrow 1)))
+
+;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly
+;;; routines.
+;;; 
+(defun emit-multiply (multiplier multiplicand result-high result-low)
+  "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result
+  in RESULT-HIGH and RESULT-LOW.  KIND is either :signed or :unsigned.
+  Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap."
+  (declare (type tn multiplier result-high result-low)
+	   (type (or tn (signed-byte 13)) multiplicand))
+  ;; It seems that emit-multiply is only used to do an unsigned
+  ;; multiply, so the code only does an unsigned multiply.
+  (cond ((backend-featurep :sparc-64)
+	 ;; Take advantage of V9's 64-bit multiplier.
+	 ;;
+	 ;; Make sure the multiplier and multiplicand are really
+	 ;; unsigned 64-bit numbers.
+	 (inst clruw multiplier)
+	 (inst clruw multiplicand)
+	 
+	 ;; Multiply the two numbers and put the result in
+	 ;; result-high.  Copy the low 32-bits to result-low.  Then
+	 ;; shift result-high so the high 32-bits end up in the low
+	 ;; 32-bits.
+	 (inst mulx result-high multiplier multiplicand)
+	 (inst move result-low result-high)
+	 (inst srax result-high 32))
+	((or (backend-featurep :sparc-v8)
+	     (backend-featurep :sparc-v9))
+	 ;; V8 has a multiply instruction.  This should also work for
+	 ;; the V9, but umul and the Y register is deprecated on the
+	 ;; V9.
+	 (inst umul result-low multiplier multiplicand)
+	 (inst rdy result-high))
+	(t
+	 (let ((label (gen-label)))
+	   (inst wry multiplier)
+	   (inst andcc result-high zero-tn)
+	   ;; Note: we can't use the Y register until three insts
+	   ;; after it's written.
+	   (inst nop)
+	   (inst nop)
+	   (dotimes (i 32)
+	     (inst mulscc result-high multiplicand))
+	   (inst mulscc result-high zero-tn)
+	   (inst cmp multiplicand)
+	   (inst b :ge label)
+	   (inst nop)
+	   (inst add result-high multiplier)
+	   (emit-label label)
+	   (inst rdy result-low)))))
+
+(define-vop (bignum-mult-and-add-3-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :to (:eval 1))
+	 (y :scs (unsigned-reg) :to (:eval 1))
+	 (carry-in :scs (unsigned-reg) :to (:eval 2)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (hi :scs (unsigned-reg) :from (:eval 0))
+	    (lo :scs (unsigned-reg) :from (:eval 1)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 40
+    (emit-multiply x y hi lo)
+    (inst addcc lo carry-in)
+    (inst addx hi zero-tn)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :to (:eval 1))
+	 (y :scs (unsigned-reg) :to (:eval 1))
+	 (prev :scs (unsigned-reg) :to (:eval 2))
+	 (carry-in :scs (unsigned-reg) :to (:eval 2)))
+  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+  (:results (hi :scs (unsigned-reg) :from (:eval 0))
+	    (lo :scs (unsigned-reg) :from (:eval 1)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 40
+    (emit-multiply x y hi lo)
+    (inst addcc lo carry-in)
+    (inst addx hi zero-tn)
+    (inst addcc lo prev)
+    (inst addx hi zero-tn)))
+
+(define-vop (bignum-mult)
+  (:translate bignum::%multiply)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :to (:result 1))
+	 (y :scs (unsigned-reg) :to (:result 1)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 40
+    (emit-multiply x y hi 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 r x)))
+
+(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 sran digit fixnum fixnum-tag-bits)))
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (div-high :scs (unsigned-reg) :target rem)
+	 (div-low :scs (unsigned-reg) :target quo)
+	 (divisor :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (quo :scs (unsigned-reg) :from (:argument 1))
+	    (rem :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:guard (not (or (backend-featurep :sparc-v8)
+		   (backend-featurep :sparc-v9))))
+  (:generator 300
+    (move rem div-high)
+    (move quo div-low)
+    (dotimes (i 33)
+      (let ((label (gen-label)))
+	(inst cmp rem divisor)
+	(inst b :ltu label)
+	(inst addxcc quo quo)
+	(inst sub rem divisor)
+	(emit-label label)
+	(unless (= i 32)
+	  (inst addx rem rem))))
+    (inst not quo)))
+
+(define-vop (bignum-floor-v8)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (div-high :scs (unsigned-reg) :target rem)
+	 (div-low :scs (unsigned-reg) :target quo)
+	 (divisor :scs (unsigned-reg)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (quo :scs (unsigned-reg) :from (:argument 1))
+	    (rem :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num unsigned-num)
+  (:temporary (:scs (unsigned-reg) :target quo) q)
+  ;; This vop is for a v8 or v9, provided we're also not using
+  ;; sparc-64, for which there a special sparc-64 vop.
+  (:guard (or (backend-featurep :sparc-v8)
+	      (and (backend-featurep :sparc-v9)
+		   (not (backend-featurep :sparc-64)))))
+  (:generator 15
+    (inst wry div-high)
+    (inst nop)
+    (inst nop)
+    (inst nop)
+    ;; Compute the quotient [Y, div-low] / divisor
+    (inst udiv q div-low divisor)
+    ;; Compute the remainder.  The high part of the result is in the Y
+    ;; register.
+    (inst umul rem q divisor)
+    (inst sub rem div-low rem)
+    (unless (location= quo q)
+      (move quo q))))
+
+(define-vop (bignum-floor-v9)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (div-high :scs (unsigned-reg))
+	 (div-low :scs (unsigned-reg))
+	 (divisor :scs (unsigned-reg) :to (:result 1)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :from (:argument 0)) dividend)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:guard (backend-featurep :sparc-64))
+  (:generator 5
+    ;; Set dividend to be div-high and div-low	      
+    (inst sllx dividend div-high 32)
+    (inst add dividend div-low)
+    ;; Compute quotient
+    (inst udivx quo dividend divisor)
+    ;; Compute the remainder
+    (inst mulx rem quo divisor)
+    (inst sub rem dividend rem)))
+
+(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 1
+    (sc-case res
+      (any-reg
+       (inst slln res digit fixnum-tag-bits))
+      (signed-reg
+       (move res digit)))))
+
+
+(define-vop (digit-ashr)
+  (:translate bignum::%ashr)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg))
+	 (count :scs (signed-reg unsigned-reg immediate)))
+  (:arg-types unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (sc-case count
+      ((signed-reg unsigned-reg)
+       (inst sran result digit count))
+      (immediate
+       (inst sran result digit (tn-value count))))))
+
+(define-vop (digit-lshr digit-ashr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:generator 1
+    (sc-case count
+      ((signed-reg unsigned-reg)
+       (inst srln result digit count))
+      (immediate
+       (inst srln result digit (tn-value count))))))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 1
+    (sc-case count
+      ((signed-reg unsigned-reg)
+       (inst slln result digit count))
+      (immediate
+       (inst slln result digit (tn-value count))))))
+
+
+;;;; Static functions.
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-+ (x y) :translate +)
+(define-static-function two-arg-- (x y) :translate -)
+(define-static-function two-arg-* (x y) :translate *)
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-< (x y) :translate <)
+(define-static-function two-arg-<= (x y) :translate <=)
+(define-static-function two-arg-> (x y) :translate >)
+(define-static-function two-arg->= (x y) :translate >=)
+(define-static-function two-arg-= (x y) :translate =)
+(define-static-function two-arg-/= (x y) :translate /=)
+
+(define-static-function %negate (x) :translate %negate)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
+
+
+;; Truncation by a constant can be done by multiplication with the
+;; appropriate constant.
+;;
+;; See generic/vm-tran.lisp for the algorithm.
+
+(define-vop (signed-truncate-by-mult fast-signed-binop)
+  (:translate truncate)
+  (:args (x :scs (signed-reg)))
+  (:info y)
+  (:arg-types signed-num (:constant (integer 2 #.(1- (ash 1 vm:word-bits)))))
+  (:results (quo :scs (signed-reg))
+            (rem :scs (signed-reg)))
+  (:result-types signed-num signed-num)
+  (:note _N"inline (signed-byte 32) arithmetic")
+  (:guard (or (backend-featurep :sparc-v8)
+              (and (backend-featurep :sparc-v9)
+                   (not (backend-featurep :sparc-64)))))
+  (:temporary (:scs (signed-reg)) q)
+  (:temporary (:scs (signed-reg)) r)
+  (:temporary (:scs (signed-reg)) temp)
+  (:generator 6
+    (multiple-value-bind (recip shift)
+        (c::find-signed-reciprocal y vm:word-bits)
+      ;; Compute q = floor(M*n/2^32).  That is, the high half of the
+      ;; product.
+      (inst li temp recip)
+      (inst smul r x temp)
+      (inst rdy q)
+      ;; Adjust if the M is negative.
+      (when (minusp recip)
+        (inst add q x))
+      ;; Shift quotient as needed.
+      (unless (zerop shift)
+        (inst sran q shift))
+      ;; Add one to quotient if X is negative.  This is done by right
+      ;; shifting X to give either -1 or 0.  Then subtract this from
+      ;; the quotient.  (NOTE: in the book, the sample code has this
+      ;; wrong and ADDS instead of SUBTRACTS.)
+      (inst sran temp x 31)
+      (inst sub q q temp)
+      ;; Now compute remainder via r = x - q*d
+      (cond ((typep y '(signed-byte 13))
+             (inst smul r q y))
+            (t
+             (inst li temp y)
+             (inst smul r q temp)))
+      (inst sub rem x r)
+      (unless (location= quo q)
+        (move quo q)))))
+
+(define-vop (unsigned-truncate-by-mult fast-signed-binop)
+  (:translate truncate)
+  (:args (x :scs (unsigned-reg)))
+  (:info y)
+  (:arg-types unsigned-num (:constant (integer 2 #.(1- (ash 1 vm:word-bits)))))
+  (:results (quo :scs (unsigned-reg))
+            (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:note _N"inline (unsigned-byte 32) arithmetic")
+  (:guard (or (backend-featurep :sparc-v8)
+              (and (backend-featurep :sparc-v9)
+                   (not (backend-featurep :sparc-64)))))
+  (:temporary (:scs (unsigned-reg)) q)
+  (:temporary (:scs (unsigned-reg)) r)
+  (:temporary (:scs (unsigned-reg)) temp)
+  (:generator 6
+    (multiple-value-bind (recip shift overflowp)
+        (c::find-unsigned-reciprocal y vm:word-bits)
+      ;; q = floor(M*x/2^32)
+      (inst li temp recip)
+      (inst umul r x temp)
+      (inst rdy q)
+      (cond (overflowp
+             ;; The complicated case.  Sparc does not have a
+             ;; shift-with-carry instruction, so we use idea above.
+             ;; (But we could also do this by putting the carry flag
+             ;; into a register, shifting it left some amount,
+             ;; shifting the quotient right, and adding the two
+             ;; results together.)
+             (inst sub temp x q)
+             (inst srln temp 1)
+             (inst add temp q)
+             (inst srln q temp (1- shift)))
+            (t
+             ;; The easy case
+             (unless (zerop shift)
+               (inst srln q shift))))
+      ;; Compute the remainder
+      (cond ((typep y '(signed-byte 13))
+             (inst umul r q y))
+            (t
+             (inst li temp y)
+             (inst umul r q temp)))
+      (inst sub rem x r)
+      (unless (location= quo q)
+        (move quo q)))))
+
+;; Need these so constant folding works with the deftransform.
+
+#-(and sparc-v9 sparc-v8plus)
+(progn
+(defun ash-right-signed (num shift)
+  (declare (type (signed-byte #.vm:word-bits) num)
+	   (type (integer 0 #.(1- vm:word-bits)) shift))
+  (ash num (- shift)))
+
+(defun ash-right-unsigned (num shift)
+  (declare (type (unsigned-byte #.vm:word-bits) num)
+	   (type (integer 0 #.(1- vm:word-bits)) shift))
+  (ash num (- shift)))
+)
+
+#+(and sparc-v9 sparc-v8plus)
+(progn
+(defun ash-right-signed (num shift)
+  (declare (type (signed-byte #.(* 2 vm:word-bits)) num)
+	   (type (integer 0 #.(1- (* 2 vm:word-bits))) shift))
+  (ash num (- shift)))
+
+(defun ash-right-unsigned (num shift)
+  (declare (type (unsigned-byte #.(* 2 vm:word-bits)) num)
+	   (type (integer 0 #.(1- (* 2 vm:word-bits))) shift))
+  (ash num (- shift)))
+)
+
+;; If we can prove that we have a right shift, just do the right shift
+;; instead of calling the inline ASH which has to check for the
+;; direction of the shift at run-time.
+(in-package "C")
+
+#-(and sparc-v9 sparc-v8plus)
+(deftransform ash ((num shift) (integer integer))
+  (let ((num-type (continuation-type num))
+	(shift-type (continuation-type shift)))
+    ;; Can only handle right shifts
+    (unless (csubtypep shift-type (specifier-type '(integer * 0)))
+      (give-up))
+
+    ;; If we can prove the shift is so large that all bits are shifted
+    ;; out, return the appropriate constant.  If the shift is small
+    ;; enough, call the VOP.  Otherwise, check for the shift size and
+    ;; do the appropriate thing.  (Hmm, could we just leave the IF
+    ;; s-expr and depend on other parts of the compiler to delete the
+    ;; unreachable parts, if any?)
+    (cond ((csubtypep num-type (specifier-type '(signed-byte #.vm:word-bits)))
+	   ;; A right shift by 31 is the same as a right shift by
+	   ;; larger amount.  We get just the sign.
+	   (if (csubtypep shift-type (specifier-type '(integer #.(- 1 vm:word-bits) 0)))
+	       `(sparc::ash-right-signed num (- shift))
+	       `(sparc::ash-right-signed num (min (- shift) #.(1- vm:word-bits)))))
+	  ((csubtypep num-type (specifier-type '(unsigned-byte #.vm:word-bits)))
+	   (if (csubtypep shift-type (specifier-type '(integer #.(- 1 vm:word-bits) 0)))
+	       `(sparc::ash-right-unsigned num (- shift))
+	       `(if (<= shift #.(- vm:word-bits))
+		 0
+		 (sparc::ash-right-unsigned num (- shift)))))
+	  (t
+	   (give-up)))))
+
+#+(and later sparc-v9 sparc-v8plus)
+(deftransform ash ((num shift) (integer integer))
+  (let ((num-type (continuation-type num))
+	(shift-type (continuation-type shift)))
+    ;; Can only handle right shifts
+    (unless (csubtypep shift-type (specifier-type '(integer * 0)))
+      (give-up))
+
+    ;; If we can prove the shift is so large that all bits are shifted
+    ;; out, return the appropriate constant.  If the shift is small
+    ;; enough, call the VOP.  Otherwise, check for the shift size and
+    ;; do the appropriate thing.  (Hmm, could we just leave the IF
+    ;; s-expr and depend on other parts of the compiler to delete the
+    ;; unreachable parts, if any?)
+    (cond ((csubtypep num-type (specifier-type '(signed-byte #.(* 2 vm:word-bits))))
+	   ;; A right shift by 31 is the same as a right shift by
+	   ;; larger amount.  We get just the sign.
+	   (if (csubtypep shift-type (specifier-type '(integer #.(- 1 (* 2 vm:word-bits)) 0)))
+	       `(sparc::ash-right-signed num (- shift))
+	       `(sparc::ash-right-signed num (min (- shift) #.(1- (* 2 vm:word-bits))))))
+	  ((csubtypep num-type (specifier-type '(unsigned-byte #.(* 2 vm:word-bits))))
+	   (if (csubtypep shift-type (specifier-type '(integer #.(- 1 (* 2 vm:word-bits)) 0)))
+	       `(sparc::ash-right-unsigned num (- shift))
+	       `(if (<= shift #.(- vm:word-bits))
+		 0
+		 (sparc::ash-right-unsigned num (- shift)))))
+	  (t
+	   (give-up)))))
+
+
+;;; 64-bit integer operations
+(in-package "SPARC")
+
+;; Unary operations
+
+#+(and sparc-v9 sparc-v8plus)
+(progn
+
+;;; The vops for the 64-bit operations are written this way because I
+;;; (RLT) can't figure out how to get representation selection to
+;;; convert signed-num and unsigned-num to signed64-num when
+;;; needed. (Actually, I don't even know how representation selection
+;;; works.)
+;;;
+;;; Thus, any arg that is a 64-bit register defines the SCS to include
+;;; the 64-bit reg and well as the 32-bit regs.  Then the generators
+;;; will have to dispatch on the sc type that is actually used.  This
+;;; probably generates lots of redundant moves, but we still win big
+;;; by not having to do bignum arithmetic.
+;;;
+;;; I think the dispatch could be simplified if we just sign or zero
+;;; extended the 32-bit registers in place.  However, we can't do that
+;;; in general because not all of the 32-bit regs preserve all 64-bits
+;;; on task switches.  If we constrain the 32-bit regs to be the same
+;;; 6 regs used for the 64-bit regs, we run out of regs when do
+;;; foreign function calls because we need 6 regs for that and we
+;;; don't have any more non-descriptor regs for temps.
+
+
+(define-vop (signed64-unop fast-safe-arith-op)
+  (:args (x :target res :scs (signed64-reg signed-reg unsigned-reg zero)))
+  (:results (res :scs (signed64-reg)))
+  (:arg-types (:or signed64-num signed-num unsigned-num))
+  (:result-types signed64-num)
+  (:temporary (:scs (signed64-reg)) x64)
+  (:note _N"inline (signed-byte 64) arithmetic"))
+
+(define-vop (fast-signed64-binop fast-safe-arith-op)
+  (:args (x :target r :scs (signed64-reg unsigned-reg signed-reg zero))
+	 (y :target r :scs (signed64-reg unsigned-reg signed-reg zero)))
+  (:arg-types (:or signed64-num signed-num unsigned-num)
+	      (:or signed64-num signed-num unsigned-num))
+  (:results (r :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:note _N"inline (signed-byte 64) arithmetic"))
+
+(define-vop (fast-signed64-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (signed64-reg unsigned-reg signed-reg zero)))
+  (:info y)
+  (:arg-types (:or signed64-num signed-num unsigned-num)
+	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
+  (:results (r :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:note _N"inline (signed-byte 64) arithmetic"))
+
+(define-vop (fast-unsigned64-binop fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned64-reg unsigned-reg zero))
+	 (y :target r :scs (unsigned64-reg unsigned-reg zero)))
+  (:arg-types (:or unsigned64-num unsigned-num)
+	      (:or unsigned64-num unsigned-num))
+  (:results (r :scs (unsigned64-reg)))
+  (:result-types unsigned64-num)
+  (:note _N"inline (unsigned-byte 64) arithmetic"))
+
+(define-vop (fast-unsigned64-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned64-reg unsigned-reg zero)))
+  (:info y)
+  (:arg-types (:or unsigned64-num unsigned-num)
+	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
+  (:results (r :scs (unsigned64-reg)))
+  (:result-types unsigned64-num)
+  (:note _N"inline (unsigned-byte 64) arithmetic"))
+
+;; Extend the sign of Y appropriately and perform the desired
+;; operation. R is where the result should go, X is the first arg, Y
+;; is the second, and Y64 is a 64-bit temp reg for us to use.
+(defmacro sc-case-64 (r x y y64 op)
+  `(if (tn-p ,y)
+     (sc-case ,y
+       ((signed64-reg unsigned64-reg)
+	(inst ,op ,r ,x ,y))
+       (signed-reg
+	;; Sign-extend Y
+	(inst signx ,y64 ,y)
+	(inst ,op ,r ,x ,y64))
+       (unsigned-reg
+	;; Zero-extend Y
+	(inst clruw ,y64 ,y)
+	(inst ,op ,r ,x ,y64))
+       (immediate
+	(inst ,op ,r ,x ,y)))
+      (inst ,op ,r ,x ,y)))
+
+;; Same as above, but we only have one arg.
+(defmacro sc-case-64-one-arg (r x x64 op)
+  `(sc-case ,x
+     ((signed64-reg unsigned64-reg)
+      (inst ,op ,r ,x))
+     (signed-reg
+      ;; Sign-extend X
+      (inst signx ,x64 ,x)
+      (inst ,op ,r ,x64))
+     (unsigned-reg
+      ;; Zero-extend X
+      (inst clruw ,x64 ,x)
+      (inst ,op ,r ,x64))))
+  
+;; Try all possible combinations of signed64-reg, signed-reg, and
+;; unsigned-reg and appropriately extend the sign of the shorter
+;; operand and perform the desired operation on the 64-bit operands
+;; with a 64-bit result.
+;;
+;; FIXME: This should be more like numeric-dispatch so it can be used
+;; in other places.
+(defmacro sc-dispatch (r x y x64 y64 op)
+  `(sc-case x
+     ((signed64-reg unsigned64-reg)
+      ;; X is 64-bits
+      (sc-case-64 ,r ,x ,y ,y64 ,op))
+     (signed-reg
+      ;; Sign-extend X
+      (inst signx ,x64 ,x)
+      (sc-case-64 ,r ,x64 ,y ,y64 ,op))
+     (unsigned-reg
+      ;; Zero-extend X
+      (inst clruw ,x64 ,x)
+      (sc-case-64 ,r ,x64 ,y ,y64 ,op))))
+
+;; Operations that result in 64-bit results.
+
+(defmacro define-binop-64 (translate op)
+  `(progn
+    (define-vop (,(symbolicate "FAST-" translate "/SIGNED64")
+		 fast-signed64-binop)
+      (:translate ,translate)
+      (:temporary (:scs (signed64-reg)) x64 y64)
+      (:generator 2
+       (sc-dispatch r x y x64 y64 ,op)))
+    (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED64")
+		 fast-unsigned64-binop)
+      (:translate ,translate)
+      (:temporary (:scs (signed64-reg)) x64 y64)
+      (:generator 2
+       (sc-dispatch r x y x64 y64 ,op)))
+    (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED64")
+		 fast-signed64-binop-c)
+      (:translate ,translate)
+      (:temporary (:scs (signed64-reg)) x64 y64)
+      (:generator 2
+       (sc-dispatch r x y x64 y64 ,op)))
+    (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED64")
+		 fast-unsigned64-binop-c)
+      (:translate ,translate)
+      (:temporary (:scs (signed64-reg)) x64 y64)
+      (:generator 2
+       (sc-dispatch r x y x64 y64 ,op)))
+    ))
+
+(define-binop-64 + add)
+(define-binop-64 - sub)
+(define-binop-64 logand and)
+(define-binop-64 logandc2 andn)
+(define-binop-64 logior or)
+(define-binop-64 logorc2 orn)
+(define-binop-64 logxor xor)
+(define-binop-64 logeqv xnor)
+
+;; Some special cases for logand.
+(define-vop (fast-logand/signed64 fast-safe-arith-op)
+  (:args (x :target r :scs (signed64-reg signed-reg zero))
+	 (y :target r :scs (signed64-reg signed-reg zero)))
+  (:arg-types (:or signed64-num signed-num)
+	      (:or signed64-num signed-num))
+  (:results (r :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:translate logand)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:generator 2
+    (sc-dispatch r x y x64 y64 and)))
+
+(define-vop (fast-logand/u32-64=>signed fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero))
+	 (y :target r :scs (signed64-reg unsigned64-reg signed-reg  zero)))
+  (:arg-types (:or unsigned-num)
+	      (:or signed64-num unsigned64-num signed-num))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate logand)
+  (:generator 2
+    (sc-case y
+      ((signed64-reg unsigned64-reg)
+       (inst clruw r x)			; Zero-extend, just in case
+       (inst and r y)
+       (inst clruw r)			; Zero-extend, just in case
+       )
+      (signed-reg
+       (inst and r x y)
+       ))))
+
+
+(define-vop (fast-logand/64-u32=>signed fast-safe-arith-op)
+  (:args (x :target r :scs (signed64-reg unsigned64-reg signed-reg zero))
+	 (y :target r :scs (unsigned-reg zero)))
+  (:arg-types (:or signed64-num unsigned64-num signed-num)
+	      (:or unsigned-num))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate logand)
+  (:generator 2
+    (sc-case x
+      ((signed64-reg unsigned64-reg)
+       (inst clruw r y)			; Zero-extend, just in case
+       (inst and r x y)
+       (inst clruw r)			; Zero-extend, just in case
+       )
+      (signed-reg
+       (inst and r x y)
+       ))))
+
+(define-vop (fast-lognot/signed64 signed64-unop)
+  (:translate lognot)
+  (:generator 2
+    (sc-case-64-one-arg res x x64 not)))
+
+(define-vop (fast-negate/signed64 signed64-unop)
+  (:args (x :target res :scs (signed64-reg zero)))
+  (:arg-types signed64-num)
+  (:results (res :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:translate %negate)
+  (:generator 1
+    (inst neg res x)))
+
+(define-vop (fast-negate/unsigned=>signed64 fast-safe-arith-op)
+  (:args (x :target res :scs (unsigned-reg zero)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:translate %negate)
+  (:generator 1
+    ;; Zero-extend	      
+    (inst clruw res x)
+    (inst neg res)))
+
+(define-vop (fast-negate/signed=>signed64 fast-safe-arith-op)
+  (:args (x :target res :scs (signed-reg zero)))
+  (:arg-types signed-num)
+  (:results (res :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:translate %negate)
+  (:generator 1
+    ;; Sign-extend	      
+    (inst signx res x)
+    (inst neg res)))
+
+;; Signed 64x64->64 bit multiply
+(define-vop (fast-*/signed64 fast-safe-arith-op)
+  (:args (x :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero))
+	 (y :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero)))
+  (:arg-types (:or signed64-num unsigned64-num signed-num unsigned-num)
+	      (:or signed64-num unsigned64-num signed-num unsigned-num))
+  (:results (r :scs (signed64-reg unsigned64-reg)))
+  (:result-types signed64-num)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:translate *)
+  (:note _N"inline (signed-byte 64) arithmetic")
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 3
+    (sc-dispatch r x y x64 y64 mulx)))
+
+(define-vop (fast-*/unsigned64 fast-safe-arith-op)
+  (:args (x :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero))
+	 (y :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero)))
+  (:arg-types (:or signed64-num unsigned64-num signed-num unsigned-num)
+	      (:or signed64-num unsigned64-num signed-num unsigned-num))
+  (:results (r :scs (signed64-reg unsigned64-reg)))
+  (:result-types unsigned64-num)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:translate *)
+  (:note _N"inline (signed-byte 64) arithmetic")
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 3
+    (sc-dispatch r x y x64 y64 mulx)))
+
+
+;; Signed 32x32->64 multiply 
+(define-vop (fast-*/signed=>signed64 fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg unsigned-reg zero))
+	 (y :target r :scs (signed-reg unsigned-reg zero)))
+  (:arg-types (:or signed-num unsigned-num)
+	      (:or signed-num unsigned-num))
+  (:results (r :scs (signed64-reg unsigned64-reg)))
+  (:result-types signed64-num)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:translate *)
+  (:note _N"inline (signed-byte 64) arithmetic")
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 3
+    (sc-dispatch r x y x64 y64 mulx)))
+
+;; Unsigned 32x32->64 multiply
+(define-vop (fast-*/u32=>unsigned64 fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg zero))
+	 (y :target r :scs (unsigned-reg zero)))
+  (:arg-types (:or unsigned-num)
+	      (:or unsigned-num))
+  (:results (r :scs (signed64-reg unsigned64-reg)))
+  (:result-types unsigned64-num)
+  (:temporary (:scs (unsigned64-reg)) x64 y64)
+  (:translate *)
+  (:note _N"inline (unsigned-byte 64) arithmetic")
+  (:guard (backend-featurep :sparc-v9))
+  (:generator 3
+    (sc-dispatch r x y x64 y64 mulx)))
+
+(define-vop (fast-ash/signed64=>signed64)
+  (:note _N"inline (signed-byte 64) ASH")
+  (:args (number :scs (signed64-reg unsigned-reg signed-reg) :to :save)
+	 (amount :scs (signed64-reg signed-reg unsigned-reg) :to :save))
+  (:arg-types (:or signed64-num signed-num unsigned-num)
+	      (:or signed64-num signed-num unsigned-num))
+  (:results (result :scs (signed64-reg)))
+  (:result-types signed64-num)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:sc signed64-reg) ndesc)
+  (:temporary (:scs (signed64-reg)) num64)
+  (:guard (and (backend-featurep :sparc-v9)
+	       (backend-featurep :sparc-v8plus)
+	       (not (backend-featurep :sparc-64))))
+  (:generator 5
+    (sc-case number
+      (signed64-reg
+       (move num64 number))
+      (signed-reg
+       (inst signx num64 number))
+      (unsigned-reg
+       (inst clruw num64 number)))
+    (sc-case amount
+      (signed64-reg
+       (let ((done (gen-label)))
+	 (inst cmp amount)
+	 (inst b :ge done :pt :xcc)
+	 ;; The result-type assures us that this shift will not
+	 ;; overflow.
+	 (inst sllx result num64 amount)
+	 (inst neg ndesc amount)
+	 ;; ndesc = max(-amount, 31)
+	 (inst cmp ndesc 31)
+	 (inst cmove :ge ndesc 31 :xcc)
+	 (inst srax result num64 ndesc)
+	 (emit-label done)))
+      (signed-reg
+       (let ((done (gen-label)))
+	 (inst cmp amount)
+	 (inst b :ge done :pt)
+	 ;; The result-type assures us that this shift will not
+	 ;; overflow.
+	 (inst sllx result num64 amount)
+	 (inst neg ndesc amount)
+	 ;; ndesc = max(-amount, 31)
+	 (inst cmp ndesc 31)
+	 (inst cmove :ge ndesc 31)
+	 (inst srax result num64 ndesc)
+	 (emit-label done)))
+      (unsigned-reg
+       (inst sllx result num64 amount))
+
+      (immediate
+       (let ((amount (tn-value amount)))
+	 (cond ((< amount -63)
+		(inst li result -1))
+	       ((< amount 0)
+		(inst srax result num64 (- amount)))
+	       ((> amount 0)
+		(inst sllx result num64 amount))
+	       (t
+		;; amount = 0.  Shouldn't happen because of a
+		;; deftransform, but it's easy.
+		(move result num64))))))))
+
+(define-vop (fast-ash/unsigned64=>unsigned64)
+  (:note _N"inline (signed-byte 64) ASH")
+  (:args (number :scs (unsigned64-reg unsigned-reg) :to :save)
+	 (amount :scs (signed64-reg signed-reg unsigned-reg immediate) :to :save))
+  (:arg-types (:or unsigned64-num unsigned-num)
+	      (:or signed64-num signed-num unsigned-num))
+  (:results (result :scs (unsigned64-reg)))
+  (:result-types unsigned64-num)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:temporary (:scs (unsigned64-reg)) ndesc num64)
+  (:guard (and (backend-featurep :sparc-v9)
+	       (backend-featurep :sparc-v8plus)
+	       (not (backend-featurep :sparc-64))))
+  (:generator 5
+    (sc-case number
+      (unsigned64-reg
+       (move num64 number))
+      (unsigned-reg
+       (inst clruw num64 number)))
+    (sc-case amount
+      (signed64-reg
+       (let ((done (gen-label)))
+	 (inst cmp amount)
+	 (inst b :ge done :pt :xcc)
+	 ;; The result-type assures us that this shift will not
+	 ;; overflow.
+	 (inst sllx result num64 amount)
+	 (inst neg ndesc amount)
+	 ;; ndesc = max(-amount, 31)
+	 (inst cmp ndesc 31)
+	 (inst cmove :ge ndesc 31 :xcc)
+	 (inst srlx result num64 ndesc)
+	 (emit-label done)))
+      (signed-reg
+       (let ((done (gen-label)))
+	 (inst cmp amount)
+	 (inst b :ge done :pt)
+	 ;; The result-type assures us that this shift will not
+	 ;; overflow.
+	 (inst sllx result num64 amount)
+	 (inst neg ndesc amount)
+	 ;; ndesc = max(-amount, 31)
+	 (inst cmp ndesc 31)
+	 (inst cmove :ge ndesc 31)
+	 (inst srlx result num64 ndesc)
+	 (emit-label done)))
+      (unsigned-reg
+       (inst sllx result num64 amount))
+
+      (immediate
+       (let ((amount (tn-value amount)))
+	 (cond ((< amount -63)
+		(inst li result -1))
+	       ((< amount 0)
+		(inst srlx result num64 (- amount)))
+	       ((> amount 0)
+		(inst sllx result num64 amount))
+	       (t
+		;; amount = 0.  Shouldn't happen because of a
+		;; deftransform, but it's easy.
+		(move result num64))))))))
+
+
+
+;;; Conditional operations on 64-bit numbers
+
+(define-vop (fast-conditional-c/64-fixnum fast-conditional)
+  (:args (x :scs (signed64-reg unsigned-reg signed-reg zero)))
+  (:arg-types (:or signed64-num unsigned-num signed-num)
+	      (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits))))
+  (:info target not-p y))
+	      
+(define-vop (fast-conditional/signed64 fast-conditional)
+  (:args (x :scs (signed64-reg unsigned-reg signed-reg zero))
+	 (y :scs (signed64-reg unsigned-reg signed-reg zero)))
+  (:arg-types (:or signed64-num unsigned-num signed-num)
+	      (:or signed64-num unsigned-num signed-num))
+  (:note _N"inline (signed-byte 64) comparison"))
+
+(define-vop (fast-conditional-c/signed64 fast-conditional)
+  (:args (x :scs (signed64-reg unsigned-reg signed-reg zero)))
+  (:arg-types (:or signed64-num unsigned-num signed-num)
+	      (:constant (signed-byte 13)))
+  (:info target not-p y)
+  (:note _N"inline (signed-byte 64) comparison"))
+
+(define-vop (fast-conditional/unsigned64 fast-conditional)
+  (:args (x :scs (unsigned64-reg zero))
+	 (y :scs (unsigned64-reg zero)))
+  (:arg-types (:or unsigned64-num)
+	      (:or unsigned64-num))
+  (:note _N"inline (unsigned-byte 64) comparison"))
+
+(define-vop (fast-conditional-c/unsigned64 fast-conditional)
+  (:args (x :scs (unsigned64-reg zero)))
+  (:arg-types (:or unsigned64-num)
+	      (:constant (unsigned-byte 12)))
+  (:info target not-p y)
+  (:note _N"inline (signed-byte 64) comparison"))
+
+;; If I were smarter, This would be a macro like it is for the 32-bit
+;; versions.  It's easier this way to see what's happening, though.
+;;
+(define-vop (fast-if-</signed64 fast-conditional/signed64)
+  (:translate <)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:generator 6
+    (sc-case x
+      (signed-reg
+       (inst signx x64 x))
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (sc-case y
+      (signed-reg
+       (inst signx y64 y))
+      (unsigned-reg
+       (inst clruw y64 y))
+      ((signed64-reg unsigned64-reg zero)
+       (move y64 y)))
+
+    (inst cmp x64 y64)
+    (inst b (if not-p :ge :lt)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if->/signed64 fast-conditional/signed64)
+  (:translate >)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:generator 6
+    (sc-case x
+      (signed-reg
+       (inst signx x64 x))
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (sc-case y
+      (signed-reg
+       (inst signx y64 y))
+      (unsigned-reg
+       (inst clruw y64 y))
+      ((signed64-reg unsigned64-reg zero)
+       (move y64 y)))
+
+    (inst cmp x64 y64)
+    (inst b (if not-p :le :gt)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if-eql/signed64 fast-conditional/signed64)
+  (:translate eql)
+  (:temporary (:scs (signed64-reg)) x64 y64)
+  (:generator 6
+    (sc-case x
+      (signed-reg
+       (inst signx x64 x))
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (sc-case y
+      (signed-reg
+       (inst signx y64 y))
+      (unsigned-reg
+       (inst clruw y64 y))
+      ((signed64-reg unsigned64-reg zero)
+       (move y64 y)))
+
+    (inst cmp x64 y64)
+    (inst b (if not-p :ne :eq)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if-eql-c/signed64 fast-conditional-c/signed64)
+  (:translate eql)
+  (:temporary (:scs (signed64-reg)) x64)
+  (:generator 6
+    (sc-case x
+      (signed-reg
+       (inst signx x64 x))
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (inst cmp x64 y)
+    (inst b (if not-p :ne :eq)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if-</unsigned64 fast-conditional/unsigned64)
+  (:translate <)
+  (:temporary (:scs (unsigned64-reg)) x64 y64)
+  (:generator 6
+    (sc-case x
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (sc-case y
+      (unsigned-reg
+       (inst clruw y64 y))
+      ((signed64-reg unsigned64-reg zero)
+       (move y64 y)))
+
+    (inst cmp x64 y64)
+    (inst b (if not-p :geu :ltu)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if->/unsigned64 fast-conditional/unsigned64)
+  (:translate >)
+  (:temporary (:scs (unsigned64-reg)) x64 y64)
+  (:generator 6
+    (sc-case x
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (sc-case y
+      (unsigned-reg
+       (inst clruw y64 y))
+      ((signed64-reg unsigned64-reg zero)
+       (move y64 y)))
+
+    (inst cmp x64 y64)
+    (inst b (if not-p :leu :gtu)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if-eql/unsigned64 fast-conditional/unsigned64)
+  (:translate eql)
+  (:temporary (:scs (unsigned64-reg)) x64 y64)
+  (:generator 6
+    (sc-case x
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (sc-case y
+      (unsigned-reg
+       (inst clruw y64 y))
+      ((signed64-reg unsigned64-reg zero)
+       (move y64 y)))
+
+    (inst cmp x64 y64)
+    (inst b (if not-p :ne :eq)
+	  target :pt :xcc)
+    (inst nop)))
+
+(define-vop (fast-if-eql-c/unsigned64 fast-conditional-c/unsigned64)
+  (:translate eql)
+  (:temporary (:scs (unsigned64-reg)) x64)
+  (:generator 6
+    (sc-case x
+      (unsigned-reg
+       (inst clruw x64 x))
+      (t
+       (move x64 x)))
+    (inst cmp x64 y)
+    (inst b (if not-p :ne :eq)
+	  target :pt :xcc)
+    (inst nop)))
+  
+)
+
+;;; Sparc implementation of modular arithmetic.
+#+modular-arith
+(progn
+(c::define-modular-fun lognot-mod32 (x) lognot 32)
+
+(define-vop (lognot-mod32/unsigned=>unsigned)
+  (:translate lognot-mod32)
+  (:args (x :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst not res x)))
+
+(define-vop (lognot-mod32/signed=>unsigned)
+  (:translate lognot-mod32)
+  (:args (x :scs (signed-reg)))
+  (:arg-types signed-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst not res x)))
+
+;; Handle (ldb (byte 32 0) (- x)).  The (- x) gets converted to
+;; (%negate x), so we build modular functions for %negate.
+
+(c::define-modular-fun %negate-mod32 (x) kernel:%negate 32)
+
+(define-vop (%negate-mod32/unsigned=>unsigned fast-safe-arith-op)
+  (:translate %negate-mod32)
+  (:args (x :scs (unsigned-reg) :target res))
+  (:arg-types unsigned-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst neg res x)))
+
+(define-vop (%negate-mod32/signed=>unsigned fast-safe-arith-op)
+  (:translate %negate-mod32)
+  (:args (x :scs (signed-reg)))
+  (:arg-types signed-num)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (inst neg res x)))
+
+;; Define a bunch of vops for converting signed to unsigned.
+(macrolet
+    ((frob (op &optional trans)
+       (let ((name (symbolicate "FAST-" op "/SIGNED=>UNSIGNED"))
+	     (vop (symbolicate "FAST-" op "/SIGNED=>SIGNED"))
+	     (trans (symbolicate (or trans op) "-MOD32")))
+	 `(progn
+	    (defknown ,trans ((signed-byte 32) (signed-byte 32))
+	      (unsigned-byte 32)
+	      (movable foldable flushable))
+	    (define-vop (,name ,vop)
+	    (:translate ,trans)
+	    (:results (r :scs (unsigned-reg)))
+	    (:result-types unsigned-num))))))
+  (frob +)
+  (frob -)
+  (frob logxor)
+  (frob logeqv)
+  (frob logandc1)
+  (frob logandc2)
+  (frob logorc1)
+  (frob logorc2)
+  (frob v8-* *))
+
+(defmacro define-modular-backend (fun &optional constantp derived)
+  (let ((mfun-name (symbolicate fun '-mod32))
+	(modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
+	(modcvop (symbolicate 'fast- fun '-mod32-c/unsigned=>unsigned))
+	(vop (symbolicate 'fast- (or derived fun) '/unsigned=>unsigned))
+	(cvop (symbolicate 'fast- (or derived fun) '-c/unsigned=>unsigned))
+	(smodvop (symbolicate 'fast- (or derived fun) '-mod32/signed=>unsigned))
+	(svop (symbolicate 'fast- (or derived fun) '/signed=>unsigned)))
+    `(progn
+       (c::define-modular-fun ,mfun-name (x y) ,fun 32)
+       (define-vop (,modvop ,vop)
+	 (:translate ,mfun-name))
+       ,@(when constantp
+	       `((define-vop (,modcvop ,cvop)
+		   (:translate ,mfun-name))))
+       (define-vop (,smodvop ,svop)
+	 (:translate ,mfun-name)))))
+
+(define-modular-backend + t)
+(define-modular-backend - t)
+(define-modular-backend logxor t)
+(define-modular-backend logeqv t)
+(define-modular-backend logandc1)
+(define-modular-backend logandc2 t)
+(define-modular-backend logorc1)
+(define-modular-backend logorc2 t)
+(define-modular-backend * t v8-*)
+
+(def-source-transform lognand (x y)
+  `(lognot (logand ,x ,y)))
+(def-source-transform lognor (x y)
+  `(lognot (logior ,x ,y)))
+
+(defknown vm::ash-left-mod32 (integer (integer 0))
+  (unsigned-byte 32)
+  (foldable flushable movable))
+
+(defknown vm::ash-mod32 (integer integer)
+  (unsigned-byte 32)
+  (foldable flushable movable))
+
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
+	     digit-ashl)
+  (:translate ash-left-mod32))
+
+(define-vop (fast-ash-mod32/unsigned=>unsigned
+	     fast-ash/unsigned=>unsigned)
+    (:translate ash-mod32))
+
+)
+
+(in-package :c)
+
+#+modular-arith
+(define-modular-fun-optimizer ash ((integer count) :width width)
+  ;; The count needs to be (mod 32) because the Sparc shift
+  ;; instruction takes the count modulo 32.  (NOTE: Should we make
+  ;; this work on Ultrasparcs?  We could then use the sllx instruction
+  ;; which takes the count mod 64.  Then a left shift of 32 or more
+  ;; will produce 0 in the lower 32 bits of the register, which is
+  ;; what we want.)
+  (when (<= width 32)
+    ;; We can do a modular shift.  If the shift is known to be a left
+    ;; shift, we can use the left shift vop to get a left shift
+    ;; instruction.  Otherwise, we can use the regular fast-ash vop to
+    ;; get the shift.
+    (let ((count-type (continuation-type count)))
+      (cond ((csubtypep count-type (specifier-type '(unsigned-byte 5)))
+	     (cut-to-width integer width)
+	     'vm::ash-left-mod32)
+	    ((csubtypep count-type (specifier-type '(integer -31 31)))
+	     (cut-to-width integer width)
+	     'vm::ash-mod32)
+	    (t
+	     ;; Return NIL to say we can't do anything special.
+	     nil)))))
+
+;;; If both arguments and the result are (unsigned-byte 32), try to come up
+;;; with a ``better'' multiplication using multiplier recoding.  There are two
+;;; different ways the multiplier can be recoded.  The more obvious is to shift
+;;; X by the correct amount for each bit set in Y and to sum the results.  But
+;;; if there is a string of bits that are all set, you can add X shifted by
+;;; one more then the bit position of the first set bit and subtract X shifted
+;;; by the bit position of the last set bit.  We can't use this second method
+;;; when the high order bit is bit 31 because shifting by 32 doesn't work
+;;; too well.
+;;;
+
+
+(defun *-transformer (y)
+  (let ((y (continuation-value y)))
+    (multiple-value-bind (result adds shifts)
+	(strength-reduce-constant-multiply 'x y)
+      (cond
+        ((c::backend-featurep '(or :sparc-v9 :sparc-v8))
+	 ;; This is an approximate break-even point.  It's pretty
+	 ;; rough.
+	 (when (> (+ adds shifts) 9)
+	   (give-up)))
+	(t
+	 (give-up)))
+      (or result 0))))  
+
+#+modular-arith
+(deftransform * ((x y)
+		 ((unsigned-byte 32) (constant-argument (unsigned-byte 32)))
+		 (unsigned-byte 32))
+  "recode as shifts and adds"
+  (*-transformer y))
+
+#+modular-arith
+(deftransform vm::*-mod32 ((x y)
+		 ((unsigned-byte 32) (constant-argument (unsigned-byte 32)))
+		 (unsigned-byte 32))
+  "recode as shifts and adds"
+  (*-transformer y))
diff --git a/src/compiler/sparcv9/array.lisp b/src/compiler/sparcv9/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..71313285594af47c546da670ec54c98bba29c429
--- /dev/null
+++ b/src/compiler/sparcv9/array.lisp
@@ -0,0 +1,1272 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/array.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the SPARC definitions for array operations.
+;;;
+;;; Written by William Lott
+;;; Signed-array support by Douglas Crosher 1997.
+;;; Complex-float and long-float support by Douglas Crosher 1998.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;;; Allocator for the array header.
+
+(define-vop (make-array-header)
+  (:translate make-array-header)
+  (:policy :fast-safe)
+  (:args (type :scs (any-reg))
+	 (rank :scs (any-reg)))
+  (:arg-types tagged-num tagged-num)
+  (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:scs (non-descriptor-reg)) gc-temp)	; gencgc
+  (:results (result :scs (descriptor-reg)))
+  (:generator 0
+    (pseudo-atomic ()
+      (inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
+      (inst andn ndescr 4)
+      (allocation header ndescr other-pointer-type :temp-tn gc-temp)
+      (inst add ndescr rank (fixnumize (1- vm:array-dimensions-offset)))
+      (inst slln ndescr ndescr vm:type-bits)
+      (inst or ndescr ndescr type)
+      ;; Remove the extraneous fixnum tag bits because TYPE and RANK
+      ;; were fixnums
+      (inst srln ndescr ndescr fixnum-tag-bits)
+      (storew ndescr header 0 vm:other-pointer-type))
+    (move result header)))
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t fixnum) fixnum
+  (flushable))
+(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
+  ())
+
+(define-vop (%array-dimension word-index-ref)
+  (:translate lisp::%array-dimension)
+  (:policy :fast-safe)
+  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+
+(define-vop (%set-array-dimension word-index-set)
+  (:translate lisp::%set-array-dimension)
+  (:policy :fast-safe)
+  (:variant vm:array-dimensions-offset vm:other-pointer-type))
+
+
+
+(defknown lisp::%array-rank (t) fixnum (flushable))
+
+(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 vm:other-pointer-type)
+    (inst sra temp vm:type-bits)
+    (inst sub temp (1- vm:array-dimensions-offset))
+    (inst slln res temp fixnum-tag-bits)))
+
+
+
+;;;; Bounds checking routine.
+
+
+(define-vop (check-bound)
+  (:translate %check-bound)
+  (:policy :fast-safe)
+  (:args (array :scs (descriptor-reg))
+	 (bound :scs (any-reg descriptor-reg))
+	 (index :scs (any-reg descriptor-reg) :target result))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (let ((error (generate-error-code vop invalid-array-index-error
+				      array bound index)))
+      (inst cmp index bound)
+      (inst b :geu error)
+      (inst nop)
+      (move result index))))
+
+
+
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whose
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(defmacro def-data-vector-frobs (type variant element-type &rest scs)
+  `(progn
+     (define-vop (,(intern (concatenate 'simple-string
+					"DATA-VECTOR-REF/"
+					(string type)))
+		  ,(intern (concatenate 'simple-string
+					(string variant)
+					"-REF")))
+       (:note _N"inline array access")
+       (:variant vm:vector-data-offset vm:other-pointer-type)
+       (:translate data-vector-ref)
+       (:arg-types ,type positive-fixnum)
+       (:results (value :scs ,scs))
+       (:result-types ,element-type))
+     (define-vop (,(intern (concatenate 'simple-string
+					"DATA-VECTOR-SET/"
+					(string type)))
+		  ,(intern (concatenate 'simple-string
+					(string variant)
+					"-SET")))
+       (:note _N"inline array store")
+       (:variant vm:vector-data-offset vm:other-pointer-type)
+       (:translate data-vector-set)
+       (:arg-types ,type positive-fixnum ,element-type)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg zero immediate))
+	      (value :scs ,scs))
+       (:results (result :scs ,scs))
+       (:result-types ,element-type))))
+
+#-unicode
+(def-data-vector-frobs simple-string byte-index
+  base-char base-char-reg)
+#+unicode
+(def-data-vector-frobs simple-string halfword-index
+  base-char base-char-reg)
+
+(def-data-vector-frobs simple-vector word-index
+  * descriptor-reg any-reg)
+
+(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
+  positive-fixnum unsigned-reg)
+(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
+  positive-fixnum unsigned-reg)
+(def-data-vector-frobs simple-array-unsigned-byte-32 word-index
+  unsigned-num unsigned-reg)
+
+(def-data-vector-frobs simple-array-signed-byte-30 word-index
+  tagged-num any-reg)
+(def-data-vector-frobs simple-array-signed-byte-32 word-index
+  signed-num signed-reg)
+
+;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;;
+;;; The elements are stored in the word with the first element in the
+;;; most-significant parts of the word.
+;;; 
+
+(eval-when (compile eval)
+
+(defmacro def-small-data-vector-frobs (type bits)
+  (let* ((elements-per-word (floor vm:word-bits bits))
+	 (bit-shift (1- (integer-length elements-per-word))))
+    `(progn
+       (define-vop (,(symbolicate 'data-vector-ref/ type))
+	 (:note _N"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 (non-descriptor-reg) :to (:result 0)) temp result)
+	 (:generator 20
+	   ;; temp = floor(index bit-shift), to get address of word
+	   ;; containing our bits.
+	   (inst srln temp index ,bit-shift)
+	   (inst slln temp fixnum-tag-bits)
+	   (inst add temp (- (* vm:vector-data-offset vm:word-bytes)
+			     vm:other-pointer-type))
+	   (inst ldn result object temp)
+	   ;; temp = mod(index, bit-shift) to figure out what part of
+	   ;; word we want.  (XOR is a quick way of computing
+	   ;; elements-per-word minus temp.)
+	   (inst and temp index ,(1- elements-per-word))
+	   (inst xor temp ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst slln temp ,(1- (integer-length bits)))))
+	   (inst srln result temp)
+	   (inst and result ,(1- (ash 1 bits)))
+	   (inst slln value result vm:fixnum-tag-bits)))
+       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:arg-types ,type (:constant index))
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) temp)
+	 (:generator 15
+	   (multiple-value-bind (word extra)
+	       (floor index ,elements-per-word)
+	     ;; Compute how many "units" we need to right shift to get
+	     ;; the bits we want.
+	     (setf extra (- ,(1- elements-per-word) extra))
+	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
+			      vm:other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 13))
+		      (inst ldn result object offset))
+		     (t
+		      (inst li temp offset)
+		      (inst ldn result object temp))))
+	     (unless (zerop extra)
+	       (inst srln result (* ,bits extra)))
+	     ;; Always need the mask unless the bits we wanted were the
+	     ;; most significant bits of the word.
+	     (unless (= extra ,(1- elements-per-word))
+	       (inst and result ,(1- (ash 1 bits)))))))
+       (define-vop (,(symbolicate 'data-vector-set/ type))
+	 (:note _N"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 (non-descriptor-reg)) temp old offset)
+	 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+	 (:generator 25
+	   (inst srln offset index ,bit-shift)
+	   (inst slln offset fixnum-tag-bits)
+	   (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			       vm:other-pointer-type))
+	   (inst ldn old object offset)
+	   (inst and shift index ,(1- elements-per-word))
+	   (inst xor shift ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst slln shift ,(1- (integer-length bits)))))
+	   (unless (and (sc-is value immediate)
+			(= (tn-value value) ,(1- (ash 1 bits))))
+	     (inst li temp ,(1- (ash 1 bits)))
+	     (inst slln temp shift)
+	     (inst not temp)
+	     (inst and old temp))
+	   (unless (sc-is value zero)
+	     (sc-case value
+	       (immediate
+		(inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
+	       (unsigned-reg
+		(inst and temp value ,(1- (ash 1 bits)))))
+	     (inst slln temp shift)
+	     (inst or old temp))
+	   (inst stn old object offset)
+	   (sc-case value
+	     (immediate
+	      (inst li result (tn-value value)))
+	     (t
+	      (move result value)))))
+       (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 index)
+		     positive-fixnum)
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
+	 (:generator 20
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
+			      vm:other-pointer-type)))
+	       (cond ((typep offset '(signed-byte 13))
+		      (inst ldn old object offset))
+		     (t
+		      (inst li offset-reg offset)
+		      (inst ldn old object offset-reg)))
+	       (unless (and (sc-is value immediate)
+			    (= (tn-value value) ,(1- (ash 1 bits))))
+		 (cond ((zerop extra)
+			(inst slln old ,bits)
+			(inst srln old ,bits))
+		       (t
+			(inst li temp
+			      (lognot (ash ,(1- (ash 1 bits))
+					   (* (logxor extra
+						      ,(1- elements-per-word))
+					      ,bits))))
+			(inst and old temp))))
+	       (sc-case value
+		 (zero)
+		 (immediate
+		  (let ((value (ash (logand (tn-value value)
+					    ,(1- (ash 1 bits)))
+				    (* (logxor extra
+					       ,(1- elements-per-word))
+				       ,bits))))
+		    (cond ((typep value '(signed-byte 13))
+			   (inst or old value))
+			  (t
+			   (inst li temp value)
+			   (inst or old temp)))))
+		 (unsigned-reg
+		  (inst slln temp value
+			(* (logxor extra ,(1- elements-per-word)) ,bits))
+		  (inst or old temp)))
+	       (if (typep offset '(signed-byte 13))
+		   (inst stn old object offset)
+		   (inst stn old object offset-reg)))
+	     (sc-case value
+	       (immediate
+		(inst li result (tn-value value)))
+	       (t
+		(move result value)))))))))
+
+); eval-when (compile eval)
+
+(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 _N"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)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:result-types single-float)
+  (:generator 5
+    (inst add offset index (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type))
+    (inst ldf value object offset)))
+
+(define-vop (data-vector-ref-c/simple-array-single-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:arg-types simple-array-single-float (:constant index))
+  (:info index)
+  (:results (value :scs (single-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:result-types single-float)
+  (:generator 3
+    (let ((offset (+ (fixnumize index)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))))
+      (if (typep offset '(signed-byte 13))
+	  (inst ldf value object offset)
+	  (progn
+	    (inst li temp offset)
+	    (inst ldf value object temp))))))
+
+
+(define-vop (data-vector-set/simple-array-single-float)
+  (:note _N"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 (non-descriptor-reg)) offset)
+  (:generator 5
+    (inst add offset index
+	  (- (* vm:vector-data-offset vm:word-bytes)
+	     vm:other-pointer-type))
+    (inst stf value object offset)
+    (unless (location= result value)
+      (inst fmovs result value))))
+
+(define-vop (data-vector-set-c/simple-array-single-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (single-reg) :target result))
+  (:arg-types simple-array-single-float
+	      (:constant index)
+	      single-float)
+  (:info index)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 2
+    (let ((offset (+ (fixnumize index)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))))
+      (if (typep offset '(signed-byte 13))
+	  (inst stf value object offset)
+	  (progn
+	    (inst li temp offset)
+	    (inst stf value object temp)))
+      (unless (location= result value)
+	(inst fmovs result value)))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+  (:note _N"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 (non-descriptor-reg)) offset)
+  (:generator 7
+    (inst slln offset index (- 3 fixnum-tag-bits))
+    (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))
+    (inst lddf value object offset)))
+
+(define-vop (data-vector-ref-c/simple-array-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:arg-types simple-array-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 3
+    (let ((offset (+ (* index double-float-bytes)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))))
+      (if (typep offset '(signed-byte 13))
+	  (inst lddf value object offset)
+	  (progn
+	    (inst li temp offset)
+	    (inst lddf value object temp))))))
+
+(define-vop (data-vector-set/simple-array-double-float)
+  (:note _N"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 (non-descriptor-reg)) offset)
+  (:generator 20
+    (inst slln offset index (- 3 fixnum-tag-bits))
+    (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))
+    (inst stdf value object offset)
+    (unless (location= result value)
+      (move-double-reg result value))))
+
+(define-vop (data-vector-set-c/simple-array-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (double-reg) :target result))
+  (:arg-types simple-array-double-float
+	      (:constant index)
+	      double-float)
+  (:info index)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 10
+    (let ((offset (+ (* index double-float-bytes)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))))
+      (if (typep offset '(signed-byte 13))
+	  (inst stdf value object offset)
+	  (progn
+	    (inst li temp offset)
+	    (inst stdf value object temp)))
+      (unless (location= result value)
+	(move-double-reg result value)))))
+
+#+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-long-float positive-fixnum)
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:generator 7
+    (inst slln offset index 2)
+    (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))
+    (load-long-reg value object offset nil)))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-long-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (long-reg) :target result))
+  (:arg-types simple-array-long-float positive-fixnum long-float)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:generator 20
+    (inst slln offset index 2)
+    (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))
+    (store-long-reg value object offset nil)
+    (unless (location= result value)
+      (move-long-reg result value))))
+
+
+;;;; Misc. Array VOPs.
+
+
+#+nil
+(define-vop (vector-word-length)
+  (:args (vec :scs (descriptor-reg)))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 6
+    (loadw res vec clc::g-vector-header-words)
+    (inst niuo res res clc::g-vector-words-mask-16)))
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
+
+;;;
+(define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
+  (:note _N"inline array access")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-ref)
+  (:arg-types simple-array-signed-byte-8 positive-fixnum)
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num))
+
+(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
+  (:note _N"inline array store")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-set)
+  (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg zero immediate))
+	 (value :scs (signed-reg)))
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num))
+
+
+(define-vop (data-vector-ref/simple-array-signed-byte-16
+	     signed-halfword-index-ref)
+  (:note _N"inline array access")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-ref)
+  (:arg-types simple-array-signed-byte-16 positive-fixnum)
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num))
+
+(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
+  (:note _N"inline array store")
+  (:variant vm:vector-data-offset vm:other-pointer-type)
+  (:translate data-vector-set)
+  (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg zero immediate))
+	 (value :scs (signed-reg)))
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num))
+
+
+;;; Complex float arrays.
+
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-single-float positive-fixnum)
+  (:results (value :scs (complex-single-reg)))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:result-types complex-single-float)
+  (:generator 5
+    (let ((real-tn (complex-single-reg-real-tn value)))
+      (inst slln offset index (- 3 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst ldf real-tn object offset))
+    (let ((imag-tn (complex-single-reg-imag-tn value)))
+      (inst add offset single-float-bytes)
+      (inst ldf imag-tn object offset))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-single-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-complex-single-float
+	      (:constant index))
+  (:info index)
+  (:results (value :scs (complex-single-reg)))
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:result-types complex-single-float)
+  (:generator 3
+    (let ((offset (+ (* index (* 2 single-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type)))
+	  (real-tn (complex-single-reg-real-tn value))
+	  (imag-tn (complex-single-reg-imag-tn value)))
+      (cond ((typep (+ offset single-float-bytes) '(signed-byte 13))
+	     (inst ldf real-tn object offset)
+	     (inst ldf imag-tn object (+ offset single-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst ldf real-tn object temp)
+	     (inst add temp single-float-bytes)
+	     (inst ldf imag-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-single-reg) :target result))
+  (:arg-types simple-array-complex-single-float positive-fixnum
+	      complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 5
+    (let ((value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result)))
+      (inst slln offset index (- 3 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst stf value-real object offset)
+      (unless (location= result-real value-real)
+	(inst fmovs result-real value-real)))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (inst add offset single-float-bytes)
+      (inst stf value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(inst fmovs result-imag value-imag)))))
+
+(define-vop (data-vector-set-c/simple-array-complex-single-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (complex-single-reg) :target result))
+  (:arg-types simple-array-complex-single-float
+	      (:constant index)
+	      complex-single-float)
+  (:info index)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 3
+    (let ((offset (+ (* index (* 2 single-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type)))
+	  (value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result))
+	  (value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (cond ((typep (+ offset single-float-bytes) '(signed-byte 13))
+	     (inst stf value-real object offset)
+	     (inst stf value-imag object (+ offset single-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst stf value-real object temp)
+	     (inst add temp single-float-bytes)
+	     (inst stf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(inst fmovs result-real value-real))
+      (unless (location= result-imag value-imag)
+	(inst fmovs result-imag value-imag)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-float positive-fixnum)
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (complex-double-reg-real-tn value)))
+      (inst slln offset index (- 4 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst lddf real-tn object offset))
+    (let ((imag-tn (complex-double-reg-imag-tn value)))
+      (inst add offset double-float-bytes)
+      (inst lddf imag-tn object offset))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-complex-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (real-tn (complex-double-reg-real-tn value))
+	  (imag-tn (complex-double-reg-imag-tn value)))
+      (cond ((typep (+ offset double-float-bytes) '(signed-byte 13))
+	     (inst lddf real-tn object offset)
+	     (inst lddf imag-tn object (+ offset double-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf real-tn object temp)
+	     (inst add temp double-float-bytes)
+	     (inst lddf imag-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-reg) :target result))
+  (:arg-types simple-array-complex-double-float positive-fixnum
+	      complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result)))
+      (inst slln offset index (- 4 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst stdf value-real object offset)
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real)))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result)))
+      (inst add offset double-float-bytes)
+      (inst stdf value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (complex-double-reg) :target result))
+  (:arg-types simple-array-complex-double-float
+	      (:constant index)
+	      complex-double-float)
+  (:info index)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result))
+	  (value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result))
+	  (offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset double-float-bytes) '(signed-byte 13))
+	     (inst stdf value-real object offset)
+	     (inst stdf value-imag object (+ offset double-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-real object temp)
+	     (inst add temp double-float-bytes)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+#+long-float
+(define-vop (data-vector-ref/simple-array-complex-long-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-long-float positive-fixnum)
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (inst slln offset index 3)
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (load-long-reg real-tn object offset nil))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (inst add offset (* 4 vm:word-bytes))
+      (load-long-reg imag-tn object offset nil))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-complex-long-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:arg-types simple-array-complex-long-float positive-fixnum
+	      complex-long-float)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (inst slln offset index 3)
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (store-long-reg value-real object offset nil)
+      (unless (location= result-real value-real)
+	(move-long-reg result-real value-real)))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst add offset (* 4 vm:word-bytes))
+      (store-long-reg value-imag object offset nil)
+      (unless (location= result-imag value-imag)
+	(move-long-reg result-imag value-imag)))))
+
+
+;;; 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))
+
+;; Versions with constant offsets
+(define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index)))
+;;;
+(define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index) single-float))
+(define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index)))
+
+(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index) double-float))
+
+;;;
+#+long-float
+(define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
+  (:translate %raw-ref-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+#+long-float
+(define-vop (raw-set-double data-vector-set/simple-array-long-float)
+  (:translate %raw-set-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
+
+(define-vop (raw-ref-complex-single
+	     data-vector-ref/simple-array-complex-single-float)
+  (:translate %raw-ref-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-complex-single
+	     data-vector-set/simple-array-complex-single-float)
+  (:translate %raw-set-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+	      complex-single-float))
+;;;
+(define-vop (raw-ref-complex-double
+	     data-vector-ref/simple-array-complex-double-float)
+  (:translate %raw-ref-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-complex-double
+	     data-vector-set/simple-array-complex-double-float)
+  (:translate %raw-set-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+	      complex-double-float))
+
+(define-vop (raw-ref-complex-single-c
+	     data-vector-ref-c/simple-array-complex-single-float)
+  (:translate %raw-ref-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index)))
+;;;
+(define-vop (raw-set-complex-single-c
+	     data-vector-set-c/simple-array-complex-single-float)
+  (:translate %raw-set-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index)
+	      complex-single-float))
+;;;
+(define-vop (raw-ref-complex-double-c
+	     data-vector-ref-c/simple-array-complex-double-float)
+  (:translate %raw-ref-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index)))
+;;;
+(define-vop (raw-set-complex-double-c
+	     data-vector-set-c/simple-array-complex-double-float)
+  (:translate %raw-set-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant index)
+	      complex-double-float))
+;;;
+#+long-float
+(define-vop (raw-ref-complex-long
+	     data-vector-ref/simple-array-complex-long-float)
+  (:translate %raw-ref-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+#+long-float
+(define-vop (raw-set-complex-long
+	     data-vector-set/simple-array-complex-long-float)
+  (:translate %raw-set-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+	      complex-long-float))
+
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;; 
+
+(define-vop (raw-bits word-index-ref)
+  (:note _N"raw-bits VOP")
+  (:translate %raw-bits)
+  (:results (value :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:variant 0 vm:other-pointer-type))
+
+(define-vop (set-raw-bits word-index-set)
+  (:note _N"setf raw-bits VOP")
+  (:translate %set-raw-bits)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg zero immediate))
+	 (value :scs (unsigned-reg)))
+  (:arg-types * tagged-num unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:variant 0 vm:other-pointer-type))
+
+
+#+double-double
+(progn
+(define-vop (data-vector-ref/simple-array-double-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-double-float positive-fixnum)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((hi-tn (double-double-reg-hi-tn value)))
+      (inst slln offset index (- 4 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst lddf hi-tn object offset))
+    (let ((lo-tn (double-double-reg-lo-tn value)))
+      (inst add offset double-float-bytes)
+      (inst lddf lo-tn object offset))))
+
+(define-vop (data-vector-ref-c/simple-array-double-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (hi-tn (double-double-reg-hi-tn value))
+	  (lo-tn (double-double-reg-lo-tn value)))
+      (cond ((typep (+ offset double-float-bytes) '(signed-byte 13))
+	     (inst lddf hi-tn object offset)
+	     (inst lddf lo-tn object (+ offset double-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf hi-tn object temp)
+	     (inst add temp double-float-bytes)
+	     (inst lddf lo-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-double-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float positive-fixnum
+	      double-double-float)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-hi (double-double-reg-hi-tn value))
+	  (result-hi (double-double-reg-hi-tn result)))
+      (inst slln offset index (- 4 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst stdf value-hi object offset)
+      (unless (location= result-hi value-hi)
+	(move-double-reg result-hi value-hi)))
+    (let ((value-lo (double-double-reg-lo-tn value))
+	  (result-lo (double-double-reg-lo-tn result)))
+      (inst add offset double-float-bytes)
+      (inst stdf value-lo object offset)
+      (unless (location= result-lo value-lo)
+	(move-double-reg result-lo value-lo)))))
+
+(define-vop (data-vector-set-c/simple-array-double-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float
+	      (:constant index)
+	      double-double-float)
+  (:info index)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-hi (double-double-reg-hi-tn value))
+	  (result-hi (double-double-reg-hi-tn result))
+	  (value-lo (double-double-reg-lo-tn value))
+	  (result-lo (double-double-reg-lo-tn result))
+	  (offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset double-float-bytes) '(signed-byte 13))
+	     (inst stdf value-hi object offset)
+	     (inst stdf value-lo object (+ offset double-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-hi object temp)
+	     (inst add temp double-float-bytes)
+	     (inst stdf value-lo object temp)))
+      (unless (location= result-hi value-hi)
+	(move-double-reg result-hi value-hi))
+      (unless (location= result-lo value-lo)
+	(move-double-reg result-lo value-lo)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
+      (inst slln offset index (- 5 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst lddf real-tn object offset))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
+      (inst add offset double-float-bytes)
+      (inst lddf real-tn object offset))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
+      (inst add offset double-float-bytes)
+      (inst lddf imag-tn object offset))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
+      (inst add offset double-float-bytes)
+      (inst lddf imag-tn object offset))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-double-float)
+  (:note _N"inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-complex-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (real-hi-tn (complex-double-double-reg-real-hi-tn value))
+	  (imag-hi-tn (complex-double-double-reg-imag-hi-tn value))
+	  (real-lo-tn (complex-double-double-reg-real-lo-tn value))
+	  (imag-lo-tn (complex-double-double-reg-imag-lo-tn value)))
+      (cond ((typep (+ offset (* 3 double-float-bytes)) '(signed-byte 13))
+	     (inst lddf real-hi-tn object offset)
+	     (inst lddf real-lo-tn object (+ offset double-float-bytes))
+	     (inst lddf imag-hi-tn object (+ offset (* 2 double-float-bytes)))
+	     (inst lddf imag-lo-tn object (+ offset (* 3 double-float-bytes))))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf real-hi-tn object temp)
+	     (inst add temp double-float-bytes)
+	     (inst lddf real-lo-tn object temp)
+	     (inst add temp double-float-bytes)
+	     (inst lddf imag-hi-tn object temp)
+	     (inst add temp double-float-bytes)
+	     (inst lddf imag-lo-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum
+	      complex-double-double-float)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result)))
+      (inst slln offset index (- 5 fixnum-tag-bits))
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst stdf value-real object offset)
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real)))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result)))
+      (inst add offset double-float-bytes)
+      (inst stdf value-real object offset)
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real)))
+    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
+      (inst add offset double-float-bytes)
+      (inst stdf value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))
+    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
+      (inst add offset double-float-bytes)
+      (inst stdf value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-double-float)
+  (:note _N"inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float
+	      (:constant index)
+	      complex-double-double-float)
+  (:info index)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result))
+	  (value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result))
+	  (offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset double-float-bytes) '(signed-byte 13))
+	     (inst stdf value-real object offset)
+	     (inst stdf value-imag object (+ offset double-float-bytes)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-real object temp)
+	     (inst add temp double-float-bytes)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result))
+	  (value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result))
+	  (offset (+ (* index (* 2 double-float-bytes))
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset (* 3 double-float-bytes)) '(signed-byte 13))
+	     (inst stdf value-real object (+ offset (* 2 double-float-bytes)))
+	     (inst stdf value-imag object (+ offset (* 3 double-float-bytes))))
+	    (t
+	     (inst add temp double-float-bytes)
+	     (inst stdf value-real object temp)
+	     (inst add temp double-float-bytes)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+
+)
diff --git a/src/compiler/sparcv9/c-call.lisp b/src/compiler/sparcv9/c-call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..c3a18becbf89abfab16597bf5802208561a4d8e8
--- /dev/null
+++ b/src/compiler/sparcv9/c-call.lisp
@@ -0,0 +1,314 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/c-call.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+(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
+  (register-args 0)
+  ;; No matter what we have to allocate at least 7 stack frame slots.  One
+  ;; because the C call convention requries it, and 6 because whoever we call
+  ;; is going to expect to be able to save his 6 register arguments there.
+  (stack-frame-size 7))
+
+(defun int-arg (state prim-type reg-sc stack-sc)
+  (let ((reg-args (arg-state-register-args state)))
+    (cond ((< reg-args 6)
+	   (setf (arg-state-register-args state) (1+ reg-args))
+	   (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
+	  (t
+	   (let ((frame-size (arg-state-stack-frame-size state)))
+	     (setf (arg-state-stack-frame-size state) (1+ frame-size))
+	     (my-make-wired-tn prim-type stack-sc (+ frame-size 16)))))))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (if (alien-integer-type-signed type)
+      (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
+      (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+  (declare (ignore type))
+  (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
+
+(defstruct result-state
+  (num-results 0))
+
+(defun result-reg-offset (slot)
+  (ecase slot
+    (0 nl0-offset)
+    (1 nl1-offset)))
+
+(def-alien-type-method (integer :result-tn) (type state)
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (multiple-value-bind (ptype reg-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-32 'signed-reg)
+	    (values 'unsigned-byte-32 'unsigned-reg))
+      (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
+  
+(def-alien-type-method (system-area-pointer :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'system-area-pointer 'sap-reg
+		      (result-reg-offset num-results))))
+
+(def-alien-type-method (double-float :result-tn) (type state)
+  (declare (ignore type state))
+  (my-make-wired-tn 'double-float 'double-reg 0))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+  (declare (ignore type state))
+  (my-make-wired-tn 'single-float 'single-reg 0))
+
+#+long-float
+(def-alien-type-method (long-float :result-tn) (type)
+  (declare (ignore type))
+  (my-make-wired-tn 'long-float 'long-reg 0))
+
+(def-alien-type-method (values :result-tn) (type state)
+  (let ((values (alien-values-type-values type)))
+    (when (> (length values) 2)
+      (error (intl:gettext "Too many result values from c-call.")))
+    (mapcar #'(lambda (type)
+		(invoke-alien-type-method :result-tn type state))
+	    values)))
+
+(def-vm-support-routine make-call-out-tns (type)
+  (declare (type alien-function-type 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)
+	      (* (arg-state-stack-frame-size arg-state) word-bytes)
+	      (arg-tns)
+	      (invoke-alien-type-method
+	       :result-tn
+	       (alien-function-type-result-type type)
+	       (make-result-state))))))
+
+(deftransform %alien-funcall ((function type &rest args))
+  (assert (c::constant-continuation-p type))
+  (let* ((type (c::continuation-value type))
+	 (arg-types (alien-function-type-arg-types type))
+	 (result-type (alien-function-type-result-type type)))
+    (assert (= (length arg-types) (length args)))
+    ;; We need to do something special for the following argument
+    ;; types: single-float, double-float, and 64-bit integers.  For
+    ;; results, we need something special for 64-bit integer results.
+    (if (or (some #'alien-single-float-type-p arg-types)
+	    (some #'alien-double-float-type-p arg-types)
+	    (some #'(lambda (type)
+		      (and (alien-integer-type-p type)
+			   (> (alien::alien-integer-type-bits type) 32)))
+		  arg-types)
+	    #+long-float (some #'alien-long-float-type-p arg-types)
+	    (and (alien-integer-type-p result-type)
+		 (> (alien::alien-integer-type-bits result-type) 32)))
+	(collect ((new-args) (lambda-vars) (new-arg-types) (mv-vars) (mv-form))
+	  (dolist (type arg-types)
+	    (let ((arg (gensym)))
+	      (lambda-vars arg)
+	      (cond ((and (alien-integer-type-p type)
+			  (> (alien::alien-integer-type-bits type) 32))
+		     ;; 64-bit long long types are stored in
+		     ;; consecutive locations, most significant word
+		     ;; first (big-endian).
+		     (new-args `(ash ,arg -32))
+		     (new-args `(logand ,arg #xffffffff))
+		     (if (alien-integer-type-signed type)
+			 (new-arg-types (parse-alien-type '(signed 32)))
+			 (new-arg-types (parse-alien-type '(unsigned 32))))
+		     (new-arg-types (parse-alien-type '(unsigned 32))))
+		    ((alien-single-float-type-p type)
+		     (new-args `(single-float-bits ,arg))
+		     (new-arg-types (parse-alien-type '(signed 32))))
+		    ((alien-double-float-type-p type)
+		     ;; Use double-float-bits instead of
+		     ;; double-float-hi/lo-bits to get the bits
+		     ;; out.  This gives a some improvement
+		     ;; because there's only store of the FP value.
+		     ;;
+		     ;; Sparc calling conventions say floats must be
+		     ;; passed in the integer registers.
+		     (let ((mvarg1 (gensym))
+			   (mvarg2 (gensym)))
+		       (mv-vars `(,mvarg1 ,mvarg2))
+		       (mv-form `(double-float-bits ,arg))
+		       (new-args mvarg1)
+		       (new-args mvarg2)
+		       (new-arg-types (parse-alien-type '(signed 32)))
+		       (new-arg-types (parse-alien-type '(unsigned 32)))))
+		    #+long-float
+		    ((alien-long-float-type-p type)
+		     (new-args `(long-float-exp-bits ,arg))
+		     (new-args `(long-float-high-bits ,arg))
+		     (new-args `(long-float-mid-bits ,arg))
+		     (new-args `(long-float-low-bits ,arg))
+		     (new-arg-types (parse-alien-type '(signed 32)))
+		     (new-arg-types (parse-alien-type '(unsigned 32)))
+		     (new-arg-types (parse-alien-type '(unsigned 32)))
+		     (new-arg-types (parse-alien-type '(unsigned 32))))
+		    (t
+		     (new-args arg)
+		     (new-arg-types type)))))
+	  (flet ((mv (vars forms body)
+		   ;; Create the set of nested mv-binds
+		   (let ((res body))
+		     (do ((v (reverse vars) (cdr v))
+			  (f (reverse forms) (cdr f)))
+			 ((null v))
+		       (setf res `(multiple-value-bind ,(car v)
+				   ,(car f)
+				   ,res)))
+		     res)))
+	    (cond ((and (alien-integer-type-p result-type)
+			(> (alien::alien-integer-type-bits result-type) 32))
+		   (let* ((new-result-type
+			   (let ((alien::*values-type-okay* t))
+			     (parse-alien-type
+			      (if (alien-integer-type-signed result-type)
+				  '(values (signed 32) (unsigned 32))
+				  '(values (unsigned 32) (unsigned 32))))))
+			  (body (mv (mv-vars)
+				    (mv-form)
+				    `(multiple-value-bind (high low)
+				      (%alien-funcall function
+				       ',(make-alien-function-type
+					  :arg-types (new-arg-types)
+					  :result-type new-result-type)
+				       ,@(new-args))
+				      (logior low (ash high 32))))))
+		     `(lambda (function type ,@(lambda-vars))
+		       (declare (ignore type))
+		       ,body)))
+		  (t
+		   (let ((body (mv (mv-vars)
+				   (mv-form)
+				   `(%alien-funcall function
+				     ',(make-alien-function-type
+					:arg-types (new-arg-types)
+					:result-type result-type)
+				     ,@(new-args)))))
+		     `(lambda (function type ,@(lambda-vars))
+		       (declare (ignore type))
+		       ,body))))))
+	(c::give-up))))
+
+
+#-linkage-table
+(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 res (make-fixup (extern-alien-name foreign-symbol)
+			     :foreign))))
+
+(define-vop (foreign-symbol-code-address)
+  (:translate #+linkage-table foreign-symbol-code-address
+	      #-linkage-table 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 res (make-fixup (extern-alien-name foreign-symbol)
+			     :foreign))))
+
+(define-vop (foreign-symbol-data-address)
+  (:translate foreign-symbol-data-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:temporary (:scs (non-descriptor-reg)) addr)
+  (:generator 2
+    (inst li addr (make-fixup (extern-alien-name foreign-symbol)
+			      :foreign-data))
+    (loadw res addr)))
+
+(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 interior-reg :offset lip-offset) lip)
+  (:temporary (:scs (any-reg) :to (:result 0)) temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:vop-var vop)
+  (:generator 0
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (move cfunc function)
+      (inst li temp (make-fixup (extern-alien-name "call_into_c") :foreign))
+      (inst jal lip temp)
+      (inst nop)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))))
+
+
+(define-vop (alloc-number-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 7) 7)))
+	(cond ((< delta (ash 1 12))
+	       (inst sub nsp-tn delta))
+	      (t
+	       (inst li temp delta)
+	       (inst sub nsp-tn temp)))))
+    (unless (location= result nsp-tn)
+      ;; They are only location= when the result tn was allocated by
+      ;; make-call-out-tns above, which takes the number-stack-displacement
+      ;; into account itself.
+      (inst add result nsp-tn number-stack-displacement))))
+
+(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 12))
+	       (inst add nsp-tn delta))
+	      (t
+	       (inst li temp delta)
+	       (inst add nsp-tn temp)))))))
diff --git a/src/compiler/sparcv9/c-callback.lisp b/src/compiler/sparcv9/c-callback.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b1fa10cd47dfac5ba3a432b26b8b3fb80b4ca002
--- /dev/null
+++ b/src/compiler/sparcv9/c-callback.lisp
@@ -0,0 +1,217 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/c-callback.lisp $")
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+(use-package "ALIEN")
+(use-package "ALIEN-INTERNALS")
+
+;;; Support for callbacks to Lisp.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(export '(make-callback-trampoline callback-accessor-form
+	  compatible-function-types-p))
+)
+
+(defun callback-accessor-form (type sp offset)
+  (let ((parsed-type (alien::parse-alien-type type)))
+    (typecase parsed-type
+      (alien::double$
+       ;; Due to sparc calling conventions, a double arg doesn't have to
+       ;; be aligned on a double word boundary.  We have to get the two
+       ;; words separately and create the double from them.  Doubles are
+       ;; stored in big-endian order, naturally.
+       `(kernel:make-double-float
+	 (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int)))
+	 (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes))
+				 (* c-call:unsigned-int)))))
+      (alien::integer-64$
+       ;; Same as for double, above
+       `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset)
+					  ,(if (alien-integer-type-signed parsed-type)
+					       '(* c-call:int)
+					       '(* c-call:unsigned-int)))))
+	      (lo (alien:deref (sap-alien (sys:sap+ ,sp
+						    (+ ,offset vm:word-bytes))
+					  (* c-call:unsigned-int)))))
+	  (+ (ash hi vm:word-bits) lo)))
+      (alien::integer$
+       ;; All other objects can be accessed directly.  But we need to
+       ;; get the offset right, since the offset we're given is the
+       ;; start of the object, and we're a big-endian machine.
+       (let ((byte-offset
+	      (- vm:word-bytes
+		 (ceiling (alien::alien-integer-type-bits parsed-type)
+			  vm:byte-bits))))
+	 `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset))
+			    (* ,type)))))
+      (t
+       `(deref (sap-alien (sys:sap+ ,sp ,offset)
+			  (* ,type)))))))
+
+(defun compatible-function-types-p (type1 type2)
+  (flet ((machine-rep (type)
+	   (etypecase type
+	     (alien::integer-64$ :dword)
+	     ((or alien::integer$ alien::pointer$ alien::sap$) :word)
+	     (alien::single$ :single)
+	     (alien::double$ :double)
+	     (alien::void$ :void))))
+    (let ((type1 (alien-function-type-result-type type1))
+	  (type2 (alien-function-type-result-type type2)))
+      (eq (machine-rep type1) (machine-rep type2)))))
+
+(defun make-callback-trampoline (index fn-type)
+  "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+  (let ((return-type (alien-function-type-result-type fn-type)))
+    (flet ((def-reg-tn (offset)
+	     (c:make-random-tn :kind :normal
+			       :sc (c:sc-or-lose 'vm::unsigned-reg)
+			       :offset offset)))
+      (let* ((segment (make-segment))
+	     ;; Window save area (16 registers)
+	     (window-save-size (* 16 vm:word-bytes))
+	     ;; Structure return pointer area (1 register)
+	     (struct-return-size vm:word-bytes)
+	     ;; Register save area (6 registers)
+	     (reg-save-area-size (* 6 vm:word-bytes))
+	     ;; Local var.  Should be large enough to hold a double-float or long
+	     (return-value-size (* 2 vm:word-bytes))
+	     ;; Frame size: the register window, the arg save area, the
+	     ;; structure return area, and return-value-area, all
+	     ;; rounded to a multiple of eight.
+	     (framesize (* 8 (ceiling (+ window-save-size struct-return-size
+					 reg-save-area-size
+					 return-value-size)
+				      8)))
+	     ;; Offset from FP where the first arg is located.
+	     (arg0-save-offset (+ window-save-size struct-return-size))
+	     ;; Establish the registers we need
+	     (%g0 (def-reg-tn vm::zero-offset))
+	     (%o0 (def-reg-tn vm::nl0-offset))
+	     (%o1 (def-reg-tn vm::nl1-offset))
+	     (%o2 (def-reg-tn vm::nl2-offset))
+	     (%o3 (def-reg-tn vm::nl3-offset))
+	     (%o7 (def-reg-tn vm::nargs-offset))
+	     (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6
+	     (%l0 (def-reg-tn vm::a0-offset))
+	     (%i0 (def-reg-tn vm::cname-offset))
+	     (%i1 (def-reg-tn vm::lexenv-offset))
+	     (%i2 (def-reg-tn 26))
+	     (%i3 (def-reg-tn vm::nfp-offset))
+	     (%i4 (def-reg-tn vm::cfunc-offset))
+	     (%i5 (def-reg-tn vm::code-offset))
+	     (%fp (def-reg-tn 30))
+	     (%i7 (def-reg-tn vm::lip-offset))
+	     (f0-s (c:make-random-tn :kind :normal
+				     :sc (c:sc-or-lose 'vm::single-reg)
+				     :offset 0))
+	     (f0-d (c:make-random-tn :kind :normal
+				     :sc (c:sc-or-lose 'vm::double-reg)
+				     :offset 0))
+	     )
+	;; The generated assembly roughly corresponds to this C code:
+	;;
+	;;        tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...)
+	;;	{
+	;;	  double result;
+	;;	  funcall3(call-callback, <index>, &a0, &result);
+	;;	  return <cast> result;
+	;;	}
+	;;
+	;; Except, of course, the result is the appropriate result type
+	;; for the trampoline.
+	;;	       
+	(assemble (segment)
+	  ;; Save old %fp, etc. establish our call frame with local vars
+	  ;; %i contains the input args
+	  (inst save %sp %sp (- framesize))
+	  ;; The stack frame now looks like
+	  ;;
+	  ;; TOP (high memory)
+	  ;;
+	  ;; argn
+	  ;; ...
+	  ;; arg6
+	  ;; arg5
+	  ;; arg4
+	  ;; arg3
+	  ;; arg2
+	  ;; arg1
+	  ;; arg0
+	  ;; struct_return
+	  ;; window-save-area	<- %fp + 64
+	  ;;			<- %fp
+	  ;; local-vars-extra-args	(8-bytes)
+	  ;; arg5-save
+	  ;; arg4-save
+	  ;; arg3-save
+	  ;; arg2-save
+	  ;; arg1-save
+	  ;; arg0-save
+	  ;; struct_return		
+	  ;; window-save-area
+	  ;;			<- %sp
+
+	  ;; Save all %i arg register values on the stack.  (We
+	  ;; might not always need to save all, but this is safe
+	  ;; and easy.)
+	  (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes)))
+	  (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes)))
+	  (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes)))
+	  (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes)))
+	  (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes)))
+	  (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes)))
+
+	  ;; Set up our args to call funcall3
+	  ;;
+	  ;; %o0 = address of call-callback
+	  ;; %o1 = index
+	  ;; %o2 = pointer to the arguments of the caller (address
+	  ;;       of arg0 above)
+	  ;; %o3 = pointer to return area
+
+	  (inst li %o0 (alien::address-of-call-callback))
+	  (inst li %o1 (ash index vm:fixnum-tag-bits))
+	  (inst add %o2 %fp arg0-save-offset)
+	  (inst add %o3 %fp (- return-value-size))
+
+	  ;; And away we go to funcall3!
+	  (let ((addr (alien::address-of-funcall3)))
+	    (inst sethi %l0 (ldb (byte 22 10) addr))
+	    (inst jal %o7 %l0 (ldb (byte 10 0) addr))
+	    (inst nop))
+
+	  ;; Ok, we're back.  The value returned is actually
+	  ;; stored in the return area.  Need to get that into
+	  ;; the right registers for return.
+	  (etypecase return-type
+	    (alien::integer-64$
+	     ;; A 64-bit bignum, stored big-endian
+	     (inst ld %i0 %fp (- return-value-size))
+	     (inst ld %i1 %fp (- (- return-value-size vm:word-bytes))))
+	    ((or alien::integer$ alien::pointer$ alien::sap$)
+	     (inst ld %i0 %fp (- return-value-size)))
+	    (alien::single$
+	     ;; Get the FP value into F0
+	     (inst ldf f0-s %fp (- return-value-size))
+	     )
+	    (alien::double$
+	     (inst lddf f0-d %fp (- return-value-size)))
+	    (alien::void$
+	     ))
+
+	  (inst jal %g0 %i7 8)
+	  (inst restore %g0 %g0 %g0)
+	  )
+	(let ((length (finalize-segment segment)))
+	  (prog1 (alien::segment-to-trampoline segment length)
+	    (release-segment segment)))))))
+
+
diff --git a/src/compiler/sparcv9/call.lisp b/src/compiler/sparcv9/call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6c8b2f2467877bbfd96725b5e5ee2e8d40f17426
--- /dev/null
+++ b/src/compiler/sparcv9/call.lisp
@@ -0,0 +1,1300 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/call.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the SPARC.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;;; 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)
+  (if standard
+      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
+      (make-restricted-tn *any-primitive-type* register-arg-scn)))
+
+;;; Make-Old-FP-Passing-Location  --  Interface
+;;;
+;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to 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)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env)
+   (make-wired-tn *any-primitive-type*
+		  control-stack-arg-scn
+		  lra-save-offset)))
+
+;;; Make-Argument-Count-Location  --  Interface
+;;;
+;;;    Make a TN for the standard argument count passing location.  We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+;;;
+(def-vm-support-routine make-argument-count-location ()
+  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
+
+
+;;; MAKE-NFP-TN  --  Interface
+;;;
+;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
+;;; once per component, and is component-live.
+;;;
+(def-vm-support-routine make-nfp-tn ()
+  (component-live-tn
+   (make-wired-tn *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)
+     vm:word-bytes))
+
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+  (:results (val :scs (any-reg)))
+  (:generator 1
+    (move val cfp-tn)))
+
+;;; Used for computing the caller's NFP for use in known-values return.  Only
+;;; works assuming there is no variable size stuff on the nstack.
+;;;
+(define-vop (compute-old-nfp)
+  (:results (val :scs (any-reg)))
+  (:vop-var vop)
+  (:generator 1
+    (let ((nfp (current-nfp-tn vop)))
+      (when nfp
+	(inst add val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
+
+
+(define-vop (xep-allocate-frame)
+  (:info start-lab copy-more-arg-follows clear-memory-p)
+  (:ignore copy-more-arg-follows)
+  (: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 vm:lowtag-bits)
+    (trace-table-entry trace-table-function-prologue)
+    (emit-label start-lab)
+    ;; Allocate function header.
+    (inst function-header-word)
+    (dotimes (i (1- vm:function-code-offset))
+      (inst word 0))
+    ;; The start of the actual code.
+    ;; Fix CODE, cause the function object was passed in.
+    (inst compute-code-from-fn code-tn code-tn start-lab temp)
+    ;; Rob says we should zero out the words that are allocated for
+    ;; the args that are passed in registers and also zero out the
+    ;; words from CSP to CFP+size.
+    (when clear-memory-p
+      
+      ;; Zero out the args that correspond to register args
+      (dotimes (k register-arg-count)
+	(inst stn zero-tn cfp-tn (* k vm:word-bytes)))
+	
+      ;; Zero out memory from CSP to CFP+size
+      (let ((zero-out-mem (gen-label))
+	    (loop-test (gen-label)))
+
+	(inst b loop-test)
+	(inst add temp cfp-tn
+	      (* vm:word-bytes (1- (sb-allocated-size 'control-stack))))
+
+	(emit-label zero-out-mem)
+	(inst stn zero-tn csp-tn (- vm:word-bytes))
+	(emit-label loop-test)
+	(inst cmp csp-tn temp)
+	(inst b :lt zero-out-mem)
+	(inst add csp-tn vm:word-bytes))
+      )
+    ;; Build our stack frames.
+    (let ((size (* vm:word-bytes (sb-allocated-size 'control-stack))))
+      (cond ((typep size '(signed-byte 13))
+	     (inst add csp-tn cfp-tn size))
+	    (t
+	     (inst li temp size)
+	     (inst add csp-tn cfp-tn temp))))
+    (let ((nfp-tn (current-nfp-tn vop)))
+      (when nfp-tn
+	(inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
+	(inst add nfp-tn nsp-tn number-stack-displacement)))
+    (trace-table-entry trace-table-normal)))
+
+(define-vop (allocate-frame)
+  (:results (res :scs (any-reg))
+	    (nfp :scs (any-reg)))
+  (:info callee clear-memory-p)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 2
+    (trace-table-entry trace-table-function-prologue)
+    (move res csp-tn)
+    (when clear-memory-p
+      ;; Rob Maclaclan says we should zero out this memory.
+      (let ((zero-out-loop (gen-label))
+	    (zero-out-test (gen-label)))
+	(inst b zero-out-test)
+	(inst li temp (* vm:word-bytes (sb-allocated-size 'control-stack)))
+      
+	(emit-label zero-out-loop)
+	(emit-label zero-out-test)
+	(inst subcc temp vm:word-bytes)
+	(inst b :gt zero-out-loop)
+	(inst stn zero-tn csp-tn temp)
+	))
+    (let ((size (* vm:word-bytes (sb-allocated-size 'control-stack))))
+      (cond ((typep size '(signed-byte 13))
+	     (inst add csp-tn csp-tn size))
+	    (t
+	     (inst li temp size)
+	     (inst add csp-tn csp-tn temp))))
+    (when (ir2-environment-number-stack-p callee)
+      (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
+      (inst add nfp nsp-tn number-stack-displacement))
+    (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 res csp-tn)
+      (inst add csp-tn csp-tn (* nargs vm:word-bytes)))))
+
+
+
+
+;;; 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 old-fp csp			; Set up args for SP resetting
+
+regs-defaulted
+	subcc temp nargs register-arg-count
+
+	b :lt default-value-7	; jump to default code
+	loadw move-temp ocfp-tn 6	; Move value to correct location.
+        subcc temp 1
+	store-stack-tn val4-tn move-temp
+
+	b :lt default-value-8
+	loadw move-temp ocfp-tn 7
+        subcc temp 1
+	store-stack-tn val5-tn move-temp
+
+	...
+
+defaulting-done
+	move csp 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
+	(new-assem:without-scheduling ()
+	  (note-this-location vop :single-value-return)
+	  (move csp-tn ocfp-tn)
+	  (inst nop))
+	(inst compute-code-from-lra code-tn code-tn lra-label temp))
+      (let ((regs-defaulted (gen-label))
+	    (defaulting-done (gen-label))
+	    (default-stack-vals (gen-label)))
+	;; Branch off to the MV case.
+	(new-assem:without-scheduling ()
+	  (note-this-location vop :unknown-return)
+	  (inst b regs-defaulted)
+	  (if (> nvals register-arg-count)
+	      (inst subcc temp nargs-tn (fixnumize register-arg-count))
+	      (move csp-tn ocfp-tn)))
+	
+	;; 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 (tn-ref-tn val) null-tn))
+	(when (> nvals register-arg-count)
+	  (inst b default-stack-vals)
+	  (move ocfp-tn csp-tn))
+	
+	(emit-label regs-defaulted)
+	(when (> nvals register-arg-count)
+	  (collect ((defaults))
+	    (do ((i register-arg-count (1+ i))
+		 (val (do ((i 0 (1+ i))
+			   (val values (tn-ref-across val)))
+			  ((= i register-arg-count) val))
+		      (tn-ref-across val)))
+		((null val))
+	      
+	      (let ((default-lab (gen-label))
+		    (tn (tn-ref-tn val)))
+		(defaults (cons default-lab tn))
+		
+		(inst b :le default-lab)
+		(inst ldn move-temp ocfp-tn (* i vm:word-bytes))
+		(inst subcc temp (fixnumize 1))
+		(store-stack-tn tn move-temp)))
+	    
+	    (emit-label defaulting-done)
+	    (move csp-tn ocfp-tn)
+	    
+	    (let ((defaults (defaults)))
+	      (when defaults
+		(assemble (*elsewhere*)
+		  (emit-label default-stack-vals)
+		  (trace-table-entry trace-table-function-prologue)
+		  (do ((remaining defaults (cdr remaining)))
+		      ((null remaining))
+		    (let ((def (car remaining)))
+		      (emit-label (car def))
+		      (when (null (cdr remaining))
+			(inst b defaulting-done))
+		      (store-stack-tn (cdr def) null-tn)))
+		  (trace-table-entry trace-table-normal))))))
+
+	(inst compute-code-from-lra code-tn code-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)))
+    (new-assem:without-scheduling ()
+      (inst b variable-values)
+      (inst nop))
+    
+    (inst compute-code-from-lra code-tn code-tn lra-label temp)
+    (inst add csp-tn 4)
+    (storew (first register-arg-tns) csp-tn -1)
+    (inst sub start csp-tn 4)
+    (inst li count (fixnumize 1))
+    
+    (emit-label done)
+    
+    (assemble (*elsewhere*)
+      (trace-table-entry trace-table-function-prologue)
+      (emit-label variable-values)
+      (inst compute-code-from-lra code-tn code-tn lra-label temp)
+      (do ((arg register-arg-tns (rest arg))
+	   (i 0 (1+ i)))
+	  ((null arg))
+	(storew (first arg) args i))
+      (move start args)
+      (move count nargs)
+      (inst b done)
+      (inst nop)
+      (trace-table-entry trace-table-normal)))
+  (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 0)) 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 0)) ocfp)
+  (:ignore arg-locs args ocfp)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (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)))
+	(when callee-nfp
+	  (maybe-load-stack-tn callee-nfp nfp)))
+      (maybe-load-stack-tn cfp-tn fp)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst b target)
+      (inst nop)
+      (emit-return-pc label)
+      (default-unknown-values vop values nvals move-temp temp label)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))
+    (trace-table-entry trace-table-normal)))
+
+
+;;; 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)
+  (:generator 20
+    (trace-table-entry trace-table-call-site)
+    (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)))
+	(when callee-nfp
+	  (maybe-load-stack-tn callee-nfp nfp)))
+      (maybe-load-stack-tn cfp-tn fp)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst b target)
+      (inst nop)
+      (emit-return-pc label)
+      (note-this-location vop :unknown-return)
+      (receive-unknown-values values-start nvals start count label temp)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; 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
+    (trace-table-entry trace-table-call-site)
+    (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)))
+	(when callee-nfp
+	  (maybe-load-stack-tn callee-nfp nfp)))
+      (maybe-load-stack-tn cfp-tn fp)
+      (inst compute-lra-from-code
+	    (callee-return-pc-tn callee) code-tn label temp)
+      (note-this-location vop :call-site)
+      (inst b target)
+      (inst nop)
+      (emit-return-pc label)
+      (note-this-location vop :known-return)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save)))
+    (trace-table-entry trace-table-normal)))
+
+;;; 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 (old-fp :target old-fp-temp)
+	 (return-pc :target return-pc-temp)
+	 (vals :more t))
+  (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
+  (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
+  (:move-args :known-return)
+  (:info val-locs)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    (maybe-load-stack-tn old-fp-temp old-fp)
+    (maybe-load-stack-tn return-pc-temp return-pc)
+    (move csp-tn cfp-tn)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst add nsp-tn cur-nfp 
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+    (inst j return-pc-temp (- vm:word-bytes vm:other-pointer-type))
+    (move cfp-tn old-fp-temp)
+    (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 Old-Fp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument.  If Variable is false, then the passing locations are
+;;; passed as a more arg.  Variable is true if there are a variable number of
+;;; arguments passed on the stack.  Variable cannot be specified with :Tail
+;;; return.  TR variable argument call is implemented separately.
+;;;
+;;; 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)
+	  '((old-fp :target old-fp-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
+      ,@(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)))
+		 old-fp-pass)
+
+     (:temporary (:sc descriptor-reg
+		  :offset lra-offset
+		  :from (:argument ,(if (eq return :tail) 2 1))
+		  :to :eval)
+		 return-pc-pass)
+
+     ,(if named
+	  `(:temporary (:sc descriptor-reg :offset cname-offset
+			    :from (:argument ,(if (eq return :tail) 0 1))
+			    :to :eval)
+		       name-pass)
+	  `(:temporary (:sc descriptor-reg :offset lexenv-offset
+			    :from (:argument ,(if (eq return :tail) 0 1))
+			    :to :eval)
+		       lexenv))
+
+     (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+		 function)
+     (:temporary (:sc any-reg :offset nargs-offset :to :eval)
+		 nargs-pass)
+     (:temporary (:scs (non-descriptor-reg)) temp)
+	   
+     ,@(when variable
+	 (mapcar #'(lambda (name offset)
+		     `(:temporary (:sc descriptor-reg
+				   :offset ,offset
+				   :to :eval)
+			 ,name))
+		 register-arg-names register-arg-offsets))
+     ,@(when (eq return :fixed)
+	 '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+
+     ,@(unless (eq return :tail)
+	 '((:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+
+     (:generator ,(+ (if named 5 0)
+		     (if variable 19 1)
+		     (if (eq return :tail) 0 10)
+		     15
+		     (if (eq return :unknown) 25 0))
+       (trace-table-entry trace-table-call-site)
+       (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= old-fp old-fp-pass)
+				       :load-old-fp)
+				     (unless (location= return-pc
+							return-pc-pass)
+				       :load-return-pc)
+				     (when cur-nfp
+				       :frob-nfp))
+				   '(: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 sub nargs-pass csp-tn new-fp)
+			       ,@(let ((index -1))
+				   (mapcar #'(lambda (name)
+					       `(loadw ,name new-fp
+						       ,(incf index)))
+					   register-arg-names)))
+			     '((inst li nargs-pass (fixnumize nargs)))))
+		      ,@(if (eq return :tail)
+			    '((:load-old-fp
+			       (sc-case old-fp
+				 (any-reg
+				  (inst move old-fp-pass old-fp))
+				 (control-stack
+				  (loadw old-fp-pass cfp-tn
+					 (tn-offset old-fp) 0 temp))))
+			      (:load-return-pc
+			       (sc-case return-pc
+				 (descriptor-reg
+				  (inst move return-pc-pass return-pc))
+				 (control-stack
+				  (loadw return-pc-pass cfp-tn
+					 (tn-offset return-pc) 0 temp))))
+			      (:frob-nfp
+			       (inst add nsp-tn cur-nfp
+				     (- (bytes-needed-for-non-descriptor-stack-frame)
+					number-stack-displacement))))
+			    `((: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 old-fp-pass cfp-tn))
+			      (:load-fp
+			       ,(if variable
+				    '(move cfp-tn new-fp)
+				    '(if (> nargs register-arg-count)
+					 (move cfp-tn new-fp)
+					 (move cfp-tn csp-tn))))))
+		      ((nil))))))
+
+	   ,@(if named
+		 `((sc-case name
+		     (descriptor-reg (move name-pass name))
+		     (control-stack
+		      (loadw name-pass cfp-tn (tn-offset name) 0 temp)
+		      (do-next-filler))
+		     (constant
+		      (loadw name-pass code-tn (tn-offset name)
+			     vm:other-pointer-type temp)
+		      (do-next-filler)))
+		   (loadw function name-pass fdefn-raw-addr-slot
+			  other-pointer-type)
+		   (do-next-filler))
+		 `((sc-case arg-fun
+		     (descriptor-reg (move lexenv arg-fun))
+		     (control-stack
+		      (loadw lexenv cfp-tn (tn-offset arg-fun) 0 temp)
+		      (do-next-filler))
+		     (constant
+		      (loadw lexenv code-tn (tn-offset arg-fun)
+			     vm:other-pointer-type)
+		      (do-next-filler)))
+		   (loadw function lexenv vm:closure-function-slot
+			  vm:function-pointer-type)
+		   (do-next-filler)))
+	   (loop
+	     (if filler
+		 (do-next-filler)
+		 (return)))
+	   
+	   (note-this-location vop :call-site)
+	   (inst j function
+		 (- (ash vm:function-code-offset vm:word-shift)
+		    vm:function-pointer-type))
+	   (inst move code-tn function))
+
+	 ,@(ecase return
+	     (:fixed
+	      '((emit-return-pc lra-label)
+		(default-unknown-values vop values nvals move-temp
+					temp lra-label)
+		(when cur-nfp
+		  (load-stack-tn cur-nfp nfp-save))))
+	     (:unknown
+	      '((emit-return-pc lra-label)
+		(note-this-location vop :unknown-return)
+		(receive-unknown-values values-start nvals start count
+					lra-label temp)
+		(when cur-nfp
+		  (load-stack-tn cur-nfp nfp-save))))
+	     (:tail)))
+       (trace-table-entry trace-table-normal))))
+
+
+(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)
+   (old-fp-arg :scs (any-reg) :target old-fp)
+   (lra-arg :scs (descriptor-reg) :target lra))
+
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
+  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
+  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp)
+  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
+
+  (:temporary (:scs (any-reg) :from :eval) temp)
+
+  (:vop-var vop)
+
+  (:generator 75
+
+    ;; Move these into the passing locations if they are not already there.
+    (move args args-arg)
+    (move lexenv function-arg)
+    (move old-fp old-fp-arg)
+    (move lra lra-arg)
+
+    ;; Clear the number stack if anything is there.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst add nsp-tn cur-nfp
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+
+    ;; And jump to the assembly-routine that does the bliting.
+    (inst ji temp (make-fixup 'tail-call-variable :assembly-routine))
+    (inst nop)))
+
+
+;;;; Unknown values return:
+
+
+;;; Return a single value using the unknown-values convention.
+;;; 
+(define-vop (return-single)
+  (:args (old-fp :scs (any-reg))
+	 (return-pc :scs (descriptor-reg))
+	 (value))
+  (:ignore value)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Clear the number stack.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst add nsp-tn cur-nfp
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+    ;; Clear the control stack, and restore the frame pointer.
+    (move csp-tn cfp-tn)
+    (move cfp-tn old-fp)
+    ;; Out of here.
+    (lisp-return return-pc :offset 2)
+    (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
+   (old-fp :scs (any-reg))
+   (return-pc :scs (descriptor-reg) :to (:eval 1))
+   (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)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Clear the number stack.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst add nsp-tn cur-nfp
+	      (- (bytes-needed-for-non-descriptor-stack-frame)
+		 number-stack-displacement))))
+    (cond ((= nvals 1)
+	   ;; Clear the control stack, and restore the frame pointer.
+	   (move csp-tn cfp-tn)
+	   (move cfp-tn old-fp)
+	   ;; Out of here.
+	   (lisp-return return-pc :offset 2))
+	  (t
+	   ;; Establish the values pointer and values count.
+	   (move val-ptr cfp-tn)
+	   (inst li nargs (fixnumize nvals))
+	   ;; restore the frame pointer and clear as much of the control
+	   ;; stack as possible.
+	   (move cfp-tn old-fp)
+	   (inst add csp-tn val-ptr (* nvals word-bytes))
+	   ;; 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 reg null-tn)))
+	   ;; And away we go.
+	   (lisp-return return-pc)))
+    (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
+   (old-fp-arg :scs (any-reg) :to (:eval 1))
+   (lra-arg :scs (descriptor-reg) :to (:eval 1))
+   (vals-arg :scs (any-reg) :target vals)
+   (nvals-arg :scs (any-reg) :target nvals))
+
+  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
+  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
+
+  (:temporary (:scs (any-reg) :from (:eval 1)) 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 add nsp-tn cur-nfp
+		(- (bytes-needed-for-non-descriptor-stack-frame)
+		   number-stack-displacement))))
+
+      ;; Check for the single case.
+      (inst cmp nvals-arg (fixnumize 1))
+      (inst b :ne not-single)
+      (inst ldn a0 vals-arg)
+
+      ;; Return with one value.
+      (move csp-tn cfp-tn)
+      (move cfp-tn old-fp-arg)
+      (lisp-return lra-arg :offset 2)
+		
+      ;; Nope, not the single case.
+      (emit-label not-single)
+      (move old-fp old-fp-arg)
+      (move lra lra-arg)
+      (move vals vals-arg)
+      (move nvals nvals-arg)
+      (inst ji temp (make-fixup 'return-multiple :assembly-routine))
+      (inst nop))
+    (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 closure lexenv)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments. 
+;;;
+(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 nl3-offset) dst)
+  (:temporary (:sc descriptor-reg :offset cname-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 result csp-tn))
+      ;; Allocate the space on the stack.
+      (cond ((zerop fixed)
+	     (inst cmp nargs-tn)
+	     (inst b :eq done)
+	     (inst add csp-tn csp-tn nargs-tn))
+	    (t
+	     (inst subcc count nargs-tn (fixnumize fixed))
+	     (inst b :le done)
+	     (inst nop)
+	     (inst add csp-tn csp-tn count)))
+      (when (< fixed register-arg-count)
+	;; We must stop when we run out of stack args, not when we run out of
+	;; more args.
+	(inst subcc count nargs-tn (fixnumize register-arg-count))
+	;; Everything of interest in registers.
+	(inst b :le do-regs))
+      ;; Initialize dst to be end of stack.
+      (move dst csp-tn)
+      ;; Initialize src to be end of args.
+      (inst add src cfp-tn nargs-tn)
+
+      (emit-label loop)
+      ;; *--dst = *--src, --count
+      (inst add src src (- vm:word-bytes))
+      (inst subcc count count (fixnumize 1))
+      (loadw temp src)
+      (inst add dst dst (- vm:word-bytes))
+      (inst b :gt loop)
+      (storew temp dst)
+
+      (emit-label do-regs)
+      (when (< fixed register-arg-count)
+	;; Now we have to deposit any more args that showed up in registers.
+	(inst subcc count nargs-tn (fixnumize fixed))
+	(do ((i fixed (1+ i)))
+	    ((>= i register-arg-count))
+	  ;; Don't deposit any more than there are.
+	  (inst b :eq done)
+	  (inst subcc count (fixnumize 1))
+	  ;; Store it relative to the pointer saved at the start.
+	  (storew (nth i register-arg-tns) result (- i fixed))))
+      (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-vop (more-arg word-index-ref)
+  (:variant 0 0)
+  (:translate %more-arg))
+
+
+;;; Turn more arg (context, count) into a list.
+;;;
+(define-vop (listify-rest-args)
+  (:args (context-arg :target context :scs (descriptor-reg))
+	 (count-arg :target count :scs (any-reg)))
+  (:arg-types * tagged-num (:constant t))
+  (:info dynamic-extent)
+  (:temporary (:scs (any-reg) :from (:argument 0)) context)
+  (:temporary (:scs (any-reg) :from (:argument 1)) count)
+  (:temporary (:scs (descriptor-reg) :from :eval) temp)
+  (:temporary (:scs (non-descriptor-reg) :from :eval) dst)
+  (:results (result :scs (descriptor-reg)))
+  (:translate %listify-rest-args)
+  (:policy :safe)
+  (:generator 20
+    (move context context-arg)
+    (move count count-arg)
+    ;; Check to see if there are any arguments.
+    (inst cmp count)
+    (inst b :eq done)
+    (move result null-tn)
+
+    ;; We need to do this atomically.
+    (pseudo-atomic ()
+      (assemble ()
+	;; Allocate a cons (2 words) for each item.
+	(inst slln temp count 1)
+	(allocation result temp list-pointer-type
+		    :stack-p dynamic-extent
+		    :temp-tn dst)
+	(inst b enter)
+	(move dst result)
+
+
+	;; Compute the next cons and store it in the current one.
+	LOOP
+	(inst add dst dst (* 2 vm:word-bytes))
+	(storew dst dst -1 vm:list-pointer-type)
+
+	;; Grab one value.
+	ENTER
+	(loadw temp context)
+	(inst add context context vm:word-bytes)
+
+	;; Dec count, and if != zero, go back for more.
+	(inst subcc count (fixnumize 1))
+	(inst b :gt loop)
+
+	;; Store the value into the car of the current cons (in the delay
+	;; slot).
+	(storew temp dst 0 vm:list-pointer-type)
+
+	;; NIL out the last cons.
+	(storew null-tn dst 1 vm:list-pointer-type)))
+    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 _N"more-arg-context")
+  (:generator 5
+    (inst sub count supplied (fixnumize fixed))
+    (inst sub context csp-tn count)))
+
+
+;;; 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))
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (inst cmp nargs (fixnumize count))
+      ;; Assume we don't take the branch
+      (inst b :ne err-lab #+sparc-v9 :pn)
+      (inst nop))))
+
+;;; Signal various errors.
+;;;
+(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/src/compiler/sparcv9/cell.lisp b/src/compiler/sparcv9/cell.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..448775c9084f039fa0f2f94e7a7cbd5ff733686e
--- /dev/null
+++ b/src/compiler/sparcv9/cell.lisp
@@ -0,0 +1,319 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/cell.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of various primitive memory access
+;;; VOPs for the SPARC.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;;; 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)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results)
+  (:generator 1
+    (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 (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 obj-temp object)
+    (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type)
+    (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+      (inst cmp value vm:unbound-marker-type)
+      (inst b :eq err-lab)
+      (inst nop))))
+
+;;; 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))
+
+(define-vop (boundp boundp-frob)
+  (:translate boundp)
+  (:generator 9
+    (loadw value object vm:symbol-value-slot vm:other-pointer-type)
+    (inst cmp value vm:unbound-marker-type)
+    (inst b (if not-p :eq :ne) target)
+    (inst nop)))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant vm:symbol-value-slot vm:other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+(define-vop (symbol-hash)
+  (:policy :fast-safe)
+  (:translate symbol-hash)
+  (:args (symbol :scs (descriptor-reg null)))
+  (:results (res :scs (any-reg)))
+  (:result-types tagged-num)
+  (:generator 2
+    ;; the symbol-hash slot of NIL holds NIL because it is also the cdr
+    ;; slot, so we have to strip off the two low bits to make sure it is
+    ;; a fixnum.
+    (loadw res symbol symbol-hash-slot other-pointer-type)
+    (inst andn res vm:fixnum-tag-mask)))
+
+(define-vop (%set-symbol-hash cell-set)
+  (:translate %set-symbol-hash)
+  (:variant symbol-hash-slot other-pointer-type))
+
+
+;;;; 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)
+  (:generator 10
+    (move obj-temp object)
+    (loadw value obj-temp fdefn-function-slot other-pointer-type)
+    (inst cmp value null-tn)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+      (inst b :eq err-lab))
+    (inst nop)))
+
+(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 (descriptor-reg)) temp)
+  (: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 cmp type function-header-type)
+      (inst b :eq normal-fn)
+      (inst move temp function)
+      (inst li temp (make-fixup 'closure-tramp
+			       :assembly-routine))
+      (emit-label normal-fn)
+      (storew function fdefn fdefn-function-slot other-pointer-type)
+      (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
+      (move result function))))
+
+(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 temp (make-fixup 'undefined-tramp
+			      :assembly-routine))
+    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result fdefn)))
+
+
+
+;;;; 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 vm:symbol-value-slot vm:other-pointer-type)
+    (inst add bsp-tn bsp-tn (* 2 vm:word-bytes))
+    (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size))
+    (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+    (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
+
+
+(define-vop (unbind)
+  (:temporary (:scs (descriptor-reg)) symbol value)
+  (:generator 0
+    (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+    (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size))
+    (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+    (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+    (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes))))
+
+
+(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)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (skip (gen-label))
+	  (done (gen-label)))
+      (move where arg)
+      (inst cmp where bsp-tn)
+      (inst b :eq done)
+      (inst nop)
+
+      (emit-label loop)
+      (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+      (inst cmp symbol)
+      (inst b :eq skip)
+      (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size))
+      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+      (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size))
+
+      (emit-label skip)
+      (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes))
+      (inst cmp where bsp-tn)
+      (inst b :ne loop)
+      (inst nop)
+
+      (emit-label done))))
+
+
+
+;;;; Closure indexing.
+
+(define-vop (closure-index-ref word-index-ref)
+  (:variant vm:closure-info-offset vm:function-pointer-type)
+  (:translate %closure-index-ref))
+
+(define-vop (funcallable-instance-info word-index-ref)
+  (:variant funcallable-instance-info-offset vm:function-pointer-type)
+  (:translate %funcallable-instance-info))
+
+(define-vop (set-funcallable-instance-info word-index-set)
+  (:variant funcallable-instance-info-offset function-pointer-type)
+  (:translate %set-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)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (loadw temp struct 0 instance-pointer-type)
+    (inst srln res temp vm:type-bits)))
+
+(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)
+  ;; This is an invalid translation because %instance-set needs a
+  ;; return value, and this VOP doesn't return anything.  I (RLT)
+  ;; don't know how to fix this so that this VOP returns a value and
+  ;; still works correctly when it is called directly by the compiler.
+  ;; However, disabling the translation works around the bug.
+  
+  ;;(:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) *))
+
+(define-vop (instance-index-ref word-index-ref)
+  (:policy :fast-safe) 
+  (:translate %instance-ref)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance positive-fixnum))
+
+(define-vop (instance-index-set word-index-set)
+  (:policy :fast-safe) 
+  (:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance positive-fixnum *))
+
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-header-ref word-index-ref)
+  (:translate code-header-ref)
+  (:policy :fast-safe)
+  (:variant 0 other-pointer-type))
+
+(define-vop (code-header-set word-index-set)
+  (:translate code-header-set)
+  (:policy :fast-safe)
+  (:variant 0 other-pointer-type))
+
diff --git a/src/compiler/sparcv9/char.lisp b/src/compiler/sparcv9/char.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5ab27789f9c1969cd53f8c533950233c20b002c2
--- /dev/null
+++ b/src/compiler/sparcv9/char.lisp
@@ -0,0 +1,173 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/char.lisp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the SPARC VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the MIPS R2000 by Christopher Hoover.
+;;; And then to the SPARC by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+
+;;;; 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)))
+  (:note _N"character untagging")
+  (:generator 1
+    (inst srln y x vm:type-bits)))
+;;;
+(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)))
+  (:note _N"character tagging")
+  (:generator 1
+    (inst slln y x vm:type-bits)
+    (inst or y vm:base-char-type)))
+;;;
+(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))))
+  (:note _N"character move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(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))
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:note _N"character arg move")
+  (:generator 0
+    (sc-case y
+      (base-char-reg
+       (move y x))
+      (base-char-stack
+       (storew x fp (tn-offset y) 0 temp)))))
+;;;
+(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 slln res ch fixnum-tag-bits)))
+
+(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 srln res code fixnum-tag-bits)))
+
+
+;;; 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)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note _N"inline comparison")
+  (:variant-vars condition not-condition)
+  (:generator 3
+    (inst cmp x y)
+    (inst b (if not-p not-condition condition) target)
+    (inst nop)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+  (:translate char=)
+  (:variant :eq :ne))
+
+(define-vop (fast-char</base-char base-char-compare)
+  (:translate char<)
+  (:variant :ltu :geu))
+
+(define-vop (fast-char>/base-char base-char-compare)
+  (:translate char>)
+  (:variant :gtu :leu))
+
+(define-vop (base-char-compare-c)
+  (:args (x :scs (base-char-reg)))
+  (:arg-types base-char (:constant base-char))
+  (:conditional)
+  (:info target not-p y)
+  (:policy :fast-safe)
+  (:note _N"inline comparison")
+  (:variant-vars condition not-condition)
+  (:generator 2
+    (inst cmp x (char-code y))
+    (inst b (if not-p not-condition condition) target)
+    (inst nop)))
+
+(define-vop (fast-char=-c/base-char base-char-compare-c)
+  (:translate char=)
+  (:variant :eq :ne))
+
+(define-vop (fast-char<-c/base-char base-char-compare-c)
+  (:translate char<)
+  (:variant :ltu :geu))
+
+(define-vop (fast-char>-c/base-char base-char-compare-c)
+  (:translate char>)
+  (:variant :gtu :leu))
+
diff --git a/src/compiler/sparcv9/debug.lisp b/src/compiler/sparcv9/debug.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fe18d015ed74db4358604ad8c7131506a0820d2b
--- /dev/null
+++ b/src/compiler/sparcv9/debug.lisp
@@ -0,0 +1,127 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/debug.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+(defknown di::current-sp () system-area-pointer (movable flushable))
+(defknown di::current-fp () system-area-pointer (movable flushable))
+(defknown di::stack-ref (system-area-pointer index) t (flushable))
+(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
+(defknown di::lra-code-header (t) t (movable flushable))
+(defknown di::function-code-header (t) t (movable flushable))
+(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
+(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
+(defknown di::function-word-offset (function) index (movable flushable))
+
+(define-vop (debug-cur-sp)
+  (:translate di::current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res csp-tn)))
+
+(define-vop (debug-cur-fp)
+  (:translate di::current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res cfp-tn)))
+
+(define-vop (read-control-stack)
+  (:translate kernel:stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (any-reg)))
+  (:arg-types system-area-pointer positive-fixnum)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst ldn result sap offset)))
+
+(define-vop (write-control-stack)
+  (:translate kernel:%set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (any-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:arg-types system-area-pointer positive-fixnum *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst stn value sap offset)
+    (move result value)))
+
+(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 srln temp vm:type-bits)
+      (inst cmp temp)
+      (inst b :eq bogus)
+      (inst slln temp (1- (integer-length vm:word-bytes)))
+      (unless (= lowtag vm:other-pointer-type)
+	(inst add temp (- lowtag vm:other-pointer-type)))
+      (inst sub code thing temp)
+      (emit-label done)
+      (assemble (*elsewhere*)
+	(emit-label bogus)
+	(inst b done)
+	(move code null-tn)))))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate di::lra-code-header)
+  (:variant vm:other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate di::function-code-header)
+  (:variant vm:function-pointer-type))
+
+(define-vop (make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate di::make-lisp-obj)
+  (:args (value :scs (unsigned-reg) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 1
+    (move result value)))
+
+(define-vop (get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate di::get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg) :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result thing)))
+
+
+(define-vop (function-word-offset)
+  (:policy :fast-safe)
+  (:translate di::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 srln res vm:type-bits)))
diff --git a/src/compiler/sparcv9/float.lisp b/src/compiler/sparcv9/float.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..dcdbda7d5fd5b68d0a444eb0c804e652649713e9
--- /dev/null
+++ b/src/compiler/sparcv9/float.lisp
@@ -0,0 +1,3188 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/float.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains floating point support for the MIPS.
+;;;
+;;; Written by Rob MacLachlan
+;;; Sparc conversion by William Lott.
+;;; Complex-float and long-float support by Douglas Crosher 1998.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;;; Move functions:
+
+(define-move-function (load-single 1) (vop x y)
+  ((single-stack) (single-reg))
+  (inst ldf y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)))
+
+(define-move-function (store-single 1) (vop x y)
+  ((single-reg) (single-stack))
+  (inst stf x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)))
+
+
+(define-move-function (load-double 2) (vop x y)
+  ((double-stack) (double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (inst lddf y nfp offset)))
+
+(define-move-function (store-double 2) (vop x y)
+  ((double-reg) (double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (inst stdf x nfp offset)))
+
+;;; The offset may be an integer or a TN in which case it will be
+;;; temporarily modified but is restored if restore-offset is true.
+;;;
+(defun load-long-reg (reg base offset &optional (restore-offset t))
+  (if (backend-featurep :sparc-v9)
+      (inst ldqf reg base offset)
+      (let ((reg0 (make-random-tn :kind :normal
+				  :sc (sc-or-lose 'double-reg *backend*)
+				  :offset (tn-offset reg)))
+	    (reg2 (make-random-tn :kind :normal
+				  :sc (sc-or-lose 'double-reg *backend*)
+				  :offset (+ 2 (tn-offset reg)))))
+	(cond ((integerp offset)
+	       (inst lddf reg0 base offset)
+	       (inst lddf reg2 base (+ offset (* 2 vm:word-bytes))))
+	      (t
+	       (inst lddf reg0 base offset)
+	       (inst add offset (* 2 vm:word-bytes))
+	       (inst lddf reg2 base offset)
+	       (when restore-offset
+		 (inst sub offset (* 2 vm:word-bytes))))))))
+
+#+long-float
+(define-move-function (load-long 2) (vop x y)
+  ((long-stack) (long-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (load-long-reg y nfp offset)))
+
+;;; The offset may be an integer or a TN in which case it will be
+;;; temporarily modified but is restored if restore-offset is true.
+;;;
+(defun store-long-reg (reg base offset &optional (restore-offset t))
+  (if (backend-featurep :sparc-v9)
+      (inst stqf reg base offset)
+      (let ((reg0 (make-random-tn :kind :normal
+				  :sc (sc-or-lose 'double-reg *backend*)
+				  :offset (tn-offset reg)))
+	    (reg2 (make-random-tn :kind :normal
+				  :sc (sc-or-lose 'double-reg *backend*)
+				  :offset (+ 2 (tn-offset reg)))))
+	(cond ((integerp offset)
+	       (inst stdf reg0 base offset)
+	       (inst stdf reg2 base (+ offset (* 2 vm:word-bytes))))
+	      (t
+	       (inst stdf reg0 base offset)
+	       (inst add offset (* 2 vm:word-bytes))
+	       (inst stdf reg2 base offset)
+	       (when restore-offset
+		 (inst sub offset (* 2 vm:word-bytes))))))))
+
+#+long-float
+(define-move-function (store-long 2) (vop x y)
+  ((long-reg) (long-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (store-long-reg x nfp offset)))
+
+
+;;;; Move VOPs:
+
+;;; Exploit the V9 double-float move instruction. This is conditional
+;;; on the :sparc-v9 feature.
+(defun move-double-reg (dst src)
+  (cond ((backend-featurep :sparc-v9)
+	 (unless (location= dst src)
+	   (inst fmovd dst src)))
+	(t
+	 (dotimes (i 2)
+	   (let ((dst (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg *backend*)
+				      :offset (+ i (tn-offset dst))))
+		 (src (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg *backend*)
+				      :offset (+ i (tn-offset src)))))
+	     (inst fmovs dst src))))))
+
+;;; Exploit the V9 long-float move instruction. This is conditional
+;;; on the :sparc-v9 feature.
+(defun move-long-reg (dst src)
+  (cond ((backend-featurep :sparc-v9)
+	 (inst fmovq dst src))
+	(t
+	 (dotimes (i 4)
+	   (let ((dst (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg *backend*)
+				      :offset (+ i (tn-offset dst))))
+		 (src (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg *backend*)
+				      :offset (+ i (tn-offset src)))))
+	     (inst fmovs dst src))))))
+
+(macrolet ((frob (vop sc format)
+	     `(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 _N"float move")
+		  (:generator 0
+		    (unless (location= y x)
+		      ,@(ecase format
+			  (:single `((inst fmovs y x)))
+			  (:double `((move-double-reg y x)))
+			  (:long `((move-long-reg y x)))))))
+		(define-move-vop ,vop :move (,sc) (,sc)))))
+  (frob single-move single-reg :single)
+  (frob double-move double-reg :double)
+  #+long-float
+  (frob long-move long-reg :long))
+
+
+(define-vop (move-from-float)
+  (:args (x :to :save))
+  (:results (y))
+  (:note _N"float to pointer coercion")
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:variant-vars format size type data)
+  (:generator 13
+    (with-fixed-allocation (y ndescr type size))
+    (ecase format
+      (:single
+       (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type)))
+      (:double
+       (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type)))
+      (:long
+       (store-long-reg x y (- (* data vm:word-bytes)
+			      vm:other-pointer-type))))))
+
+(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 :single
+    vm:single-float-size vm:single-float-type vm:single-float-value-slot)
+  (frob move-from-double double-reg :double
+    vm:double-float-size vm:double-float-type vm:double-float-value-slot)
+  #+long-float
+  (frob move-from-long long-reg	:long
+     vm:long-float-size vm:long-float-type vm:long-float-value-slot))
+
+(macrolet ((frob (name sc format value)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:note _N"pointer to float coercion")
+		  (:generator 2
+		    (inst ,(ecase format
+			     (:single 'ldf)
+			     (:double 'lddf))
+			  y x
+			  (- (* ,value vm:word-bytes) vm:other-pointer-type))))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+  (frob move-to-single single-reg :single vm:single-float-value-slot)
+  (frob move-to-double double-reg :double vm:double-float-value-slot))
+
+#+long-float
+(define-vop (move-to-long)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (long-reg)))
+  (:note _N"pointer to float coercion")
+  (:generator 2
+    (load-long-reg y x (- (* vm:long-float-value-slot vm:word-bytes)
+			  vm:other-pointer-type))))
+#+long-float
+(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
+
+(macrolet ((frob (name sc stack-sc format)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (nfp :scs (any-reg)
+			      :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note _N"float argument move")
+		  (:generator ,(ecase format (:single 1) (:double 2))
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+			 ,@(ecase format
+			     (:single '((inst fmovs y x)))
+			     (:double '((move-double-reg y x))))))
+		      (,stack-sc
+		       (let ((offset (* (tn-offset y) vm:word-bytes)))
+			 (inst ,(ecase format
+				  (:single 'stf)
+				  (:double 'stdf))
+			       x nfp offset))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-single-float-argument single-reg single-stack :single)
+  (frob move-double-float-argument double-reg double-stack :double))
+
+#+long-float
+(define-vop (move-long-float-argument)
+  (:args (x :scs (long-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
+  (:results (y))
+  (:note _N"float argument move")
+  (:generator 3
+    (sc-case y
+      (long-reg
+       (unless (location= x y)
+	 (move-long-reg y x)))
+      (long-stack
+       (let ((offset (* (tn-offset y) vm:word-bytes)))
+	 (store-long-reg x nfp offset))))))
+;;;
+#+long-float
+(define-move-vop move-long-float-argument :move-argument
+  (long-reg descriptor-reg) (long-reg))
+
+
+;;;; Complex float move functions
+
+(defun complex-single-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-single-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+(defun complex-double-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ (tn-offset x) 2)))
+
+#+long-float
+(defun complex-long-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
+		  :offset (tn-offset x)))
+#+long-float
+(defun complex-long-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
+		  :offset (+ (tn-offset x) 4)))
+
+#+double-double
+(progn
+(defun complex-double-double-reg-real-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-double-reg-real-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+(defun complex-double-double-reg-imag-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 4 (tn-offset x))))
+(defun complex-double-double-reg-imag-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 6 (tn-offset x))))
+)
+
+(define-move-function (load-complex-single 2) (vop x y)
+  ((complex-single-stack) (complex-single-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((real-tn (complex-single-reg-real-tn y)))
+      (inst ldf real-tn nfp offset))
+    (let ((imag-tn (complex-single-reg-imag-tn y)))
+      (inst ldf imag-tn nfp (+ offset vm:word-bytes)))))
+
+(define-move-function (store-complex-single 2) (vop x y)
+  ((complex-single-reg) (complex-single-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((real-tn (complex-single-reg-real-tn x)))
+      (inst stf real-tn nfp offset))
+    (let ((imag-tn (complex-single-reg-imag-tn x)))
+      (inst stf imag-tn nfp (+ offset vm:word-bytes)))))
+
+
+(define-move-function (load-complex-double 4) (vop x y)
+  ((complex-double-stack) (complex-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((real-tn (complex-double-reg-real-tn y)))
+      (inst lddf real-tn nfp offset))
+    (let ((imag-tn (complex-double-reg-imag-tn y)))
+      (inst lddf imag-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+(define-move-function (store-complex-double 4) (vop x y)
+  ((complex-double-reg) (complex-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((real-tn (complex-double-reg-real-tn x)))
+      (inst stdf real-tn nfp offset))
+    (let ((imag-tn (complex-double-reg-imag-tn x)))
+      (inst stdf imag-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+
+#+long-float
+(define-move-function (load-complex-long 5) (vop x y)
+  ((complex-long-stack) (complex-long-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((real-tn (complex-long-reg-real-tn y)))
+      (load-long-reg real-tn nfp offset))
+    (let ((imag-tn (complex-long-reg-imag-tn y)))
+      (load-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes))))))
+
+#+long-float
+(define-move-function (store-complex-long 5) (vop x y)
+  ((complex-long-reg) (complex-long-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((real-tn (complex-long-reg-real-tn x)))
+      (store-long-reg real-tn nfp offset))
+    (let ((imag-tn (complex-long-reg-imag-tn x)))
+      (store-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes))))))
+
+#+double-double
+(progn
+(define-move-function (load-complex-double-double 4) (vop x y)
+  ((complex-double-double-stack) (complex-double-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((value-tn (complex-double-double-reg-real-hi-tn y)))
+      (inst lddf value-tn nfp offset))
+    (let ((value-tn (complex-double-double-reg-real-lo-tn y)))
+      (inst lddf value-tn nfp (+ offset (* 2 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-hi-tn y)))
+      (inst lddf value-tn nfp (+ offset (* 4 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-lo-tn y)))
+      (inst lddf value-tn nfp (+ offset (* 6 vm:word-bytes))))))
+
+(define-move-function (store-complex-double-double 4) (vop x y)
+  ((complex-double-double-reg) (complex-double-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((value-tn (complex-double-double-reg-real-hi-tn x)))
+      (inst stdf value-tn nfp offset))
+    (let ((value-tn (complex-double-double-reg-real-lo-tn x)))
+      (inst stdf value-tn nfp (+ offset (* 2 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-hi-tn x)))
+      (inst stdf value-tn nfp (+ offset (* 4 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-lo-tn x)))
+      (inst stdf value-tn nfp (+ offset (* 6 vm:word-bytes))))))
+
+)
+
+;;;
+;;; Complex float register to register moves.
+;;;
+(define-vop (complex-single-move)
+  (:args (x :scs (complex-single-reg) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
+  (:note _N"complex single float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-single-reg-real-tn x))
+	     (y-real (complex-single-reg-real-tn y)))
+	 (inst fmovs y-real x-real))
+       (let ((x-imag (complex-single-reg-imag-tn x))
+	     (y-imag (complex-single-reg-imag-tn y)))
+	 (inst fmovs y-imag x-imag)))))
+;;;
+(define-move-vop complex-single-move :move
+  (complex-single-reg) (complex-single-reg))
+
+(define-vop (complex-double-move)
+  (:args (x :scs (complex-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
+  (:note _N"complex double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-double-reg-real-tn x))
+	     (y-real (complex-double-reg-real-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-imag (complex-double-reg-imag-tn x))
+	     (y-imag (complex-double-reg-imag-tn y)))
+	 (move-double-reg y-imag x-imag)))))
+;;;
+(define-move-vop complex-double-move :move
+  (complex-double-reg) (complex-double-reg))
+
+#+long-float
+(define-vop (complex-long-move)
+  (:args (x :scs (complex-long-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))
+  (:note _N"complex long float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-long-reg-real-tn x))
+	     (y-real (complex-long-reg-real-tn y)))
+	 (move-long-reg y-real x-real))
+       (let ((x-imag (complex-long-reg-imag-tn x))
+	     (y-imag (complex-long-reg-imag-tn y)))
+	 (move-long-reg y-imag x-imag)))))
+;;;
+#+long-float
+(define-move-vop complex-long-move :move
+  (complex-long-reg) (complex-long-reg))
+
+#+double-double
+(define-vop (complex-double-double-move)
+  (:args (x :scs (complex-double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y))))
+  (:note _N"complex double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	     (y-real (complex-double-double-reg-real-hi-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	     (y-real (complex-double-double-reg-real-lo-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-real (complex-double-double-reg-imag-hi-tn x))
+	     (y-real (complex-double-double-reg-imag-hi-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	     (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	 (move-double-reg y-imag x-imag)))))
+;;;
+#+double-double
+(define-move-vop complex-double-double-move :move
+  (complex-double-double-reg) (complex-double-double-reg))
+
+;;;
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+;;;
+(define-vop (move-from-complex-single)
+  (:args (x :scs (complex-single-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note _N"complex single float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm:complex-single-float-type
+			       vm:complex-single-float-size))
+     (let ((real-tn (complex-single-reg-real-tn x)))
+       (inst stf real-tn y (- (* vm:complex-single-float-real-slot
+				 vm:word-bytes)
+			      vm:other-pointer-type)))
+     (let ((imag-tn (complex-single-reg-imag-tn x)))
+       (inst stf imag-tn y (- (* vm:complex-single-float-imag-slot
+				 vm:word-bytes)
+			      vm:other-pointer-type)))))
+;;;
+(define-move-vop move-from-complex-single :move
+  (complex-single-reg) (descriptor-reg))
+
+(define-vop (move-from-complex-double)
+  (:args (x :scs (complex-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note _N"complex double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm:complex-double-float-type
+			       vm:complex-double-float-size))
+     (let ((real-tn (complex-double-reg-real-tn x)))
+       (inst stdf real-tn y (- (* vm:complex-double-float-real-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-reg-imag-tn x)))
+       (inst stdf imag-tn y (- (* vm:complex-double-float-imag-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+(define-move-vop move-from-complex-double :move
+  (complex-double-reg) (descriptor-reg))
+
+#+long-float
+(define-vop (move-from-complex-long)
+  (:args (x :scs (complex-long-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note _N"complex long float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm:complex-long-float-type
+			       vm:complex-long-float-size))
+     (let ((real-tn (complex-long-reg-real-tn x)))
+       (store-long-reg real-tn y (- (* vm:complex-long-float-real-slot
+				       vm:word-bytes)
+				    vm:other-pointer-type)))
+     (let ((imag-tn (complex-long-reg-imag-tn x)))
+       (store-long-reg imag-tn y (- (* vm:complex-long-float-imag-slot
+				       vm:word-bytes)
+				    vm:other-pointer-type)))))
+;;;
+#+long-float
+(define-move-vop move-from-complex-long :move
+  (complex-long-reg) (descriptor-reg))
+
+#+double-double
+(define-vop (move-from-complex-double-double)
+  (:args (x :scs (complex-double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note _N"complex double-double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm::complex-double-double-float-type
+			       vm::complex-double-double-float-size))
+     (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+       (inst stdf real-tn y (- (* vm::complex-double-double-float-real-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+       (inst stdf real-tn y (- (* vm::complex-double-double-float-real-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+       (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+       (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+#+double-double
+(define-move-vop move-from-complex-double-double :move
+  (complex-double-double-reg) (descriptor-reg))
+
+;;;
+;;; Move from a descriptor to a complex float register
+;;;
+(define-vop (move-to-complex-single)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-single-reg)))
+  (:note _N"pointer to complex float coercion")
+  (:generator 2
+    (let ((real-tn (complex-single-reg-real-tn y)))
+      (inst ldf real-tn x (- (* complex-single-float-real-slot word-bytes)
+			     other-pointer-type)))
+    (let ((imag-tn (complex-single-reg-imag-tn y)))
+      (inst ldf imag-tn x (- (* complex-single-float-imag-slot word-bytes)
+			     other-pointer-type)))))
+(define-move-vop move-to-complex-single :move
+  (descriptor-reg) (complex-single-reg))
+
+(define-vop (move-to-complex-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-double-reg)))
+  (:note _N"pointer to complex float coercion")
+  (:generator 2
+    (let ((real-tn (complex-double-reg-real-tn y)))
+      (inst lddf real-tn x (- (* complex-double-float-real-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-reg-imag-tn y)))
+      (inst lddf imag-tn x (- (* complex-double-float-imag-slot word-bytes)
+			      other-pointer-type)))))
+(define-move-vop move-to-complex-double :move
+  (descriptor-reg) (complex-double-reg))
+
+#+long-float
+(define-vop (move-to-complex-long)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-long-reg)))
+  (:note _N"pointer to complex float coercion")
+  (:generator 2
+    (let ((real-tn (complex-long-reg-real-tn y)))
+      (load-long-reg real-tn x (- (* complex-long-float-real-slot word-bytes)
+				  other-pointer-type)))
+    (let ((imag-tn (complex-long-reg-imag-tn y)))
+      (load-long-reg imag-tn x (- (* complex-long-float-imag-slot word-bytes)
+				  other-pointer-type)))))
+#+long-float
+(define-move-vop move-to-complex-long :move
+  (descriptor-reg) (complex-long-reg))
+
+#+double-double
+(define-vop (move-to-complex-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-double-double-reg)))
+  (:note _N"pointer to complex double-double float coercion")
+  (:generator 2
+    (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+      (inst lddf real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes)
+			      other-pointer-type)))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+      (inst lddf real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+      (inst lddf imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+      (inst lddf imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes)
+			      other-pointer-type)))))
+#+double-double
+(define-move-vop move-to-complex-double-double :move
+  (descriptor-reg) (complex-double-double-reg))
+
+;;;
+;;; Complex float move-argument vop
+;;;
+(define-vop (move-complex-single-float-argument)
+  (:args (x :scs (complex-single-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+  (:results (y))
+  (:note _N"complex single-float argument move")
+  (:generator 1
+    (sc-case y
+      (complex-single-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-single-reg-real-tn x))
+	       (y-real (complex-single-reg-real-tn y)))
+	   (inst fmovs y-real x-real))
+	 (let ((x-imag (complex-single-reg-imag-tn x))
+	       (y-imag (complex-single-reg-imag-tn y)))
+	   (inst fmovs y-imag x-imag))))
+      (complex-single-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((real-tn (complex-single-reg-real-tn x)))
+	   (inst stf real-tn nfp offset))
+	 (let ((imag-tn (complex-single-reg-imag-tn x)))
+	   (inst stf imag-tn nfp (+ offset word-bytes))))))))
+(define-move-vop move-complex-single-float-argument :move-argument
+  (complex-single-reg descriptor-reg) (complex-single-reg))
+
+(define-vop (move-complex-double-float-argument)
+  (:args (x :scs (complex-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+  (:results (y))
+  (:note _N"complex double-float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-double-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-double-reg-real-tn x))
+	       (y-real (complex-double-reg-real-tn y)))
+	   (move-double-reg y-real x-real))
+	 (let ((x-imag (complex-double-reg-imag-tn x))
+	       (y-imag (complex-double-reg-imag-tn y)))
+	   (move-double-reg y-imag x-imag))))
+      (complex-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((real-tn (complex-double-reg-real-tn x)))
+	   (inst stdf real-tn nfp offset))
+	 (let ((imag-tn (complex-double-reg-imag-tn x)))
+	   (inst stdf imag-tn nfp (+ offset (* 2 word-bytes)))))))))
+(define-move-vop move-complex-double-float-argument :move-argument
+  (complex-double-reg descriptor-reg) (complex-double-reg))
+
+#+long-float
+(define-vop (move-complex-long-float-argument)
+  (:args (x :scs (complex-long-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
+  (:results (y))
+  (:note _N"complex long-float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-long-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-long-reg-real-tn x))
+	       (y-real (complex-long-reg-real-tn y)))
+	   (move-long-reg y-real x-real))
+	 (let ((x-imag (complex-long-reg-imag-tn x))
+	       (y-imag (complex-long-reg-imag-tn y)))
+	   (move-long-reg y-imag x-imag))))
+      (complex-long-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((real-tn (complex-long-reg-real-tn x)))
+	   (store-long-reg real-tn nfp offset))
+	 (let ((imag-tn (complex-long-reg-imag-tn x)))
+	   (store-long-reg imag-tn nfp (+ offset (* 4 word-bytes)))))))))
+
+#+long-float
+(define-move-vop move-complex-long-float-argument :move-argument
+  (complex-long-reg descriptor-reg) (complex-long-reg))
+
+#+double-double
+(define-vop (move-complex-double-double-float-argument)
+  (:args (x :scs (complex-double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
+  (:results (y))
+  (:note _N"complex double-double float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	       (y-real (complex-double-double-reg-real-hi-tn y)))
+	   (move-double-reg y-real x-real))
+	 (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	       (y-real (complex-double-double-reg-real-lo-tn y)))
+	   (move-double-reg y-real x-real))
+	 (let ((x-imag (complex-double-double-reg-imag-hi-tn x))
+	       (y-imag (complex-double-double-reg-imag-hi-tn y)))
+	   (move-long-reg y-imag x-imag))
+	 (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	       (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	   (move-long-reg y-imag x-imag))))
+      (complex-double-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	   (inst stdf real-tn nfp offset))
+	 (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+	   (inst stdf real-tn nfp (+ offset (* 2 word-bytes))))
+	 (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	   (inst stdf imag-tn nfp (+ offset (* 4 word-bytes))))
+	 (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	   (inst stdf imag-tn nfp (+ offset (* 6 word-bytes)))))))))
+
+#+double-double
+(define-move-vop move-complex-double-double-float-argument :move-argument
+  (complex-double-double-reg descriptor-reg) (complex-double-double-reg))
+
+(define-move-vop move-argument :move-argument
+  (single-reg double-reg #+long-float long-reg #+double-double double-double-reg
+   complex-single-reg complex-double-reg #+long-float complex-long-reg
+   #+double-double complex-double-double-reg)
+  (descriptor-reg))
+
+
+;;;; Arithmetic VOPs:
+
+(define-vop (float-op)
+  (:args (x) (y))
+  (:results (r))
+  (:policy :fast-safe)
+  (:note _N"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)
+  #+long-float
+  (frob long-float-op long-reg long-float))
+
+(macrolet ((frob (op sinst sname scost dinst dname dcost)
+	     `(progn
+		(define-vop (,sname single-float-op)
+		  (:translate ,op)
+		  (:generator ,scost
+		    (inst ,sinst r x y)))
+		(define-vop (,dname double-float-op)
+		  (:translate ,op)
+		  (:generator ,dcost
+		    (inst ,dinst r x y))))))
+  (frob + fadds +/single-float 2 faddd +/double-float 2)
+  (frob - fsubs -/single-float 2 fsubd -/double-float 2)
+  (frob * fmuls */single-float 4 fmuld */double-float 5)
+  (frob / fdivs //single-float 12 fdivd //double-float 19))
+
+#+long-float
+(macrolet ((frob (op linst lname lcost)
+	     `(define-vop (,lname long-float-op)
+		  (:translate ,op)
+		  (:generator ,lcost
+		    (inst ,linst r x y)))))
+  (frob + faddq +/long-float 2)
+  (frob - fsubq -/long-float 2)
+  (frob * fmulq */long-float 6)
+  (frob / fdivq //long-float 20))
+
+
+(macrolet ((frob (name inst translate sc type)
+	     `(define-vop (,name)
+		(:args (x :scs (,sc)))
+		(:results (y :scs (,sc)))
+		(:translate ,translate)
+		(:policy :fast-safe)
+		(:arg-types ,type)
+		(:result-types ,type)
+		(:note _N"inline float arithmetic")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1
+		  (note-this-location vop :internal-error)
+		  (inst ,inst y x)))))
+  (frob abs/single-float fabss abs single-reg single-float)
+  (frob %negate/single-float fnegs %negate single-reg single-float))
+
+(defun negate-double-reg (dst src)
+  (cond ((backend-featurep :sparc-v9)
+	 (inst fnegd dst src))
+	(t
+	 ;; Negate the MS part of the numbers, then copy over the rest
+	 ;; of the bits.
+	 (inst fnegs dst src)
+	 (let ((dst-odd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'single-reg *backend*)
+					:offset (+ 1 (tn-offset dst))))
+	       (src-odd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'single-reg *backend*)
+					:offset (+ 1 (tn-offset src)))))
+	   (inst fmovs dst-odd src-odd)))))
+
+(defun abs-double-reg (dst src)
+  (cond ((backend-featurep :sparc-v9)
+	 (inst fabsd dst src))
+	(t
+	 ;; Abs the MS part of the numbers, then copy over the rest
+	 ;; of the bits.
+	 (inst fabss dst src)
+	 (let ((dst-2 (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg *backend*)
+				      :offset (+ 1 (tn-offset dst))))
+	       (src-2 (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg *backend*)
+				      :offset (+ 1 (tn-offset src)))))
+	   (inst fmovs dst-2 src-2)))))
+
+(define-vop (abs/double-float)
+  (:args (x :scs (double-reg)))
+  (:results (y :scs (double-reg)))
+  (:translate abs)
+  (:policy :fast-safe)
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:note _N"inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (abs-double-reg y x)))
+
+(define-vop (%negate/double-float)
+  (:args (x :scs (double-reg)))
+  (:results (y :scs (double-reg)))
+  (:translate %negate)
+  (:policy :fast-safe)
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:note _N"inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (negate-double-reg y x)))
+
+#+long-float
+(define-vop (abs/long-float)
+  (:args (x :scs (long-reg)))
+  (:results (y :scs (long-reg)))
+  (:translate abs)
+  (:policy :fast-safe)
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:note _N"inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (cond ((backend-featurep :sparc-v9)
+	   (inst fabsq y x))
+	  (t
+	   (inst fabss y x)
+	   (dotimes (i 3)
+	     (let ((y-odd (make-random-tn
+			   :kind :normal
+			   :sc (sc-or-lose 'single-reg *backend*)
+			   :offset (+ i 1 (tn-offset y))))
+		   (x-odd (make-random-tn
+			   :kind :normal
+			   :sc (sc-or-lose 'single-reg *backend*)
+			   :offset (+ i 1 (tn-offset x)))))
+	       (inst fmovs y-odd x-odd)))))))
+
+#+long-float
+(define-vop (%negate/long-float)
+  (:args (x :scs (long-reg)))
+  (:results (y :scs (long-reg)))
+  (:translate %negate)
+  (:policy :fast-safe)
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:note _N"inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (cond ((backend-featurep :sparc-v9)
+	   (inst fnegq y x))
+	  (t
+	   (inst fnegs y x)
+	   (dotimes (i 3)
+	     (let ((y-odd (make-random-tn
+			   :kind :normal
+			   :sc (sc-or-lose 'single-reg *backend*)
+			   :offset (+ i 1 (tn-offset y))))
+		   (x-odd (make-random-tn
+			   :kind :normal
+			   :sc (sc-or-lose 'single-reg *backend*)
+			   :offset (+ i 1 (tn-offset x)))))
+	       (inst fmovs y-odd x-odd)))))))
+
+
+;;;; Comparison:
+
+(define-vop (float-compare)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:variant-vars format yep nope)
+  (:policy :fast-safe)
+  (:note _N"inline float comparison")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (note-this-location vop :internal-error)
+    (ecase format
+      (:single (inst fcmps x y))
+      (:double (inst fcmpd x y))
+      (:long (inst fcmpq x y)))
+    ;; The SPARC V9 doesn't need an instruction between a
+    ;; floating-point compare and a floating-point branch.
+    (unless (backend-featurep :sparc-v9)
+      (inst nop))
+    (inst fb (if not-p nope yep) target)
+    (inst nop)))
+
+(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)
+  #+long-float
+  (frob long-float-compare long-reg long-float))
+
+(macrolet ((frob (translate yep nope sname dname #+long-float lname)
+	     `(progn
+		(define-vop (,sname single-float-compare)
+		  (:translate ,translate)
+		  (:variant :single ,yep ,nope))
+		(define-vop (,dname double-float-compare)
+		  (:translate ,translate)
+		  (:variant :double ,yep ,nope))
+	        #+long-float
+		(define-vop (,lname long-float-compare)
+		  (:translate ,translate)
+		  (:variant :long ,yep ,nope)))))
+  (frob < :l :ge </single-float </double-float #+long-float </long-float)
+  (frob > :g :le >/single-float >/double-float #+long-float >/long-float)
+  (frob = :eq :ne eql/single-float eql/double-float #+long-float eql/long-float))
+
+#+long-float
+(deftransform eql ((x y) (long-float long-float))
+  '(and (= (long-float-low-bits x) (long-float-low-bits y))
+	(= (long-float-mid-bits x) (long-float-mid-bits y))
+	(= (long-float-high-bits x) (long-float-high-bits y))
+	(= (long-float-exp-bits x) (long-float-exp-bits y))))
+
+#+double-double
+(deftransform eql ((x y) (double-double-float double-double-float))
+  '(and (eql (double-double-hi x) (double-double-hi y))
+	(eql (double-double-lo x) (double-double-lo y))))
+
+
+;;;; Conversion:
+
+;; Tell the compiler about %%single-float and %%double-float.  Add
+;; functions for byte-compiled code.
+(macrolet
+    ((frob (name type)
+       `(progn
+	  (defknown ,name ((signed-byte 32))
+	    ,type)
+	  (defun ,name (n)
+	    (declare (type (signed-byte 32) n))
+	    (,name n)))))
+  (frob %%single-float single-float)
+  (frob %%double-float double-float))
+
+;; Sparc doesn't have an instruction to convert a 32-bit unsigned
+;; integer to a float, but does have one for a 32-bit signed integer.
+;; What we do here is break up the 32-bit number into 2 smaller
+;; pieces.  Each of these are converted to a float, and the higher
+;; order piece is scaled appropriately, and finally everything is
+;; summed together.  The pieces are done in a way such that no
+;; roundoff occurs.  The scaling should not produce any roundoff
+;; either, since the scale factor is an exact power of two.  The final
+;; sum will produce the correct rounded result.  (I think,)
+;;
+;; But need to be careful because we still want to call the VOP for
+;; the small pieces, so we need the transform to give up if it's known
+;; that the argument is smaller than a 32-bit unsigned integer.
+(macrolet ((frob (name vop-trans limit unit)
+	     `(progn
+		(deftransform ,name ((n) ((unsigned-byte 32)))
+		  ;; Should this be extended to a (unsigned-byte 53)?  We could.  Just
+		  ;; take the low 31 bits, and the rest, and float them and combine
+		  ;; them as before.
+		  (when (csubtypep (c::continuation-type n)
+				   (c::specifier-type '(unsigned-byte 31)))
+		    ;; We want to give-up if we know the number can't have the
+		    ;; MSB set.  The signed 32-bit vop can handle that.
+		    (c::give-up))
+		  `(+ (,',vop-trans (ldb (byte ,',limit 0) n))
+		      (* (,',vop-trans (ldb (byte ,',(- 32 limit) ,',limit) n))
+			 (scale-float ,',unit ,',limit))))
+		;; Always convert %foo to %%foo for 32-bit signed values.
+		(deftransform ,name ((n) ((signed-byte 32)))
+		  `(,',vop-trans n)))))
+  ;; If we break up the numbers into the low 12 bits and the high 20
+  ;; bits, we can use a single AND instruction to get the low 12 bits.
+  ;; This is a microoptimization for Sparc.  Otherwise, the only
+  ;; constraint is that the pieces must be small enough to fit in the
+  ;; desired float format without rounding.
+  (frob %single-float %%single-float 12 1f0)
+  (frob %double-float %%double-float 12 1d0))
+
+
+(macrolet ((frob (name translate inst to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (signed-reg) :target stack-temp
+			  :load-if (not (sc-is x signed-stack))))
+		(:temporary (:scs (single-stack) :from :argument) stack-temp)
+		(:temporary (:scs (single-reg) :to :result :target y) temp)
+		(:results (y :scs (,to-sc)))
+		(:arg-types signed-num)
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note _N"inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 5
+		  (let ((stack-tn
+			 (sc-case x
+			   (signed-reg
+			    (inst st x
+				  (current-nfp-tn vop)
+				  (* (tn-offset temp) vm:word-bytes))
+			    stack-temp)
+			   (signed-stack
+			    x))))
+		    (inst ldf temp
+			  (current-nfp-tn vop)
+			  (* (tn-offset stack-tn) vm:word-bytes))
+		    (note-this-location vop :internal-error)
+		    (inst ,inst y temp))))))
+  (frob %single-float/signed %%single-float fitos single-reg single-float)
+  (frob %double-float/signed %%double-float fitod double-reg double-float)
+  #+long-float
+  (frob %long-float/signed %long-float fitoq long-reg long-float))
+
+;; Sparc doesn't have an instruction to convert a 32-bit unsigned
+;; integer to a float, but does have one for a 32-bit signed integer.
+;; What we do here is break up the 32-bit number into 2 smaller
+;; pieces.  Each of these are converted to a float, and the higher
+;; order piece is scaled appropriately, and finally everything is
+;; summed together.  The pieces are done in a way such that no
+;; roundoff occurs.  The scaling should not produce any roundoff
+;; either, since the scale factor is an exact power of two.  The final
+;; sum will produce the correct rounded result.  (I think,)
+;;
+;; But need to be careful because we still want to call the VOP for
+;; the small pieces, so we need the transform to give up if it's known
+;; that the argument is smaller than a 32-bit unsigned integer.
+(macrolet ((frob (name limit unit)
+	     `(deftransform ,name ((n) ((unsigned-byte 32)))
+		;; Should this be extended to a (unsigned-byte 53)?  We could.  Just
+		;; take the low 31 bits, and the rest, and float them and combine
+		;; them as before.
+		(when (csubtypep (c::continuation-type n)
+				 (c::specifier-type '(unsigned-byte 31)))
+		  ;; We want to give-up if we know the number can't have the
+		  ;; MSB set.  The signed 32-bit vop can handle that.
+		  (c::give-up))
+		`(+ (,',name (ldb (byte ,',limit 0) n))
+		    (* (,',name (ldb (byte ,',(- 32 limit) ,',limit) n))
+		       (scale-float ,',unit ,',limit))))))
+  ;; If we break up the numbers into the low 12 bits and the high 20
+  ;; bits, we can use a single AND instruction to get the low 12 bits.
+  ;; This is a microoptimization for Sparc.  Otherwise, the only
+  ;; constraint is that the pieces must be small enough to fit in the
+  ;; desired float format without rounding.
+  (frob %single-float 12 1f0)
+  (frob %double-float 12 1f0))
+
+(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 _N"inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 2
+		  (note-this-location vop :internal-error)
+		  (inst ,inst y x)))))
+  (frob %single-float/double-float %single-float fdtos
+    double-reg double-float single-reg single-float)
+  #+long-float
+  (frob %single-float/long-float %single-float fqtos
+    long-reg long-float single-reg single-float)
+  (frob %double-float/single-float %double-float fstod
+    single-reg single-float double-reg double-float)
+  #+long-float
+  (frob %double-float/long-float %double-float fqtod
+    long-reg long-float double-reg double-float)
+  #+long-float
+  (frob %long-float/single-float %long-float fstoq
+    single-reg single-float long-reg long-float)
+  #+long-float
+  (frob %long-float/double-float %long-float fdtoq
+    double-reg double-float long-reg long-float))
+
+(macrolet ((frob (trans from-sc from-type inst)
+	     `(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 _N"inline float truncate")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (inst ,inst temp x)
+		  (sc-case y
+		    (signed-stack
+		     (inst stf temp (current-nfp-tn vop)
+			   (* (tn-offset y) vm:word-bytes)))
+		    (signed-reg
+		     (inst stf temp (current-nfp-tn vop)
+			   (* (tn-offset stack-temp) vm:word-bytes))
+		     (inst ldsw y (current-nfp-tn vop)
+			   (* (tn-offset stack-temp) vm:word-bytes))))))))
+  (frob %unary-truncate single-reg single-float fstoi)
+  (frob %unary-truncate double-reg double-float fdtoi)
+  #+long-float
+  (frob %unary-truncate long-reg long-float fqtoi)
+  #-sun4
+  (frob %unary-round single-reg single-float fstoir)
+  #-sun4
+  (frob %unary-round double-reg double-float fdtoir))
+
+(define-vop (fast-unary-ftruncate/single-float)
+  (:args (x :scs (single-reg)))
+  (:arg-types single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:policy :fast-safe)
+  (:translate c::fast-unary-ftruncate)
+  (:guard (not (backend-featurep :sparc-v9)))
+  (:note _N"inline ftruncate")
+  (:generator 2
+    (inst fstoi r x)
+    (inst fitos r r)))
+
+(define-vop (fast-unary-ftruncate/double-float)
+  (:args (x :scs (double-reg) :target r))
+  (:arg-types double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:translate c::fast-unary-ftruncate)
+  (:guard (not (backend-featurep :sparc-v9)))
+  (:note _N"inline ftruncate")
+  (:generator 2
+    (inst fdtoi r x)
+    (inst fitod r r)))
+
+;; The V9 architecture can convert 64-bit integers.
+(define-vop (v9-fast-unary-ftruncate/single-float)
+  (:args (x :scs (single-reg)))
+  (:arg-types single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:temporary (:scs (double-reg)) temp)
+  (:policy :fast-safe)
+  (:translate c::fast-unary-ftruncate)
+  (:guard (backend-featurep :sparc-v9))
+  (:note _N"inline ftruncate")
+  (:generator 2
+    (inst fstox temp x)
+    (inst fxtos r temp)))
+
+(define-vop (v9-fast-unary-ftruncate/double-float)
+  (:args (x :scs (double-reg) :target r))
+  (:arg-types double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:translate c::fast-unary-ftruncate)
+  (:guard (backend-featurep :sparc-v9))
+  (:note _N"inline ftruncate")
+  (:generator 2
+    (inst fdtox r x)
+    (inst fxtod r r)))
+
+;; See Listing 2.2: Conversion from FP to int in in "CR-LIBM: A
+;; library of correctly rounded elementary functions in
+;; double-precision".
+#+sun4
+(deftransform %unary-round ((x) (float) (signed-byte 32))
+   '(kernel:double-float-low-bits (+ x (+ (scale-float 1d0 52)
+					  (scale-float 1d0 51)))))
+
+(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 st bits (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes))
+	  (inst ldf res (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes)))
+	 (single-stack
+	  (inst st bits (current-nfp-tn vop)
+		(* (tn-offset res) vm:word-bytes)))))
+      (signed-stack
+       (sc-case res
+	 (single-reg
+	  (inst ldf res (current-nfp-tn vop)
+		(* (tn-offset bits) vm:word-bytes)))
+	 (single-stack
+	  (unless (location= bits res)
+	    (inst ldsw temp (current-nfp-tn vop)
+		  (* (tn-offset bits) vm:word-bytes))
+	    (inst st temp (current-nfp-tn vop)
+		  (* (tn-offset res) vm:word-bytes)))))))))
+
+(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 st hi-bits (current-nfp-tn vop)
+	    (* (tn-offset stack-tn) vm:word-bytes))
+      (inst st lo-bits (current-nfp-tn vop)
+	    (* (1+ (tn-offset stack-tn)) vm:word-bytes)))
+    (when (sc-is res double-reg)
+      (inst lddf res (current-nfp-tn vop)
+	    (* (tn-offset temp) vm:word-bytes)))))
+
+#+long-float
+(define-vop (make-long-float)
+    (:args (hi-bits :scs (signed-reg))
+	   (lo1-bits :scs (unsigned-reg))
+	   (lo2-bits :scs (unsigned-reg))
+	   (lo3-bits :scs (unsigned-reg)))
+  (:results (res :scs (long-reg)
+		 :load-if (not (sc-is res long-stack))))
+  (:temporary (:scs (long-stack)) temp)
+  (:arg-types signed-num unsigned-num unsigned-num unsigned-num)
+  (:result-types long-float)
+  (:translate make-long-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (let ((stack-tn (sc-case res
+		      (long-stack res)
+		      (long-reg temp))))
+      (inst st hi-bits (current-nfp-tn vop)
+	    (* (tn-offset stack-tn) vm:word-bytes))
+      (inst st lo1-bits (current-nfp-tn vop)
+	    (* (1+ (tn-offset stack-tn)) vm:word-bytes))
+      (inst st lo2-bits (current-nfp-tn vop)
+	    (* (+ 2 (tn-offset stack-tn)) vm:word-bytes))
+      (inst st lo3-bits (current-nfp-tn vop)
+	    (* (+ 3 (tn-offset stack-tn)) vm:word-bytes)))
+    (when (sc-is res long-reg)
+      (load-long-reg res (current-nfp-tn vop)
+		     (* (tn-offset temp) vm:word-bytes)))))
+
+(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 stf float (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes))
+	  (inst ldsw bits (current-nfp-tn vop)
+		(* (tn-offset stack-temp) vm:word-bytes)))
+	 (single-stack
+	  (inst ldsw bits (current-nfp-tn vop)
+		(* (tn-offset float) vm:word-bytes)))
+	 (descriptor-reg
+	  (loadw bits float vm:single-float-value-slot
+		 vm:other-pointer-type))))
+      (signed-stack
+       (sc-case float
+	 (single-reg
+	  (inst stf float (current-nfp-tn vop)
+		(* (tn-offset bits) vm:word-bytes))))))))
+
+(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)))
+  (: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 stdf float (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes))
+       (inst ldsw hi-bits (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes)))
+      (double-stack
+       (inst ldsw hi-bits (current-nfp-tn vop)
+	     (* (tn-offset float) vm:word-bytes)))
+      (descriptor-reg
+       (loadw hi-bits float 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)))
+  (: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 stdf float (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes))
+       (inst ldsw lo-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
+      (double-stack
+       (inst ldsw lo-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset float)) vm:word-bytes)))
+      (descriptor-reg
+       (loadw lo-bits float (1+ vm:double-float-value-slot)
+	      vm:other-pointer-type)))))
+
+(define-vop (double-float-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (hi-bits :scs (signed-reg))
+	    (lo-bits :scs (unsigned-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types double-float)
+  (:result-types signed-num unsigned-num)
+  (:translate kernel::double-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (double-reg
+       (inst stdf float (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes))
+       (inst ldsw hi-bits (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes))
+       (inst ld lo-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
+      (double-stack
+       (inst ldsw hi-bits (current-nfp-tn vop)
+	     (* (tn-offset float) vm:word-bytes))
+       (inst ld lo-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset float)) vm:word-bytes)))
+      (descriptor-reg
+       (loadw hi-bits float vm:double-float-value-slot
+	      vm:other-pointer-type)
+       (loadw lo-bits float (1+ vm:double-float-value-slot)
+	      vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-exp-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (exp-bits :scs (signed-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types long-float)
+  (:result-types signed-num)
+  (:translate long-float-exp-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (long-reg
+       (let ((float (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'double-reg *backend*)
+				    :offset (tn-offset float))))
+	 (inst stdf float (current-nfp-tn vop)
+	       (* (tn-offset stack-temp) vm:word-bytes)))
+       (inst ld exp-bits (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes)))
+      (long-stack
+       (inst ld exp-bits (current-nfp-tn vop)
+	     (* (tn-offset float) vm:word-bytes)))
+      (descriptor-reg
+       (loadw exp-bits float vm:long-float-value-slot
+	      vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-high-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (high-bits :scs (unsigned-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (long-reg
+       (let ((float (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'double-reg *backend*)
+				    :offset (tn-offset float))))
+	 (inst stdf float (current-nfp-tn vop)
+	       (* (tn-offset stack-temp) vm:word-bytes)))
+       (inst ld high-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
+      (long-stack
+       (inst ld high-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset float)) vm:word-bytes)))
+      (descriptor-reg
+       (loadw high-bits float (1+ vm:long-float-value-slot)
+	      vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-mid-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (mid-bits :scs (unsigned-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-mid-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (long-reg
+       (let ((float (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'double-reg *backend*)
+				    :offset (+ 2 (tn-offset float)))))
+	 (inst stdf float (current-nfp-tn vop)
+	       (* (tn-offset stack-temp) vm:word-bytes)))
+       (inst ld mid-bits (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes)))
+      (long-stack
+       (inst ld mid-bits (current-nfp-tn vop)
+	     (* (+ 2 (tn-offset float)) vm:word-bytes)))
+      (descriptor-reg
+       (loadw mid-bits float (+ 2 vm:long-float-value-slot)
+	      vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-low-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:scs (double-stack)) stack-temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (long-reg
+       (let ((float (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'double-reg *backend*)
+				    :offset (+ 2 (tn-offset float)))))
+	 (inst stdf float (current-nfp-tn vop)
+	       (* (tn-offset stack-temp) vm:word-bytes)))
+       (inst ld lo-bits (current-nfp-tn vop)
+	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
+      (long-stack
+       (inst ld lo-bits (current-nfp-tn vop)
+	     (* (+ 3 (tn-offset float)) vm:word-bytes)))
+      (descriptor-reg
+       (loadw lo-bits float (+ 3 vm:long-float-value-slot)
+	      vm:other-pointer-type)))))
+
+
+;;;; Float mode hackery:
+
+(deftype float-modes () '(unsigned-byte 32))
+(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)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop)))
+      (inst stfsr nfp (* word-bytes (tn-offset temp)))
+      (loadw res nfp (tn-offset temp))
+      (inst nop))))
+
+#+nil
+(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 double-stack) temp)
+  (:generator 3
+    (let* ((nfp (current-nfp-tn vop))
+	   (offset (* 4 (tn-offset temp))))
+      (inst stxfsr nfp offset)
+      ;; The desired FP mode data is in the least significant 32
+      ;; bits, which is stored at the next higher word in memory.
+      (loadw res nfp (+ offset 4))
+      ;; Is this nop needed? (toy@rtp.ericsson.se)
+      (inst nop))))
+
+(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)
+  (:vop-var vop)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop)))
+      (storew new nfp (tn-offset temp))
+      (inst ldfsr nfp (* word-bytes (tn-offset temp)))
+      (move res new))))
+
+#+nil
+(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 double-stack) temp)
+  (:temporary (:sc unsigned-reg) my-fsr)
+  (:vop-var vop)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop))
+	  (offset (* word-bytes (tn-offset temp))))
+      (pseudo-atomic ()
+        ;; Get the current FSR, so we can get the new %fcc's
+        (inst stxfsr nfp offset)
+	(inst ldx my-fsr nfp offset)
+	;; Carefully merge in the new mode bits with the rest of the
+	;; FSR.  This is only needed if we care about preserving the
+	;; high 32 bits of the FSR, which contain the additional
+	;; %fcc's on the sparc V9.  If not, we don't need this, but we
+	;; do need to make sure that the unused bits are written as
+	;; zeroes, according the the V9 architecture manual.
+	(inst signx new)
+	(inst srlx my-fsr 32)
+	(inst sllx my-fsr 32)
+	(inst or my-fsr new)
+	;; Save it back and load it into the fsr register
+	(inst stx my-fsr nfp offset)
+	(inst ldxfsr nfp offset)
+	(move res new)))))
+
+#+nil
+(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 double-stack) temp)
+  (:temporary (:sc unsigned-reg) my-fsr)
+  (:vop-var vop)
+  (:generator 3
+    (let ((nfp (current-nfp-tn vop))
+	  (offset (* word-bytes (tn-offset temp))))
+      (inst stx new nfp offset)
+      (inst ldxfsr nfp offset)
+      (move res new))))
+
+
+;;;; Special functions.
+
+#-long-float
+(define-vop (fsqrt)
+  (:args (x :scs (double-reg)))
+  (:results (y :scs (double-reg)))
+  (:translate %sqrt)
+  (:policy :fast-safe)
+  (:guard (or (backend-featurep :sparc-v7)
+	      (backend-featurep :sparc-v8)
+	      (backend-featurep :sparc-v9)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:note _N"inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (inst fsqrtd y x)))
+
+#+long-float
+(define-vop (fsqrt-long)
+  (:args (x :scs (long-reg)))
+  (:results (y :scs (long-reg)))
+  (:translate %sqrt)
+  (:policy :fast-safe)
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:note _N"inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (inst fsqrtq y x)))
+
+
+;;;; Complex float VOPs
+
+(define-vop (make-complex-single-float)
+  (:translate complex)
+  (:args (real :scs (single-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (single-reg) :to :save))
+  (:arg-types single-float single-float)
+  (:results (r :scs (complex-single-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-single-stack))))
+  (:result-types complex-single-float)
+  (:note _N"inline complex single-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (complex-single-reg
+       (let ((r-real (complex-single-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (inst fmovs r-real real)))
+       (let ((r-imag (complex-single-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (inst fmovs r-imag imag))))
+      (complex-single-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (unless (location= real r)
+	   (inst stf real nfp offset))
+	 (inst stf imag nfp (+ offset vm:word-bytes)))))))
+
+(define-vop (make-complex-double-float)
+  (:translate complex)
+  (:args (real :scs (double-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (double-reg) :to :save))
+  (:arg-types double-float double-float)
+  (:results (r :scs (complex-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-stack))))
+  (:result-types complex-double-float)
+  (:note _N"inline complex double-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (complex-double-reg
+       (let ((r-real (complex-double-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (move-double-reg r-real real)))
+       (let ((r-imag (complex-double-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (move-double-reg r-imag imag))))
+      (complex-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (unless (location= real r)
+	   (inst stdf real nfp offset))
+	 (inst stdf imag nfp (+ offset (* 2 vm:word-bytes))))))))
+
+#+long-float
+(define-vop (make-complex-long-float)
+  (:translate complex)
+  (:args (real :scs (long-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (long-reg) :to :save))
+  (:arg-types long-float long-float)
+  (:results (r :scs (complex-long-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-long-stack))))
+  (:result-types complex-long-float)
+  (:note _N"inline complex long-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (complex-long-reg
+       (let ((r-real (complex-long-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (move-long-reg r-real real)))
+       (let ((r-imag (complex-long-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (move-long-reg r-imag imag))))
+      (complex-long-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (unless (location= real r)
+	   (store-long-reg real nfp offset))
+	 (store-long-reg imag nfp (+ offset (* 4 vm:word-bytes))))))))
+
+(define-vop (complex-single-float-value)
+  (:args (x :scs (complex-single-reg descriptor-reg) :target r
+	    :load-if (not (sc-is x complex-single-stack))))
+  (:arg-types complex-single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (complex-single-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-single-reg-real-tn x))
+			 (:imag (complex-single-reg-imag-tn x)))))
+	 (unless (location= value-tn r)
+	   (inst fmovs r value-tn))))
+      (complex-single-stack
+       (inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
+					      (tn-offset x))
+					   vm:word-bytes)))
+      (descriptor-reg
+       (inst ldf r x (- (* (ecase slot
+			     (:real vm::complex-single-float-real-slot)
+			     (:imag vm::complex-single-float-imag-slot))
+			   vm:word-bytes)
+			vm:other-pointer-type))))))
+
+(define-vop (realpart/complex-single-float complex-single-float-value)
+  (:translate realpart)
+  (:note _N"complex single float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-single-float complex-single-float-value)
+  (:translate imagpart)
+  (:note _N"complex single float imagpart")
+  (:variant :imag))
+
+(define-vop (complex-double-float-value)
+  (:args (x :scs (complex-double-reg descriptor-reg) :target r
+	    :load-if (not (sc-is x complex-double-stack))))
+  (:arg-types complex-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (complex-double-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-reg-real-tn x))
+			 (:imag (complex-double-reg-imag-tn x)))))
+	 (unless (location= value-tn r)
+	   (move-double-reg r value-tn))))
+      (complex-double-stack
+       (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
+					       (tn-offset x))
+					    vm:word-bytes)))
+      (descriptor-reg
+       (inst lddf r x (- (* (ecase slot
+				 (:real vm::complex-double-float-real-slot)
+				 (:imag vm::complex-double-float-imag-slot))
+			       vm:word-bytes)
+			    vm:other-pointer-type))))))
+
+(define-vop (realpart/complex-double-float complex-double-float-value)
+  (:translate realpart)
+  (:note _N"complex double float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-double-float complex-double-float-value)
+  (:translate imagpart)
+  (:note _N"complex double float imagpart")
+  (:variant :imag))
+
+#+long-float
+(define-vop (complex-long-float-value)
+  (:args (x :scs (complex-long-reg) :target r
+	    :load-if (not (sc-is x complex-long-stack))))
+  (:arg-types complex-long-float)
+  (:results (r :scs (long-reg)))
+  (:result-types long-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case x
+      (complex-long-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-long-reg-real-tn x))
+			 (:imag (complex-long-reg-imag-tn x)))))
+	 (unless (location= value-tn r)
+	   (move-long-reg r value-tn))))
+      (complex-long-stack
+       (load-long-reg r (current-nfp-tn vop)
+		      (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
+			 vm:word-bytes))))))
+
+#+long-float
+(define-vop (realpart/complex-long-float complex-long-float-value)
+  (:translate realpart)
+  (:note _N"complex long float realpart")
+  (:variant :real))
+
+#+long-float
+(define-vop (imagpart/complex-long-float complex-long-float-value)
+  (:translate imagpart)
+  (:note _N"complex long float imagpart")
+  (:variant :imag))
+
+
+
+;;;; Complex float arithmetic
+
+;;; These vops are intended to optimize some complex float arithmetic
+;;; by removing lots of redundant moves that the compiler currently
+;;; inserts.  It seems the moves are generated because of the way
+;;; unboxed complex floats are represented as pairs of registers.  The
+;;; compiler doesn't think we can use the parts directly and therefore
+;;; copies the parts to another register before operating on them.
+;;;
+;;; If we had a peephole optimizer, we could make it remove the
+;;; redundant moves instead.
+
+#+complex-fp-vops
+(progn
+
+;; Negate a complex
+(macrolet
+    ((frob (float-type fneg cost)
+       (let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type))
+	      (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	      (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	      (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	      (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,complex-reg)))
+	    (:arg-types ,c-type)
+	    (:results (r :scs (,complex-reg)))
+	    (:result-types ,c-type)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float arithmetic")
+	    (:translate %negate)
+	    (:generator ,cost
+	      (let ((xr (,real-tn x))
+		    (xi (,imag-tn x))
+		    (rr (,real-tn r))
+		    (ri (,imag-tn r)))
+		(,@fneg rr xr)
+		(,@fneg ri xi)))))))
+  (frob single (inst fnegs) 4)
+  (frob double (negate-double-reg) 4))
+
+;; Add and subtract for two complex arguments
+(macrolet
+    ((frob (op inst float-type cost)
+       (let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT"))
+	      (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	      (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	      (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	      (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	   (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
+	   (:results (r :scs (,complex-reg)))
+	   (:arg-types ,c-type ,c-type)
+	   (:result-types ,c-type)
+	   (:policy :fast-safe)
+	   (:note _N"inline complex float arithmetic")
+	   (:translate ,op)
+	   (:generator ,cost
+	    (let ((xr (,real-part x))
+		  (xi (,imag-part x))
+		  (yr (,real-part y))
+		  (yi (,imag-part y))
+		  (rr (,real-part r))
+		  (ri (,imag-part r)))
+	      (inst ,inst rr xr yr)
+	      (inst ,inst ri xi yi)))))))
+  (frob + fadds single 4)
+  (frob + faddd double 4)
+  (frob - fsubs single 4)
+  (frob - fsubd double 4))
+
+;; Add and subtract a complex and a float
+
+(macrolet
+    ((frob (size op fop cost)
+       (let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-"
+				    op
+				    "-" size "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+	     (real-reg (symbolicate size "-REG"))
+	     (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+	     (r-type (symbolicate size "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN"))
+	     (load (ecase size
+		     (single 'ldf)
+		     (double 'lddf)))
+	     (zero-sym (ecase size
+			 (single '*fp-constant-0f0*)
+			 (double '*fp-constant-0d0*)))
+	     (slot (ecase size
+		     (single vm:single-float-value-slot)
+		     (double vm:double-float-value-slot))))
+	 `(define-vop (,vop-name)
+	      (:args (x :scs (,complex-reg))
+	             (y :scs (,real-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,c-type ,r-type)
+	    (:result-types ,c-type)
+	    (:policy :fast-safe)
+	    (:temporary (:scs (,real-reg)) zero)
+	    (:temporary (:scs (descriptor-reg)) zero-val)
+	    (:note _N"inline complex float/float arithmetic")
+	    (:translate ,op)
+	    (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		;; Load up the necessary floating-point zero that we
+		;; need.  It would be nice if we could do something
+		;; like xr-xr to get a floating-point zero, but that
+		;; can cause spurious signals if xr is an infinity or
+		;; NaN.
+		(load-symbol-value zero-val ,zero-sym)
+		(inst ,load zero zero-val (- (* ,slot vm:word-bytes)
+					     vm:other-pointer-type))
+		(inst ,fop rr xr y)
+		(inst ,fop ri xi zero)))))))
+  
+  (frob single + fadds 2)
+  (frob single - fsubs 2)
+  (frob double + faddd 4)
+  (frob double - fsubd 4))
+
+;; Add a float and a complex
+(macrolet
+    ((frob (size fop cost)
+       (let ((vop-name
+	      (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+	     (real-reg (symbolicate size "-REG"))
+	     (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+	     (r-type (symbolicate size "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN"))
+	     (load (ecase size
+		     (single 'ldf)
+		     (double 'lddf)))
+	     (zero-sym (ecase size
+			 (single '*fp-constant-0f0*)
+			 (double '*fp-constant-0d0*)))
+	     (slot (ecase size
+		     (single vm:single-float-value-slot)
+		     (double vm:double-float-value-slot))))
+	 `(define-vop (,vop-name)
+	      (:args (y :scs (,real-reg))
+	             (x :scs (,complex-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,r-type ,c-type)
+	    (:result-types ,c-type)
+	    (:temporary (:scs (,real-reg)) zero)
+	    (:temporary (:scs (descriptor-reg)) zero-val)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float/float arithmetic")
+	    (:translate +)
+	    (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		(load-symbol-value zero-val ,zero-sym)
+		(inst ,load zero zero-val (- (* ,slot vm:word-bytes)
+					     vm:other-pointer-type))
+		(inst ,fop rr xr y)
+		(inst ,fop ri xi zero)))))))
+  (frob single fadds 1)
+  (frob double faddd 2))
+
+;; Subtract a complex from a float.
+;;
+(macrolet
+    ((frob (size fop cost)
+       (let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+	     (real-reg (symbolicate size "-REG"))
+	     (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+	     (r-type (symbolicate size "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN"))
+	     (load (ecase size
+		     (single 'ldf)
+		     (double 'lddf)))
+	     (zero-sym (ecase size
+			 (single '*fp-constant-0f0*)
+			 (double '*fp-constant-0d0*)))
+	     (slot (ecase size
+		     (single vm:single-float-value-slot)
+		     (double vm:double-float-value-slot))))
+	 `(define-vop (,vop-name)
+	      (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,r-type ,c-type)
+	    (:result-types ,c-type)
+	    (:temporary (:scs (,real-reg)) zero)
+	    (:temporary (:scs (descriptor-reg)) zero-val)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float/float arithmetic")
+	    (:translate -)
+	    (:generator ,cost
+	      (let ((yr (,real-part y))
+		    (yi (,imag-part y))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		(load-symbol-value zero-val ,zero-sym)
+		(inst ,load zero zero-val (- (* ,slot vm:word-bytes)
+					     vm:other-pointer-type))
+		(inst ,fop rr x yr)
+		(inst ,fop ri zero yi)))))))
+
+  (frob single fsubs 2)
+  (frob double fsubd 2))
+
+;; Multiply two complex numbers
+(macrolet
+    ((frob (size fmul fadd fsub mov cost)
+       (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+	     (real-reg (symbolicate size "-REG"))
+	     (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,complex-reg))
+	           (y :scs (,complex-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,c-type ,c-type)
+	    (:result-types ,c-type)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float multiplication")
+	    (:translate *)
+	    (:temporary (:scs (,real-reg)) p1 p2)
+	    (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (yr (,real-part y))
+		    (yi (,imag-part y))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		;; Be careful because r might be packed into the same
+		;; location as either x or y.  We have to be careful
+		;; not to modify either x or y until all uses of x or
+		;; y.
+		(inst ,fmul p1 yr xr)	; p1 = xr*yr
+		(inst ,fmul p2 xi yi)	; p2 = xi*yi
+		(inst ,fsub p2 p1 p2)	; p2 = xr*yr - xi*yi
+		(inst ,fmul p1 xr yi)	; p1 = xr*yi
+		(inst ,fmul ri xi yr)	; ri = xi*yr
+		(inst ,fadd ri ri p1)	; ri = xi*yr + xr*yi
+		(,@mov rr p2)))))))
+
+  (frob single fmuls fadds fsubs (inst fmovs) 6)
+  (frob double fmuld faddd fsubd (move-double-reg) 6))
+
+;; Multiply a complex by a float.  The case of float * complex is
+;; handled by a deftransform to convert it to the complex*float case.
+(macrolet
+    ((frob (float-type fmul mov cost)
+       (let* ((vop-name (symbolicate "COMPLEX-"
+				     float-type
+				     "-FLOAT-*-"
+				     float-type
+				     "-FLOAT"))
+	      (vop-name-r (symbolicate float-type
+				       "-FLOAT-*-COMPLEX-"
+				       float-type
+				       "-FLOAT"))
+	      (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+	      (real-sc-type (symbolicate float-type "-REG"))
+	      (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	      (r-type (symbolicate float-type "-FLOAT"))
+	      (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	      (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(progn
+	   ;; Complex * float
+	   (define-vop (,vop-name)
+	     (:args (x :scs (,complex-sc-type))
+	            (y :scs (,real-sc-type)))
+	     (:results (r :scs (,complex-sc-type)))
+	     (:arg-types ,c-type ,r-type)
+	     (:result-types ,c-type)
+	     (:policy :fast-safe)
+	     (:note _N"inline complex float arithmetic")
+	     (:translate *)
+	     (:temporary (:scs (,real-sc-type)) temp)
+	     (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		(cond ((location= y rr)
+		       (inst ,fmul temp xr y) ; xr * y
+		       (inst ,fmul ri xi y) ; xi * yi
+		       (,@mov rr temp))
+		      (t
+		       (inst ,fmul rr xr y)
+		       (inst ,fmul ri xi y))))))
+	   ;; Float * complex
+	   (define-vop (,vop-name-r)
+	     (:args (y :scs (,real-sc-type))
+	            (x :scs (,complex-sc-type)))
+	     (:results (r :scs (,complex-sc-type)))
+	     (:arg-types ,r-type ,c-type)
+	     (:result-types ,c-type)
+	     (:policy :fast-safe)
+	     (:note _N"inline complex float arithmetic")
+	     (:translate *)
+	     (:temporary (:scs (,real-sc-type)) temp)
+	     (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		(cond ((location= y rr)
+		       (inst ,fmul temp xr y) ; xr * y
+		       (inst ,fmul ri xi y) ; xi * yi
+		       (,@mov rr temp))
+		      (t
+		       (inst ,fmul rr xr y)
+		       (inst ,fmul ri xi y))))))))))
+  (frob single fmuls (inst fmovs) 4)
+  (frob double fmuld (move-double-reg) 4))
+
+
+;; Divide a complex by a complex
+
+;; Here's how we do a complex division
+;;
+;; Compute (xr + i*xi)/(yr + i*yi)
+;;
+;; Assume |yi| < |yr|.  Then
+;;
+;; (xr + i*xi)      (xr + i*xi)
+;; ----------- = -----------------
+;; (yr + i*yi)   yr*(1 + i*(yi/yr))
+;;
+;;               (xr + i*xi)*(1 - i*(yi/yr))
+;;             = ---------------------------
+;;                   yr*(1 + (yi/yr)^2)
+;;
+;;               (xr + (yi/yr)*xi) + i*(xi - (yi/yr)*xr)
+;;             = --------------------------------------
+;;                        yr + (yi/yr)*yi
+;;
+;;
+;; We do the similar thing when |yi| > |yr|.  The result is
+;;
+;;     
+;; (xr + i*xi)      (xr + i*xi)
+;; ----------- = -----------------
+;; (yr + i*yi)   yi*((yr/yi) + i)
+;;
+;;               (xr + i*xi)*((yr/yi) - i)
+;;             = -------------------------
+;;                  yi*((yr/yi)^2 + 1)
+;;
+;;               (xr*(yr/yi) + xi) + i*(xi*(yr/yi) - xr)
+;;             = ---------------------------------------
+;;                       yi + (yr/yi)*yr
+;;
+
+(macrolet
+    ((frob (float-type fcmp fadd fsub fmul fdiv fabs cost)
+       (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	     (real-reg (symbolicate float-type "-REG"))
+	     (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,complex-reg))
+		   (y :scs (,complex-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,c-type ,c-type)
+	    (:result-types ,c-type)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float division")
+	    (:translate /)
+	    (:temporary (:sc ,real-reg) ratio)
+	    (:temporary (:sc ,real-reg) den)
+	    (:temporary (:sc ,real-reg) temp-r)
+	    (:temporary (:sc ,real-reg) temp-i)
+	    (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (yr (,real-part y))
+		    (yi (,imag-part y))
+		    (rr (,real-part r))
+		    (ri (,imag-part r))
+		    (bigger (gen-label))
+		    (done (gen-label)))
+		(,@fabs ratio yr)
+		(,@fabs den yi)
+		(inst ,fcmp den ratio)
+		(unless (backend-featurep :sparc-v9)
+		  (inst nop))
+		(inst fb :ge bigger)
+		(inst nop)
+		;; The case of |yi| <= |yr|
+		(inst ,fdiv ratio yi yr) ; ratio = yi/yr
+		(inst ,fmul den ratio yi)
+		(inst ,fmul temp-r ratio xi)
+		(inst ,fmul temp-i ratio xr)
+
+		(inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+		(inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+		(inst b done)
+		(inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+
+
+		(emit-label bigger)
+		;; The case of |yi| > |yr|
+		(inst ,fdiv ratio yr yi) ; ratio = yr/yi
+		(inst ,fmul den ratio yr)
+		(inst ,fmul temp-r ratio xr)
+		(inst ,fmul temp-i ratio xi)
+
+		(inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+		(inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+
+		(inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+
+		(emit-label done)
+
+		(inst ,fdiv rr temp-r den)
+		(inst ,fdiv ri temp-i den)
+		))))))
+
+  (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15)
+  (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15))
+
+
+;; Divide a complex by a real
+(macrolet
+    ((frob (float-type fdiv fmov cost)
+       (let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" float-type "-FLOAT"))
+	      (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+	      (real-sc-type (symbolicate float-type "-REG"))
+	      (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	      (r-type (symbolicate float-type "-FLOAT"))
+	      (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	      (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	   (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
+	   (:results (r :scs (,complex-sc-type)))
+	   (:arg-types ,c-type ,r-type)
+	   (:result-types ,c-type)
+	   (:policy :fast-safe)
+	   (:note _N"inline complex float arithmetic")
+	   (:translate /)
+	   (:temporary (:sc ,real-sc-type) tmp)
+	   (:generator ,cost
+	    (let ((xr (,real-part x))
+		  (xi (,imag-part x))
+		  (rr (,real-part r))
+		  (ri (,imag-part r)))
+	      (cond ((location= r y)
+		     (inst ,fdiv tmp xr y)
+		     (inst ,fdiv ri xi y)
+		     (,@fmov rr tmp))
+		    (t
+		     (inst ,fdiv rr xr y) ; xr * y
+		     (inst ,fdiv ri xi y) ; xi * yi
+		     ))))))))
+  (frob single fdivs (inst fmovs) 2)
+  (frob double fdivd (move-double-reg) 2))
+
+;; Divide a real by a complex
+
+(macrolet
+    ((frob (float-type fcmp fadd fmul fdiv fneg fabs cost)
+       (let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	     (real-reg (symbolicate float-type "-REG"))
+	     (r-type (symbolicate float-type "-FLOAT"))
+	     (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	     (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	     (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,real-reg))
+		   (y :scs (,complex-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,r-type ,c-type)
+	    (:result-types ,c-type)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float division")
+	    (:translate /)
+	    (:temporary (:sc ,real-reg) ratio)
+	    (:temporary (:sc ,real-reg) den)
+	    (:generator ,cost
+	      (let ((yr (,real-tn y))
+		    (yi (,imag-tn y))
+		    (rr (,real-tn r))
+		    (ri (,imag-tn r))
+		    (bigger (gen-label))
+		    (done (gen-label)))
+		(,@fabs ratio yr)
+		(,@fabs den yi)
+		(inst ,fcmp den ratio)
+		(unless (backend-featurep :sparc-v9)
+		  (inst nop))
+		(inst fb :ge bigger)
+		(inst nop)
+		;; The case of |yi| <= |yr|
+		(inst ,fdiv ratio yi yr) ; ratio = yi/yr
+		(inst ,fmul den ratio yi)
+		(inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+		(inst ,fmul ri ratio x) ; ri = (yi/yr)*x
+		(inst ,fdiv rr x den)	; rr = x/den
+		(inst b done)
+		(inst ,fdiv ri ri den) ; ri = (yi/yr)*x/den
+
+		(emit-label bigger)
+		;; The case of |yi| > |yr|
+		(inst ,fdiv ratio yr yi) ; ratio = yr/yi
+		(inst ,fmul den ratio yr)
+		(inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+		(inst ,fmul ri ratio x) ; ri = (yr/yi)*x
+		(inst ,fdiv rr ri den) ; rr = (yr/yi)*x/den
+		(inst ,fdiv ri x den) ; ri = x/den
+		(emit-label done)
+
+		(,@fneg ri ri)))))))
+
+  (frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
+  (frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
+
+;; Conjugate of a complex number
+
+(macrolet
+    ((frob (float-type fneg fmov cost)
+       (let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT"))
+	     (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	     (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,complex-reg)))
+	    (:results (r :scs (,complex-reg)))
+	    (:arg-types ,c-type)
+	    (:result-types ,c-type)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex conjugate")
+	    (:translate conjugate)
+	    (:generator ,cost
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (rr (,real-part r))
+		    (ri (,imag-part r)))
+		(,@fneg ri xi)
+		(unless (location= rr xr)
+		  (,@fmov rr xr))))))))
+
+  (frob single (inst fnegs) (inst fmovs) 4)
+  (frob double (negate-double-reg) (move-double-reg) 4))
+
+;; Compare a float with a complex or a complex with a float
+#+nil
+(macrolet
+    ((frob (name name-r f-type c-type)
+       `(progn
+	 (defknown ,name (,f-type ,c-type) t)
+	 (defknown ,name-r (,c-type ,f-type) t)
+	 (defun ,name (x y)
+	   (declare (type ,f-type x)
+		    (type ,c-type y))
+	   (,name x y))
+	 (defun ,name-r (x y)
+	   (declare (type ,c-type x)
+		    (type ,f-type y))
+	   (,name-r x y))
+	 )))
+  (frob %compare-complex-single-single %compare-single-complex-single
+	single-float (complex single-float))
+  (frob %compare-complex-double-double %compare-double-complex-double
+	double-float (complex double-float)))
+	   
+#+nil
+(macrolet
+    ((frob (trans-1 trans-2 float-type fcmp fsub)
+       (let ((vop-name
+	      (symbolicate "COMPLEX-" float-type "-FLOAT-"
+			   float-type "-FLOAT-COMPARE"))
+	     (vop-name-r
+	      (symbolicate float-type "-FLOAT-COMPLEX-"
+			   float-type "-FLOAT-COMPARE"))
+	     (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	     (real-reg (symbolicate float-type "-REG"))
+	     (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	     (r-type (symbolicate float-type "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(progn
+	    ;; (= float complex)
+	    (define-vop (,vop-name)
+	      (:args (x :scs (,real-reg))
+		     (y :scs (,complex-reg)))
+	      (:arg-types ,r-type ,c-type)
+	      (:translate ,trans-1)
+	      (:conditional)
+	      (:info target not-p)
+	      (:policy :fast-safe)
+	      (:note _N"inline complex float/float comparison")
+	      (:vop-var vop)
+	      (:save-p :compute-only)
+	      (:temporary (:sc ,real-reg) fp-zero)
+	      (:guard (not (backend-featurep :sparc-v9)))
+	      (:generator 6
+	       (note-this-location vop :internal-error)
+	       (let ((yr (,real-part y))
+		     (yi (,imag-part y)))
+		 ;; Set fp-zero to zero
+		 (inst ,fsub fp-zero fp-zero fp-zero)
+		 (inst ,fcmp x yr)
+		 (inst nop)
+		 (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
+		 (inst ,fcmp yi fp-zero)
+		 (inst nop)
+		 (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
+		 (inst nop))))
+	    ;; (= complex float)
+	    (define-vop (,vop-name-r)
+	      (:args (y :scs (,complex-reg))
+	             (x :scs (,real-reg)))
+	      (:arg-types ,c-type ,r-type)
+	      (:translate ,trans-2)
+	      (:conditional)
+	      (:info target not-p)
+	      (:policy :fast-safe)
+	      (:note _N"inline complex float/float comparison")
+	      (:vop-var vop)
+	      (:save-p :compute-only)
+	      (:temporary (:sc ,real-reg) fp-zero)
+	      (:guard (not (backend-featurep :sparc-v9)))
+	      (:generator 6
+	       (note-this-location vop :internal-error)
+	       (let ((yr (,real-part y))
+		     (yi (,imag-part y)))
+		 ;; Set fp-zero to zero
+		 (inst ,fsub fp-zero fp-zero fp-zero)
+		 (inst ,fcmp x yr)
+		 (inst nop)
+		 (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
+		 (inst ,fcmp yi fp-zero)
+		 (inst nop)
+		 (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
+		 (inst nop))))))))
+  (frob %compare-complex-single-single %compare-single-complex-single
+	single fcmps fsubs)
+  (frob %compare-complex-double-double %compare-double-complex-double
+	double fcmpd fsubd))
+
+;; Compare two complex numbers for equality
+(macrolet
+    ((frob (float-type fcmp)
+       (let ((vop-name
+	      (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
+	     (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	     (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,complex-reg))
+		   (y :scs (,complex-reg)))
+	    (:arg-types ,c-type ,c-type)
+	    (:translate =)
+	    (:conditional)
+	    (:info target not-p)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float comparison")
+	    (:vop-var vop)
+	    (:save-p :compute-only)
+	    (:guard (not (backend-featurep :sparc-v9)))
+	    (:generator 6
+	      (note-this-location vop :internal-error)
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (yr (,real-part y))
+		    (yi (,imag-part y)))
+		(inst ,fcmp xr yr)
+		(inst nop)
+		(inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
+		(inst ,fcmp xi yi)
+		(inst nop)
+		(inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
+		(inst nop)))))))
+  (frob single fcmps)
+  (frob double fcmpd))
+
+;; Compare a complex with a complex, for V9
+(macrolet
+    ((frob (float-type fcmp)
+       (let ((vop-name
+	      (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
+	     (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+	     (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+	     (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+	     (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,complex-reg))
+		   (y :scs (,complex-reg)))
+	    (:arg-types ,c-type ,c-type)
+	    (:translate =)
+	    (:conditional)
+	    (:info target not-p)
+	    (:policy :fast-safe)
+	    (:note _N"inline complex float comparison")
+	    (:vop-var vop)
+	    (:save-p :compute-only)
+	    (:temporary (:sc descriptor-reg) true)
+	    (:guard (backend-featurep :sparc-v9))
+	    (:generator 6
+	      (note-this-location vop :internal-error)
+	      (let ((xr (,real-part x))
+		    (xi (,imag-part x))
+		    (yr (,real-part y))
+		    (yi (,imag-part y)))
+		;; Assume comparison is true
+		(load-symbol true t)
+		(inst ,fcmp xr yr)
+		(inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+		(inst ,fcmp xi yi)
+		(inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+		(inst cmp true null-tn)
+		(inst b (if not-p :eq :ne) target :pt)
+		(inst nop)))))))
+  (frob single fcmps)
+  (frob double fcmpd))
+
+
+;; Instead of providing vops, we just transform these to the obvious
+;; implementation.  There are probably a few unnecessary moves.
+
+(macrolet
+    ((cvt (name prototype)
+       `(progn
+	 (deftransform ,name ((n) (real) * :when :both)
+	   '(complex (float n ,prototype)))
+	 (deftransform ,name ((n) (complex) * :when :both)
+	   '(complex (float (realpart n) ,prototype)
+	             (float (imagpart n) ,prototype))))))
+  (cvt %complex-single-float 1f0)
+  (cvt %complex-double-float 1d0))
+
+
+) ; end progn complex-fp-vops
+
+#+sparc-v9
+(progn
+
+;; Vops to take advantage of the conditional move instruction
+;; available on the Sparc V9
+  
+(defknown (%%max %%min) ((or (unsigned-byte #.vm:word-bits)
+			     (signed-byte #.vm:word-bits)
+			     single-float double-float)
+			 (or (unsigned-byte #.vm:word-bits)
+			     (signed-byte #.vm:word-bits)
+			     single-float double-float))
+  (or (unsigned-byte #.vm:word-bits)
+      (signed-byte #.vm:word-bits)
+      single-float double-float)
+  (movable foldable flushable))
+
+;; We need these definitions for byte-compiled code
+(defun %%min (x y)
+  (declare (type (or (unsigned-byte 32) (signed-byte 32)
+		     single-float double-float) x y))
+  (if (<= x y)
+      x y))
+
+(defun %%max (x y)
+  (declare (type (or (unsigned-byte 32) (signed-byte 32)
+		     single-float double-float) x y))
+  (if (>= x y)
+      x y))
+  
+(macrolet
+    ((frob (name sc-type type compare cmov cost cc max min note)
+       (let ((vop-name (symbolicate name "-" type "=>" type))
+	     (trans-name (symbolicate "%%" name)))
+	 `(define-vop (,vop-name)
+	    (:args (x :scs (,sc-type))
+		   (y :scs (,sc-type)))
+	    (:results (r :scs (,sc-type)))
+	    (:arg-types ,type ,type)
+	    (:result-types ,type)
+	    (:policy :fast-safe)
+	    (:note ,note)
+	    (:translate ,trans-name)
+	    (:guard (backend-featurep :sparc-v9))
+	    (:generator ,cost
+	      (inst ,compare x y)
+	      (cond ((location= r x)
+		     ;; If x < y, need to move y to r, otherwise r already has
+		     ;; the max.
+		     (inst ,cmov ,min r y ,cc))
+		    ((location= r y)
+		     ;; If x > y, need to move x to r, otherwise r already has
+		     ;; the max.
+		     (inst ,cmov ,max r x ,cc))
+		    (t
+		     ;; It doesn't matter what R is, just copy the min to R.
+		     (inst ,cmov ,max r x ,cc)
+		     (inst ,cmov ,min r y ,cc))))))))
+  (frob max single-reg single-float fcmps cfmovs 3
+	:fcc0 :ge :l _N"inline float max")
+  (frob max double-reg double-float fcmpd cfmovd 3
+	:fcc0 :ge :l _N"inline float max")
+  (frob min single-reg single-float fcmps cfmovs 3
+	:fcc0 :l :ge _N"inline float min")
+  (frob min double-reg double-float fcmpd cfmovd 3
+	:fcc0 :l :ge _N"inline float min")
+  ;; Strictly speaking these aren't float ops, but it's convenient to
+  ;; do them here.
+  ;;
+  ;; The cost is here is the worst case number of instructions.  For
+  ;; 32-bit integer operands, we add 2 more to account for the
+  ;; untagging of fixnums, if necessary.
+  (frob max signed-reg signed-num cmp cmove 5
+	:icc :ge :lt _N"inline (signed-byte 32) max")
+  (frob max unsigned-reg unsigned-num cmp cmove 5
+	:icc :ge :lt _N"inline (unsigned-byte 32) max")
+  ;; For fixnums, make the cost lower so we don't have to untag the
+  ;; numbers.
+  (frob max any-reg tagged-num cmp cmove 3
+	:icc :ge :lt _N"inline fixnum max")
+  (frob min signed-reg signed-num cmp cmove 5
+	:icc :lt :ge _N"inline (signed-byte 32) min")
+  (frob min unsigned-reg unsigned-num cmp cmove 5
+	:icc :lt :ge _N"inline (unsigned-byte 32) min")
+  ;; For fixnums, make the cost lower so we don't have to untag the
+  ;; numbers.
+  (frob min any-reg tagged-num cmp cmove 3
+	:icc :lt :ge _N"inline fixnum min"))
+	   
+#+nil
+(define-vop (max-boxed-double-float=>boxed-double-float)
+  (:args (x :scs (descriptor-reg))
+	 (y :scs (descriptor-reg)))
+  (:results (r :scs (descriptor-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note _N"inline float max/min")
+  (:translate %max-double-float)
+  (:temporary (:scs (double-reg)) xval)
+  (:temporary (:scs (double-reg)) yval)
+  (:guard (backend-featurep :sparc-v9))
+  (:vop-var vop)
+  (:generator 3
+    (let ((offset (- (* vm:double-float-value-slot vm:word-bytes)
+		     vm:other-pointer-type)))
+      (inst lddf xval x offset)
+      (inst lddf yval y offset)
+      (inst fcmpd xval yval)
+      (cond ((location= r x)
+	     ;; If x < y, need to move y to r, otherwise r already has
+	     ;; the max.
+	     (inst cmove :l r y :fcc0))
+	    ((location= r y)
+	     ;; If x > y, need to move x to r, otherwise r already has
+	     ;; the max.
+	     (inst cmove :ge r x :fcc0))
+	    (t
+	     ;; It doesn't matter what R is, just copy the min to R.
+	     (inst cmove :ge r x :fcc0)
+	     (inst cmove :l r y :fcc0))))))
+    
+)
+
+(in-package "C")
+#+sparc-v9
+(progn
+;;; The sparc-v9 architecture has conditional move instructions that
+;;; can be used.  This should be faster than using the obvious if
+;;; expression since we don't have to do branches.
+  
+(def-source-transform min (&rest args)
+  (case (length args)
+    ((0 2) (values nil t))
+    (1 `(values (the real ,(first args))))
+    (t (c::associate-arguments 'min (first args) (rest args)))))
+
+(def-source-transform max (&rest args)
+  (case (length args)
+    ((0 2) (values nil t))
+    (1 `(values (the real ,(first args))))
+    (t (c::associate-arguments 'max (first args) (rest args)))))
+
+;; Derive the types of max and min
+(defoptimizer (max derive-type) ((x y))
+  ;; It's Y < X instead of X < Y because that's how the
+  ;; source-transform, the deftransform and the max function do the
+  ;; comparisons.  This is important if the types of X and Y are
+  ;; different types, like integer vs double-float because CMUCL
+  ;; returns the actual arg, instead of applying float-contagion to
+  ;; the result.
+  (multiple-value-bind (definitely-< definitely->=)
+      (ir1-transform-<-helper y x)
+    (cond (definitely-<
+	      (continuation-type x))
+	  (definitely->=
+	      (continuation-type y))
+	  (t
+	   (make-canonical-union-type (list (continuation-type x)
+					    (continuation-type y)))))))
+
+(defoptimizer (min derive-type) ((x y))
+  (multiple-value-bind (definitely-> definitely-<=)
+      (ir1-transform-<-helper y x)
+    (cond (definitely-<=
+	      (continuation-type x))
+	  (definitely->
+	      (continuation-type y))
+	  (t
+	   (make-canonical-union-type (list (continuation-type x)
+					    (continuation-type y)))))))
+
+(deftransform max ((x y) (number number) * :when :both)
+  (let ((x-type (continuation-type x))
+	(y-type (continuation-type y))
+	(signed (specifier-type '(signed-byte #.vm:word-bits)))
+	(unsigned (specifier-type '(unsigned-byte #.vm:word-bits)))
+	(d-float (specifier-type 'double-float))
+	(s-float (specifier-type 'single-float)))
+    ;; Use %%max if both args are good types of the same type.  As a
+    ;; last resort, use the obvious comparison to select the desired
+    ;; element.
+    (cond ((and (csubtypep x-type signed)
+		(csubtypep y-type signed))
+	   `(sparc::%%max x y))
+	  ((and (csubtypep x-type unsigned)
+		(csubtypep y-type unsigned))
+	   `(sparc::%%max x y))
+	  ((and (csubtypep x-type d-float)
+		(csubtypep y-type d-float))
+	   `(sparc::%%max x y))
+	  ((and (csubtypep x-type s-float)
+		(csubtypep y-type s-float))
+	   `(sparc::%%max x y))
+	  (t
+	   (let ((arg1 (gensym))
+		 (arg2 (gensym)))
+	     `(let ((,arg1 x)
+		    (,arg2 y))
+	       (if (> ,arg1 ,arg2)
+		   ,arg1 ,arg2)))))))
+
+(deftransform min ((x y) (real real) * :when :both)
+  (let ((x-type (continuation-type x))
+	(y-type (continuation-type y))
+	(signed (specifier-type '(signed-byte #.vm:word-bits)))
+	(unsigned (specifier-type '(unsigned-byte #.vm:word-bits)))
+	(d-float (specifier-type 'double-float))
+	(s-float (specifier-type 'single-float)))
+    (cond ((and (csubtypep x-type signed)
+		(csubtypep y-type signed))
+	   `(sparc::%%min x y))
+	  ((and (csubtypep x-type unsigned)
+		(csubtypep y-type unsigned))
+	   `(sparc::%%min x y))
+	  ((and (csubtypep x-type d-float)
+		(csubtypep y-type d-float))
+	   `(sparc::%%min x y))
+	  ((and (csubtypep x-type s-float)
+		(csubtypep y-type s-float))
+	   `(sparc::%%min x y))
+	  (t
+	   (let ((arg1 (gensym))
+		 (arg2 (gensym)))
+	     `(let ((,arg1 x)
+		    (,arg2 y))
+		(if (< ,arg1 ,arg2)
+		    ,arg1 ,arg2)))))))
+
+)
+
+
+
+(in-package "SPARC")
+
+
+;;; Support for double-double floats
+
+#+double-double
+(progn
+(defun double-double-reg-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+
+(defun double-double-reg-lo-tn (x)
+  ;; The low tn is 2 more than the offset because double regs are
+  ;; even.
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+
+(define-move-function (load-double-double 4) (vop x y)
+  ((double-double-stack) (double-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((hi-tn (double-double-reg-hi-tn y)))
+      (inst lddf hi-tn nfp offset))
+    (let ((lo-tn (double-double-reg-lo-tn y)))
+      (inst lddf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+(define-move-function (store-double-double 4) (vop x y)
+  ((double-double-reg) (double-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((hi-tn (double-double-reg-hi-tn x)))
+      (inst stdf hi-tn nfp offset))
+    (let ((lo-tn (double-double-reg-lo-tn x)))
+      (inst stdf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+;;; Double-double float register to register moves
+
+(define-vop (double-double-move)
+  (:args (x :scs (double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (double-double-reg) :load-if (not (location= x y))))
+  (:note _N"double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the double-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-hi (double-double-reg-hi-tn x))
+	     (y-hi (double-double-reg-hi-tn y)))
+	 (move-double-reg y-hi x-hi))
+       (let ((x-lo (double-double-reg-lo-tn x))
+	     (y-lo (double-double-reg-lo-tn y)))
+	 (move-double-reg y-lo x-lo)))))
+;;;
+(define-move-vop double-double-move :move
+  (double-double-reg) (double-double-reg))
+
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+
+(define-vop (move-from-double-double)
+  (:args (x :scs (double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note _N"double-double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm::double-double-float-type
+			       vm::double-double-float-size))
+     (let ((hi-tn (double-double-reg-hi-tn x)))
+       (inst stdf hi-tn y (- (* vm::double-double-float-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((lo-tn (double-double-reg-lo-tn x)))
+       (inst stdf lo-tn y (- (* vm::double-double-float-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+(define-move-vop move-from-double-double :move
+  (double-double-reg) (descriptor-reg))
+
+;;; Move from a descriptor to a double-double float register
+
+(define-vop (move-to-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (double-double-reg)))
+  (:note _N"pointer to double-double float coercion")
+  (:generator 2
+    (let ((hi-tn (double-double-reg-hi-tn y)))
+      (inst lddf hi-tn x (- (* double-double-float-hi-slot word-bytes)
+			     other-pointer-type)))
+    (let ((lo-tn (double-double-reg-lo-tn y)))
+      (inst lddf lo-tn x (- (* double-double-float-lo-slot word-bytes)
+			   other-pointer-type)))))
+
+(define-move-vop move-to-double-double :move
+  (descriptor-reg) (double-double-reg))
+
+;;; double-double float move-argument vop
+
+(define-vop (move-double-double-float-argument)
+  (:args (x :scs (double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y double-double-reg))))
+  (:results (y))
+  (:note _N"double-double float argument move")
+  (:generator 2
+    (sc-case y
+      (double-double-reg
+       (unless (location= x y)
+	 (let ((x-hi (double-double-reg-hi-tn x))
+	       (y-hi (double-double-reg-hi-tn y)))
+	   (move-double-reg y-hi x-hi))
+	 (let ((x-lo (double-double-reg-lo-tn x))
+	       (y-lo (double-double-reg-lo-tn y)))
+	   (move-double-reg y-lo x-lo))))
+      (double-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((hi-tn (double-double-reg-hi-tn x)))
+	   (inst stdf hi-tn nfp offset))
+	 (let ((lo-tn (double-double-reg-lo-tn x)))
+	   (inst stdf lo-tn nfp (+ offset (* 2 word-bytes)))))))))
+
+(define-move-vop move-double-double-float-argument :move-argument
+  (double-double-reg descriptor-reg) (double-double-reg))
+
+
+(define-vop (make/double-double-float)
+  (:args (hi :scs (double-reg) :target res
+	     :load-if (not (location= hi res)))
+	 (lo :scs (double-reg) :to :save))
+  (:results (res :scs (double-double-reg) :from (:argument 0)
+		 :load-if (not (sc-is res double-double-stack))))
+  (:arg-types double-float double-float)
+  (:result-types double-double-float)
+  (:translate kernel::%make-double-double-float)
+  (:note _N"inline double-double float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case res
+      (double-double-reg
+       (let ((res-hi (double-double-reg-hi-tn res)))
+	 (unless (location= res-hi hi)
+	   (move-double-reg res-hi hi)))
+       (let ((res-lo (double-double-reg-lo-tn res)))
+	 (unless (location= res-lo lo)
+	   (move-double-reg res-lo lo))))
+      (double-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset res) vm:word-bytes)))
+	 (unless (location= hi res)
+	   (inst stdf hi nfp offset))
+	 (inst stdf lo nfp (+ offset (* 2 vm:word-bytes))))))))
+
+(define-vop (double-double-float-value)
+  (:args (x :scs (double-double-reg descriptor-reg) :target r
+	    :load-if (not (sc-is x double-double-stack))))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (double-double-reg
+       (let ((value-tn (ecase slot
+			 (:hi (double-double-reg-hi-tn x))
+			 (:lo (double-double-reg-lo-tn x)))))
+	 (unless (location= value-tn r)
+	   (move-double-reg r value-tn))))
+      (double-double-stack
+       (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:hi 0) (:lo 2))
+					       (tn-offset x))
+					    vm:word-bytes)))
+      (descriptor-reg
+       (inst lddf r x (- (* vm:word-bytes
+			    (ecase slot
+			      (:hi vm:double-double-float-hi-slot)
+			      (:lo vm:double-double-float-lo-slot)))
+			 vm:other-pointer-type))))))
+
+(define-vop (hi/double-double-value double-double-float-value)
+  (:translate kernel::double-double-hi)
+  (:note _N"double-double high part")
+  (:variant :hi))
+
+(define-vop (lo/double-double-value double-double-float-value)
+  (:translate kernel::double-double-lo)
+  (:note _N"double-double low part")
+  (:variant :lo))
+
+
+(define-vop (make-complex-double-double-float)
+  (:translate complex)
+  (:args (real :scs (double-double-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (double-double-reg) :to :save))
+  (:arg-types double-double-float double-double-float)
+  (:results (r :scs (complex-double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-double-stack))))
+  (:result-types complex-double-double-float)
+  (:note _N"inline complex double-double float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (complex-double-double-reg
+       (let ((r-real (complex-double-double-reg-real-hi-tn r))
+	     (real-hi (double-double-reg-hi-tn real)))
+	 (move-double-reg r-real real-hi))
+       (let ((r-real (complex-double-double-reg-real-lo-tn r))
+	     (real-lo (double-double-reg-lo-tn real)))
+	 (move-double-reg r-real real-lo))
+       (let ((r-imag (complex-double-double-reg-imag-hi-tn r))
+	     (imag-hi (double-double-reg-hi-tn imag)))
+	 (move-double-reg r-imag imag-hi))
+       (let ((r-imag (complex-double-double-reg-imag-lo-tn r))
+	     (imag-lo (double-double-reg-lo-tn imag)))
+	 (move-double-reg r-imag imag-lo)))
+      (complex-double-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (let ((r-real (double-double-reg-hi-tn real)))
+	   (inst stdf r-real nfp offset))
+	 (let ((r-real (double-double-reg-lo-tn real)))
+	   (inst stdf r-real nfp (+ offset (* 2 vm:word-bytes))))
+	 (let ((r-imag (double-double-reg-hi-tn imag)))
+	   (inst stdf r-imag nfp (+ offset (* 4 vm:word-bytes))))
+	 (let ((r-imag (double-double-reg-lo-tn imag)))
+	   (inst stdf r-imag nfp (+ offset (* 6 vm:word-bytes)))))))))
+
+(define-vop (complex-double-double-float-value)
+  (:args (x :scs (complex-double-double-reg descriptor-reg)
+	    :load-if (not (or (sc-is x complex-double-double-stack)))))
+  (:arg-types complex-double-double-float)
+  (:results (r :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (complex-double-double-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-hi-tn x))
+			 (:imag (complex-double-double-reg-imag-hi-tn x))))
+	     (r-hi (double-double-reg-hi-tn r)))
+	 (unless (location= value-tn r-hi)
+	   (move-double-reg r-hi value-tn)))
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-lo-tn x))
+			 (:imag (complex-double-double-reg-imag-lo-tn x))))
+	     (r-lo (double-double-reg-lo-tn r)))
+	 (unless (location= value-tn r-lo)
+	   (move-double-reg r-lo value-tn))))
+      (complex-double-double-stack
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (inst lddf r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4))
+						    (tn-offset x))
+						 vm:word-bytes)))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (inst lddf r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6))
+						    (tn-offset x))
+						 vm:word-bytes))))
+      (descriptor-reg
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (inst lddf r-hi x (- (* (ecase slot
+				   (:real vm::complex-double-double-float-real-hi-slot)
+				   (:imag vm::complex-double-double-float-imag-hi-slot))
+				 vm:word-bytes)
+			      vm:other-pointer-type))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (inst lddf r-lo x (- (* (ecase slot
+				 (:real vm::complex-double-double-float-real-lo-slot)
+				 (:imag vm::complex-double-double-float-imag-lo-slot))
+			       vm:word-bytes)
+			    vm:other-pointer-type))))))))
+
+(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
+  (:translate realpart)
+  (:note _N"complex double-double float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-double-double-float complex-double-double-float-value)
+  (:translate imagpart)
+  (:note _N"complex double-double float imagpart")
+  (:variant :imag))
+
+); progn
+
diff --git a/src/compiler/sparcv9/insts.lisp b/src/compiler/sparcv9/insts.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ac0cee59815841bf8d3752241a89b524fce8cd21
--- /dev/null
+++ b/src/compiler/sparcv9/insts.lisp
@@ -0,0 +1,2591 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/insts.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Description of the SPARC architecture.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+(use-package "NEW-ASSEM")
+(use-package "EXT")
+(use-package "C")
+
+(def-assembler-params
+    :scheduler-p t
+  :max-locations 101)
+
+
+;;;; Constants, types, conversion functions, some disassembler stuff.
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (sc-case tn
+    (zero zero-offset)
+    (null null-offset)
+    (t
+     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
+	 (tn-offset tn)
+	 (error (intl:gettext "~S isn't a register.") tn)))))
+
+(defun fp-reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
+    (error (intl:gettext "~S isn't a floating-point register.") tn))
+  (let ((offset (tn-offset tn)))
+    (cond ((> offset 31)
+	   ;; Use the sparc v9 double float register encoding.
+	   (assert (backend-featurep :sparc-v9))
+	   ;; No single register encoding greater than reg 31.
+	   (assert (zerop (mod offset 2)))
+	   ;; Upper bit of the register number is encoded in the low bit.
+	   (1+ (- offset 32)))
+	  (t
+	   (tn-offset tn)))))
+
+(disassem:set-disassem-params :instruction-alignment 32
+			      :opcode-column-width 11)
+
+(defvar *disassem-use-lisp-reg-names* t
+  "If non-NIL, print registers using the Lisp register names.
+Otherwise, use the Sparc register names")
+
+(def-vm-support-routine location-number (loc)
+  (etypecase loc
+    (null)
+    (number)
+    (fixup)
+    (tn
+     (ecase (sb-name (sc-sb (tn-sc loc)))
+       (registers
+	(unless (zerop (tn-offset loc))
+	  (tn-offset loc)))
+       (float-registers
+	(sc-case loc
+	  (single-reg
+	   (+ (tn-offset loc) 32))
+	  (double-reg
+	   (let ((offset (tn-offset loc)))
+	     (assert (zerop (mod offset 2)))
+	     (values (+ offset 32) 2)))
+	  #+long-float
+	  (long-reg
+	   (let ((offset (tn-offset loc)))
+	     (assert (zerop (mod offset 4)))
+	     (values (+ offset 32) 4)))))
+       (control-registers
+	96)
+       (immediate-constant
+	nil)))
+    (symbol
+     (ecase loc
+       (:memory 0)
+       (:psr 97)
+       (:fsr 98)
+       (:y 99)
+       (:tick 100)))))
+
+;;; symbols used for disassembly printing
+;;;
+(defparameter reg-symbols
+  (map 'vector
+       #'(lambda (name)
+	   (cond ((null name) nil)
+		 (t (make-symbol (concatenate 'string "%" name)))))
+       sparc::*register-names*)
+  "The Lisp names for the Sparc integer registers")
+
+(defparameter sparc-reg-symbols
+  (map 'vector
+       #'(lambda (name)
+	   (cond ((null name) nil)
+		 (t (make-symbol (concatenate 'string "%" name)))))
+       #("G0" "G1" "G2" "G3" "G4" "G5" "G6" "G7"
+	 "O0" "O1" "O2" "O3" "O4" "O5" "O6" "O7"
+	 "L0" "L1" "L2" "L3" "L4" "L5" "L6" "L7"
+	 "I0" "I1" "I2" "I3" "I4" "I5" "I6" "I7"))
+  "The standard names for the Sparc integer registers")
+    
+(defun get-reg-name (index)
+  (if *disassem-use-lisp-reg-names*
+      (aref reg-symbols index)
+      (aref sparc-reg-symbols index)))
+
+(defvar *note-sethi-inst* nil
+  "An alist for the disassembler indicating the target register and
+value used in a SETHI instruction.  This is used to make annotations
+about function addresses and register values.")
+
+(defvar *pseudo-atomic-set* nil)
+
+(defun sign-extend-immed-value (val)
+  ;; val is a 13-bit signed number.  Extend the sign appropriately.
+  (if (logbitp 12 val)
+      (- val (ash 1 13))
+      val))
+
+(defmacro frob-names (names)
+  `(mapcar #'(lambda (n)
+	       (list (eval n) n))
+    ,names))
+
+(defmacro frob-names (names)
+  `(mapcar #'(lambda (n)
+	       `(,(eval n) ,n))
+    ,names))
+
+(macrolet
+    ((frob (&rest names)
+       (let ((results (mapcar #'(lambda (n)
+				  (let ((nn (intern (concatenate 'string (string n)
+								 "-TYPE"))))
+				    `(,(eval nn) ,nn)))
+			      names)))
+	 `(eval-when (compile load eval)
+	   (defconstant header-word-type-alist
+	     ',results)))))
+  ;; This is the same list as in objdefs.
+  (frob bignum
+	ratio
+	single-float
+	double-float
+	#+long-float long-float
+	#+double-double double-double-float
+	complex
+	complex-single-float
+	complex-double-float
+	#+long-float complex-long-float
+	#+double-double complex-double-double-float
+  
+	simple-array
+	simple-string
+	simple-bit-vector
+	simple-vector
+	simple-array-unsigned-byte-2
+	simple-array-unsigned-byte-4
+	simple-array-unsigned-byte-8
+	simple-array-unsigned-byte-16
+	simple-array-unsigned-byte-32
+	simple-array-signed-byte-8
+	simple-array-signed-byte-16
+	simple-array-signed-byte-30
+	simple-array-signed-byte-32
+	simple-array-single-float
+	simple-array-double-float
+	#+long-float simple-array-long-float
+	#+double-double simple-array-double-double-float
+	simple-array-complex-single-float
+	simple-array-complex-double-float
+	#+long-float simple-array-complex-long-float
+	#+double-double simple-array-complex-double-double-float
+	complex-string
+	complex-bit-vector
+	complex-vector
+	complex-array
+  
+	code-header
+	function-header
+	closure-header
+	funcallable-instance-header
+	byte-code-function
+	byte-code-closure
+	#-double-double dylan-function-header
+	closure-function-header
+	#-gengc return-pc-header
+	#+gengc forwarding-pointer
+	value-cell-header
+	symbol-header
+	base-char
+	sap
+	unbound-marker
+	weak-pointer
+	instance-header
+	fdefn
+	#+(or gengc gencgc) scavenger-hook))
+
+;; Look at the current instruction and see if we can't add some notes
+;; about what's happening.
+
+(defun maybe-add-notes (reg dstate)
+  (let* ((word (disassem::sap-ref-int (disassem:dstate-segment-sap dstate)
+				      (disassem:dstate-cur-offs dstate)
+				      vm:word-bytes
+				      (disassem::dstate-byte-order dstate)))
+	 (format (ldb (byte 2 30) word))
+	 (op3 (ldb (byte 6 19) word))
+	 (rs1 (ldb (byte 5 14) word))
+	 (rd (ldb (byte 5 25) word))
+	 (immed-p (not (zerop (ldb (byte 1 13) word))))
+	 (immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
+    ;; Only the value of format and rd are guaranteed to be correct
+    ;; because the disassembler is trying to print out the value of a
+    ;; register.  The other values may not be right.
+    (case format
+      (2
+       (case op3
+	 (#b000000
+	  (when (= reg rs1)
+	    (handle-add-inst rs1 immed-val rd dstate immed-p)))
+	 (#b000010
+	  (when (= reg rs1)
+	    (handle-or-inst rs1 immed-val rd dstate immed-p)))
+	 (#b000101
+	  (when (= reg rs1)
+	    (handle-andn-inst rs1 immed-val rd dstate immed-p)))
+	 (#b111000
+	  (when (= reg rs1)
+	    (handle-jmpl-inst rs1 immed-val rd dstate)))
+	 (#b010001
+	  (when (= reg rs1)
+	    (handle-andcc-inst rs1 immed-val rd dstate)))))
+      (3
+       (case op3
+	 ((#b000000 #b000100)
+	  (when (= reg rs1)
+	    (handle-ld/st-inst rs1 immed-val rd dstate))))))
+    ;; If this is not a SETHI instruction, and RD is the same as some
+    ;; register used by SETHI, we delete the entry.  (In case we have
+    ;; a SETHI without any additional instruction because the low bits
+    ;; were zero.)
+    (unless (and (zerop format) (= #b100 (ldb (byte 3 22) word)))
+      (let ((sethi (assoc rd *note-sethi-inst*)))
+	(when sethi
+	  (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))
+
+(defun handle-add-inst (rs1 immed-val rd dstate immed-p)
+  (let* ((sethi (assoc rs1 *note-sethi-inst*)))
+    (cond
+      (sethi
+       ;; RS1 was used in a SETHI instruction.  Assume that
+       ;; this is the offset part of the SETHI instruction for
+       ;; a full 32-bit address of something.  Make a note
+       ;; about this usage as a Lisp assembly routine or
+       ;; foreign routine, if possible.  If not, just note the
+       ;; final value.
+       (let ((addr (+ immed-val (ash (cdr sethi) 10))))
+	 (or (disassem::note-code-constant-absolute addr dstate)
+	     (disassem::maybe-note-assembler-routine addr t dstate)
+	     (disassem::note (format nil "~A = #x~8,'0X"
+				     (get-reg-name rd) addr)
+			     dstate)))
+       (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))
+      ((and (= rs1 null-offset) immed-p)
+       ;; We have an ADD %NULL, <n>, RD instruction.  This is a
+       ;; reference to a static symbol.
+       (disassem:maybe-note-nil-indexed-object immed-val
+					       dstate))
+      ((= rs1 alloc-offset)
+       ;; ADD %ALLOC, n.  This must be some allocation or
+       ;; pseudo-atomic stuff
+       (cond ((and immed-p
+		   (= immed-val 4)
+		   (= rd alloc-offset)
+		   (not *pseudo-atomic-set*))
+	      ;; "ADD 4, %ALLOC" sets the flag
+	      (disassem:note (intl:gettext "Set pseudo-atomic flag") dstate)
+	      (setf *pseudo-atomic-set* t))
+	     ((= rd alloc-offset)
+	      ;; "ADD n, %ALLOC" is either allocating space or
+	      ;; resetting the flag.
+	      (cond (immed-p
+		     (cond ((= immed-val -4)
+			    (disassem:note
+			     (format nil (intl:gettext "Reset pseudo-atomic"))
+			     dstate)
+			    (setf *pseudo-atomic-set* nil))
+			   (t
+			    (disassem:note
+			     (format nil (intl:gettext "Allocating ~D bytes") immed-val)
+			     dstate))))
+		    (t
+		     ;; Some other allocation
+		     (disassem:note
+			     (format nil (intl:gettext "Allocating bytes"))
+			     dstate))))))
+      ((and (= rs1 zero-offset) *pseudo-atomic-set*)
+       ;; "ADD %ZERO, num, RD" inside a pseudo-atomic is very
+       ;; likely loading up a header word.  Make a note to that
+       ;; effect.
+       (let ((type (second (assoc (logand immed-val #xff) header-word-type-alist)))
+	     (size (ldb (byte 24 8) immed-val)))
+	 (when type
+	   (disassem:note (format nil (intl:gettext "Header word ~A, size ~D?") type size)
+			  dstate)))))))
+
+(defun handle-or-inst (rs1 immed-val rd dstate immed-p)
+  (cond
+    ((= rs1 alloc-offset)
+     ;; OR %ALLOC, n.  This must be some allocation or
+     ;; pseudo-atomic stuff
+     (cond ((and immed-p
+		 (= immed-val pseudo-atomic-value)
+		 (= rd alloc-offset)
+		 (not *pseudo-atomic-set*))
+	    ;; "OR 4, %ALLOC" sets the flag
+	    (disassem:note (intl:gettext "Set pseudo-atomic flag") dstate)
+	    (setf *pseudo-atomic-set* t))))))
+
+(defun handle-andn-inst (rs1 immed-val rd dstate immed-p)
+  (cond
+    ((= rs1 alloc-offset)
+     ;; ANDN %ALLOC, n.  Resetting pseudo-atomic
+     (cond ((and immed-p
+		 (= immed-val pseudo-atomic-value)
+		 (= rd alloc-offset)
+		 *pseudo-atomic-set*)
+	    ;; "ANDN 4, %ALLOC" resets the flag
+	    ;;(format t "Got reset~%")
+	    (disassem:note (intl:gettext "Reset pseudo-atomic flag") dstate)
+	    (setf *pseudo-atomic-set* nil))))))
+
+(defun handle-jmpl-inst (rs1 immed-val rd dstate)
+  (declare (ignore rd))
+  (let* ((sethi (assoc rs1 *note-sethi-inst*)))
+    (when sethi
+      ;; RS1 was used in a SETHI instruction.  Assume that
+      ;; this is the offset part of the SETHI instruction for
+      ;; a full 32-bit address of something.  Make a note
+      ;; about this usage as a Lisp assembly routine or
+      ;; foreign routine, if possible.  If not, just note the
+      ;; final value.
+      (let ((addr (+ immed-val (ash (cdr sethi) 10))))
+	(disassem::maybe-note-assembler-routine addr t dstate)
+	(setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))
+
+(defun handle-ld/st-inst (rs1 immed-val rd dstate)
+  (declare (ignore rd))
+  ;; Got an LDUW/LD or STW instruction, with immediate offset.
+  (case rs1
+    (29
+     ;; A reference to a code constant (reg = %CODE)
+     (disassem:note-code-constant immed-val dstate))
+    (2
+     ;; A reference to a static symbol or static function (reg =
+     ;; %NULL)
+     (or (disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val
+						      dstate)
+	 (disassem:maybe-note-static-function immed-val dstate)))
+    (t
+     (let ((sethi (assoc rs1 *note-sethi-inst*)))
+       (when sethi
+	 (let ((addr (+ immed-val (ash (cdr sethi) 10))))
+	   (disassem::maybe-note-assembler-routine addr nil dstate)
+	   (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))))
+
+(defun handle-andcc-inst (rs1 immed-val rd dstate)
+  ;; ANDCC %ALLOC, 3, %ZERO instruction
+  (when (and (= rs1 alloc-offset) (= rd zero-offset) (= immed-val 3))
+    (disassem:note (intl:gettext "pseudo-atomic interrupted?") dstate)))
+	 
+(eval-when (compile load eval)
+(defun reg-arg-printer (value stream dstate)
+  (declare (stream stream) (fixnum value))
+  (let ((regname (get-reg-name value)))
+    (princ regname stream)
+    (disassem:maybe-note-associated-storage-ref value
+						'registers
+						regname
+						dstate)
+    (maybe-add-notes value dstate)))
+) ; eval-when
+      
+(disassem:define-argument-type reg
+  :printer #'reg-arg-printer)
+
+(defparameter float-reg-symbols
+  (coerce 
+   (loop for n from 0 to 63 collect (make-symbol (format nil "%F~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))))
+
+;;; The extended 6 bit floating point register encoding for the double
+;;; and long instructions of the sparc v9.
+(disassem:define-argument-type fp-ext-reg
+  :printer #'(lambda (value stream dstate)
+	       (declare (stream stream) (fixnum value))
+	       (let* (;; Decode the register number.
+		      (value (if (oddp value) (+ value 31) value))
+		      (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 22) value)
+			  (type disassem:disassem-state dstate))
+		 (+ (ash value 2) (disassem:dstate-cur-addr dstate))))
+
+(defconstant branch-conditions
+  '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc))
+
+;;; Note that these aren't the standard names for branch-conditions, I think
+;;; they're a bit more readable (e.g., "eq" instead of "e").  You could just
+;;; put a vector of the normal ones here too.
+(defconstant branch-cond-name-vec
+  (coerce branch-conditions 'vector))
+
+(disassem:define-argument-type branch-condition
+  :printer branch-cond-name-vec)
+
+(deftype branch-condition ()
+  `(member ,@branch-conditions))
+
+(defun branch-condition (condition)
+  (or (position condition branch-conditions)
+      (error (intl:gettext "Unknown branch condition: ~S~%Must be one of: ~S")
+	     condition branch-conditions)))
+
+(defconstant branch-cond-true
+  #b1000)
+
+(defconstant branch-fp-conditions
+  '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o))
+
+(defconstant branch-fp-cond-name-vec
+  (coerce branch-fp-conditions 'vector))
+
+(disassem:define-argument-type branch-fp-condition
+  :printer branch-fp-cond-name-vec)
+
+(disassem:define-argument-type call-fixup :use-label t)
+
+(deftype fp-branch-condition ()
+  `(member ,@branch-fp-conditions))
+
+(defun fp-branch-condition (condition)
+  (or (position condition branch-fp-conditions)
+      (error (intl:gettext "Unknown fp-branch condition: ~S~%Must be one of: ~S")
+	     condition branch-fp-conditions)))
+
+
+;;;; dissassem:define-instruction-formats
+
+(disassem:define-instruction-format
+    (format-1 32 :default-printer '(:name :tab disp))
+  (op   :field (byte 2 30) :value 1)
+  (disp :field (byte 30 0)))
+
+(disassem:define-instruction-format
+    (format-2-immed 32 :default-printer '(:name :tab immed ", " rd))
+  (op    :field (byte 2 30) :value 0)
+  (rd    :field (byte 5 25) :type 'reg)
+  (op2   :field (byte 3 22))
+  (immed :field (byte 22 0)))
+
+(defconstant branch-printer
+  `(:name (:unless (:constant ,branch-cond-true) cond)
+	  (:unless (a :constant 0) "," 'A)
+	  :tab
+	  disp))
+
+(disassem:define-instruction-format
+    (format-2-branch 32 :default-printer branch-printer)
+  (op   :field (byte 2 30) :value 0)
+  (a    :field (byte 1 29) :value 0)
+  (cond :field (byte 4 25) :type 'branch-condition)
+  (op2  :field (byte 3 22))
+  (disp :field (byte 22 0) :type 'relative-label))
+
+;; Branch with prediction instruction for V9
+
+;; Currently only %icc and %xcc are used of the four possible values
+
+(defconstant integer-condition-registers
+  '(:icc :reserved :xcc :reserved))
+
+(defconstant integer-cond-reg-name-vec
+  (coerce integer-condition-registers 'vector))
+
+(deftype integer-condition-register ()
+  `(member ,@(remove :reserved integer-condition-registers)))
+
+(defparameter integer-condition-reg-symbols
+  (map 'vector
+       #'(lambda (name)
+	   (make-symbol (concatenate 'string "%" (string name))))
+       integer-condition-registers))
+
+(disassem:define-argument-type integer-condition-register
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((regname (aref integer-condition-reg-symbols value)))
+		   (princ regname stream))))
+
+(defconstant branch-predictions
+  '(:pn :pt))
+
+(defconstant branch-predictions-name-vec
+  (coerce branch-predictions 'vector))
+
+(disassem:define-argument-type branch-prediction
+    :printer branch-predictions-name-vec)
+
+(defun integer-condition (condition-reg)
+  (declare (type (member :icc :xcc) condition-reg))
+  (or (position condition-reg integer-condition-registers)
+      (error (intl:gettext "Unknown integer condition register:  ~S~%")
+	     condition-reg)))
+
+(defun branch-prediction (pred)
+  (or (position pred branch-predictions)
+      (error (intl:gettext "Unknown branch prediction:  ~S~%Must be one of: ~S~%")
+	     pred branch-predictions)))
+
+(defconstant branch-pred-printer
+  `(:name (:unless (:constant ,branch-cond-true) cond)
+	  (:unless (a :constant 0) "," 'A)
+          (:unless (p :constant 1) "," 'pn)
+	  :tab
+	  cc
+	  ", "
+	  disp))
+
+(disassem:define-instruction-format
+    (format-2-branch-pred 32 :default-printer branch-pred-printer)
+  (op   :field (byte 2 30) :value 0)
+  (a    :field (byte 1 29) :value 0)
+  (cond :field (byte 4 25) :type 'branch-condition)
+  (op2  :field (byte 3 22))
+  (cc   :field (byte 2 20) :type 'integer-condition-register)
+  (p    :field (byte 1 19))
+  (disp :field (byte 19 0) :type 'relative-label))
+
+(defconstant fp-condition-registers
+  '(:fcc0 :fcc1 :fcc2 :fcc3))
+
+(defconstant fp-cond-reg-name-vec
+  (coerce fp-condition-registers 'vector))
+
+(defparameter fp-condition-reg-symbols
+  (map 'vector
+       #'(lambda (name)
+	   (make-symbol (concatenate 'string "%" (string name))))
+       fp-condition-registers))
+
+(disassem:define-argument-type fp-condition-register
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((regname (aref fp-condition-reg-symbols value)))
+		   (princ regname stream))))
+
+(disassem:define-argument-type fp-condition-register-shifted
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((regname (aref fp-condition-reg-symbols (ash value -1))))
+		   (princ regname stream))))
+
+(defun fp-condition (condition-reg)
+  (or (position condition-reg fp-condition-registers)
+      (error "Unknown integer condition register:  ~S~%"
+	     condition-reg)))
+
+(defconstant fp-branch-pred-printer
+  `(:name (:unless (:constant ,branch-cond-true) cond)
+	  (:unless (a :constant 0) "," 'A)
+	  (:unless (p :constant 1) "," 'pn)
+	  :tab
+	  fcc
+	  ", "
+	  disp))
+  
+(disassem:define-instruction-format
+    (format-2-fp-branch-pred 32 :default-printer fp-branch-pred-printer)
+  (op   :field (byte 2 30) :value 0)
+  (a    :field (byte 1 29) :value 0)
+  (cond :field (byte 4 25) :type 'branch-fp-condition)
+  (op2  :field (byte 3 22))
+  (fcc  :field (byte 2 20) :type 'fp-condition-register)
+  (p    :field (byte 1 19))
+  (disp :field (byte 19 0) :type 'relative-label))
+  
+
+
+(disassem:define-instruction-format
+    (format-2-unimp 32 :default-printer '(:name :tab data))
+  (op     :field (byte 2 30) :value 0)
+  (ignore :field (byte 5 25) :value 0)
+  (op2    :field (byte 3 22) :value 0)
+  (data   :field (byte 22 0)))
+
+(defconstant f3-printer
+  '(:name :tab
+	  (:unless (:same-as rd) rs1 ", ")
+	  (:choose rs2 immed) ", "
+	  rd))
+
+(disassem:define-instruction-format
+    (format-3-reg 32 :default-printer f3-printer)
+  (op  :field (byte 2 30))
+  (rd  :field (byte 5 25) :type 'reg)
+  (op3 :field (byte 6 19))
+  (rs1 :field (byte 5 14) :type 'reg)
+  (i   :field (byte 1 13) :value 0)
+  (asi :field (byte 8 5)  :value 0)
+  (rs2 :field (byte 5 0)  :type 'reg))
+
+(disassem:define-instruction-format
+    (format-3-immed 32 :default-printer f3-printer)
+  (op    :field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3   :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 1)
+  (immed :field (byte 13 0) :sign-extend t))	; usually sign extended
+
+(disassem:define-instruction-format
+    (format-binary-fpop 32
+     :default-printer '(:name :tab rs1 ", " rs2 ", " rd))
+  (op	:field (byte 2 30))
+  (rd 	:field (byte 5 25) :type 'fp-reg)
+  (op3  :field (byte 6 19))
+  (rs1  :field (byte 5 14) :type 'fp-reg)
+  (opf  :field (byte 9 5))
+  (rs2  :field (byte 5 0) :type 'fp-reg))
+
+;;; Floating point load/save instructions encoding.
+(disassem:define-instruction-format
+    (format-unary-fpop 32 :default-printer '(:name :tab rs2 ", " rd))
+  (op	:field (byte 2 30))
+  (rd 	:field (byte 5 25) :type 'fp-reg)
+  (op3  :field (byte 6 19))
+  (rs1  :field (byte 5 14) :value 0)
+  (opf  :field (byte 9 5))
+  (rs2  :field (byte 5 0) :type 'fp-reg))
+
+;;; Floating point comparison instructions encoding.
+
+;; This is a merge of the instructions for FP comparison and FP
+;; conditional moves available in the Sparc V9.  The main problem is
+;; that the new instructions use part of the opcode space used by the
+;; comparison instructions.  In particular, the OPF field is arranged
+;; as so:
+;;
+;; Bit          1       0
+;;              3       5
+;; FMOVcc	0nn0000xx	%fccn
+;;		1000000xx	%icc
+;;		1100000xx	%xcc
+;; FMOVR	0ccc001yy
+;; FCMP		001010zzz
+;;
+;; So we see that if we break up the OPF field into 4 pieces, opf0,
+;; opf1, opf2, and opf3, we can distinguish between these
+;; instructions. So bit 9 (opf2) can be used to distinguish between
+;; FCMP and the rest.  Also note that the nn field overlaps with the
+;; ccc.  We need to take this into account as well.
+;;
+(disassem:define-instruction-format
+    (format-fpop2 32
+		  :default-printer #-sparc-v9 '(:name :tab rs1 ", " rs2)
+		                   #+sparc-v9 '(:name :tab rd ", " rs1 ", " rs2))
+  (op	:field (byte 2 30))
+  (rd 	:field (byte 5 25) :value 0)
+  (op3  :field (byte 6 19))
+  (rs1  :field (byte 5 14))
+  (opf0 :field (byte 1 13))
+  (opf1 :field (byte 3 10))
+  (opf2 :field (byte 1 9))
+  (opf3 :field (byte 4 5))
+  (rs2  :field (byte 5 0) :type 'fp-reg))
+
+;;; Shift instructions
+(disassem:define-instruction-format
+    (format-3-shift-reg 32 :default-printer f3-printer)
+  (op	:field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3  :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 0)
+  (x     :field (byte 1 12))
+  (asi   :field (byte 7 5) :value 0)
+  (rs2   :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (format-3-shift-immed 32 :default-printer f3-printer)
+  (op	:field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3  :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 1)
+  (x     :field (byte 1 12))
+  (immed :field (byte 12 0) :sign-extend nil))
+
+
+;;; Conditional moves (only available for Sparc V9 architectures)
+
+;; The names of all of the condition registers on the V9: 4 FP
+;; conditions, the original integer condition register and the new
+;; extended register.  The :reserved register is reserved on the V9.
+
+(defconstant cond-move-condition-registers
+  '(:fcc0 :fcc1 :fcc2 :fcc3 :icc :reserved :xcc :reserved))
+(defconstant cond-move-cond-reg-name-vec
+  (coerce cond-move-condition-registers 'vector))
+
+(deftype cond-move-condition-register ()
+    `(member ,@(remove :reserved cond-move-condition-registers)))
+
+(defparameter cond-move-condition-reg-symbols
+  (map 'vector
+       #'(lambda (name)
+	   (make-symbol (concatenate 'string "%" (string name))))
+       cond-move-condition-registers))
+
+(disassem:define-argument-type cond-move-condition-register
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((regname (aref cond-move-condition-reg-symbols value)))
+		   (princ regname stream))))
+
+;; From the given condition register, figure out what the cc2, cc1,
+;; and cc0 bits should be.  Return cc2 and cc1/cc0 concatenated.
+(defun cond-move-condition-parts (condition-reg)
+  (let ((posn (position condition-reg cond-move-condition-registers)))
+    (if posn
+	(truncate posn 4)
+	(error (intl:gettext "Unknown conditional move condition register:  ~S~%")
+	       condition-reg))))
+
+(defun cond-move-condition (condition-reg)
+  (or (position condition-reg cond-move-condition-registers)
+      (error (intl:gettext "Unknown conditional move condition register:  ~S~%") condition-reg)))
+
+(defconstant cond-move-printer
+  `(:name cond :tab
+          cc ", " (:choose immed rs2) ", " rd))
+
+;; Conditional move integer register on integer or FP condition code
+(disassem:define-instruction-format
+    (format-4-cond-move 32 :default-printer cond-move-printer)
+  (op	:field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3  :field (byte 6 19))
+  (cc2   :field (byte 1 18) :value 1)
+  (cond  :field (byte 4 14) :type 'branch-condition)
+  (i     :field (byte 1 13) :value 0)
+  (cc    :field (byte 2 11) :type 'integer-condition-register)
+  (empty :field (byte 6 5) :value 0)
+  (rs2   :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (format-4-cond-move-immed 32 :default-printer cond-move-printer)
+  (op    :field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3   :field (byte 6 19))
+  (cc2   :field (byte 1 18) :value 1)
+  (cond  :field (byte 4 14) :type 'branch-condition)
+  (i     :field (byte 1 13) :value 1)
+  (cc    :field (byte 2 11) :type 'integer-condition-register)
+  (immed :field (byte 11 0) :sign-extend t))
+
+;; Floating-point versions of the above integer conditional moves
+(defconstant cond-fp-move-printer
+  `(:name rs1 :tab opf1 ", " rs2 ", " rd))
+
+;;; Conditional move on integer register condition (only on Sparc
+;;; V9). That is, move an integer register if some other integer
+;;; register satisfies some condition.
+
+(defconstant cond-move-integer-conditions
+  '(:reserved :z :lez :lz :reserved :nz :gz :gez))
+(defconstant cond-move-integer-condition-vec
+  (coerce cond-move-integer-conditions 'vector))
+
+(deftype cond-move-integer-condition ()
+  `(member ,@(remove :reserved cond-move-integer-conditions)))
+
+(disassem:define-argument-type register-condition
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((regname (aref cond-move-integer-condition-vec value)))
+		   (princ regname stream))))
+
+(defconstant cond-move-integer-printer
+  `(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd))
+
+(defun register-condition (rcond)
+  (or (position rcond cond-move-integer-conditions)
+      (error (intl:gettext "Unknown register condition:  ~S~%") rcond)))
+
+(disassem:define-instruction-format
+    (format-4-cond-move-integer 32 :default-printer cond-move-integer-printer)
+  (op    :field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3   :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 0)
+  (rcond :field (byte 3 10) :type 'register-condition)
+  (opf   :field (byte 5 5))
+  (rs2   :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (format-4-cond-move-integer-immed 32 :default-printer cond-move-integer-printer)
+  (op    :field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3   :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 1)
+  (rcond :field (byte 3 10) :type 'register-condition)
+  (immed :field (byte 10 0) :sign-extend t))
+
+(defconstant trap-printer
+  `(:name rd :tab cc ", " rs1 "+" rs2))
+
+(defconstant trap-immed-printer
+  `(:name rd :tab cc ", " (:unless (rs1 :constant 0) rs1 "+") immed))
+
+
+(disassem:define-instruction-format
+    (format-4-trap-immed 32 :default-printer trap-immed-printer)
+  (op    :field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3   :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 1)
+  (cc    :field (byte 2 11) :type 'integer-condition-register)
+  (immed :field (byte 11 0)))
+
+
+(disassem:define-instruction-format
+    (format-4-trap 32 :default-printer trap-printer)
+  (op    :field (byte 2 30))
+  (rd    :field (byte 5 25) :type 'reg)
+  (op3   :field (byte 6 19))
+  (rs1   :field (byte 5 14) :type 'reg)
+  (i     :field (byte 1 13) :value 0)
+  (cc    :field (byte 2 11) :type 'integer-condition-register)
+  (rs2   :field (byte 11 0) :type 'reg))
+
+
+(defconstant cond-fp-move-integer-printer
+  `(:name opf1 :tab rs1 ", " rs2 ", " rd))
+
+
+;;;; Primitive emitters.
+
+(define-emitter emit-word 32
+  (byte 32 0))
+
+(define-emitter emit-short 16
+  (byte 16 0))
+
+(define-emitter emit-format-1 32
+  (byte 2 30) (byte 30 0))
+
+(define-emitter emit-format-2-immed 32
+  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
+
+(define-emitter emit-format-2-branch 32
+  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))
+
+;; Integer and FP branches with prediction for V9
+(define-emitter emit-format-2-branch-pred 32
+  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
+(define-emitter emit-format-2-fp-branch-pred 32
+  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
+  
+(define-emitter emit-format-2-unimp 32
+  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
+
+(define-emitter emit-format-3-reg 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
+  (byte 5 0))
+
+(define-emitter emit-format-3-immed 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))
+
+(define-emitter emit-format-3-fpop 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))
+
+(define-emitter emit-format-3-fpop2 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14)
+  (byte 1 13) (byte 3 10) (byte 1 9) (byte 4 5)
+  (byte 5 0))
+
+;;; Shift instructions
+
+(define-emitter emit-format-3-shift-reg 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 7 5)
+  (byte 5 0))
+
+(define-emitter emit-format-3-shift-immed 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 12 0))
+
+;;; Conditional moves
+
+;; Conditional move in condition code
+(define-emitter emit-format-4-cond-move 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 1 18) (byte 4 14) (byte 1 13) (byte 2 11)
+  (byte 11 0))
+
+;; Conditional move on integer condition
+(define-emitter emit-format-4-cond-move-integer 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10) (byte 5 5)
+  (byte 5 0))
+
+(define-emitter emit-format-4-cond-move-integer-immed 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10)
+  (byte 10 0))
+
+(define-emitter emit-format-4-trap 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 2 11)
+  (byte 11 0))
+  
+
+;;;; Most of the format-3-instructions.
+
+(defun emit-format-3-inst (segment op op3 dst src1 src2
+				   &key load-store fixup dest-kind)
+  (unless src2
+    (cond ((and (typep src1 'tn) load-store)
+	   (setf src2 0))
+	  (t
+	   (setf src2 src1)
+	   (setf src1 dst))))
+  (etypecase src2
+    (tn
+     (emit-format-3-reg segment op
+			(if dest-kind
+			    (fp-reg-tn-encoding dst)
+			    (reg-tn-encoding dst))
+			op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
+    (integer
+     (emit-format-3-immed segment op
+			  (if dest-kind
+			      (fp-reg-tn-encoding dst)
+			      (reg-tn-encoding dst))
+			  op3 (reg-tn-encoding src1) 1 src2))
+    (fixup
+     (unless (or load-store fixup)
+       (error (intl:gettext "Fixups aren't allowed.")))
+     (note-fixup segment :add src2)
+     (emit-format-3-immed segment op
+			  (if dest-kind
+			      (fp-reg-tn-encoding dst)
+			      (reg-tn-encoding dst))
+			  op3 (reg-tn-encoding src1) 1 0))))
+
+;;; Shift instructions because an extra bit is used in Sparc V9's to
+;;; indicate whether the shift is a 32-bit or 64-bit shift.
+;;;
+(defun emit-format-3-shift-inst (segment op op3 dst src1 src2 &key extended)
+  (unless src2
+    (setf src2 src1)
+    (setf src1 dst))
+  (etypecase src2
+    (tn
+     (emit-format-3-shift-reg segment op (reg-tn-encoding dst)
+			      op3 (reg-tn-encoding src1) 0 (if extended 1 0)
+			      0 (reg-tn-encoding src2)))
+    (integer
+     (emit-format-3-shift-immed segment op (reg-tn-encoding dst)
+				op3 (reg-tn-encoding src1) 1
+				(if extended 1 0) src2))))
+
+
+(eval-when (compile eval)
+
+;;; have to do this because defconstant is evalutated in the null lex env.
+(defmacro with-ref-format (printer)
+  `(let* ((addend
+	   '(:choose (:plus-integer immed) ("+" rs2)))
+	  (ref-format
+	   `("[" rs1 (:unless (:constant 0) ,addend) "]"
+	     (:choose (:unless (:constant 0) asi) nil))))
+     ,printer))
+
+(defconstant load-printer
+  (with-ref-format `(:NAME :TAB ,ref-format ", " rd)))
+
+(defconstant store-printer
+  (with-ref-format `(:NAME :TAB rd ", " ,ref-format)))
+
+(defmacro define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
+			       (printer :default) reads writes flushable print-name)
+  (let ((printer
+	 (if (eq printer :default)
+	     (case load-store
+	       ((nil) :default)
+	       ((:load t) 'load-printer)
+	       (:store 'store-printer))
+	     printer)))
+    (when (and (atom reads) (not (null reads)))
+      (setf reads (list reads)))
+    (when (and (atom writes) (not (null writes)))
+       (setf writes (list writes)))
+    `(define-instruction ,name (segment dst src1 &optional src2)
+       (:declare (type tn dst)
+		 ,(if (or fixup load-store)
+		      '(type (or tn (signed-byte 13) null fixup) src1 src2)
+		      '(type (or tn (signed-byte 13) null) src1 src2)))
+       (:printer format-3-reg
+		 ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
+	 	 ,printer
+	         ,@(when print-name `(:print-name ,print-name)))
+       (:printer format-3-immed
+	 	 ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
+	 	 ,printer
+	         ,@(when print-name `(:print-name ,print-name)))
+       ,@(when flushable
+	   '((:attributes flushable)))
+       (:dependencies
+	(reads src1)
+	,@(let ((reads-list nil))
+	    (dolist (read reads)
+	      (push (list 'reads read) reads-list))
+	    reads-list)
+	,@(cond ((eq load-store :store)
+		 '((reads dst)
+		   (if src2 (reads src2))))
+		 ((eq load-store t)
+		  '((reads :memory)
+		    (reads dst)
+		    (if src2 (reads src2))))
+		((eq load-store :load)
+		 '((reads :memory)
+		   (if src2 (reads src2) (reads dst))))
+		(t
+		 '((if src2 (reads src2) (reads dst)))))
+	,@(let ((writes-list nil))
+	    (dolist (write writes)
+	      (push (list 'writes write) writes-list))
+	    writes-list)
+	,@(cond ((eq load-store :store)
+		 '((writes :memory :partially t)))
+		((eq load-store t)
+		 '((writes :memory :partially t)
+		   (writes dst)))
+		((eq load-store :load)
+		 '((writes dst)))
+		(t
+		 '((writes dst)))))
+       (:delay 0)
+       (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
+				     :load-store ,load-store
+				     :fixup ,fixup
+				     :dest-kind (not (eq ',dest-kind 'reg)))))))
+
+(defmacro define-f3-shift-inst (name op op3 &key extended)
+  `(define-instruction ,name (segment dst src1 &optional src2)
+     (:declare (type tn dst)
+	       (type (or tn (unsigned-byte 6) null) src1 src2))
+     (:printer format-3-shift-reg
+	       ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0)))
+     (:printer format-3-shift-immed
+	       ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1)))
+     (:dependencies
+      (reads src1)
+      (if src2 (reads src2) (reads dst))
+      (writes dst))
+     (:delay 0)
+     (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2
+					 :extended ,extended))))
+
+) ; eval-when (compile eval)
+
+(define-f3-inst ldsb #b11 #b001001 :load-store :load)
+(define-f3-inst ldsh #b11 #b001010 :load-store :load)
+(define-f3-inst ldub #b11 #b000001 :load-store :load)
+(define-f3-inst lduh #b11 #b000010 :load-store :load)
+
+;; This instruction is called lduw for V9 , but looks exactly like ld
+;; on previous architectures.
+(define-f3-inst ld #b11 #b000000 :load-store :load
+		#+sparc-v9 :print-name #+sparc-v9 'lduw)
+
+;; The code sometimes uses ldsw and lduw.  LDSW is a real instruction
+;; for V9 that sign-extends a 32-bit load.  LDUW is the same as LD.
+;; For non-V9, we define macros to replace these with the equivalent
+;; instruction (LD) since sign-extending and zero-extending a 32-bit
+;; value in a 32-bit register is the same.
+#+sparc-v9
+(progn
+  (define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9
+  (define-instruction-macro lduw (&rest args)
+    `(inst ld ,@args)))
+
+#-sparc-v9
+(progn
+  (define-instruction-macro ldsw (&rest args)
+    `(inst ld ,@args))
+  (define-instruction-macro lduw (&rest args)
+    `(inst ld ,@args)))
+
+
+;; ldd is deprecated on the Sparc V9.
+(define-f3-inst ldd #b11 #b000011 :load-store :load)
+
+(define-f3-inst ldx #b11 #b001011 :load-store :load) ; v9
+
+(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
+(define-f3-inst lddf #b11 #b100011 :dest-kind fp-ext-reg :load-store :load )
+(define-f3-inst ldqf #b11 #b100010 :dest-kind fp-ext-reg :load-store :load)	; v9
+(define-f3-inst stb #b11 #b000101 :load-store :store)
+(define-f3-inst sth #b11 #b000110 :load-store :store)
+(define-f3-inst st #b11 #b000100 :load-store :store)
+
+;; std is deprecated on the Sparc V9.
+(define-f3-inst std #b11 #b000111 :load-store :store)
+
+(define-f3-inst stx #b11 #b001110 :load-store :store) ; v9
+
+(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
+(define-f3-inst stdf #b11 #b100111 :dest-kind fp-ext-reg :load-store :store)
+(define-f3-inst stqf #b11 #b100110 :dest-kind fp-ext-reg :load-store :store) ; v9
+(define-f3-inst ldstub #b11 #b001101 :load-store t)
+
+;; swap is deprecated on the Sparc V9
+(define-f3-inst swap #b11 #b001111 :load-store t)
+
+(define-f3-inst add #b10 #b000000 :fixup t)
+(define-f3-inst addcc #b10 #b010000 :writes :psr)
+(define-f3-inst addx #b10 #b001000 :reads :psr)
+(define-f3-inst addxcc #b10 #b011000 :reads :psr :writes :psr)
+(define-f3-inst taddcc #b10 #b100000 :writes :psr)
+
+;; taddcctv is deprecated on the Sparc V9.  Use taddcc and bpvs or
+;; taddcc and trap to get a similar effect.  (Requires changing the C
+;; code though!)
+;;(define-f3-inst taddcctv #b10 #b100010 :writes :psr)
+
+(define-f3-inst sub #b10 #b000100)
+(define-f3-inst subcc #b10 #b010100 :writes :psr)
+(define-f3-inst subx #b10 #b001100 :reads :psr)
+(define-f3-inst subxcc #b10 #b011100 :reads :psr :writes :psr)
+(define-f3-inst tsubcc #b10 #b100001 :writes :psr)
+
+;; tsubcctv is deprecated on the Sparc V9.  Use tsubcc and bpvs or
+;; tsubcc and trap to get a similar effect.  (Requires changing the C
+;; code though!)
+;;(define-f3-inst tsubcctv #b10 #b100011 :writes :psr)
+
+(define-f3-inst mulscc #b10 #b100100 :reads :y :writes (:psr :y))
+(define-f3-inst and #b10 #b000001)
+(define-f3-inst andcc #b10 #b010001 :writes :psr)
+(define-f3-inst andn #b10 #b000101)
+(define-f3-inst andncc #b10 #b010101 :writes :psr)
+(define-f3-inst or #b10 #b000010)
+(define-f3-inst orcc #b10 #b010010 :writes :psr)
+(define-f3-inst orn #b10 #b000110)
+(define-f3-inst orncc #b10 #b010110 :writes :psr)
+(define-f3-inst xor #b10 #b000011)
+(define-f3-inst xorcc #b10 #b010011 :writes :psr)
+(define-f3-inst xnor #b10 #b000111)
+(define-f3-inst xnorcc #b10 #b010111 :writes :psr)
+
+(define-f3-shift-inst sll #b10 #b100101)
+(define-f3-shift-inst srl #b10 #b100110)
+(define-f3-shift-inst sra #b10 #b100111)
+(define-f3-shift-inst sllx #b10 #b100101 :extended t)	; v9
+(define-f3-shift-inst srlx #b10 #b100110 :extended t)	; v9
+(define-f3-shift-inst srax #b10 #b100111 :extended t)	; v9
+
+(define-f3-inst save #b10 #b111100 :reads :psr :writes :psr)
+(define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr)
+
+;; smul, smulcc, umul, umulcc, sdiv, sdivcc, udiv, and udivcc are
+;; deprecated on the Sparc V9.  Use mulx, sdivx, and udivx instead.
+(define-f3-inst smul #b10 #b001011 :writes :y)			; v8
+(define-f3-inst smulcc #b10 #b011011 :writes (:psr :y))		; v8
+(define-f3-inst umul #b10 #b001010 :writes :y)			; v8
+(define-f3-inst umulcc #b10 #b011010 :writes (:psr :y))		; v8
+(define-f3-inst sdiv #b10 #b001111 :reads :y)			; v8
+(define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr)	; v8
+(define-f3-inst udiv #b10 #b001110 :reads :y)			; v8
+(define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr)	; v8
+
+(define-f3-inst mulx #b10 #b001001)	; v9 for both signed and unsigned
+(define-f3-inst sdivx #b10 #b101101)	; v9
+(define-f3-inst udivx #b10 #b001101)	; v9
+
+(define-f3-inst popc #b10 #b101110)	; v9: count one bits
+
+
+;;;; Random instructions.
+
+;; ldfsr is deprecated on the Sparc V9.  Use ldxfsr instead
+(define-instruction ldfsr (segment src1 src2)
+  (:declare (type tn src1) (type (signed-byte 13) src2))
+  (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 0)))
+  :pinned
+  (:delay 0)
+  (:emitter (emit-format-3-immed segment #b11 0 #b100001
+				 (reg-tn-encoding src1) 1 src2)))
+
+#+sparc-64
+(define-instruction ldxfsr (segment src1 src2)
+  (:declare (type tn src1) (type (signed-byte 13) src2))
+  (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 1))
+	    '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR")
+	    :print-name 'ldx)
+  :pinned
+  (:delay 0)
+  (:emitter (emit-format-3-immed segment #b11 1 #b100001
+				 (reg-tn-encoding src1) 1 src2)))
+  
+;; stfsr is deprecated on the Sparc V9.  Use stxfsr instead.
+(define-instruction stfsr (segment src1 src2)
+  (:declare (type tn src1) (type (signed-byte 13) src2))
+  (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 0)))
+  :pinned
+  (:delay 0)
+  (:emitter (emit-format-3-immed segment #b11 0 #b100101 
+				 (reg-tn-encoding src1) 1 src2)))
+
+#+sparc-64
+(define-instruction stxfsr (segment src1 src2)
+  (:declare (type tn src1) (type (signed-byte 13) src2))
+  (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 1))
+	    '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]")
+	    :print-name 'stx)
+  :pinned
+  (:delay 0)
+  (:emitter (emit-format-3-immed segment #b11 1 #b100101 
+				 (reg-tn-encoding src1) 1 src2)))
+
+(eval-when (compile load eval)
+  (defun sethi-arg-printer (value stream dstate)
+    (format stream "%hi(#x~8,'0x)" (ash value 10))
+    ;; Save the immediate value and the destination register from this
+    ;; sethi instruction.  This is used later to print some possible
+    ;; notes about the value loaded by sethi.
+    (let* ((word (disassem::sap-ref-int (disassem:dstate-segment-sap dstate)
+					(disassem:dstate-cur-offs dstate)
+					vm:word-bytes
+					(disassem::dstate-byte-order dstate)))
+	   (imm22 (ldb (byte 22 0) word))
+	   (rd (ldb (byte 5 25) word)))
+      (push (cons rd imm22) *note-sethi-inst*)
+      ))
+) ; eval-when (compile load eval)
+
+(define-instruction sethi (segment dst src1)
+  (:declare (type tn dst)
+	    (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
+  (:printer format-2-immed
+            ((op2 #b100) (immed nil :printer #'sethi-arg-printer)))
+  (:dependencies (writes dst))
+  (:delay 0)
+  (:emitter
+   (etypecase src1
+     (integer
+      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
+				 src1))
+     (fixup
+      (note-fixup segment :sethi src1)
+      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
+			   
+;; rdy is deprecated on the Sparc V9.  It's not needed with 64-bit
+;; registers.
+(define-instruction rdy (segment dst)
+  (:declare (type tn dst))
+  (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 0) (rs2 0))
+            '('RD :tab '%Y ", " rd))
+  (:dependencies (reads :y) (writes dst))
+  (:delay 0)
+  (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000
+				 0 0 0)))
+
+(defconstant wry-printer
+  '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y))
+
+;; wry is deprecated on the Sparc V9.  It's not needed with 64-bit
+;; registers.
+(define-instruction wry (segment src1 &optional src2)
+  (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
+  (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
+  (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
+  (:dependencies (reads src1) (if src2 (reads src2)) (writes :y))
+  (:delay 3)
+  (:emitter
+   (etypecase src2
+     (null 
+      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
+     (tn
+      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
+			 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
+			   src2)))))
+
+;; Read the tick register available on sparc v9
+(define-instruction rdtick (segment dst)
+  (:declare (type tn dst))
+  (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 4) (rs2 0))
+            '('RD :tab '%TICK ", " rd))
+  (:dependencies (reads :tick) (writes dst))
+  (:delay 0)
+  (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000
+				 4 0 0)))
+
+;; Sparc-v9 Compare and Swap instructions
+
+(defconstant immediate-asi-alist
+  '((:asi_aiup . #x10)			; ASI_AS_IF_USER_PRIMARY
+    (:asi_aius . #x11)			; ASI_AS_IF_USER_SECONDARY
+    (:asi_aiup_l . #x18)		; ASI_AS_IF_USER_PRIMARY_LITTLE
+    (:asi_aius_l . #x19)		; ASI_AS_IF_USER_SECONDARY_LITTLE
+    (:asi_p . #x80)			; ASI_PRIMARY
+    (:asi_s . #x81)			; ASI_SECONDARY
+    (:asi_pnf . #x82)			; ASI_PRIMARY_NOFAULT
+    (:asi_snf . #x83)			; ASI_SECONDARY_NOFAULT
+    (:asi_p_l . #x88)			; ASI_PRIMARY_LITTLE
+    (:asi_s_l . #x89)			; ASI_SECONDARY_LITTLE
+    (:asi_pnf_l . #x8a)			; ASI_PRIMARY_NOFAULT_LITTLE
+    (:asi_snf_l . #x8b)))		; ASI_SECONDARY_NOFAULT_LITTLE
+
+(deftype immediate-asi ()
+  `(member ,@(mapcar #'car immediate-asi-alist)))
+
+(disassem:define-argument-type immediate-asi
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((symbolic (rassoc value immediate-asi-alist)))
+		   (if symbolic
+		       (format stream "#~A" (car symbolic))
+		       (format stream "~D" value)))))
+
+(defconstant compare-swap-asi-printer
+  `(:name :tab "[" rs1 "]" '%asi
+	  ", "
+	  rs2
+	  ", "
+	  rd))
+
+(defconstant compare-swap-immed-asi-printer
+  `(:name :tab "[" rs1 "]"
+	  asi
+	  ", "
+	  rs2
+	  ", "
+	  rd))
+	  
+(macrolet
+    ((cas (name op3)
+     `(define-instruction ,name (segment dst src1 src2 &key immed-asi)
+	(:declare (type tn dst src1 src2)
+		  (type (or null (unsigned-byte 8) immediate-asi) immed-asi))
+	(:printer format-3-reg
+		  ((op #b11) (op3 ,op3) (i 1) (asi nil))
+		  compare-swap-asi-printer
+		  )
+	(:printer format-3-reg
+		  ((op #b11) (op3 ,op3) (i 0) (asi nil :type 'immediate-asi))
+		  compare-swap-immed-asi-printer
+		  )
+	(:dependencies (reads src1)
+		       (reads src2)
+		       (reads dst)
+		       (reads :memory)
+		       (writes dst)
+		       (writes :memory))
+	(:delay 0)
+	(:emitter
+	 (let ((asi-value (if immed-asi
+			      (if (integerp immed-asi)
+				  immed-asi
+				  (cdr (assoc immed-asi immediate-asi-alist))))))
+	   (emit-format-3-reg segment #b11 (reg-tn-encoding dst) ,op3
+			      (reg-tn-encoding src1)
+			      (if immed-asi 0 1)
+			      (or asi-value 0)
+			      (reg-tn-encoding src2)))))))
+  ;; 32-bit compre and swap
+  (cas casa  #b111100)
+  ;; 64-bit compare and swap
+  (cas casxa #b111110))
+
+;; Prefetch
+(defconstant prefetch-type-alist
+  '((:n_reads . 0)
+    (:one_read . 1)
+    (:n_writes . 2)
+    (:one_write . 3)
+    (:page . 4)))
+
+(deftype prefetch-type ()
+  `(member ,@(mapcar #'car prefetch-type-alist)))
+
+(disassem:define-argument-type prefetch-fcn
+    :printer #'(lambda (value stream dstate)
+		 (declare (stream stream) (fixnum value) (ignore dstate))
+		 (let ((symbolic (rassoc value prefetch-type-alist)))
+		   (if symbolic
+		       (format stream "#~A" (car symbolic))
+		       (format stream "~D" value)))))
+
+(define-instruction prefetch (segment fcn src1 src2)
+  (:declare (type tn src1)
+	    (type (or tn (signed-byte 13)) src2)
+	    (type (or (unsigned-byte 5) prefetch-type) fcn))
+  (:printer format-3-reg
+	    ((op #b11) (op3 #b101101) (i 0) (rd nil :type 'prefetch-fcn))
+	    load-printer)
+  (:printer format-3-immed
+	    ((op #b11) (op3 #b101101) (i 1) (rd nil :type 'prefetch-fcn))
+	    load-printer)
+  (:delay 0)
+  (:emitter
+   (let ((fcn-type (if (integerp fcn)
+		       fcn
+		       (cdr (assoc fcn prefetch-type-alist)))))
+     (etypecase src2
+       (tn
+	(emit-format-3-reg segment #b11 fcn-type #b101101
+			   (reg-tn-encoding src1)
+			   0 0
+			   (reg-tn-encoding src2)))
+       (integer
+	(emit-format-3-immed segment #b11 fcn-type #b101101
+			     (reg-tn-encoding src1)
+			     1
+			     src2))))))
+
+;;; Some synthetic instructions
+
+;; Sign-extend a 32-bit number to 64 bits.  (Basically sra rs1, %g0,
+;; rd).
+(define-instruction signx (segment dst &optional src)
+  (:declare (type tn dst)
+	    (type (or null tn) src))
+  (:printer format-3-shift-reg
+	    ((op #b10) (op3 #b100111) (x 0) (i 0) (rs2 0))
+	    '(:name :tab (:unless (:same-as rd) rs1 ", ") rd))
+  (:dependencies
+   (if src (reads src) (reads dst))
+   (writes dst))
+  (:delay 0)
+  (:emitter
+   (unless src
+     (setf src dst))
+   (emit-format-3-shift-inst segment #b10 #b100111 dst src zero-tn))
+  )
+
+;; Zero-extend (clear upper part of word) a 32-bit number to 64 bits.
+;; (Basically srl rs1, %g0, rd)
+(define-instruction clruw (segment dst &optional src)
+  (:declare (type tn dst)
+	    (type (or null tn) src))
+  (:printer format-3-shift-reg
+	    ((op #b10) (op3 #b100110) (x 0) (i 0) (rs2 0))
+	    '(:name :tab (:unless (:same-as rd) rs1 ", ") rd))
+  (:dependencies
+   (if src (reads src) (reads dst))
+   (writes dst))
+  (:delay 0)
+  (:emitter
+   (unless src
+     (setf src dst))
+   (emit-format-3-shift-inst segment #b10 #b100110 dst src zero-tn))
+  )
+
+
+(defun snarf-error-junk (sap offset &optional length-only)
+  (let* ((length (system:sap-ref-8 sap offset))
+         (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type system:system-area-pointer sap)
+             (type (unsigned-byte 8) length)
+             (type (simple-array (unsigned-byte 8) (*)) vector))
+    (cond (length-only
+           (values 0 (1+ length) nil nil))
+          (t
+           (kernel:copy-from-system-area sap (* sparc:byte-bits (1+ offset))
+                                         vector (* sparc:word-bits
+                                                   sparc:vector-data-offset)
+                                         (* length sparc:byte-bits))
+           (collect ((sc-offsets)
+                     (lengths))
+             (lengths 1)                ; the length byte
+             (let* ((index 0)
+                    (error-number (c::read-var-integer vector index)))
+               (lengths index)
+               (loop
+                 (when (>= index length)
+                   (return))
+                 (let ((old-index index))
+                   (sc-offsets (c::read-var-integer vector index))
+                   (lengths (- index old-index))))
+               (values error-number
+                       (1+ length)
+                       (sc-offsets)
+                       (lengths))))))))
+
+(defun unimp-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (disassem:note x dstate))))
+    (case (format-2-unimp-data chunk dstate)
+      (#.vm:error-trap
+       (nt "Error trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:cerror-trap
+       (nt "Cerror trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:object-not-list-trap
+       (nt "Object not list trap"))
+      (#.vm:breakpoint-trap
+       (nt "Breakpoint trap"))
+      (#.vm:pending-interrupt-trap
+       (nt "Pending interrupt trap"))
+      (#.vm:halt-trap
+       (nt "Halt trap"))
+      (#.vm:function-end-breakpoint-trap
+       (nt "Function end breakpoint trap"))
+      (#.vm:object-not-instance-trap
+       (nt "Object not instance trap"))
+    )))
+
+(eval-when (compile load eval)
+  ;; Print Value as a Lisp hex number
+  (defun hex-data-printer (value stream dstate)
+    (declare (ignore dstate))
+    (format stream "#x~X" value)))
+
+(define-instruction unimp (segment data)
+  (:declare (type (unsigned-byte 22) data))
+  (:printer format-2-unimp ((data nil :printer #'hex-data-printer))
+	    :default :control #'unimp-control
+	    :print-name #-sparc-v9 'unimp #+sparc-v9 'illtrap)
+  (:delay 0)
+  (:emitter (emit-format-2-unimp segment 0 0 0 data)))
+
+
+
+;;;; Branch instructions.
+
+;; The branch instruction is deprecated on the Sparc V9.  Use the
+;; branch with prediction instructions instead.
+(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
+  (emit-back-patch segment 4
+    #'(lambda (segment posn)
+	(unless target
+	  (setf target cond-or-target)
+	  (setf cond-or-target :t))
+	(emit-format-2-branch
+	  segment #b00 a
+	  (if fp
+	      (fp-branch-condition cond-or-target)
+	      (branch-condition cond-or-target))
+	  op2
+	  (let ((offset (ash (- (label-position target) posn) -2)))
+	    (when (and (= a 1) (> 0 offset))
+	      (error "Offset of BA must be positive"))
+	    offset)))))
+
+#+sparc-v9
+(defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt))
+  (declare (type integer-condition-register cc))
+  (emit-back-patch segment 4
+    #'(lambda (segment posn)
+	(unless target
+	  (setf target cond-or-target)
+	  (setf cond-or-target :t))
+	(emit-format-2-branch-pred
+	  segment #b00 a
+	  (branch-condition cond-or-target)
+	  op2
+	  (integer-condition cc)
+	  (branch-prediction pred)
+	  (let ((offset (ash (- (label-position target) posn) -2)))
+	    (when (and (= a 1) (> 0 offset))
+	      (error "Offset of BA must be positive"))
+	    offset)))))
+
+#+sparc-v9
+(defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt))
+  (emit-back-patch segment 4
+    #'(lambda (segment posn)
+	(unless target
+	  (setf target cond-or-target)
+	  (setf cond-or-target :t))
+	(emit-format-2-branch-pred
+	  segment #b00 a
+	  (fp-branch-condition cond-or-target)
+	  op2
+	  (fp-condition cc)
+	  (branch-prediction pred)
+	  (let ((offset (ash (- (label-position target) posn) -2)))
+	    (when (and (= a 1) (> 0 offset))
+	      (error "Offset of BA must be positive"))
+	    offset)))))
+
+;; So that I don't have to go change the syntax of every single use of
+;; branches, I'm keeping the Lisp instruction names the same.  They
+;; just get translated to the branch with prediction
+;; instructions. However, the disassembler uses the correct V9
+;; mnemonic.
+#-sparc-v9
+(define-instruction b (segment cond-or-target &optional target &rest ignored)
+  (:declare (type (or label branch-condition) cond-or-target)
+	    (type (or label null) target)
+	    (ignore ignored))
+  (:printer format-2-branch ((op #b00) (op2 #b010)))
+  (:attributes branch)
+  (:dependencies (reads :psr))
+  (:delay 1)
+  (:emitter
+   (emit-relative-branch segment 0 #b010 cond-or-target target)))
+
+#+sparc-v9
+(define-instruction b (segment cond-or-target &optional target pred cc)
+  (:declare (type (or label branch-condition) cond-or-target)
+	    (type (or label null) target)
+	    (type (or null (member :icc :xcc)) cc)
+	    (type (or null (member :pt :pn)) pred))
+  (:printer format-2-branch-pred ((op #b00) (op2 #b001))
+	    branch-pred-printer
+	    :print-name 'bp)
+  (:attributes branch)
+  (:dependencies (reads :psr))
+  (:delay 1)
+  (:emitter
+   (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
+
+#-sparc-v9
+(define-instruction ba (segment cond-or-target &optional target)
+  (:declare (type (or label branch-condition) cond-or-target)
+	    (type (or label null) target))
+  (:printer format-2-branch ((op #b00) (op2 #b010) (a 1))
+            branch-printer
+            :print-name 'b)
+  (:attributes branch)
+  (:dependencies (reads :psr))
+  (:delay 0)
+  (:emitter
+   (emit-relative-branch segment 1 #b010 cond-or-target target)))
+
+#+sparc-v9
+(define-instruction ba (segment cond-or-target &optional target pred cc)
+  (:declare (type (or label branch-condition) cond-or-target)
+	    (type (or label null) target)
+	    (type (or null (member :icc :xcc)) cc)
+	    (type (or null (member :pt :pn)) pred))
+  (:printer format-2-branch-pred ((op #b00) (op2 #b001) (a 1))
+            branch-pred-printer
+            :print-name 'bp)
+  (:attributes branch)
+  (:dependencies (reads :psr))
+  (:delay 0)
+  (:emitter
+   (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun trap-arg-printer (value stream dstate)
+    ;; We just print a note, if it's one of our recognized traps
+    (let ((*package* (find-package :vm)))
+      (case value
+	(#.pseudo-atomic-trap
+	 (disassem:note (intl:gettext "Pseudo atomic interrupted trap?") dstate))
+	(#.allocation-trap
+	 (disassem:note (intl:gettext "Allocation trap") dstate)))
+      (format stream "~A" value))))
+
+;; The Sparc Compliance Definition 2.4.1 says only trap numbers 16-31
+;; are allowed for user code.  All other trap numbers have other
+;; uses. The restriction on target will prevent us from using bad trap
+;; numbers by mistake.
+;;
+;; Note that the V9 architecture only allows 7 bits for the immediate
+;; trap number.  Previous architectures allowed 13 bits. CMUCL doesn't
+;; need all 13 bits, and the SCD only allows 16-31, so we only allow
+;; for those now.
+(define-instruction t (segment condition src1-or-imm &optional src2
+			       #+sparc-v9 (cc #-sparc-64 :icc #+sparc-64 :xcc))
+  (:declare (type branch-condition condition)
+	    (type (or tn (unsigned-byte 8)) src1-or-imm)
+	    (type (or null tn (unsigned-byte 8)) src2)
+	    #+sparc-v9
+	    (type integer-condition-register cc))
+  (:printer format-4-trap-immed ((op #b10)
+				 (rd nil :type 'branch-condition)
+				 (op3 #b111010)
+				 (i 1)
+				 (immed nil :printer #'trap-arg-printer))
+	    trap-immed-printer)
+  (:printer format-4-trap ((op #b10)
+			   (rd nil :type 'branch-condition)
+			   (op3 #b111010)
+			   (i 0)
+			   (rs2 nil :type 'reg))
+	    trap-printer)
+  (:attributes branch)
+  (:dependencies (reads :psr))
+  (:delay 0)
+  (:emitter
+   (let ((cc-reg #+sparc-v9 (integer-condition cc)
+		 #-sparc-v9 0))
+     (etypecase src1-or-imm
+       (integer
+	;; src2 shouldn't be given (or should be NIL) in this case.
+	(assert (null src2))
+	(unless (typep src1-or-imm '(integer 16 31))
+	  (cerror (intl:gettext "Use it anyway")
+		  (intl:gettext "Immediate trap number ~A specified, but only trap numbers
+   16 to 31 are available to the application")
+		  src1-or-imm))
+	(emit-format-4-trap segment
+			    #b10
+			    (branch-condition condition)
+			    #b111010 0 1
+			    cc-reg
+			    src1-or-imm))
+       (tn
+	;; src1 is a register.  src2 must be given.
+	(etypecase src2
+	  (integer
+	   (emit-format-4-trap segment
+			       #b10
+			       (branch-condition condition)
+			       #b111010
+			       (reg-tn-encoding src1-or-imm)
+			       1
+			       cc-reg
+			       src2))
+	  (tn
+	   (emit-format-4-trap segment
+			       #b10
+			       (branch-condition condition)
+			       #b111010
+			       (reg-tn-encoding src1-or-imm)
+			       0
+			       cc-reg
+			       (reg-tn-encoding src2))))))))
+  )
+
+;; Same as for the branch instructions.  On the Sparc V9, we will use
+;; the FP branch with prediction instructions instead.
+#-sparc-v9
+(define-instruction fb (segment condition target)
+  (:declare (type fp-branch-condition condition) (type label target))
+  (:printer format-2-branch ((op #B00)
+                             (cond nil :type 'branch-fp-condition)
+                             (op2 #b110)))
+  (:attributes branch)
+  (:dependencies (reads :fsr))
+  (:delay 1)
+  (:emitter
+   (emit-relative-branch segment 0 #b110 condition target t)))
+
+#+sparc-v9
+(define-instruction fb (segment condition target &optional fcc pred)
+  (:declare (type fp-branch-condition condition) (type label target))
+  (:printer format-2-fp-branch-pred ((op #b00) (op2 #b101))
+	    fp-branch-pred-printer
+	    :print-name 'fbp)
+  (:attributes branch)
+  (:dependencies (reads :fsr))
+  (:delay 1)
+  (:emitter
+   (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
+
+(defconstant jal-printer
+  '(:name :tab
+          (:choose (rs1 (:unless (:constant 0) (:plus-integer immed)))
+                   (:cond ((rs2 :constant 0) rs1)
+                          ((rs1 :constant 0) rs2)
+                          (t rs1 "+" rs2)))
+          (:unless (:constant 0) ", " rd)))
+
+(define-instruction jal (segment dst src1 &optional src2)
+  (:declare (type tn dst)
+	    (type (or tn integer) src1)
+	    (type (or null fixup tn (signed-byte 13)) src2))
+  (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer :print-name 'jmpl)
+  (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer :print-name 'jmpl)
+  (:attributes branch)
+  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+  (:delay 1)
+  (:emitter
+   (unless src2
+     (setf src2 src1)
+     (setf src1 0))
+   (etypecase src2
+     (tn
+      (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
+			 (if (integerp src1)
+			     src1
+			     (reg-tn-encoding src1))
+			 0 0 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
+			   (reg-tn-encoding src1) 1 src2))
+     (fixup
+      (note-fixup segment :add src2)
+      (emit-format-3-immed segment #b10 (reg-tn-encoding dst)
+			   #b111000 (reg-tn-encoding src1) 1 0)))))
+
+(define-instruction j (segment src1 &optional src2)
+  (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
+  (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
+  (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
+  (:attributes branch)
+  (:dependencies (reads src1) (if src2 (reads src2)))
+  (:delay 1)
+  (:emitter
+   (etypecase src2
+     (null
+      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
+     (tn
+      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
+			 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
+			   src2))
+     (fixup
+      (note-fixup segment :add src2)
+      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
+			   0)))))
+
+
+
+;;;; Unary and binary fp insts.
+
+(eval-when (compile eval)
+
+(defmacro define-unary-fp-inst (name opf &key reads extended)
+  `(define-instruction ,name (segment dst src)
+     (:declare (type tn dst src))
+     (:printer format-unary-fpop
+       ((op #b10) (op3 #b110100) (opf ,opf)
+	(rs1 0)
+	(rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+	(rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))))
+     (:dependencies
+      ,@(when reads
+	  `((reads ,reads)))
+      (reads dst)
+      (reads src)
+      (writes dst))
+     (:delay 0)
+     (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
+		#b110100 0 ,opf (fp-reg-tn-encoding src)))))
+
+(defmacro define-binary-fp-inst (name opf &key (op3 #b110100)
+				      reads writes delay extended)
+  `(define-instruction ,name (segment dst src1 src2)
+     (:declare (type tn dst src1 src2))
+     (:printer format-binary-fpop
+      ((op #b10) (op3 ,op3) (opf ,opf)
+       (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+       (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+       (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+       ))
+     (:dependencies
+      ,@(when reads
+	  `((reads ,reads)))
+      (reads src1)
+      (reads src2)
+      ,@(when writes
+	  `((writes ,writes)))
+      (writes dst))
+     ,@(if delay
+	   `((:delay ,delay))
+	   '((:delay 0)))
+     (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
+		,op3 (fp-reg-tn-encoding src1) ,opf
+		(fp-reg-tn-encoding src2)))))
+
+(defmacro define-cmp-fp-inst (name opf &key extended)
+  (let ((opf0 #b0)
+	(opf1 #b010)
+	(opf2 #b1))
+    `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0))
+       (:declare (type tn src1 src2)
+	         (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc))
+       (:printer format-fpop2
+		 ((op #b10)
+		  (op3 #b110101)
+		  (opf0 ,opf0)
+		  (opf1 ,opf1)
+		  (opf2 ,opf2)
+		  (opf3 ,opf)
+		  (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+		  (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+		  #-sparc-v9
+		  (rd 0)
+		  #+sparc-v9
+		  (rd nil :type 'fp-condition-register))
+	)
+     (:dependencies
+      (reads src1)
+      (reads src2)
+      (writes :fsr))
+     ;; The Sparc V9 doesn't need a delay after a FP compare.
+     (:delay #-sparc-v9 1 #+sparc-v9 0)
+       (:emitter
+	(emit-format-3-fpop2 segment #b10
+	                     (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
+				 0)
+	                     #b110101
+			     (fp-reg-tn-encoding src1)
+			     ,opf0 ,opf1 ,opf2 ,opf
+			     (fp-reg-tn-encoding src2))))))
+
+); eval-when (compile eval)
+
+
+(define-unary-fp-inst fitos #b011000100 :reads :fsr)
+(define-unary-fp-inst fitod #b011001000 :reads :fsr :extended t)
+(define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t)	; v8
+
+(define-unary-fp-inst fxtos #b010000100 :reads :fsr)                    ; v9
+(define-unary-fp-inst fxtod #b010001000 :reads :fsr :extended t)        ; v9
+(define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t)	; v9
+
+
+;; I (toy@rtp.ericsson.se) don't think these f{sd}toir instructions
+;; exist on any Ultrasparc, but I only have a V9 manual.  The code in
+;; float.lisp seems to indicate that they only existed on non-sun4
+;; machines (sun3 68K machines?).
+#-sparc
+(progn
+  (define-unary-fp-inst fstoir #b011000001 :reads :fsr)
+  (define-unary-fp-inst fdtoir #b011000010 :reads :fsr)
+)
+
+(define-unary-fp-inst fstoi #b011010001)
+(define-unary-fp-inst fdtoi #b011010010 :extended t)
+(define-unary-fp-inst fqtoi #b011010011 :extended t)	; v8
+
+(define-unary-fp-inst fstox #b010000001)                ; v9
+(define-unary-fp-inst fdtox #b010000010 :extended t)    ; v9
+(define-unary-fp-inst fqtox #b010000011 :extended t)	; v9
+
+(define-unary-fp-inst fstod #b011001001 :reads :fsr)
+(define-unary-fp-inst fstoq #b011001101 :reads :fsr)	; v8
+(define-unary-fp-inst fdtos #b011000110 :reads :fsr)
+(define-unary-fp-inst fdtoq #b011001110 :reads :fsr)	; v8
+(define-unary-fp-inst fqtos #b011000111 :reads :fsr)	; v8
+(define-unary-fp-inst fqtod #b011001011 :reads :fsr)	; v8
+
+(define-unary-fp-inst fmovs #b000000001)
+(define-unary-fp-inst fmovd #b000000010 :extended t)	; v9
+(define-unary-fp-inst fmovq #b000000011 :extended t)	; v9
+
+(define-unary-fp-inst fnegs #b000000101)
+(define-unary-fp-inst fnegd #b000000110 :extended t)	; v9
+(define-unary-fp-inst fnegq #b000000111 :extended t)	; v9
+
+(define-unary-fp-inst fabss #b000001001)
+(define-unary-fp-inst fabsd #b000001010 :extended t)	; v9
+(define-unary-fp-inst fabsq #b000001011 :extended t)	; v9
+
+(define-unary-fp-inst fsqrts #b000101001 :reads :fsr)		; V7
+(define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t)	; V7
+(define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t)	; v8
+
+(define-binary-fp-inst fadds #b001000001)
+(define-binary-fp-inst faddd #b001000010 :extended t)
+(define-binary-fp-inst faddq #b001000011 :extended t)	; v8
+(define-binary-fp-inst fsubs #b001000101)
+(define-binary-fp-inst fsubd #b001000110 :extended t)
+(define-binary-fp-inst fsubq #b001000111 :extended t)	; v8
+
+(define-binary-fp-inst fmuls #b001001001)
+(define-binary-fp-inst fmuld #b001001010 :extended t)
+(define-binary-fp-inst fmulq #b001001011 :extended t)	; v8
+(define-binary-fp-inst fdivs #b001001101)
+(define-binary-fp-inst fdivd #b001001110 :extended t)
+(define-binary-fp-inst fdivq #b001001111 :extended t)	; v8
+
+;;; Float comparison instructions.
+;;;
+(define-cmp-fp-inst fcmps #b0001)
+(define-cmp-fp-inst fcmpd #b0010 :extended t)
+(define-cmp-fp-inst fcmpq #b0011 :extended t) ;v8
+(define-cmp-fp-inst fcmpes #b0101)
+(define-cmp-fp-inst fcmped #b0110 :extended t)
+(define-cmp-fp-inst fcmpeq #b0111 :extended t)	; v8
+
+
+
+;;;; li, jali, ji, nop, cmp, not, neg, move, and more
+
+#-sparc-v9
+(defun %li (reg value)
+  (etypecase value
+    ((signed-byte 13)
+     (inst add reg zero-tn value))
+    ((or (signed-byte 32) (unsigned-byte 32))
+     (let ((hi (ldb (byte 22 10) value))
+	   (lo (ldb (byte 10 0) value)))
+       (inst sethi reg hi)
+       (unless (zerop lo)
+	 (inst add reg lo))))
+    (fixup
+     (inst sethi reg value)
+     (inst add reg value))))
+
+#+sparc-v9
+(defun %li (reg value)
+  (etypecase value
+    ((signed-byte 13)
+     (inst add reg zero-tn value))
+    ((unsigned-byte 32)
+     (let ((hi (ldb (byte 22 10) value))
+	   (lo (ldb (byte 10 0) value)))
+       ;; Sethi sets the top 32-bits to zero.
+       (inst sethi reg hi)
+       (unless (zerop lo)
+	 (inst add reg lo))))
+    ((signed-byte 32)
+     (let ((hi (ldb (byte 22 10) value))
+	   (lo (ldb (byte 10 0) value)))
+       ;; Sethi sets the top 32-bits to zero.
+       (inst sethi reg hi)
+       (unless (zerop lo)
+	 (inst add reg lo))
+       ;; Sign-extend the result
+       (inst signx reg)))
+    (fixup
+     (inst sethi reg value)
+     (inst add reg value))))
+
+(define-instruction-macro li (reg value)
+  `(%li ,reg ,value))
+
+#+sparc-v9
+(progn
+(defun %li64 (reg value &optional temp)
+  (etypecase value
+    ((signed-byte 13)
+     (inst add reg zero-tn value))
+    ((unsigned-byte 32)
+     (let ((hi (ldb (byte 22 10) value))
+	   (lo (ldb (byte 10 0) value)))
+       (inst sethi reg hi)
+       (unless (zerop lo)
+	 (inst add reg lo))))
+    ((signed-byte 32)
+     (let ((hi (ldb (byte 22 10) value))
+	   (lo (ldb (byte 10 0) value)))
+       ;; Sethi sets the top 32-bits to zero.
+       (inst sethi reg hi)
+       (unless (zerop lo)
+	 (inst add reg lo))
+       ;; Sign-extend the result
+       (inst signx reg)))
+    ((unsigned-byte 32)
+     (let ((hi (ldb (byte 22 10) value))
+	   (lo (ldb (byte 10 0) value)))
+       ;; Sethi sets the top 32-bits to zero.
+       (inst sethi reg hi)
+       (unless (zerop lo)
+	 (inst add reg lo))))
+    ((or (signed-byte 64) (unsigned-byte 64))
+     (cond (temp
+	    ;; If we have a temp register to use, we can use this
+	    ;; shorter sequence
+	    (let ((hh (ldb (byte 22 42) value))
+		  (lm (ldb (byte 22 32) value))
+		  (hm (ldb (byte 22 10) value))
+		  (lo (ldb (byte 10 0) value)))
+	      (inst sethi temp hh)
+	      (inst sethi reg lm)
+	      (inst or temp hm)
+	      (inst or reg lo)
+	      (inst sllx temp 32)
+	      (inst or reg temp)))
+	   (t
+	    ;; Hmm, no temp register given, so we have to use the
+	    ;; following longer sequence.
+	    (let ((bits-63-48 (ldb (byte 16 48) value))
+		  (bits-47-36 (ldb (byte 12 36) value))
+		  (bits-35-24 (ldb (byte 12 24) value))
+		  (bits-23-12 (ldb (byte 12 12) value))
+		  (bits-11-00 (ldb (byte 12 0) value)))
+	      (inst sethi reg bits-63-48)
+	      (inst or reg bits-47-36)
+	      (inst sllx reg 12)
+	      (inst or reg bits-35-24)
+	      (inst sllx reg 12)
+	      (inst or reg bits-23-12)
+	      (inst sllx reg 12)
+	      (inst or reg bits-11-00)))))
+    (fixup
+     (inst sethi reg value)
+     (inst add reg value))))
+
+(define-instruction-macro li64 (reg value &optional temp)
+  `(%li64 ,reg ,value ,temp))
+
+)
+
+;; Define LDN/STN synthetic instructions to do "natural" loads and
+;; stores for 32-bit or 64-bit objects depending on whether this is a
+;; 32-bit or 64-bit build.  Change these to use ldx/stx/sllx/srlx/srax
+;; for 64-bit build.
+(macrolet ((frob (name inst)
+	     `(define-instruction-macro ,name (dst src1 &optional src2)
+	       `(inst ,',inst ,dst ,src1 ,src2))))
+  (frob ldn ld)
+  (frob stn st)
+  (frob slln sll)
+  (frob srln srl)
+  (frob sran sra))
+  
+;;; Jal to a full 32-bit address.  Tmpreg is trashed.
+(define-instruction jali (segment link tmpreg value)
+  (:declare (type tn link tmpreg)
+	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+		      fixup) value))
+  (:attributes variable-length)
+ (:vop-var vop)
+  (:attributes branch)
+  (:dependencies (writes link) (writes tmpreg))
+  (:delay 1)
+  (:emitter
+   (assemble (segment vop)
+     (etypecase value
+       ((signed-byte 13)
+	(inst jal link zero-tn value))
+       ((or (signed-byte 32) (unsigned-byte 32))
+	(let ((hi (ldb (byte 22 10) value))
+	      (lo (ldb (byte 10 0) value)))
+	  (inst sethi tmpreg hi)
+	  (inst jal link tmpreg lo)))
+       (fixup
+	(inst sethi tmpreg value)
+	(inst jal link tmpreg value))))))
+
+;;; Jump to a full 32-bit address.  Tmpreg is trashed.
+(define-instruction ji (segment tmpreg value)
+  (:declare (type tn tmpreg)
+	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+		      fixup) value))
+  (:attributes variable-length)
+  (:vop-var vop)
+  (:attributes branch)
+  (:dependencies (writes tmpreg))
+  (:delay 1)
+  (:emitter
+   (assemble (segment vop)
+	     (inst jali zero-tn tmpreg value))))
+
+(define-instruction nop (segment)
+  (:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name))
+  (:attributes flushable)
+  (:delay 0)
+  (:emitter (emit-format-2-immed segment 0 0 #b100 0)))
+
+(def-vm-support-routine emit-nop (segment)
+  (emit-format-2-immed segment 0 0 #b100 0))
+
+(define-instruction cmp (segment src1 &optional src2)
+  (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2))
+  (:printer format-3-reg ((op #b10) (op3 #b010100) (rd 0))
+            '(:name :tab rs1 ", " rs2))
+  (:printer format-3-immed ((op #b10) (op3 #b010100) (rd 0))
+            '(:name :tab rs1 ", " immed))
+  (:dependencies (reads src1) (if src2 (reads src2)) (writes :psr))
+  (:delay 0)
+  (:emitter
+   (etypecase src2
+     (null
+      (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
+     (tn
+      (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
+			 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
+			   src2)))))
+
+(define-instruction not (segment dst &optional src1)
+  (:declare (type tn dst) (type (or tn null) src1))
+  (:printer format-3-reg ((op #b10) (op3 #b000111) (rs2 0))
+            '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd))
+  (:dependencies (if src1 (reads src1) (reads dst)) (writes dst))
+  (:delay 0)
+  (:emitter
+   (unless src1
+     (setf src1 dst))
+   (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
+		      (reg-tn-encoding src1) 0 0 0)))
+
+(define-instruction neg (segment dst &optional src1)
+  (:declare (type tn dst) (type (or tn null) src1))
+  (:printer format-3-reg ((op #b10) (op3 #b000100) (rs1 0))
+            '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd))
+  (:dependencies (if src1 (reads src1) (reads dst)) (writes dst))
+  (:delay 0)
+  (:emitter
+   (unless src1
+     (setf src1 dst))
+   (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
+		      0 0 0 (reg-tn-encoding src1))))
+
+;; As in the suggested synthetic instructions, a register move is
+;; really just or'ing the src register with %g0.
+(define-instruction move (segment dst src1)
+  (:declare (type tn dst src1))
+  (:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0))
+            '(:name :tab rs2 ", " rd)
+	    :print-name 'mov)
+  (:attributes flushable)
+  (:dependencies (reads src1) (writes dst))
+  (:delay 0)
+  (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
+			       0 0 0 (reg-tn-encoding src1))))
+
+
+
+;;;; Instructions for dumping data and header objects.
+
+(define-instruction word (segment word)
+  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction short (segment short)
+  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-short segment short)))
+
+(define-instruction byte (segment byte)
+  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-emitter emit-header-object 32
+  (byte 24 8) (byte 8 0))
+  
+(defun emit-header-data (segment type)
+  (emit-back-patch
+   segment 4
+   #'(lambda (segment posn)
+       (emit-word segment
+		  (logior type
+			  (ash (+ posn (component-header-length))
+			       (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+  :pinned
+  (:delay 0)
+  (:emitter
+   (emit-header-data segment return-pc-header-type)))
+
+
+;;;; Instructions for converting between code objects, functions, and lras.
+
+(defun emit-compute-inst (segment vop dst src label temp calc)
+  (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 12)) delta (1- (ash 1 12)))
+	   (emit-back-patch segment 4
+			    #'(lambda (segment posn)
+				(assemble (segment vop)
+					  (inst add dst src
+						(funcall calc label posn 0)))))
+	   t)))
+   #'(lambda (segment posn)
+       (let ((delta (funcall calc label posn 0)))
+	 (assemble (segment vop)
+		   (inst sethi temp (ldb (byte 22 10) delta))
+		   (inst or temp (ldb (byte 10 0) delta))
+		   (inst add dst src temp))))))
+
+;; code = fn - fn-ptr-type - 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))
+  (:attributes variable-length)
+  (:dependencies (reads src) (writes dst) (writes temp))
+  (:delay 0)
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (- other-pointer-type
+			     function-pointer-type
+			     (label-position label posn delta-if-after)
+			     (component-header-length))))))
+
+;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-lra (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:attributes variable-length)
+  (:dependencies (reads src) (writes dst) (writes temp))
+  (:delay 0)
+  (: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))
+  (:attributes variable-length)
+  (:dependencies (reads src) (writes dst) (writes temp))
+  (:delay 0)
+  (: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))))))
+
+;;; Sparc V9 additions
+
+
+
+;; Conditional move integer on condition code
+(define-instruction cmove (segment condition dst src &optional (ccreg :icc))
+  (:declare (type (or branch-condition fp-branch-condition) condition)
+	    (type cond-move-condition-register ccreg)
+	    (type tn dst)
+	    (type (or (signed-byte 13) tn) src))
+  (:printer format-4-cond-move
+	    ((op #b10)
+	     (op3 #b101100)
+	     (cc2 #b1)
+	     (i 0)
+	     (cc nil :type 'integer-condition-register))
+	     cond-move-printer
+	     :print-name 'mov)
+  (:printer format-4-cond-move-immed
+	    ((op #b10)
+	     (op3 #b101100)
+	     (cc2 #b1)
+	     (i 1)
+	     (cc nil :type 'integer-condition-register))
+	     cond-move-printer
+	     :print-name 'mov)
+  (:printer format-4-cond-move
+	    ((op #b10)
+	     (op3 #b101100)
+	     (cc2 #b0)
+	     (cond nil :type 'branch-fp-condition)
+	     (i 0)
+	     (cc nil :type 'fp-condition-register))
+	     cond-move-printer
+	     :print-name 'mov)
+  (:printer format-4-cond-move-immed
+	    ((op #b10)
+	     (op3 #b101100)
+	     (cc2 #b0)
+	     (cond nil :type 'branch-fp-condition)
+	     (i 1)
+	     (cc nil :type 'fp-condition-register))
+	     cond-move-printer
+	     :print-name 'mov)
+  (:delay 0)
+  (:dependencies
+   (if (member ccreg '(:icc :xcc))
+       (reads :psr)
+       (reads :fsr))
+   (reads src)
+   (reads dst)
+   (writes dst))
+  (:emitter
+   (let ((op #b10)
+	 (op3 #b101100))
+     (multiple-value-bind (cc2 cc01)
+	 (cond-move-condition-parts ccreg)
+       (etypecase src
+	 (tn
+	  (emit-format-4-cond-move segment
+				   op
+				   (reg-tn-encoding dst)
+				   op3
+				   cc2
+				   (if (member ccreg '(:icc :xcc))
+				       (branch-condition condition)
+				       (fp-branch-condition condition))
+				   0
+				   cc01
+				   (reg-tn-encoding src)))
+	 (integer
+	  (emit-format-4-cond-move segment
+				   op
+				   (reg-tn-encoding dst)
+				   op3
+				   cc2
+				   (if (member ccreg '(:icc :xcc))
+				       (branch-condition condition)
+				       (fp-branch-condition condition))
+				   1
+				   cc01
+				   src)))))))
+
+;; Conditional move floating-point on condition codes
+(defmacro define-cond-fp-move (name print-name op op3 opf_low &key extended)
+  `(define-instruction ,name (segment condition dst src &optional (ccreg :fcc0))
+     (:declare (type (or branch-condition fp-branch-condition) condition)
+	       (type cond-move-condition-register ccreg)
+	       (type tn dst src))
+     (:printer format-fpop2
+	       ((op ,op)
+		(op3 ,op3)
+		(opf0 0)
+		(opf1 nil :type 'fp-condition-register-shifted)
+		(opf2 0)
+		(opf3 ,opf_low)
+		(rs1 nil :type 'branch-fp-condition)
+		(rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+		(rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
+                cond-fp-move-printer
+                :print-name ',print-name)
+     (:printer format-fpop2
+	       ((op ,op)
+		(op3 ,op3)
+		(opf0 1)
+		(opf1 nil :type 'integer-condition-register)
+		(opf2 0)
+		(rs1 nil :type 'branch-condition)
+		(opf3 ,opf_low)
+		(rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+		(rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
+               cond-fp-move-printer
+               :print-name ',print-name)
+     (:delay 0)
+     (:dependencies
+      (if (member ccreg '(:icc :xcc))
+	  (reads :psr)
+	  (reads :fsr))
+      (reads src)
+      (reads dst)
+      (writes dst))
+     (:emitter
+      (multiple-value-bind (opf_cc2 opf_cc01)
+	  (cond-move-condition-parts ccreg)
+	(emit-format-3-fpop2 segment
+			     ,op
+			     (fp-reg-tn-encoding dst)
+			     ,op3
+			     (if (member ccreg '(:icc :xcc))
+				 (branch-condition condition)
+				 (fp-branch-condition condition))
+			     opf_cc2
+			     (ash opf_cc01 1)
+			     0
+			     ,opf_low
+			     (fp-reg-tn-encoding src))))))
+
+(define-cond-fp-move cfmovs fmovs #b10 #b110101 #b0001)
+(define-cond-fp-move cfmovd fmovd #b10 #b110101 #b0010 :extended t)
+(define-cond-fp-move cfmovq fmovq #b10 #b110101 #b0011 :extended t)
+
+
+;; Move on integer register condition
+;;
+;; movr dst src reg reg-cond
+;;
+;; This means if reg satisfies reg-cond, src is copied to dst.  If the
+;; condition is not satisfied, nothing is done.
+;;
+(define-instruction movr (segment dst src2 src1 reg-condition)
+  (:declare (type cond-move-integer-condition reg-condition)
+	    (type tn dst src1)
+	    (type (or (signed-byte 10) tn) src2))
+  (:printer format-4-cond-move-integer
+	    ((op #b10)
+	     (op3 #b101111)
+	     (i 0)))
+  (:printer format-4-cond-move-integer-immed
+	    ((op #b10)
+	     (op3 #b101111)
+	     (i 1)))
+  (:delay 0)
+  (:dependencies
+   (reads :psr)
+   (reads src2)
+   (reads src1)
+   (reads dst)
+   (writes dst))
+  (:emitter
+   (etypecase src2
+     (tn
+      (emit-format-4-cond-move-integer
+       segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1)
+       0 (register-condition reg-condition)
+       0 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-4-cond-move-integer-immed
+       segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1)
+       1 (register-condition reg-condition) src2)))))
+
+
+;; Same as MOVR, except we move FP registers depending on the value of
+;; an integer register.
+;;
+;; fmovr dst src reg cond
+;;
+;; This means if REG satifies COND, SRC is COPIED to DST.  Nothing
+;; happens if the condition is not satisfied.
+(defmacro define-cond-fp-move-integer (name opf_low &key extended)
+  `(define-instruction ,name (segment dst src2 src1 reg-condition)
+     (:declare (type cond-move-integer-condition reg-condition)
+	       (type tn dst src1 src2))
+     (:printer format-fpop2
+	       ((op #b10)
+		(rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+		(op3 #b110101)
+		(rs1 nil :type 'reg)
+		(opf0 0)
+		(opf1 nil :type 'register-condition)
+		(opf2 0)
+		(opf3 ,opf_low)
+		(rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+		)
+               cond-fp-move-integer-printer)
+     (:delay 0)
+     (:dependencies
+      (reads src2)
+      (reads src1)
+      (reads dst)
+      (writes dst))
+     (:emitter
+      (emit-format-3-fpop2
+       segment
+       #b10
+       (fp-reg-tn-encoding dst)
+       #b110101
+       (reg-tn-encoding src1)
+       0
+       (register-condition reg-condition)
+       0
+       ,opf_low
+       (fp-reg-tn-encoding src2)))))
+
+(define-cond-fp-move-integer fmovrs #b0101)
+(define-cond-fp-move-integer fmovrd #b0110 :extended t)
+(define-cond-fp-move-integer fmovrq #b0111 :extended t)
diff --git a/src/compiler/sparcv9/macros.lisp b/src/compiler/sparcv9/macros.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..332508a1e04a7d7d3123af5fb23bbeca4f9cdafb
--- /dev/null
+++ b/src/compiler/sparcv9/macros.lisp
@@ -0,0 +1,606 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/macros.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/compiler/sparc/macros.lisp $
+;;;
+;;; This file contains various useful macros for generating SPARC code.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;; Instruction-like macros.
+
+(defmacro move (dst src)
+  "Move SRC into DST unless they are location=."
+  (once-only ((n-dst dst)
+	      (n-src src))
+    `(unless (location= ,n-dst ,n-src)
+       (inst move ,n-dst ,n-src))))
+
+;; (loadw object base &optional (offset 0) (lowtag 0) temp)
+;;
+;; Load a word at a given address into the register OBJECT. The
+;; address of the word is in register BASE, plus an offset given by
+;; OFFSET, which is in words.  LOWTAG is an adjustment to OFFSET to
+;; account for any tag bits used in the BASE descriptor register.
+;;
+;; In some situations, the offset may be so large that it cannot fit
+;; into the offset field of the LD instruction (a 13-bit signed
+;; quantity).  In this situation, the TEMP non-descriptor register, if
+;; supplied, is used to compute the correct offset.  If TEMP is not
+;; given, the offset is assumed to fit.  (TEMP must be a
+;; non-descriptor because we store random values into it.  If OBJECT
+;; were always a non-descriptor, we wouldn't need the TEMP register.)
+;;
+;; Samething for storew, except we store OBJECT at the given address.
+(macrolet
+    ((frob (op inst shift)
+     `(defmacro ,op (object base &optional (offset 0) (lowtag 0) temp)
+       (if temp
+	   (let ((offs (gensym)))
+	     `(let ((,offs (- (ash ,offset ,',shift) ,lowtag)))
+	       (if (typep ,offs '(signed-byte 13))
+		   (inst ,',inst ,object ,base ,offs)
+		   (progn
+		     (inst li ,temp ,offs)
+		     (inst ,',inst ,object ,base ,temp)))))
+	   `(inst ,',inst ,object ,base (- (ash ,offset ,',shift) ,lowtag))))))
+  (frob loadw ldn word-shift)
+  #+(and sparc-v9 sparc-v8plus)
+  (frob loadsw ldsw word-shift)
+  (frob storew stn word-shift))
+
+#+(and sparc-v9 sparc-v8plus)
+(macrolet
+    ((frob (op inst shift)
+     `(defmacro ,op (object base &optional (offset 0) (lowtag 0) temp)
+       (if temp
+	   (let ((offs (gensym)))
+	     `(let ((,offs (- (ash ,offset ,',shift) ,lowtag)))
+	       (if (typep ,offs '(signed-byte 13))
+		   (inst ,',inst ,object ,base ,offs)
+		   (progn
+		     (inst li ,temp ,offs)
+		     (inst ,',inst ,object ,base ,temp)))))
+	   `(inst ,',inst ,object ,base (- (ash ,offset ,',shift) ,lowtag))))))
+  (frob load64 ldx (* 2 word-shift))
+  (frob store64 stx (* 2 word-shift)))
+
+(defmacro load-symbol (reg symbol)
+  `(inst add ,reg null-tn (static-symbol-offset ,symbol)))
+
+(macrolet
+    ((frob (slot)
+       (let ((loader (intern (concatenate 'simple-string
+					  "LOAD-SYMBOL-"
+					  (string slot))))
+	     (storer (intern (concatenate 'simple-string
+					  "STORE-SYMBOL-"
+					  (string slot))))
+	     (offset (intern (concatenate 'simple-string
+					  "SYMBOL-"
+					  (string slot)
+					  "-SLOT")
+			     (find-package "VM"))))
+	 `(progn
+	    (defmacro ,loader (reg symbol)
+	      `(inst ldn ,reg null-tn
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))
+	    (defmacro ,storer (reg symbol)
+	      `(inst stn ,reg null-tn
+		     (+ (static-symbol-offset ',symbol)
+			(ash ,',offset word-shift)
+			(- other-pointer-type))))))))
+  (frob value)
+  (frob function))
+
+(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))
+    (ecase (backend-byte-order *target-backend*)
+      (:little-endian
+       `(inst ldub ,n-target ,n-source ,n-offset))
+      (:big-endian
+       `(inst ldub ,n-target ,n-source (+ ,n-offset 3))))))
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions. 
+
+(defmacro lisp-jump (function)
+  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
+  `(progn
+     (inst j ,function
+	   (- (ash function-code-offset word-shift) vm:function-pointer-type))
+     (move code-tn ,function)))
+
+(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+  "Return to RETURN-PC."
+  `(progn
+     (inst j ,return-pc
+	   (- (* (1+ ,offset) word-bytes) other-pointer-type))
+     ,(if frob-code
+	  `(move code-tn ,return-pc)
+	  '(inst nop))))
+
+(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 0 gtemp-tn))))))
+
+(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 0 gtemp-tn))))))
+
+
+;;; MAYBE-LOAD-STACK-TN  --  Interface
+;;;
+(defmacro maybe-load-stack-tn (reg reg-or-stack)
+  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
+  (once-only ((n-reg reg)
+	      (n-stack reg-or-stack))
+    `(sc-case ,n-reg
+       ((any-reg descriptor-reg)
+	(sc-case ,n-stack
+	  ((any-reg descriptor-reg)
+	   (move ,n-reg ,n-stack))
+	  ((control-stack)
+	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+
+
+;;;; Storage allocation:
+
+;; Allocation macro
+;;
+;; This macro does the appropriate stuff to allocate space.
+;;
+;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
+;; applied.  The amount of space to be allocated is SIZE bytes (which
+;; must be a multiple of the lisp object size).
+;;
+;; If STACK-P is given, then allocation occurs on the control stack
+;; (for dynamic-extent).  In this case, you MUST also specify NODE, so
+;; that the appropriate compiler policy can be used, and TEMP-TN,
+;; which is needed for work-space.  TEMP-TN MUST be a non-descriptor
+;; reg.
+;;
+;; If generational GC is enabled, you MUST supply a value for TEMP-TN
+;; because a temp register is needed to do inline allocation.
+;; TEMP-TN, in this case, can be any register, since it holds a
+;; double-word aligned address (essentially a fixnum).
+(defmacro allocation (result-tn size lowtag &key stack-p temp-tn)
+  ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
+  ;; set.
+  `(cond (,stack-p
+	  ;; Stack allocation
+	  ;;
+	  ;; The control stack grows up, so round up CSP to a
+	  ;; multiple of 8 (lispobj size).  Use that as the
+	  ;; allocation pointer.  Then add SIZE bytes to the
+	  ;; allocation and set CSP to that, so we have the desired
+	  ;; space.
+
+	  ;; Make sure the temp-tn is a non-descriptor register!
+	  (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg)))
+
+	  ;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size)
+	  (inst add ,temp-tn csp-tn vm:lowtag-mask)
+	  (inst andn ,temp-tn vm:lowtag-mask)
+	  ;; Set the result to temp-tn, with appropriate lowtag
+	  (inst or ,result-tn ,temp-tn ,lowtag)
+
+	  ;; Allocate the desired space on the stack.
+	  ;;
+	  ;; FIXME: Can't allocate on stack if SIZE is too large.
+	  ;; Need to rearrange this code.
+	  (inst add csp-tn ,temp-tn ,size)
+	  )
+	 #-gencgc
+	 (t
+	  ;; Normal allocation to the heap.
+	  (if (logbitp (1- lowtag-bits) ,lowtag)
+	      (progn
+		(inst or ,result-tn alloc-tn ,lowtag)
+		(inst add alloc-tn ,size))
+	      (progn
+		(inst andn ,result-tn alloc-tn lowtag-mask)
+		(inst or ,result-tn ,lowtag)
+		(inst add alloc-tn ,size))))
+	 #+gencgc
+	 (t
+	  ;; See if we can do an inline allocation.  The updated
+	  ;; free pointer should not point past the end of the
+	  ;; current region.  If it does, a full alloc needs to be
+	  ;; done.
+	  (load-symbol-value ,result-tn *current-region-end-addr*)
+
+	  ;; Sometimes the size is an known constant, but won't fit in
+	  ;; the immediate field of an instruction.  Hence we have to
+	  ;; do this to get it.
+	  (cond ((and (tn-p ,temp-tn)
+		      (numberp ,size)
+		      (not (typep ,size '(signed-byte 13))))
+		 (inst li ,temp-tn ,size)
+		 (inst add alloc-tn ,temp-tn))
+		(t
+		 (inst add alloc-tn ,size)))
+
+	  (inst andn ,temp-tn alloc-tn lowtag-mask) ; Zap PA bits
+	      
+	  ;; temp-tn points to the new end of region.  Did we go
+	  ;; past the actual end of the region?  If so, we need a
+	  ;; full alloc.
+	  (inst cmp ,temp-tn ,result-tn)
+	  (without-scheduling ()
+	    ;; NOTE: alloc-tn has been updated to point to the new
+	    ;; end.  But the allocation routines expect alloc-tn
+	    ;; points to original free region.  Thus, the allocation
+	    ;; trap handler MUST subtract SIZE from alloc-tn before
+	    ;; calling the alloc routine.  This allows for
+	    ;; (slightly) faster code for inline allocation.
+
+	    ;; As above, SIZE might not fit in the immediate field of
+	    ;; an instruction.  Need to do this complicated thing.
+			      
+            (cond ((and (tn-p ,temp-tn)
+			(numberp ,size)
+			(not (typep ,size '(signed-byte 13))))
+		   (inst li ,result-tn ,size)
+		   (inst sub ,result-tn ,temp-tn ,result-tn))
+		  (t
+		   (inst sub ,result-tn ,temp-tn ,size)))
+	    (inst t :gt allocation-trap))
+	  ;; Set lowtag appropriately
+	  (inst or ,result-tn ,lowtag))))
+
+(defmacro with-fixed-allocation ((result-tn temp-tn type-code size
+					    &key (lowtag other-pointer-type)
+					    stack-p)
+				 &body body)
+  "Do stuff to allocate an other-pointer object of fixed Size with a single
+  word header having the specified Type-Code.  The result is placed in
+  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
+  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
+  initializes the object."
+  (once-only ((result-tn result-tn) (temp-tn temp-tn)
+	      (type-code type-code) (size size)
+	      (lowtag lowtag))
+    `(pseudo-atomic ()
+       (allocation ,result-tn (pad-data-block ,size) ,lowtag
+	           :temp-tn ,temp-tn
+	           :stack-p ,stack-p)
+      (when ,type-code
+	(inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
+	(storew ,temp-tn ,result-tn 0 ,lowtag))
+       ,@body)))
+
+
+;;;; Type testing noise.
+
+;;; GEN-RANGE-TEST -- internal
+;;;
+;;; Generate code that branches to TARGET iff REG contains one of VALUES.
+;;; If NOT-P is true, invert the test.  Jumping to NOT-TARGET is the same
+;;; as falling out the bottom.
+;;; 
+(defun gen-range-test (reg target not-target not-p min seperation max values)
+  (let ((tests nil)
+	(start nil)
+	(end nil)
+	(insts nil))
+    (multiple-value-bind (equal less-or-equal greater-or-equal label)
+			 (if not-p
+			     (values :ne :gt :lt not-target)
+			     (values :eq :le :ge target))
+      (flet ((emit-test ()
+	       (if (= start end)
+		   (push start tests)
+		   (push (cons start end) tests))))
+	(dolist (value values)
+	  (cond ((< value min)
+		 (error (intl:gettext "~S is less than the specified minimum of ~S")
+			value min))
+		((> value max)
+		 (error (intl:gettext "~S is greater than the specified maximum of ~S")
+			value max))
+		((not (zerop (rem (- value min) seperation)))
+		 (error (intl:gettext "~S isn't an even multiple of ~S from ~S")
+			value seperation min))
+		((null start)
+		 (setf start value))
+		((> value (+ end seperation))
+		 (emit-test)
+		 (setf start value)))
+	  (setf end value))
+	(emit-test))
+      (macrolet ((inst (name &rest args)
+		       `(push (list 'inst ',name ,@args) insts)))
+	(do ((remaining (nreverse tests) (cdr remaining)))
+	    ((null remaining))
+	  (let ((test (car remaining))
+		(last (null (cdr remaining))))
+	    (if (atom test)
+		(progn
+		  (inst cmp reg test)
+		  (if last
+		      (inst b equal target)
+		      (inst b :eq label)))
+		(let ((start (car test))
+		      (end (cdr test)))
+		  (cond ((and (= start min) (= end max))
+			 (warn (intl:gettext "The values ~S cover the entire range from ~
+			 ~S to ~S [step ~S].")
+			       values min max seperation)
+			 (push `(unless ,not-p (inst b ,target)) insts))
+			((= start min)
+			 (inst cmp reg end)
+			 (if last
+			     (inst b less-or-equal target)
+			     (inst b :le label)))
+			((= end max)
+			 (inst cmp reg start)
+			 (if last
+			     (inst b greater-or-equal target)
+			     (inst b :ge label)))
+			(t
+			 (inst cmp reg start)
+			 (inst b :lt (if not-p target not-target))
+			 (inst cmp reg end)
+			 (if last
+			     (inst b less-or-equal target)
+			     (inst b :le label))))))))))
+    (nreverse insts)))
+
+(defun gen-other-immediate-test (reg target not-target not-p values)
+  (gen-range-test reg target not-target not-p
+		  (+ other-immediate-0-type lowtag-limit)
+		  (- other-immediate-1-type other-immediate-0-type)
+		  (ash 1 type-bits)
+		  values))
+
+
+(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
+			  function-p)
+  (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
+		       (member odd-fixnum-type lowtags :test #'eql)))
+	 (lowtags (sort (if fixnump
+			    (delete even-fixnum-type
+				    (remove odd-fixnum-type lowtags
+					    :test #'eql)
+				    :test #'eql)
+			    (copy-list lowtags))
+			#'<))
+	 (lowtag (if function-p
+		     vm:function-pointer-type
+		     vm:other-pointer-type))
+	 (hdrs (sort (copy-list hdrs) #'<))
+	 (immed (sort (copy-list immed) #'<)))
+    (append
+     (when immed
+       `((inst and ,temp ,reg type-mask)
+	 ,@(if (or fixnump lowtags hdrs)
+	       (let ((fall-through (gensym)))
+		 `((let (,fall-through (gen-label))
+		     ,@(gen-other-immediate-test
+			temp (if not-p not-target target)
+			fall-through nil immed)
+		     (emit-label ,fall-through))))
+	       (gen-other-immediate-test temp target not-target not-p immed))))
+     (when fixnump
+       `((inst andcc zero-tn ,reg fixnum-tag-mask)
+	 ,(if (or lowtags hdrs)
+	      `(inst b :eq ,(if not-p not-target target)
+		     #+sparc-v9 ,(if not-p :pn :pt))
+	      `(inst b ,(if not-p :ne :eq) ,target
+		       #+sparc-v9 ,(if not-p :pn :pt)))))
+     (when (or lowtags hdrs)
+       `((inst and ,temp ,reg lowtag-mask)))
+     (when lowtags
+       (if hdrs
+	   (let ((fall-through (gensym)))
+	     `((let ((,fall-through (gen-label)))
+		 ,@(gen-range-test temp (if not-p not-target target)
+				   fall-through nil
+				   0 1 (1- lowtag-limit) lowtags)
+		 (emit-label ,fall-through))))
+	   (gen-range-test temp target not-target not-p 0 1
+			   (1- lowtag-limit) lowtags)))
+     (when hdrs
+       `((inst cmp ,temp ,lowtag)
+	 (inst b :ne ,(if not-p target not-target)
+	         #+sparc-v9 ,(if not-p :pn :pt))
+	 (inst nop)
+	 (load-type ,temp ,reg (- ,lowtag))
+	 ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
+
+(defconstant immediate-types
+  (list base-char-type unbound-marker-type))
+
+(defconstant function-subtypes
+  (list funcallable-instance-header-type
+	#-double-double dylan-function-header-type
+	function-header-type closure-function-header-type
+	closure-header-type))
+
+(defmacro test-type (register temp target not-p &rest type-codes)
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended immediate-types :test #'eql))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p nil))
+    (unless type-codes
+      (error (intl:gettext "Must supply at least on type for test-type.")))
+    (when (and headers (member other-pointer-type lowtags))
+      (warn (intl:gettext "OTHER-POINTER-TYPE supersedes the use of ~S") headers)
+      (setf headers nil))
+    (when (and immediates
+	       (or (member other-immediate-0-type lowtags)
+		   (member other-immediate-1-type lowtags)))
+      (warn (intl:gettext "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S") immediates)
+      (setf immediates nil))
+    (when (intersection headers function-subtypes)
+      (unless (subsetp headers function-subtypes)
+	(error (intl:gettext "Can't test for mix of function subtypes and normal ~
+		header types.")))
+      (setq function-p t))
+      
+    (let ((n-reg (gensym))
+	  (n-temp (gensym))
+	  (n-target (gensym))
+	  (not-target (gensym)))
+      `(let ((,n-reg ,register)
+	     (,n-temp ,temp)
+	     (,n-target ,target)
+	     (,not-target (gen-label)))
+	 (declare (ignorable ,n-temp))
+	 ,@(if (constantp not-p)
+	       (test-type-aux n-reg n-temp n-target not-target
+			      (eval not-p) lowtags immediates headers
+			      function-p)
+	       `((cond (,not-p
+			,@(test-type-aux n-reg n-temp n-target not-target t
+					 lowtags immediates headers
+					 function-p))
+		       (t
+			,@(test-type-aux n-reg n-temp n-target not-target nil
+					 lowtags immediates headers
+					 function-p)))))
+	 (inst nop)
+	 (emit-label ,not-target)))))
+
+
+;;;; 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 unimp ,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 b ,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)
+  (declare (ignore extra))
+  `(progn
+     ;; Set the pseudo-atomic flag
+     (without-scheduling ()
+       (inst or alloc-tn pseudo-atomic-value))
+     ,@forms
+     ;; Reset the pseudo-atomic flag
+     (without-scheduling ()
+       ;; Remove the pseudo-atomic flag.  (Could do subtraction here,
+       ;; but the disassembler prints some notes based on the add
+       ;; instruction.)
+       (inst andn alloc-tn pseudo-atomic-value)
+       ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1)
+       (inst andcc zero-tn alloc-tn pseudo-atomic-interrupted-value)
+       ;; The C code needs to process this correctly and fixup alloc-tn.
+       (inst t :ne pseudo-atomic-trap)
+       )))
diff --git a/src/compiler/sparcv9/memory.lisp b/src/compiler/sparcv9/memory.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3830309614818191c2589dabf95bda90cbc11b63
--- /dev/null
+++ b/src/compiler/sparcv9/memory.lisp
@@ -0,0 +1,118 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/memory.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the SPARC definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "SPARC")
+
+;;; 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)))
+  (: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)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (storew value object (+ base offset) lowtag)))
+
+
+
+;;;; Indexed references:
+
+;;; Define-Indexer  --  Internal
+;;;
+;;;    Define some VOPs for indexed memory reference.
+;;;
+(defmacro define-indexer (name write-p op shift)
+  `(define-vop (,name)
+     (:args (object :scs (descriptor-reg))
+	    (index :scs (any-reg zero immediate))
+	    ,@(when write-p
+		'((value :scs (any-reg descriptor-reg) :target result))))
+     (:arg-types * tagged-num ,@(when write-p '(*)))
+     (:temporary (:scs (non-descriptor-reg)) temp)
+     (:results (,(if write-p 'result 'value)
+		:scs (any-reg descriptor-reg)))
+     (:result-types *)
+     (:variant-vars offset lowtag)
+     (:policy :fast-safe)
+     (:generator 5
+       (sc-case index
+	 ((immediate zero)
+	  (let ((offset (- (+ (if (sc-is index zero)
+				  0
+				  (ash (tn-value index)
+				       (- vm:word-shift ,shift)))
+			      (ash offset vm:word-shift))
+			   lowtag)))
+	    (etypecase offset
+	      ((signed-byte 13)
+	       (inst ,op value object offset))
+	      ((or (unsigned-byte 32) (signed-byte 32))
+	       (inst li temp offset)
+	       (inst ,op value object temp)))))
+	 (t
+	  ,@(unless (zerop shift)
+	      `((inst srln temp index ,shift)))
+	  (inst add temp ,(if (zerop shift) 'index 'temp)
+		(- (ash offset vm:word-shift) lowtag))
+	  (inst ,op value object temp)))
+       ,@(when write-p
+	   '((move result value))))))
+
+#+sparc-v9
+(define-indexer signed-word-index-ref nil ldsw 0)
+#+sparc-v9
+(define-indexer signed-word-index-set nil st 0)
+(define-indexer word-index-ref nil ld 0)
+(define-indexer word-index-set t st 0)
+(define-indexer halfword-index-ref nil lduh 1)
+(define-indexer signed-halfword-index-ref nil ldsh 1)
+(define-indexer halfword-index-set t sth 1)
+(define-indexer byte-index-ref nil ldub 2)
+(define-indexer signed-byte-index-ref nil ldsb 2)
+(define-indexer byte-index-set t stb 2)
+
diff --git a/src/compiler/sparcv9/move.lisp b/src/compiler/sparcv9/move.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7b683b5c0dae594be7a27bbef0f99ce426797549
--- /dev/null
+++ b/src/compiler/sparcv9/move.lisp
@@ -0,0 +1,680 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/move.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/compiler/sparc/move.lisp $
+;;;
+;;;    This file contains the SPARC VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by Rob MacLachlan.
+;;; SPARC conversion by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((null immediate zero)
+   (any-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (inst li y (fixnumize val)))
+      (null
+       (move y null-tn))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst li y (logior (ash (char-code val) type-bits)
+			  base-char-type))))))
+
+#-(and sparc-v9 sparc-v8plus)
+(define-move-function (load-number 1) (vop x y)
+  ((immediate zero)
+   (signed-reg unsigned-reg))
+  (inst li y (tn-value x)))
+
+#+(and sparc-v9 sparc-v8plus)
+(define-move-function (load-number 1) (vop x y)
+  ((immediate zero)
+   (signed-reg unsigned-reg signed64-reg unsigned64-reg))
+  (inst li64 y (tn-value x)))
+
+(define-move-function (load-base-char 1) (vop x y)
+  ((immediate) (base-char-reg))
+  (inst li y (char-code (tn-value x))))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst li y (sap-int (tn-value x))))
+
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg))
+  (loadw y code-tn (tn-offset x) other-pointer-type gtemp-tn))
+
+(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)
+   (sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (let ((nfp (current-nfp-tn vop)))
+    (loadw y nfp (tn-offset x))))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((any-reg descriptor-reg) (control-stack))
+  (store-stack-tn y x))
+
+(define-move-function (store-number-stack 5) (vop x y)
+  ((base-char-reg) (base-char-stack)
+   (sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (let ((nfp (current-nfp-tn vop)))
+    (storew 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)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+
+(define-move-vop move :move
+  (any-reg descriptor-reg)
+  (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 zero null))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg descriptor-reg)
+       (move y x))
+      (control-stack
+       (storew x fp (tn-offset y) 0 temp)))))
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg descriptor-reg)
+  (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 _N"fixnum untagging")
+  (:generator 1
+    (inst sran y x fixnum-tag-bits)))
+
+;;;
+(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 _N"constant load")
+  (:generator 1
+    (inst li y (tn-value x))))
+
+;;;
+(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.
+#-(and sparc-v9 sparc-v8plus)
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note _N"integer to untagged word coercion")
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst andcc temp x fixnum-tag-mask)
+      (inst b :eq done)
+      (inst sran y x fixnum-tag-bits)
+      
+      (loadw y x bignum-digits-offset other-pointer-type)
+      
+      (emit-label done))))
+
+;; Same as above, but the number is sign-extended to a full 64-bit
+;; length.  Not really needed, I suppose.
+#+(and sparc-v9 sparc-v8plus)
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note _N"integer to untagged word coercion")
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst andcc temp x fixnum-tag-mask)
+      (inst signx temp x)		; sign-extend x to temp
+      (inst b :eq done)
+      (inst srax y temp fixnum-tag-bits)
+      
+      (loadsw y x bignum-digits-offset other-pointer-type)
+      
+      (emit-label done))))
+
+;;;
+(define-move-vop move-to-word/integer :move
+  (descriptor-reg) (signed-reg unsigned-reg))
+
+
+    
+;;; 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 _N"fixnum tagging")
+  (:generator 1
+    (inst slln y x fixnum-tag-bits)))
+;;;
+(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)
+  (:note _N"signed word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((done (gen-label)))
+      ;; Need to figure out if we have a fixnum or not, so look at the
+      ;; top 3 bits of the 32-bit int.  If these 3 bits are 0 or 7,
+      ;; then we have a fixnum.  Otherwise we need to allocate a
+      ;; bignum.
+      ;;
+      ;; A simple way to tell if those 3 bits are 0 or 7 was given by
+      ;; Frode Vatvedt Fjeld: (zerop (logand #b110 (1+ temp)))
+      (inst srln temp x positive-fixnum-bits)
+      (inst add temp 1)
+      (inst andcc temp #b110)
+      (inst b :eq done)
+      (inst slln y x fixnum-tag-bits)
+      
+      (with-fixed-allocation
+	(y temp bignum-type (1+ bignum-digits-offset))
+	(storew x y bignum-digits-offset other-pointer-type))
+      (emit-label done))))
+;;;
+(define-move-vop move-from-signed :move
+  (signed-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.
+;;;
+    
+;;; 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.
+;;;
+#-sparc-v9
+(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)
+  (:note _N"unsigned word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((done (gen-label))
+	  (one-word (gen-label)))
+      (inst sran temp x positive-fixnum-bits)
+      (inst cmp temp)
+      (inst b :eq done)
+      (inst slln y x fixnum-tag-bits)
+
+      ;; We always allocate 2 words even if we don't need it.  (The
+      ;; copying GC will take care of freeing the unused extra word.)
+      (with-fixed-allocation
+	  (y temp bignum-type (+ 2 bignum-digits-offset))
+	(inst cmp x)
+	(inst b :ge one-word)
+	(inst li temp (logior (ash 1 type-bits) bignum-type))
+	(inst li temp (logior (ash 2 type-bits) bignum-type))
+	(emit-label one-word)
+	;; Set the header word, then the actual digit.  The extra
+	;; digit, if any, is automatically set to zero, so we don't
+	;; have to.
+	(storew temp y 0 other-pointer-type)
+	(storew x y bignum-digits-offset other-pointer-type))
+      (emit-label done))))
+
+#+sparc-v9
+(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)
+  (:note _N"unsigned word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((done (gen-label)))
+      (inst sran temp x positive-fixnum-bits)
+      (inst cmp temp)
+      (inst b :eq done)
+      (inst slln y x fixnum-tag-bits)
+
+      ;; We always allocate 2 words even if we don't need it.  (The
+      ;; copying GC will take care of freeing the unused extra word.)
+      (with-fixed-allocation (y temp nil (+ 2 bignum-digits-offset))
+	(inst cmp x)
+	(inst li temp (logior (ash 2 type-bits) bignum-type))
+	(inst cmove :ge temp (logior (ash 1 type-bits) bignum-type))
+	;; Set the header word, then the actual digit.  The extra
+	;; digit, if any, is automatically set to zero, so we don't
+	;; have to.
+	(storew temp y 0 other-pointer-type)
+	(storew x y bignum-digits-offset other-pointer-type))
+      (emit-label 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 _N"word integer move")
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop word-move :move
+  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:note _N"word integer argument move")
+  (:generator 0
+    (sc-case y
+      ((signed-reg unsigned-reg)
+       (move y x))
+      ((signed-stack unsigned-stack)
+       (storew x fp (tn-offset y) 0 temp)))))
+;;;
+(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))
+
+;; 64-bit stuff
+#+(and sparc-v9 sparc-v8plus)
+(progn
+
+;; Move a signed-reg to a signed64-reg by sign-extending.  (Is this
+;; needed?)
+(define-move-function (load-signed64-signed 1) (vop x y)
+  ((signed-reg) (signed64-reg unsigned64-reg))
+  (inst signx y x))
+
+;; Move a signed64-reg to signed-reg by setting the high 32 bits to be
+;; the sign.  (Is this needed and will this do the right thing when
+;; that signed64-reg actually has more than 32 significant bits?)
+#+nil
+(define-move-function (load-signed-signed64 1) (vop x y)
+  ((signed64-reg) (signed-reg))
+  (inst signx y x))
+
+;; Load a 64-bit number from the stack
+(define-move-function (load-number-stack-64 5) (vop x y)
+  ((signed64-stack) (signed64-reg)
+   (unsigned64-stack) (unsigned64-reg))
+  (let ((nfp (current-nfp-tn vop)))
+    (load64 y nfp (tn-offset x))))
+
+;; Save a 64-bit number to the stack
+(define-move-function (store-number-stack-64 5) (vop x y)
+  ((signed64-reg) (signed64-stack)
+   (unsigned64-reg) (unsigned64-stack))
+  (let ((nfp (current-nfp-tn vop)))
+    (store64 x nfp (tn-offset y))))
+
+;; Move a tagged integer to a raw double-word representation.
+(define-vop (move-to-64bit-word/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)))
+  (:results (y :scs (signed64-reg unsigned64-reg)))
+  (:arg-types tagged-num)
+  (:note _N"fixnum untagging")
+  (:generator 0
+    ;; Sign-extend the fixnum and then remove the tag.  (Can't just
+    ;; remove the tag because we don't know for sure if X has been
+    ;; sign-extended to 64-bits.  Let's be safe.)
+    (inst signx y x)	      
+    (inst srax y y fixnum-tag-bits)))
+
+(define-move-vop move-to-64bit-word/fixnum :move
+  (any-reg descriptor-reg) (signed64-reg unsigned64-reg))
+
+;; Arg is a non-immediate constant, load it.
+(define-vop (move-to-64bit-word-c)
+  (:args (x :scs (constant)))
+  (:results (y :scs (signed64-reg unsigned64-reg)))
+  (:note _N"constant load")
+  (:generator 1
+    (inst li64 y (tn-value x))))
+
+(define-move-vop move-to-64bit-word-c :move
+  (constant) (signed64-reg unsigned64-reg))
+
+;; Arg is a fixnum or bignum.  Figure out which and load if necessary
+(define-vop (move-to-64bit-word/integer)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (signed64-reg)))
+  (:note _N"integer to untagged word coercion")
+  (:temporary (:scs (signed64-reg)) temp)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst andcc temp x fixnum-tag-mask)
+      (inst signx temp x)		; sign-extend X to TEMP
+      (inst b :eq done :pt :xcc)
+      (inst sran y temp fixnum-tag-bits)	; Zap the tag bits
+
+      ;; We have a bignum.  We need to check the length.  If the
+      ;; length is 1, just get the one word.  If it's 2, we need to
+      ;; get both words.
+
+      (loadw temp x 0 other-pointer-type)
+      (inst srln temp 8)
+      (inst cmp temp 1)
+      (inst b :eq done)
+      ;; Get the low word and sign-extend it
+      (loadsw y x bignum-digits-offset other-pointer-type)
+
+      
+      ;; Get the high word and then the low word.  Merge them
+      ;; together. (If we knew that bignum digits started on an 8-byte
+      ;; boundary, we could do an 8-byte load and them manipulate the
+      ;; pieces to get the order we want.  I think this would require
+      ;; adding a filler word to the bignum type in objdef.lisp.  But
+      ;; then every bignum has a wasted word.  Is that ok?)
+      (loadw temp x (1+ bignum-digits-offset) other-pointer-type)
+      (inst sllx temp temp 32)
+      (loadw y x bignum-digits-offset other-pointer-type)
+      (inst or y temp)
+
+      (emit-label done)
+
+      )))
+
+(define-move-vop move-to-64bit-word/integer :move
+  (descriptor-reg) (signed64-reg))
+
+;; Move a signed-byte 32 to a signed-byte 64.  (Is this ever called?
+;; I don't think so.)
+(define-vop (move-to-64bit-word/signed)
+  (:args (x :scs (signed-reg)))
+  (:results (y :scs (signed64-reg)))
+  (:arg-types signed-num)
+  (:generator 0
+    ;; Sign-extend the 32-bit number
+    (inst signx y x)))
+
+(define-move-vop move-to-64bit-word/signed :move
+  (signed-reg) (signed64-reg unsigned64-reg))
+
+;; Move an unsigned-byte 32 to signed-byte 64.  (I don't think this
+;; ever gets called.)
+(define-vop (move-to-64bit-word/unsigned)
+  (:args (x :scs (unsigned-reg)))
+  (:results (y :scs (signed64-reg)))
+  (:arg-types unsigned-num)
+  (:generator 1
+    ;; Zero-extend the 32-bit number	      
+    (inst clruw y x)))
+
+(define-move-vop move-to-64bit-word/unsigned :move
+  (unsigned-reg) (signed64-reg unsigned64-reg))
+
+;; Save a 64-bit int to a bignum.
+(define-vop (move-from-signed64)
+  (:args (arg :scs (signed64-reg) :target x))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (signed64-reg) :from (:argument 0)) x temp)
+  (:note _N"signed 64-bit word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((fixnum (gen-label))
+	  (done (gen-label)))
+      ;; See if the result will fit in a fixnum.
+      (inst srax temp x positive-fixnum-bits)
+      (inst cmp temp)
+      ;; If result is all zeroes, we have a positive fixnum.
+      (inst b :eq fixnum :pt :xcc)
+      (inst orncc temp zero-tn temp)
+      ;; If result is all zeroes, we have a negative fixnum.
+      (inst b :eq done :pt :xcc)
+      (inst slln y x fixnum-tag-bits)
+
+      ;; A 64-bit signed integer takes exactly 2 bignum digits
+      (with-fixed-allocation
+	(y temp bignum-type (+ 2 bignum-digits-offset))
+	;; Store the low word at the low address, the high word at the
+	;; higher address.  (Like move-to-64bit-word/integer, if we knew
+	;; the first bignum digit was on a 8-byte boundary, we could
+	;; just do a single 8-byte store instead of 2 stores here.)
+	(storew x y bignum-digits-offset other-pointer-type)
+	(inst srax x x 32)
+	(storew x y (1+ bignum-digits-offset) other-pointer-type))
+      (inst b done)
+      (inst nop)
+      
+      (emit-label fixnum)
+      (inst slln y x fixnum-tag-bits)
+      (emit-label done))))
+
+(define-move-vop move-from-signed64 :move
+  (signed64-reg) (descriptor-reg))
+
+;; Save an unsigned 64-bit int to a bignum.
+(define-vop (move-from-unsigned64)
+  (:args (arg :scs (unsigned64-reg) :target x))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (unsigned64-reg) :from (:argument 0)) x temp)
+  (:note _N"unsigned 64-bit word to integer coercion")
+  (:generator 20
+    (move x arg)
+    (let ((two-words (gen-label))
+	  (done (gen-label)))
+      ;; See if the result will fit in a fixnum.
+      (inst srax temp x positive-fixnum-bits)
+      (inst cmp temp)
+      ;; If result is all zeroes, we have a positive fixnum.
+      (inst b :eq done :pt :xcc)
+      (inst slln y x fixnum-tag-bits)
+
+      ;; A unsigned 64-bit signed integer takes exactly 2 or 3 bignum
+      ;; digits.  We always allocate 3.  (The copying GC will take
+      ;; care of freeing the unused extra word, if any.)
+      (with-fixed-allocation
+	(y temp bignum-type (+ 3 bignum-digits-offset))
+	(inst cmp x)
+	(inst b :ge two-words :pn :xcc)
+	(inst li temp (logior (ash 2 type-bits) bignum-type))
+	(inst li temp (logior (ash 3 type-bits) bignum-type))
+	(emit-label two-words)
+	;; Set the header word with the correct bignum length.
+	(storew temp y 0 other-pointer-type)
+	;; Store the low word at the low address, the high word at the
+	;; higher address.  (Like move-to-64bit-word/integer, if we knew
+	;; the first bignum digit was on a 8-byte boundary, we could
+	;; just do a single 8-byte store instead of 2 stores here.)
+	(storew x y bignum-digits-offset other-pointer-type)
+	(inst srax x x 32)
+	(storew x y (1+ bignum-digits-offset) other-pointer-type))
+      (emit-label done))))
+
+(define-move-vop move-from-unsigned64 :move
+  (unsigned64-reg) (descriptor-reg))
+
+(define-vop (move-to-unsigned-64bit-word/integer)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (unsigned64-reg)))
+  (:note _N"integer to untagged word coercion")
+  (:temporary (:scs (unsigned64-reg)) temp)
+  (:generator 4
+    (let ((done (gen-label)))
+      (inst andcc temp x fixnum-tag-mask)
+      (inst signx temp x)		; sign-extend X to TEMP
+      (inst b :eq done :pt :xcc)
+      (inst sran y temp fixnum-tag-bits)	; Zap the tag bits
+
+      ;; We have a bignum.  We need to check the length.  If the
+      ;; length is 1, just get the one word.  If it's 2, we need to
+      ;; get both words.
+
+      (loadw temp x 0 other-pointer-type)
+      (inst srln temp 8)
+      (inst cmp temp 1)
+      (inst b :eq done)
+      ;; Get the low word and zero-extend it and we're done.
+      (loadw y x bignum-digits-offset other-pointer-type)
+
+      
+      ;; Get the high word and then the low word.  Merge them
+      ;; together. (If we knew that bignum digits started on an 8-byte
+      ;; boundary, we could do an 8-byte load and them manipulate the
+      ;; pieces to get the order we want.  I think this would require
+      ;; adding a filler word to the bignum type in objdef.lisp.  But
+      ;; then every bignum has a wasted word.  Is that ok?)
+      (loadw temp x (1+ bignum-digits-offset) other-pointer-type)
+      (inst sllx temp temp 32)
+      (loadw y x bignum-digits-offset other-pointer-type)
+      (inst or y temp)
+
+      (emit-label done)
+
+      )))
+
+(define-move-vop move-to-unsigned-64bit-word/integer :move
+  (descriptor-reg) (unsigned64-reg))
+
+(define-vop (64bit-word-move)
+  (:args (x :target y
+	    :scs (signed64-reg unsigned64-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (signed64-reg unsigned64-reg)
+	       :load-if (not (location= x y))))
+  (:effects)
+  (:affected)
+  (:note _N"word integer move")
+  (:generator 0
+    (move y x)))
+
+(define-move-vop 64bit-word-move :move
+  (signed64-reg unsigned64-reg) (signed64-reg unsigned64-reg))
+
+;; Move untagged number arguments/return-values.
+(define-vop (move-64bit-word-argument)
+  (:args (x :target y
+	    :scs (signed-reg signed64-reg unsigned64-reg immediate))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note _N"word integer argument move")
+  (:generator 0
+    (sc-case y
+      ((signed64-reg unsigned64-reg)
+       (sc-case x
+	 ((signed64-reg unsigned64-reg)
+	  (move y x))
+	 (signed-reg
+	  (inst signx y x))
+	 (immediate
+	  (inst li64 y (tn-value x)))))
+      ((signed64-stack unsigned64-stack)
+       (store64 x fp (tn-offset y))))))
+
+(define-move-vop move-64bit-word-argument :move-argument
+  (descriptor-reg signed64-reg unsigned64-reg) (signed64-reg unsigned64-reg))
+
+(define-move-vop move-argument :move-argument
+  (signed64-reg unsigned64-reg) (descriptor-reg))
+
+)
diff --git a/src/compiler/sparcv9/nlx.lisp b/src/compiler/sparcv9/nlx.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d8a5b8b94eeb5f62f5a52487d2cdd58bd5979dc1
--- /dev/null
+++ b/src/compiler/sparcv9/nlx.lisp
@@ -0,0 +1,303 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/nlx.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;
+;;;    This file contains the definitions of VOPs used for non-local exit
+;;; (throw, lexical exit, etc.)
+;;;
+;;; Written by Rob MacLachlan
+;;;
+(in-package "SPARC")
+
+;;; 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))
+
+;;; Make-NLX-Entry-Argument-Start-Location  --  Interface
+;;;
+;;;    Make a TN for the argument count passing location for a
+;;; non-local entry.
+;;;
+(def-vm-support-routine make-nlx-entry-argument-start-location ()
+  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
+
+
+;;; Save and restore dynamic environment.
+;;;
+;;;    These VOPs are used in the reentered function to restore the appropriate
+;;; dynamic environment.  Currently we only save the Current-Catch and binding
+;;; stack pointer.  We don't need to save/restore the current unwind-protect,
+;;; since unwind-protects are implicitly processed during unwinding.  If there
+;;; were any additional stacks, then this would be the place to restore the top
+;;; pointers.
+
+
+;;; Make-Dynamic-State-TNs  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(def-vm-support-routine make-dynamic-state-tns ()
+  (make-n-tns 4 *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
+	(move nfp cur-nfp)))
+    (move nsp nsp-tn)
+    (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)
+  (:generator 10
+    (store-symbol-value catch lisp::*current-catch-block*)
+    (store-symbol-value eval lisp::*eval-stack-top*)
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(move cur-nfp nfp)))
+    (move nsp-tn nsp)))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move res csp-tn)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (move res bsp-tn)))
+
+
+
+;;;; 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
+    (let ((byte-offset (* (tn-offset tn) vm:word-bytes)))
+      (if (typep byte-offset '(signed-byte 13))
+	  (inst add block cfp-tn byte-offset)
+	  (progn
+	    (inst li ndescr byte-offset)
+	    (inst add block cfp-tn ndescr))))
+    (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 any-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
+    (let ((byte-offset (* (tn-offset tn) vm:word-bytes)))
+      (if (typep byte-offset '(signed-byte 13))
+	  (inst add result cfp-tn byte-offset)
+	  (progn
+	    (inst li ndescr byte-offset)
+	    (inst add result cfp-tn ndescr))))
+    (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 block result)))
+
+
+;;; 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)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 7
+    (let ((byte-offset (* (tn-offset tn) vm:word-bytes)))
+      (if (typep byte-offset '(signed-byte 13))
+	  (inst add new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
+	  (progn
+	    (inst li ndescr byte-offset)
+	    (inst add new-uwp cfp-tn ndescr))))
+    (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)
+  (: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)))
+	     (inst cmp count)
+	     (inst b :eq no-values)
+	     (move (tn-ref-tn values) null-tn)
+	     (loadw (tn-ref-tn values) start)
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (inst subcc count (fixnumize 1))
+	     (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 b :lt default-lab)
+		 (inst subcc count (fixnumize 1))
+		 (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 tn null-tn))
+			      (control-stack
+			       (store-stack-tn tn null-tn)))))
+		 (inst b defaulting-done)
+		 (inst nop))))))
+    (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+  (:args (top :target result) (src) (count))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (:info label)
+  (:temporary (:scs (any-reg)) dst)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:results (result :scs (any-reg) :from (:argument 0))
+	    (num :scs (any-reg) :from (:argument 0)))
+  (: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)))
+
+      ;; Setup results, and test for the zero value case.
+      (load-stack-tn result top)
+      (inst cmp count)
+      (inst b :eq done)
+      (inst li num 0)
+
+      ;; Compute dst as one slot down from result, because we inc the index
+      ;; before we use it.
+      (inst sub dst result 4)
+
+      ;; Copy stuff down the stack.
+      (emit-label loop)
+      (inst ldn temp src num)
+      (inst add num (fixnumize 1))
+      (inst cmp num count)
+      (inst b :ne loop)
+      (inst stn temp dst num)
+
+      ;; Reset the CSP.
+      (emit-label done)
+      (inst add csp-tn result num))))
+
+
+;;; 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/src/compiler/sparcv9/parms.lisp b/src/compiler/sparcv9/parms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ec151f4197a8741d7634a44fa09b76c38d116a4b
--- /dev/null
+++ b/src/compiler/sparcv9/parms.lisp
@@ -0,0 +1,425 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/parms.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains some parameterizations of various VM
+;;; attributes for the SPARC.  This file is separate from other stuff so 
+;;; that it can be compiled and loaded earlier. 
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted to MIPS by William Lott.
+;;;
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+(use-package "C")
+
+
+;;;; Compiler constants.
+
+(eval-when (compile eval load)
+
+#+svr4
+(adjoin :svr4 (backend-features *target-backend*))
+#+svr4
+(adjoin :solaris (backend-features *target-backend*))
+(setf (backend-name *target-backend*) "SPARC")
+#+svr4
+(setf (backend-version *target-backend*)
+      #-sparc-v9 "SPARCstation/Solaris 2.x"
+      #+sparc-v9 "UltraSPARC/Solaris")
+#-svr4
+(setf (backend-version *target-backend*) "SPARCstation/Sun 4")
+(setf (backend-fasl-file-type *target-backend*) "sparcf")
+(setf (backend-fasl-file-implementation *target-backend*)
+      sparc-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) byte-fasl-file-version)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :big-endian)
+(setf (backend-page-size *target-backend*)
+      #+mach 4096 #+sunos 8192)
+
+(setf (c::backend-foreign-linkage-space-start *target-backend*)
+      ;; This better match the value in sparc-validate.h!
+      #x0f800000
+      (c::backend-foreign-linkage-entry-size *target-backend*)
+      ;; This better agree with what sparc-arch.c thinks it is!  Right now,
+      ;; it's 4 instructions, so 16 bytes.
+      16)
+); eval-when
+
+(pushnew :new-assembler *features*)
+
+
+;;;; Machine Architecture parameters:
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(export '(word-bits byte-bits char-bits word-shift word-bytes char-bytes
+	  fixnum-tag-bits fixnum-tag-mask positive-fixnum-bits
+
+	  float-sign-shift
+
+	  single-float-bytes
+	  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-bytes
+	  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
+
+	  long-float-bias long-float-exponent-byte
+	  long-float-significand-byte long-float-normal-exponent-min
+	  long-float-normal-exponent-max long-float-hidden-bit
+	  long-float-trapping-nan-bit long-float-digits
+
+	  float-underflow-trap-bit float-overflow-trap-bit
+	  float-imprecise-trap-bit float-invalid-trap-bit
+	  float-divide-by-zero-trap-bit))
+
+#+double-double
+(export '(double-double-float-digits))
+) ; eval-when
+	  
+
+(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 char-bits #-unicode 8 #+unicode 16
+  "Number of bits needed to represent a character")
+
+(defconstant char-bytes (truncate char-bits byte-bits)
+  "Number of bytes needed to represent a character")
+
+(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 lowtag-bits 3
+  "Number of bits at the low end of a pointer used for type information.")
+
+(defconstant lowtag-mask (1- (ash 1 lowtag-bits))
+  "Mask to extract the low tag bits from a pointer.")
+  
+(defconstant lowtag-limit (ash 1 lowtag-bits)
+  "Exclusive upper bound on the value of the low tag bits from a
+  pointer.")
+
+(defconstant fixnum-tag-bits (1- lowtag-bits)
+  "Number of tag bits used for a fixnum")
+
+(defconstant fixnum-tag-mask (1- (ash 1 fixnum-tag-bits))
+  "Mask to get the fixnum tag")
+
+(defconstant positive-fixnum-bits (- word-bits fixnum-tag-bits 1)
+  "Maximum number of bits in a positive fixnum")
+
+(defconstant float-sign-shift 31)
+
+(defconstant single-float-bytes 4)	; Bytes to hold a single-float
+(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-bytes 8)	; Bytes to hold a double-float
+(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))
+
+;;; X These values are for the x86 80 bit format and are no doubt
+;;; incorrect for the sparc.
+(defconstant long-float-bias 16382)
+(defconstant long-float-exponent-byte (byte 15 0))
+(defconstant long-float-significand-byte (byte 31 0))
+(defconstant long-float-normal-exponent-min 1)
+(defconstant long-float-normal-exponent-max #x7FFE)
+(defconstant long-float-hidden-bit (ash 1 31))
+(defconstant long-float-trapping-nan-bit (ash 1 30))
+
+(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 long-float-digits
+  (+ (byte-size long-float-significand-byte) word-bits 1))
+
+#+double-double
+(defconstant double-double-float-digits
+  (* 2 double-float-digits))
+
+(defconstant float-inexact-trap-bit (ash 1 0))
+(defconstant float-divide-by-zero-trap-bit (ash 1 1))
+(defconstant float-underflow-trap-bit (ash 1 2))
+(defconstant float-overflow-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 30))	  ; RD 
+(defconstant float-sticky-bits (byte 5 5))	  ; aexc
+(defconstant float-traps-byte (byte 5 23))	  ; TEM
+(defconstant float-exceptions-byte (byte 5 0))	  ; cexc
+
+;;; According to the SPARC doc (as opposed to FPU doc), the fast mode
+;;; bit (EFM) is "reserved", and should always be zero.  However, for
+;;; sparc-V8 and sparc-V9, it appears to work, causing denormals to
+;;; be truncated to 0 silently.
+(defconstant float-fast-bit (ash 1 22))
+
+); eval-when
+
+;;; NUMBER-STACK-DISPLACEMENT
+;;;
+;;; The number of bytes reserved above the number stack pointer.  These
+;;; slots are required by architecture for a place to spill register windows.
+;;; 
+(defconstant number-stack-displacement
+  (* 16 vm:word-bytes))
+
+
+;;;; Description of the target address space.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(export '(target-read-only-space-start
+	  target-static-space-start
+	  target-dynamic-space-start
+	  target-foreign-linkage-space-start
+	  target-foreign-linkage-entry-size))
+)
+
+;;; Where to put the different spaces.  Must match the C code!
+;;; 
+(defconstant target-read-only-space-start #x10000000)
+(defconstant target-static-space-start    #x28000000)
+(defconstant target-dynamic-space-start   #x40000000)
+
+(defconstant target-foreign-linkage-space-start
+  (c:backend-foreign-linkage-space-start *target-backend*))
+(defconstant target-foreign-linkage-entry-size
+  (c:backend-foreign-linkage-entry-size *target-backend*))
+
+
+;;;; Other random constants.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
+	  breakpoint-trap function-end-breakpoint-trap
+	  after-breakpoint-trap allocation-trap
+	  pseudo-atomic-trap
+	  object-not-list-trap object-not-instance-trap
+	  trace-table-normal trace-table-call-site
+	  trace-table-function-prologue trace-table-function-epilogue))
+
+#+heap-overflow-check
+(export '(dynamic-space-overflow-error-trap
+	  dynamic-space-overflow-warning-trap))
+)
+	  
+(defenum (:suffix -trap :start 8)
+  halt
+  pending-interrupt
+  error
+  cerror
+  breakpoint
+  function-end-breakpoint
+  after-breakpoint
+  #+heap-overflow-check
+  dynamic-space-overflow-warning
+  #+heap-overflow-check
+  dynamic-space-overflow-error
+  )
+
+;; Make sure this starts AFTER the last element of the above enum!
+(defenum (:prefix object-not- :suffix -trap :start 16)
+  list
+  instance)
+
+(defenum (:prefix trace-table-)
+  normal
+  call-site
+  function-prologue
+  function-epilogue)
+
+
+;;;; Static symbols.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(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
+    ext::*batch-mode*
+    lisp::*initial-fdefn-objects*
+
+    ;; Functions that the C code needs to call
+    lisp::%initial-function
+    lisp::maybe-gc
+    kernel::internal-error
+    #+stack-checking kernel::yellow-zone-hit
+    #+stack-checking kernel::red-zone-hit
+    #+heap-overflow-check kernel::dynamic-space-overflow-warning-hit
+    #+heap-overflow-check kernel::dynamic-space-overflow-error-hit
+    di::handle-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*
+
+    ;; Foreign linkage stuff
+    #+linkage-table
+    lisp::*linkage-table-data*
+
+    ;;
+    lisp::*cmucl-lib*
+    lisp::*cmucl-core-path*
+
+    ;; Gencgc
+    ;;
+    ;; Sparc doesn't use current-region-free-pointer, but we leave it
+    ;; here anyway.
+    #+gencgc
+    *current-region-free-pointer*
+    ;; current-region-end-addr is a 32-bit physical address, but when
+    ;; printed from Lisp, it's a fixnum, so it's too small by a factor
+    ;; of 4.  Remember to multiply by 4 to get the actual region end
+    ;; address.
+    #+gencgc
+    *current-region-end-addr*
+    #+gencgc
+    *scavenge-read-only-space*
+
+    ;; Types of weak hash tables
+    :key
+    :value
+    :key-and-value
+    :key-or-value
+
+    ;; FP constants
+    *fp-constant-0d0*
+    *fp-constant-0f0*
+
+    lisp::*unidata-path*
+    
+    ;; Some spare static symbols.  Useful for adding another static
+    ;; symbol without having to do a cross-compile.  Just rename one
+    ;; of these to the desired name.
+    spare-9
+    spare-8
+    spare-7
+    spare-6
+    spare-5
+    spare-4
+    spare-3
+    spare-2
+    spare-1
+    spare-0
+    ))
+
+(defparameter static-functions
+  '(length
+    two-arg-+ two-arg-- two-arg-* 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
+    ))
+
+
+
+;;;; Assembler parameters:
+
+;;; The number of bits per element in the assemblers code vector.
+;;;
+(defparameter *assembly-unit-length* 8)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(export '(pseudo-atomic-trap allocation-trap
+	  pseudo-atomic-value pseudo-atomic-interrupted-value))
+)
+;;;; Pseudo-atomic trap number.
+;;;;
+;;;; This is the trap number to use when a pseudo-atomic section has
+;;;; been interrupted.
+;;;;
+;;;; This should be any valid trap number. According to the Sparc
+;;;; Compliance Definition 2.4.1, only traps 16-31 are allowed for
+;;;; user applications.  All others are reserved.  It's ok if this
+;;;; number matches any of the other trap enums above because those
+;;;; are only used in an illtrap instruction, not the trap
+;;;; instruction.  This needs to be coordinated with the C code.
+(defconstant pseudo-atomic-trap 16)
+
+;;;; Allocation trap number.
+;;;;
+;;;; This is the trap number to use when we need to allocate memory.
+;;;; This must match the C runtime code
+(defconstant allocation-trap 31)
+
+;;;; Pseudo-atomic flag
+;;;;
+;;;; This value is added to alloc-tn to indicate a pseudo-atomic
+;;;; section.
+(defconstant pseudo-atomic-value (ash 1 (1- vm::lowtag-bits)))
+
+;;;; Pseudo-atomic-interrupted-mask
+;;;;
+;;;; This is a mask used to check if a pseudo-atomic section was
+;;;; interrupted.  On sparc, this is indicated by least-significant
+;;;; bit of alloc-tn being 1.
+(defconstant pseudo-atomic-interrupted-value 1)
diff --git a/src/compiler/sparcv9/pred.lisp b/src/compiler/sparcv9/pred.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b9daba0bb6f9d0f0a437698291ac5dbe70595131
--- /dev/null
+++ b/src/compiler/sparcv9/pred.lisp
@@ -0,0 +1,48 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/pred.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/compiler/sparc/pred.lisp $
+;;;
+;;;    This file contains the VM definition of predicate VOPs for the SPARC.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by William Lott.
+;;; 
+
+(in-package "SPARC")
+
+
+;;;; 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 b dest)
+    (inst nop)))
+
+
+;;;; Conditional VOPs:
+
+(define-vop (if-eq)
+  (:args (x :scs (any-reg descriptor-reg zero null))
+	 (y :scs (any-reg descriptor-reg zero null)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:translate eq)
+  (:generator 3
+    (inst cmp x y)
+    (inst b (if not-p :ne :eq) target)
+    (inst nop)))
diff --git a/src/compiler/sparcv9/print.lisp b/src/compiler/sparcv9/print.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..c4e106ec67840463bd4b7bd0759e5fd349a719a8
--- /dev/null
+++ b/src/compiler/sparcv9/print.lisp
@@ -0,0 +1,43 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/print.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/compiler/sparc/print.lisp $
+;;;
+;;; This file contains VOPs for things like printing during %initial-function
+;;; before the world is initialized.
+;;;
+;;; Written by William Lott.
+
+(in-package "SPARC")
+
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg any-reg) :target nl0))
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0)
+  (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
+  (:temporary (:sc interior-reg :offset lip-offset) lip)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+  (:vop-var vop)
+  (:generator 100
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(store-stack-tn nfp-save cur-nfp))
+      (move nl0 object)
+      (inst li cfunc (make-fixup (extern-alien-name "debug_print") :foreign))
+      (inst li temp (make-fixup (extern-alien-name "call_into_c") :foreign))
+      (inst jal lip temp)
+      (inst nop)
+      (when cur-nfp
+	(load-stack-tn cur-nfp nfp-save))
+      (move result nl0))))
diff --git a/src/compiler/sparcv9/sap.lisp b/src/compiler/sparcv9/sap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..4c403017e60a802728fb3ced6e3584c565e0cc32
--- /dev/null
+++ b/src/compiler/sparcv9/sap.lisp
@@ -0,0 +1,320 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/sap.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the SPARC VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:note _N"pointer to SAP coercion")
+  (:generator 1
+    (loadw 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 (sap :scs (sap-reg) :to :save))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:results (res :scs (descriptor-reg)))
+  (:note _N"SAP to pointer coercion") 
+  (:generator 20
+    (with-fixed-allocation (res ndescr sap-type sap-size)
+      (storew sap res 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))))
+  (:note _N"SAP move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(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))
+  (:note _N"SAP argument move")
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move y x))
+      (sap-stack
+       (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+  (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (sap-reg) (descriptor-reg))
+
+
+
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+  (:args (sap :scs (sap-reg) :target int))
+  (:arg-types system-area-pointer)
+  (:results (int :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate sap-int)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int sap)))
+
+(define-vop (int-sap)
+  (:args (int :scs (unsigned-reg) :target sap))
+  (:arg-types unsigned-num)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate int-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap int)))
+
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg))
+	 (offset :scs (signed-reg)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 2
+    (inst add res ptr offset)))
+
+(define-vop (pointer+-c)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg)))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 13)))
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (inst add res ptr offset)))
+
+(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 sub res ptr1 ptr2)))
+
+
+
+;;;; 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 (sap :scs (sap-reg))
+		(offset :scs (signed-reg)))
+	 (:arg-types system-area-pointer signed-num)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   ,@(if (eql size :long-float)
+		 '((load-long-reg result sap offset t))
+		 `((inst ,(ecase size
+			    (:byte (if signed 'ldsb 'ldub))
+			    (:short (if signed 'ldsh 'lduh))
+			    (:long 'ld)
+			    (:single 'ldf)
+			    (:double 'lddf))
+		    result sap offset)))))
+       (define-vop (,ref-name-c)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 13)))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   ,@(if (eql size :long-float)
+		 '((load-long-reg result sap offset t))
+		 `((inst ,(ecase size
+			   (:byte (if signed 'ldsb 'ldub))
+			   (:short (if signed 'ldsh 'lduh))
+			   (:long 'ld)
+			   (:single 'ldf)
+			   (:double 'lddf))
+		       result sap offset)))))
+       (define-vop (,set-name)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(offset :scs (signed-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer signed-num ,type)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   ,@(if (eql size :long-float)
+		 '((store-long-reg value sap offset t))
+		 `((inst ,(ecase size
+			   (:byte 'stb)
+			   (:short 'sth)
+			   (:long 'st)
+			   (:single 'stf)
+			   (:double 'stdf))
+		       value sap offset)))
+	   (unless (location= result value)
+	     ,@(case size
+		 (:single
+		  '((inst fmovs result value)))
+		 (:double
+		  '((move-double-reg result value)))
+		 (:long-float
+		  '((move-long-reg result value)))
+		 (t
+		  '((inst move result value)))))))
+       (define-vop (,set-name-c)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type)
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   ,@(if (eql size :long-float)
+		 '((store-long-reg value sap offset t))
+		 `((inst ,(ecase size
+			    (:byte 'stb)
+			    (:short 'sth)
+			    (:long 'st)
+			    (:single 'stf)
+			    (:double 'stdf))
+		    value sap offset)))
+	   (unless (location= result value)
+	     ,@(case size
+		 (:single
+		  '((inst fmovs result value)))
+		 (:double
+		  '((move-double-reg result value)))
+		 (:long-float
+		  '((move-long-reg result value)))
+		 (t
+		  '((inst move result value))))))))))
+
+); 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-sap %set-sap-ref-sap
+  sap-reg system-area-pointer :long)
+(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)
+#+long-float
+(def-system-ref-and-set sap-ref-long %set-sap-ref-long
+  long-reg long-float :long-float)
+
+
+
+;;; 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 add sap vector
+	  (- (* vector-data-offset word-bytes) other-pointer-type))))
+
+
+
+;;; Transforms for 64-bit SAP accessors.
+
+(deftransform sap-ref-64 ((sap offset) (* *))
+  '(logior (ash (sap-ref-32 sap offset) 32)
+	   (sap-ref-32 sap (+ offset 4))))
+
+(deftransform signed-sap-ref-64 ((sap offset) (* *))
+  '(logior (ash (signed-sap-ref-32 sap offset) 32)
+	   (sap-ref-32 sap (+ 4 offset))))
+
+(deftransform %set-sap-ref-64 ((sap offset value) (* * *))
+  '(progn
+     (%set-sap-ref-32 sap offset (ash value -32))
+     (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
+
+(deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
+  '(progn
+     (%set-signed-sap-ref-32 sap offset (ash value -32))
+     (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff))))
diff --git a/src/compiler/sparcv9/static-fn.lisp b/src/compiler/sparcv9/static-fn.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..82cd106fa603803d7901e23a7f0fb619803efd8a
--- /dev/null
+++ b/src/compiler/sparcv9/static-fn.lisp
@@ -0,0 +1,153 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/static-fn.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: src/compiler/sparc/static-fn.lisp $
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+
+(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 (:scs (descriptor-reg)) func)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
+  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
+
+
+(eval-when (compile load eval)
+
+
+(defun static-function-template-name (num-args num-results)
+  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+		  num-args num-results)))
+
+
+(defun moves (dst src)
+  (collect ((moves))
+    (do ((dst dst (cdr dst))
+	 (src src (cdr src)))
+	((or (null dst) (null src)))
+      (moves `(move ,(car dst) ,(car src))))
+    (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+  (assert (and (<= num-args register-arg-count)
+	       (<= num-results register-arg-count))
+	  (num-args num-results)
+	  (intl:gettext "Either too many args (~D) or too many results (~D).  Max = ~D")
+	  num-args num-results register-arg-count)
+  (let ((num-temps (max num-args num-results)))
+    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+      (dotimes (i num-results)
+	(let ((result-name (intern (format nil "RESULT-~D" i))))
+	  (result-names result-name)
+	  (results `(,result-name :scs (any-reg descriptor-reg)))))
+      (dotimes (i num-temps)
+	(let ((temp-name (intern (format nil "TEMP-~D" i))))
+	  (temp-names temp-name)
+	  (temps `(:temporary (:sc descriptor-reg
+			       :offset ,(nth i register-arg-offsets)
+			       ,@(when (< i num-args)
+				   `(:from (:argument ,i)))
+			       ,@(when (< i num-results)
+				   `(:to (:result ,i)
+				     :target ,(nth i (result-names)))))
+			      ,temp-name))))
+      (dotimes (i num-args)
+	(let ((arg-name (intern (format nil "ARG-~D" i))))
+	  (arg-names arg-name)
+	  (args `(,arg-name
+		  :scs (any-reg descriptor-reg)
+		  :target ,(nth i (temp-names))))))
+      `(define-vop (,(static-function-template-name num-args num-results)
+		    static-function-template)
+	 (:args ,@(args))
+	 ,@(temps)
+	 (:results ,@(results))
+	 (:generator ,(+ 50 num-args num-results)
+	   (let ((lra-label (gen-label))
+		 (cur-nfp (current-nfp-tn vop)))
+	     ,@(moves (temp-names) (arg-names))
+	     (inst ldn func null-tn (static-function-offset symbol))
+	     (inst li nargs (fixnumize ,num-args))
+	     (when cur-nfp
+	       (store-stack-tn nfp-save cur-nfp))
+	     (inst move old-fp cfp-tn)
+	     (inst move cfp-tn csp-tn)
+	     (inst compute-lra-from-code lra code-tn lra-label temp)
+	     (note-this-location vop :call-site)
+	     (inst j func (- (ash function-code-offset word-shift)
+			     function-pointer-type))
+	     (inst move code-tn func)
+	     (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
+	       (load-stack-tn cur-nfp nfp-save))
+	     ,@(moves (result-names) (temp-names))))))))
+
+
+) ; eval-when (compile load eval)
+
+
+(macrolet ((frob (num-args num-res)
+	     (static-function-template-vop (eval num-args) (eval num-res))))
+  (frob 0 1)
+  (frob 1 1)
+  (frob 2 1)
+  (frob 3 1)
+  (frob 4 1)
+  (frob 5 1))
+
+
+(defmacro define-static-function (name args &key (results '(x)) translate
+				       policy cost arg-types result-types)
+  `(define-vop (,name
+		,(static-function-template-name (length args)
+						(length results)))
+     (:variant ',name)
+     (:note ,(format nil "static-function ~@(~S~)" name))
+     ,@(when translate
+	 `((:translate ,translate)))
+     ,@(when policy
+	 `((:policy ,policy)))
+     ,@(when cost
+	 `((:generator-cost ,cost)))
+     ,@(when arg-types
+	 `((:arg-types ,@arg-types)))
+     ,@(when result-types
+	 `((:result-types ,@result-types)))))
diff --git a/src/compiler/sparcv9/subprim.lisp b/src/compiler/sparcv9/subprim.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..89cbc66703f9ac8bb45a1d105c7fbc285c45ee29
--- /dev/null
+++ b/src/compiler/sparcv9/subprim.lisp
@@ -0,0 +1,60 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/subprim.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "SPARC")
+
+
+
+;;;; 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
+    (let ((done (gen-label))
+	  (loop (gen-label))
+	  (not-list (generate-cerror-code vop object-not-list-error object)))
+      (move ptr object)
+      (move count zero-tn)
+
+      (emit-label loop)
+
+      (inst cmp ptr null-tn)
+      (inst b :eq done)
+      (inst nop)
+
+      (test-type ptr temp not-list t vm:list-pointer-type)
+
+      (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
+      (inst add count count (fixnumize 1))
+      (test-type ptr temp loop nil vm:list-pointer-type)
+
+      (cerror-call vop done object-not-list-error ptr)
+
+      (emit-label done)
+      (move result count))))
+       
+
+(define-static-function length (object) :translate length)
+
diff --git a/src/compiler/sparcv9/system.lisp b/src/compiler/sparcv9/system.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..dba4b6d78387c092081bae84e0b8e09786662bfa
--- /dev/null
+++ b/src/compiler/sparcv9/system.lisp
@@ -0,0 +1,304 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/system.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    MIPS VM definitions of various system hacking operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Mips conversion by William Lott and Christopher Hoover.
+;;;
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+
+
+
+;;;; 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 result object vm:lowtag-mask)))
+
+(define-vop (get-type)
+  (:translate get-type)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 1)))
+  (:results (result :scs (unsigned-reg) :from (:eval 0)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    ;; Grab the lowtag.
+    (inst andcc result object lowtag-mask)
+    ;; Check for various pointer types.
+    (inst cmp result list-pointer-type)
+    (inst b :eq done)
+    (inst cmp result other-pointer-type)
+    (inst b :eq other-pointer)
+    (inst cmp result function-pointer-type)
+    (inst b :eq function-pointer)
+    (inst cmp result instance-pointer-type)
+    (inst b :eq done)
+    ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
+    ;; we want the low 8 bits.
+    (inst andcc zero-tn object vm:fixnum-tag-mask)
+    (inst b :eq done)
+    (inst li result 0)			; Watch out!  LI in branch delay slot!
+    ;; It wasn't a fixnum, so get the low 8 bits.
+    (inst b done)
+    (inst and result object type-mask)
+    
+    FUNCTION-POINTER
+    (inst b done)
+    (load-type result object (- function-pointer-type))
+
+    OTHER-POINTER
+    (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 (- vm: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 *)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    ;; Sparc is big-endian, and the type bits are in the least
+    ;; significant byte of the word, which means the type bits are at
+    ;; the highest byte.
+    (inst stb type function (- (- vm:word-bytes 1) function-pointer-type))
+    (move result type)))
+
+(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 vm:other-pointer-type)
+    (inst srln res res vm:type-bits)))
+
+(define-vop (get-closure-length)
+  (:translate get-closure-length)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 vm:function-pointer-type)
+    (inst srln res res vm:type-bits)))
+
+(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 vm:other-pointer-type)
+    (inst and t1 vm:type-mask)
+    (sc-case data
+      (any-reg
+       (inst slln t2 data (- vm:type-bits vm:fixnum-tag-bits))
+       (inst or t1 t2))
+      (immediate
+       (inst or t1 (ash (tn-value data) vm:type-bits)))
+      (zero))
+    (storew t1 x 0 vm:other-pointer-type)
+    (move res x)))
+
+
+(define-vop (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 slln res ptr vm:lowtag-bits)
+    (inst srln res res 1)))
+
+(define-vop (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 slln temp val vm:type-bits)
+       (inst or res temp (tn-value type)))
+      (t
+       (inst sran temp type vm:fixnum-tag-bits)
+       (inst slln res val (- vm:type-bits vm:fixnum-tag-bits))
+       (inst or res res temp)))))
+
+
+;;;; Allocation
+
+(define-vop (dynamic-space-free-pointer)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate dynamic-space-free-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int alloc-tn)))
+
+(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 int bsp-tn)))
+
+(define-vop (control-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate control-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int csp-tn)))
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+  (: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 vm:other-pointer-type)
+    (inst srln ndescr vm:type-bits)
+    (inst slln ndescr vm:word-shift)
+    (inst sub ndescr vm:other-pointer-type)
+    (inst add sap code ndescr)))
+
+(define-vop (compute-function)
+  (:args (code :scs (descriptor-reg))
+	 (offset :scs (signed-reg unsigned-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (func :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:generator 10
+    (loadw ndescr code 0 vm:other-pointer-type)
+    (inst srln ndescr vm:type-bits)
+    (inst slln ndescr vm:word-shift)
+    (inst add ndescr offset)
+    (inst add ndescr (- vm:function-pointer-type vm:other-pointer-type))
+    (inst add func code ndescr)))
+
+
+
+;;;; 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 unimp pending-interrupt-trap)))
+
+
+(define-vop (halt)
+  (:generator 1
+    (inst unimp 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)))
+      (assert (typep offset '(signed-byte 13)))
+      (inst ldn count count-vector offset)
+      (inst add count 1)
+      (inst stn count count-vector offset))))
+
+;; The RDTICK instruction on Sparc V9s allows access to a 63-bit cycle
+;; counter.
+
+(defknown read-cycle-counter ()
+  (values (unsigned-byte 32) (unsigned-byte 32)))
+
+;; Note: This should probably really only be used sparc-v8plus because
+;; the tick counter is returned in a 64-bit register.
+(define-vop (read-cycle-counter)
+  (:translate read-cycle-counter)
+  (:guard (backend-featurep :sparc-v9))
+  (:args)
+  (:policy :fast-safe)
+  (:results (lo :scs (unsigned-reg))
+	    (hi :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  ;; The temporary can be any of the 64-bit non-descriptor regs.  It
+  ;; can't be any non-descriptor reg because they might not get saved
+  ;; on a task switch, since we're still a 32-bit app.  Arbitrarily
+  ;; select nl5.
+  (:temporary (:sc unsigned-reg :offset nl5-offset) tick)
+  (:generator 3
+    (inst rdtick tick)
+    ;; Get the hi and low parts of the counter into the results.
+    (inst srlx hi tick 32)
+    (inst clruw lo tick)))
+
+#+sparc-v9
+(defun read-cycle-counter ()
+  _N"Read the instruction cycle counter available on UltraSparcs.  The
+64-bit counter is returned as two 32-bit unsigned integers.  The low 32-bit
+result is the first value."
+  (read-cycle-counter))
+
+(defmacro with-cycle-counter (&body body)
+  "Returns the primary value of BODY as the primary value, and the
+ number of CPU cycles elapsed as secondary value."
+  (let ((hi0 (gensym))
+	(hi1 (gensym))
+	(lo0 (gensym))
+	(lo1 (gensym)))
+    `(multiple-value-bind (,lo0 ,hi0)
+	 (read-cycle-counter)
+       (values (locally ,@body)
+               (multiple-value-bind (,lo1 ,hi1)
+		   (read-cycle-counter)
+		 ;; Can't do anything about the notes about generic
+		 ;; arithmetic, so silence the notes..
+		 (declare (optimize (inhibit-warnings 3)))
+                 (+ (ash (- ,hi1 ,hi0) 32)
+                    (- ,lo1 ,lo0)))))))
diff --git a/src/compiler/sparcv9/type-vops.lisp b/src/compiler/sparcv9/type-vops.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1be97e8fd571a2e187bba09fa0ac702a72f9b13b
--- /dev/null
+++ b/src/compiler/sparcv9/type-vops.lisp
@@ -0,0 +1,529 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/type-vops.lisp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the SPARC.
+;;;
+;;; Written by William Lott.
+;;; Signed-array support by Douglas Crosher 1997.
+;;; Complex-float and long-float support by Douglas Crosher 1998.
+;;;
+(in-package "SPARC")
+
+
+;;;; Simple type checking and testing:
+;;;
+;;;    These types are represented by a single type code, so are easily
+;;; open-coded as a mask and compare.
+
+(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)) temp)
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:temporary (:scs (non-descriptor-reg)) temp))
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2)))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+				   &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value temp target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value temp err-lab t ,@type-codes)
+		   (move result value))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+); eval-when (compile eval)
+
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+	       vm:even-fixnum-type vm:odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+  object-not-function-error vm:function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+  vm:list-pointer-type)
+(def-type-vops %instancep check-instance instance object-not-instance-error
+  vm:instance-pointer-type)
+
+(def-type-vops bignump check-bignum bignum
+  object-not-bignum-error vm:bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error vm:ratio-type)
+
+(def-type-vops complexp check-complex complex object-not-complex-error
+  vm:complex-type vm:complex-single-float-type
+  vm:complex-double-float-type #+long-float vm:complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
+
+(def-type-vops complex-rational-p check-complex-rational nil
+  object-not-complex-rational-error vm:complex-type)
+
+(def-type-vops complex-float-p check-complex-float nil
+  object-not-complex-float-error
+  vm:complex-single-float-type vm:complex-double-float-type
+  #+long-float vm:complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
+
+(def-type-vops complex-single-float-p check-complex-single-float
+  complex-single-float object-not-complex-single-float-error
+  vm:complex-single-float-type)
+
+(def-type-vops complex-double-float-p check-complex-double-float
+  complex-double-float object-not-complex-double-float-error
+  vm:complex-double-float-type)
+
+#+long-float
+(def-type-vops complex-long-float-p check-complex-long-float
+  complex-long-float object-not-complex-long-float-error
+  vm:complex-long-float-type)
+
+#+double-double
+(def-type-vops complex-double-double-float-p check-complex-double-double-float
+  complex-double-double-float object-not-complex-double-double-float-error
+  vm::complex-double-double-float-type)
+
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error vm:single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error vm:double-float-type)
+
+#+long-float
+(def-type-vops long-float-p check-long-float long-float
+  object-not-long-float-error vm:long-float-type)
+
+#+double-double
+(def-type-vops double-double-float-p check-double-double-float
+  double-double-float object-not-double-double-float-error
+  vm:double-double-float-type)
+	       
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error vm:simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error vm:simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error vm:simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+  check-simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-2
+  object-not-simple-array-unsigned-byte-2-error
+  vm:simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+  check-simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-4
+  object-not-simple-array-unsigned-byte-4-error
+  vm:simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+  check-simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-8
+  object-not-simple-array-unsigned-byte-8-error
+  vm:simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+  check-simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-16
+  object-not-simple-array-unsigned-byte-16-error
+  vm:simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+  check-simple-array-unsigned-byte-32
+  simple-array-unsigned-byte-32
+  object-not-simple-array-unsigned-byte-32-error
+  vm:simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-signed-byte-8-p
+  check-simple-array-signed-byte-8
+  simple-array-signed-byte-8
+  object-not-simple-array-signed-byte-8-error
+  simple-array-signed-byte-8-type)
+
+(def-type-vops simple-array-signed-byte-16-p
+  check-simple-array-signed-byte-16
+  simple-array-signed-byte-16
+  object-not-simple-array-signed-byte-16-error
+  simple-array-signed-byte-16-type)
+
+(def-type-vops simple-array-signed-byte-30-p
+  check-simple-array-signed-byte-30
+  simple-array-signed-byte-30
+  object-not-simple-array-signed-byte-30-error
+  simple-array-signed-byte-30-type)
+
+(def-type-vops simple-array-signed-byte-32-p
+  check-simple-array-signed-byte-32
+  simple-array-signed-byte-32
+  object-not-simple-array-signed-byte-32-error
+  simple-array-signed-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+  simple-array-single-float object-not-simple-array-single-float-error
+  vm:simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+  simple-array-double-float object-not-simple-array-double-float-error
+  vm:simple-array-double-float-type)
+
+#+long-float
+(def-type-vops simple-array-long-float-p check-simple-array-long-float
+  simple-array-long-float object-not-simple-array-long-float-error
+  vm:simple-array-long-float-type)
+
+#+double-double
+(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float
+  simple-array-double-double-float object-not-simple-array-double-double-float-error
+  vm::simple-array-double-double-float-type)
+
+(def-type-vops simple-array-complex-single-float-p
+  check-simple-array-complex-single-float
+  simple-array-complex-single-float
+  object-not-simple-array-complex-single-float-error
+  vm:simple-array-complex-single-float-type)
+
+(def-type-vops simple-array-complex-double-float-p
+  check-simple-array-complex-double-float
+  simple-array-complex-double-float
+  object-not-simple-array-complex-double-float-error
+  vm:simple-array-complex-double-float-type)
+
+#+long-float
+(def-type-vops simple-array-complex-long-float-p
+  check-simple-array-complex-long-float
+  simple-array-complex-long-float
+  object-not-simple-array-complex-long-float-error
+  vm:simple-array-complex-long-float-type)
+
+#+double-double
+(def-type-vops simple-array-complex-double-double-float-p
+  check-simple-array-complex-double-double-float
+  simple-array-complex-double-double-float
+  object-not-simple-array-complex-double-double-float-error
+  vm::simple-array-complex-double-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error vm:base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error vm:sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error vm:weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  #-gencgc 0 #+gencgc scavenger-hook-type)
+
+(def-type-vops code-component-p nil nil nil
+  vm:code-header-type)
+
+(def-type-vops lra-p nil nil nil
+  vm:return-pc-header-type)
+
+(def-type-vops fdefn-p nil nil nil
+  vm:fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+  vm:funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+  vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
+  vm:complex-vector-type vm:complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
+  vm:function-pointer-type vm:symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  vm:simple-string-type vm:complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  vm:simple-bit-vector-type vm:complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
+  vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
+  vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
+  vm:simple-array-unsigned-byte-32-type
+  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+  simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+  vm:simple-array-single-float-type vm:simple-array-double-float-type
+  #+long-float vm:simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
+  vm:simple-array-complex-single-float-type
+  vm:simple-array-complex-double-float-type
+  #+long-float vm:simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
+  vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
+  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
+  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
+  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
+  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+  simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+  vm:simple-array-single-float-type vm:simple-array-double-float-type
+  #+long-float vm:simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
+  vm:simple-array-complex-single-float-type
+  vm:simple-array-complex-double-float-type
+  #+long-float vm:simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
+  )
+
+(def-type-vops arrayp check-array nil object-not-array-error
+  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
+  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
+  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
+  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
+  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+  simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+  vm:simple-array-single-float-type vm:simple-array-double-float-type
+  #+long-float vm:simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
+  vm:simple-array-complex-single-float-type
+  vm:simple-array-complex-double-float-type
+  #+long-float vm:simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
+  vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
+  vm:complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  #+double-double vm:double-double-float-type
+  vm:complex-type vm:complex-single-float-type vm:complex-double-float-type
+  #+long-float vm:complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  #+double-double vm:double-double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  #+double-double vm:double-double-float-type)
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:generator 45
+    (let ((not-target (gen-label)))
+      (multiple-value-bind
+	  (yep nope)
+	  (if not-p
+	      (values not-target target)
+	      (values target not-target))
+	(inst andcc zero-tn value fixnum-tag-mask)
+	(inst b :eq yep)
+	(test-type value temp nope t vm:other-pointer-type)
+	(loadw temp value 0 vm:other-pointer-type)
+	(inst cmp temp (+ (ash 1 vm:type-bits)
+			  vm:bignum-type))
+	(inst b (if not-p :ne :eq) target)
+	(inst nop)
+	(emit-label not-target)))))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
+	  (yep (gen-label)))
+      (inst andcc temp value fixnum-tag-mask)
+      (inst b :eq yep)
+      (test-type value temp nope t vm:other-pointer-type)
+      (loadw temp value 0 vm:other-pointer-type)
+      (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
+      (inst b :ne nope)
+      (inst nop)
+      (emit-label yep)
+      (move result value))))
+
+
+;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
+;;; bignum with exactly one positive digit, or a bignum with exactly two digits
+;;; and the second digit all zeros.
+
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:generator 45
+    (let ((not-target (gen-label))
+	  (single-word (gen-label))
+	  (fixnum (gen-label)))
+      (multiple-value-bind
+	  (yep nope)
+	  (if not-p
+	      (values not-target target)
+	      (values target not-target))
+	;; Is it a fixnum?
+	(inst andcc temp value fixnum-tag-mask)
+	(inst b :eq fixnum)
+	(inst cmp value)
+
+	;; If not, is it an other pointer?
+	(test-type value temp nope t vm:other-pointer-type)
+	;; Get the header.
+	(loadw temp value 0 vm:other-pointer-type)
+	;; Is it one?
+	(inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
+	(inst b :eq single-word)
+	;; If it's other than two, we can't be an (unsigned-byte 32)
+	(inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type))
+	(inst b :ne nope)
+	;; Get the second digit.
+	(loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+	;; All zeros, its an (unsigned-byte 32).
+	(inst cmp temp)
+	(inst b :eq yep)
+	(inst nop)
+	;; Otherwise, it isn't.
+	(inst b nope)
+	(inst nop)
+	
+	(emit-label single-word)
+	;; Get the single digit.
+	(loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
+	(inst cmp temp)
+
+	;; positive implies (unsigned-byte 32).
+	(emit-label fixnum)
+	(inst b (if not-p :lt :ge) target)
+	(inst nop)
+
+	(emit-label not-target)))))	  
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((nope
+	   (generate-error-code vop object-not-unsigned-byte-32-error value))
+	  (yep (gen-label))
+	  (fixnum (gen-label))
+	  (single-word (gen-label)))
+      ;; Is it a fixnum?
+      (inst andcc temp value fixnum-tag-mask)
+      (inst b :eq fixnum)
+      (inst cmp value)
+
+      ;; If not, is it an other pointer?
+      (test-type value temp nope t vm:other-pointer-type)
+      ;; Get the number of digits.
+      (loadw temp value 0 vm:other-pointer-type)
+      ;; Is it one?
+      (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
+      (inst b :eq single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 32)
+      (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type))
+      (inst b :ne nope)
+      ;; Get the second digit.
+      (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst cmp temp)
+      (inst b :eq yep)
+      ;; Otherwise, it isn't.
+      (inst b :ne nope)
+      (inst nop)
+      
+      (emit-label single-word)
+      ;; Get the single digit.
+      (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
+      ;; positive implies (unsigned-byte 32).
+      (inst cmp temp)
+      
+      (emit-label fixnum)
+      (inst b :lt nope)
+      (inst nop)
+      
+      (emit-label yep)
+      (move result value))))
+
+
+
+
+;;;; List/symbol types:
+;;; 
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (let* ((drop-thru (gen-label))
+	   (is-symbol-label (if not-p drop-thru target)))
+      (inst cmp value null-tn)
+      (inst b :eq is-symbol-label)
+      (test-type value temp target not-p vm:symbol-header-type)
+      (emit-label drop-thru))))
+
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (let ((drop-thru (gen-label))
+	  (error (generate-error-code vop object-not-symbol-error value)))
+      (inst cmp value null-tn)
+      (inst b :eq drop-thru)
+      (test-type value temp error t vm:symbol-header-type)
+      (emit-label drop-thru)
+      (move result value))))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (let* ((drop-thru (gen-label))
+	   (is-not-cons-label (if not-p target drop-thru)))
+      (inst cmp value null-tn)
+      (inst b :eq is-not-cons-label)
+      (test-type value temp target not-p vm:list-pointer-type)
+      (emit-label drop-thru))))
+
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst cmp value null-tn)
+      (inst b :eq error)
+      (test-type value temp error t vm:list-pointer-type)
+      (move result value))))
+
diff --git a/src/compiler/sparcv9/values.lisp b/src/compiler/sparcv9/values.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..089e4d3c2f3be1d754fadc44cab3eb1042f5385e
--- /dev/null
+++ b/src/compiler/sparcv9/values.lisp
@@ -0,0 +1,125 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/values.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted for SPARC by William Lott.
+;;; 
+
+(in-package "SPARC")
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move csp-tn ptr)))
+
+
+;;; 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) :from :load)
+	    (count :scs (any-reg)))
+  (:info nvals)
+  (:temporary (:scs (descriptor-reg)) temp)
+  (:generator 20
+    (inst move start csp-tn)
+    (inst add csp-tn csp-tn (* nvals vm:word-bytes))
+    (do ((val vals (tn-ref-across val))
+	 (i 0 (1+ i)))
+	((null val))
+      (let ((tn (tn-ref-tn val)))
+	(sc-case tn
+	  (descriptor-reg
+	   (storew tn start i))
+	  (control-stack
+	   (load-stack-tn temp tn)
+	   (storew temp start i)))))
+    (inst li count (fixnumize nvals))))
+
+;;; 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 (descriptor-reg)) temp)
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (done (gen-label)))
+
+      (move list arg)
+      (move start csp-tn)
+
+      (emit-label loop)
+      (inst cmp list null-tn)
+      (inst b :eq done)
+      (loadw temp list vm:cons-car-slot vm:list-pointer-type)
+      (loadw list list vm:cons-cdr-slot vm:list-pointer-type)
+      (inst add csp-tn csp-tn vm:word-bytes)
+      (storew temp csp-tn -1)
+      (test-type list ndescr loop nil vm:list-pointer-type)
+      (error-call vop bogus-argument-to-values-list-error list)
+
+      (emit-label done)
+      (inst sub count csp-tn start))))
+
+
+
+;;; 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 any-reg) i)
+  (:results (start :scs (any-reg))
+	    (count :scs (any-reg)))
+  (:generator 20
+    (sc-case skip
+      (zero
+       (move src context))
+      (immediate
+       (inst add src context (* (tn-value skip) word-bytes)))
+      (any-reg
+       (inst add src context skip)))
+    (inst orcc count zero-tn num)
+    (inst b :eq done)
+    (inst move start csp-tn)
+    (inst move dst csp-tn)
+    (inst add csp-tn count)
+    (inst move i count)
+    LOOP
+    (inst subcc i 4)
+    (inst ldn temp src i)
+    (inst b :ne loop)
+    (inst stn temp dst i)
+    DONE))
diff --git a/src/compiler/sparcv9/vm.lisp b/src/compiler/sparcv9/vm.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..17c20ee2f6c22e0f173ffb1a7f7284c6abc60b66
--- /dev/null
+++ b/src/compiler/sparcv9/vm.lisp
@@ -0,0 +1,472 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/vm.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition for the SPARC.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "SPARC")
+
+
+;;;; 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)
+
+
+;; Globals.  These are difficult to extract from a sigcontext.
+(defreg zero 0)				; %g0
+(defreg alloc 1)			; %g1
+(defreg null 2)				; %g2
+(defreg csp 3)				; %g3
+(defreg cfp 4)				; %g4
+(defreg bsp 5)				; %g5
+;; %g6 and %g7 are supposed to be reserved for the system.  %g7 is
+;; apparently used by thread libraries, and on Solaris 10, is always
+;; used, even for apps that aren't threaded.  %g6 doesn't seem to be
+;; currently used.
+
+;; NOTE: We need some otherwise unused register for the
+;; define-move-function functions so we can access things where the
+;; offset of the object is too large to fit in the offset part of an
+;; instruction.  It needs to be fixed because these move functions
+;; don't have any other args to use.  And since the register allocator
+;; doesn't know about such uses, we can't use it for anything else.
+(defreg gtemp 26)			; %i2, aka L0
+
+;; Outs.  These get clobbered when we call into C.
+(defreg nl0 8)				; %o0
+(defreg nl1 9)				; %o1
+(defreg nl2 10)				; %o2
+(defreg nl3 11)				; %o3
+(defreg nl4 12)				; %o4
+(defreg nl5 13)				; %o5
+(defreg nsp 14)				; %o6, aka %sp
+(defreg nargs 15)			; %o7
+
+;; Locals.  These are preserved when we call into C.
+(defreg a0 16)				; %l0
+(defreg a1 17)				; %l1
+(defreg a2 18)				; %l2
+(defreg a3 19)				; %l3
+(defreg a4 20)				; %l4
+(defreg a5 21)				; %l5
+(defreg ocfp 22)			; %l6
+(defreg lra 23)				; %l7
+
+;; Ins.  These are preserved just like locals.
+(defreg cname 24)			; %i0
+(defreg lexenv 25)			; %i1
+;; WARNING: Register L0 is used as a global temp for
+;; define-move-functions to access stack variables when needed.  We
+;; can't use it for anything else!
+#+nil
+(defreg l0 26)				; %i2
+
+(defreg nfp 27)				; %i3
+(defreg cfunc 28)			; %i4
+(defreg code 29)			; %i5
+;; We can't touch reg 30 (aka %i6, aka %fp) if we ever want to return
+(defreg lip 31)				; %i7
+
+(eval-when (compile load eval)
+  ;; Registers %g6, %g7, and %fp are not defined above so we can't
+  ;; access them by accident. However, it's useful to be able to
+  ;; disassemble code that uses these registers.  (Callbacks use %fp).
+  ;; So manually give names to these registers
+  (setf (aref *register-names* 6) "G6")
+  (setf (aref *register-names* 7) "G7")
+  (setf (aref *register-names* 26) "L0")
+  (setf (aref *register-names* 30) "FP")
+  )
+
+(defregset non-descriptor-regs
+  nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
+
+;; These are the non-descriptor-regs that can be used to hold 64-bit
+;; integers in v8plus mode.  Basically any %o register, except we
+;; don't want NSP.
+#+(and sparc-v9 sparc-v8plus)
+(defregset non-descriptor64-regs
+  nl0 nl1 nl2 nl3 nl4 nl5 nargs)
+
+(defregset descriptor-regs
+  a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv)
+
+(defregset register-arg-offsets
+  a0 a1 a2 a3 a4 a5)
+
+
+
+;;;; SB and SC definition:
+
+(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)
+
+  ;; 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) ; (signed-byte 32)
+  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
+  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
+  (sap-stack non-descriptor-stack) ; System area pointers.
+  (single-stack non-descriptor-stack) ; single-floats
+  (double-stack non-descriptor-stack
+		:element-size 2 :alignment 2) ; double floats.
+  #+long-float
+  (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats.
+  #+double-double
+  (double-double-stack non-descriptor-stack :element-size 4 :alignment 2)
+  ;; complex-single-floats
+  (complex-single-stack non-descriptor-stack :element-size 2)
+  ;; complex-double-floats.
+  (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
+  #+long-float
+  ;; complex-long-floats.
+  (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4)
+
+  #+double-double
+  (complex-double-double-stack non-descriptor-stack :element-size 8 :alignment 4)
+  
+  ;; **** 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)
+
+  ;; 64-bit signed and unsigned integers
+
+  #+(and sparc-v9 sparc-v8plus)
+  (signed64-stack non-descriptor-stack :element-size 2 :alignment 2)
+  #+(and sparc-v9 sparc-v8plus)
+  (unsigned64-stack non-descriptor-stack :element-size 2 :alignment 2)
+
+  ;; 64-bit signed or unsigned integers.  Since CMUCL is still a
+  ;; 32-bit app, the v8plus ABI says that only the global and out
+  ;; registers can be 64-bit.  (Because task switches will only
+  ;; preserve all 64 bits of these registers.  The other registers get
+  ;; stored on the stack and thus only preserve 32 bits.)  Since the
+  ;; globals are already spoken for, only the out registers are
+  ;; available.
+  #+(and sparc-v9 sparc-v8plus)
+  (signed64-reg registers
+    :locations #.non-descriptor64-regs
+    :constant-scs (zero immediate)
+    :save-p t
+    :alternate-scs (signed64-stack))
+  #+(and sparc-v9 sparc-v8plus)
+  (unsigned64-reg registers
+    :locations #.non-descriptor64-regs
+    :constant-scs (zero immediate)
+    :save-p t
+    :alternate-scs (unsigned64-stack))
+
+  ;; 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 0 to 31 collect i)
+   :reserve-locations (28 29 30 31)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (single-stack))
+
+  ;; Non-Descriptor double-floats.
+  (double-reg float-registers
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63
+		      by 2 collect i)
+   :element-size 2 :alignment 2
+   :reserve-locations (28 30)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (double-stack))
+
+  ;; Non-Descriptor double-floats.
+  #+long-float
+  (long-reg float-registers
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63
+		      by 4 collect i)
+   :element-size 4 :alignment 4
+   :reserve-locations (28)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (long-stack))
+
+  ;; Non-descriptor double-double floats
+  #+double-double
+  (double-double-reg float-registers
+   :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64
+		   by 4 collect i)
+   :element-size 4 :alignment 4
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (double-double-stack))
+  
+  (complex-single-reg float-registers
+   :locations #.(loop for i from 0 to 31 by 2 collect i)
+   :element-size 2 :alignment 2
+   :reserve-locations (28 30)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-single-stack))
+
+  (complex-double-reg float-registers
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63
+		      by 4 collect i)
+   :element-size 4 :alignment 4
+   :reserve-locations (28)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-double-stack))
+
+  #+long-float
+  (complex-long-reg float-registers
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63
+		      by 8 collect i)
+   :element-size 8 :alignment 8
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-long-stack))
+
+  #+double-double
+  (complex-double-double-reg float-registers
+   :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64
+		      by 8 collect i)
+   :element-size 8 :alignment 8
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-double-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)
+
+(defregtn zero any-reg)
+(defregtn null descriptor-reg)
+(defregtn code descriptor-reg)
+(defregtn alloc any-reg)
+
+(defregtn nargs any-reg)
+(defregtn bsp any-reg)
+(defregtn csp any-reg)
+(defregtn cfp any-reg)
+(defregtn ocfp any-reg)
+(defregtn nsp any-reg)
+(defregtn gtemp any-reg) 
+
+(defregtn lexenv descriptor-reg)
+(defregtn cname descriptor-reg)
+
+
+;;; 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))))
+
+
+;;;; 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 8)
+
+
+;;; 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"))))
diff --git a/src/lisp/sparcv9-assem.S b/src/lisp/sparcv9-assem.S
new file mode 100644
index 0000000000000000000000000000000000000000..d4b96cb5ecde7d97f9fbffd7cc5064f713bd0592
--- /dev/null
+++ b/src/lisp/sparcv9-assem.S
@@ -0,0 +1,565 @@
+
+#ifdef SOLARIS
+#define _ASM
+#include <sys/asm_linkage.h>
+#include <sys/psw.h>
+#include <sys/trap.h>
+#ifdef __STDC__
+#define FUNCDEF(x)	.type x, \#function
+#else
+#define FUNCDEF(x)	.type x, #function
+#endif
+#else
+#endif
+
+#define LANGUAGE_ASSEMBLY
+#include "lispregs.h"
+#include "internals.h"
+#include "globals.h"
+
+#define load(sym, reg) \
+        sethi %hi(sym), reg; ld [reg+%lo(sym)], reg
+#define store(reg, sym) \
+        sethi %hi(sym), reg_L0; st reg, [reg_L0+%lo(sym)]
+
+/*
+ * Our frame size needs to be large enough to hold our window, 
+ * the structure return pointer, and some temp space.  The temp space
+ * is to hold the 64-bit %o registers that might be converted to %i 
+ * registers.  A task switch will will not preserve all 64 bits of the
+ * %i registers, so we need to save our %o registers before entering C.
+ * Since %o0 and %o1 contain the return results, we do not have to save 
+ * these.
+ */
+#ifdef v8plus	
+#define FRAMESIZE (SA(WINDOWSIZE+4 + 6*8))
+#else	
+#define FRAMESIZE (SA(MINFRAME))
+#endif
+        .seg    "text"
+        .global call_into_lisp
+	FUNCDEF(call_into_lisp)
+call_into_lisp:
+        save    %sp, -FRAMESIZE, %sp
+	/* Flush all of C's register windows to the stack. */
+	ta	ST_FLUSH_WINDOWS
+
+        /* Save the return address. */
+        st      %i7, [%fp-4]
+
+        /* Clear the descriptor regs. (See sparc/vm.lisp) */
+        mov     reg_ZERO, reg_A0
+        mov     reg_ZERO, reg_A1
+        mov     reg_ZERO, reg_A2
+        mov     reg_ZERO, reg_A3
+        mov     reg_ZERO, reg_A4
+        mov     reg_ZERO, reg_A5
+        mov     reg_ZERO, reg_OCFP
+        mov     reg_ZERO, reg_LRA
+        mov     reg_ZERO, reg_CODE
+
+        /* Establish NIL */
+        set     NIL, reg_NIL
+
+	/* Set the pseudo-atomic flag. */
+	set	pseudo_atomic_Value, reg_ALLOC
+
+	/* Turn off foreign function call. */
+        sethi   %hi(foreign_function_call_active), reg_NL0
+        st      reg_ZERO, [reg_NL0+%lo(foreign_function_call_active)]
+
+        /* Load the rest of lisp state. */
+        load(current_dynamic_space_free_pointer, reg_NL0)
+	add	reg_NL0, reg_ALLOC, reg_ALLOC
+        load(current_binding_stack_pointer, reg_BSP)
+        load(current_control_stack_pointer, reg_CSP)
+        load(current_control_frame_pointer, reg_OCFP)
+
+        /* No longer atomic, and check for interrupt. */
+	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
+	andcc	reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO
+	tne	trap_PseudoAtomic
+
+        /* Pass in the args. */
+        sll     %i2, 2, reg_NARGS
+        mov     %i1, reg_CFP
+	mov	%i0, reg_LEXENV
+        ld      [reg_CFP+0], reg_A0
+        ld      [reg_CFP+4], reg_A1
+        ld      [reg_CFP+8], reg_A2
+        ld      [reg_CFP+12], reg_A3
+        ld      [reg_CFP+16], reg_A4
+        ld      [reg_CFP+20], reg_A5
+
+        /* Calculate LRA */
+        set     lra + type_OtherPointer, reg_LRA
+
+        /* Indirect closure */
+        ld      [reg_LEXENV+CLOSURE_FUNCTION_OFFSET], reg_CODE
+
+        jmp     reg_CODE+FUNCTION_CODE_OFFSET
+        nop
+
+        .align  8
+lra:
+        .word   type_ReturnPcHeader
+
+        /* Blow off any extra values. */
+        mov     reg_OCFP, reg_CSP
+        nop
+
+        /* Return the one value. */
+        mov     reg_A0, %i0
+
+        /* Turn on pseudo_atomic */
+	or	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
+
+        /* Store LISP state */
+	andn	reg_ALLOC, lowtag_Mask, reg_NL1
+        store(reg_NL1,current_dynamic_space_free_pointer)
+        store(reg_BSP,current_binding_stack_pointer)
+        store(reg_CSP,current_control_stack_pointer)
+        store(reg_CFP,current_control_frame_pointer)
+
+        /* No longer in Lisp. */
+        store(reg_NL1,foreign_function_call_active)
+
+        /* Were we interrupted? */
+	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
+	andcc	reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO
+	tne	trap_PseudoAtomic
+
+        /* Back to C we go. */
+	ld	[%sp+FRAMESIZE-4], %i7
+        ret
+        restore	%sp, FRAMESIZE, %sp
+	SET_SIZE(call_into_lisp)
+
+
+
+        .global call_into_c
+	FUNCDEF(call_into_c)
+call_into_c:
+#ifdef v8plus
+	stx	%o2, [%fp - 8 - 1*8]
+	stx	%o3, [%fp - 8 - 2*8]
+	stx	%o4, [%fp - 8 - 3*8]
+	stx	%o5, [%fp - 8 - 4*8]
+	stx	%o6, [%fp - 8 - 5*8]
+	stx	%o7, [%fp - 8 - 6*8]
+#endif		
+        /* Build a lisp stack frame */
+        mov     reg_CFP, reg_OCFP
+        mov     reg_CSP, reg_CFP
+        add     reg_CSP, 32, reg_CSP
+        st      reg_OCFP, [reg_CFP]
+        st      reg_CODE, [reg_CFP+8]
+
+        /* Turn on pseudo-atomic. */
+	or	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
+
+	/* Convert the return address to an offset and save it on the stack. */
+	sub	reg_LIP, reg_CODE, reg_L0
+	add	reg_L0, type_OtherPointer, reg_L0
+	st	reg_L0, [reg_CFP+4]
+
+        /* Store LISP state */
+        store(reg_BSP,current_binding_stack_pointer)
+        store(reg_CSP,current_control_stack_pointer)
+        store(reg_CFP,current_control_frame_pointer)
+
+	/* Use reg_CFP as a work register, and restore it */
+	andn	reg_ALLOC, lowtag_Mask, reg_CFP
+        store(reg_CFP,current_dynamic_space_free_pointer)
+	load(current_control_frame_pointer, reg_CFP)
+
+        /* No longer in Lisp. */
+        store(reg_CSP,foreign_function_call_active)
+
+        /* Were we interrupted? */
+	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
+	andcc	reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO
+	tne	trap_PseudoAtomic
+
+        /* Into C we go. */
+        call    reg_CFUNC
+        nop
+
+	/*
+	 * Note: C calling conventions (32-bit) say that %o0 and %o1
+	 * are used to return function results.  In particular 64-bit
+	 * results are in %o0 (hi) and %o1 (low).  
+	 */
+	
+        /* Re-establish NIL */
+        set     NIL, reg_NIL
+
+	/* Atomic. */
+	set	pseudo_atomic_Value, reg_ALLOC
+
+        /* No longer in foreign function call. */
+        sethi   %hi(foreign_function_call_active), reg_NL2
+        st      reg_ZERO, [reg_NL2+%lo(foreign_function_call_active)]
+
+        /* Load the rest of lisp state. */
+        load(current_dynamic_space_free_pointer, reg_NL2)
+	add	reg_NL2, reg_ALLOC, reg_ALLOC
+        load(current_binding_stack_pointer, reg_BSP)
+        load(current_control_stack_pointer, reg_CSP)
+        load(current_control_frame_pointer, reg_CFP)
+
+	/* Get the return address back. */
+	ld	[reg_CFP+4], reg_LIP
+	ld	[reg_CFP+8], reg_CODE
+	add	reg_LIP, reg_CODE, reg_LIP
+	sub	reg_LIP, type_OtherPointer, reg_LIP
+
+        /* No longer atomic. */
+	andn	reg_ALLOC, pseudo_atomic_Value, reg_ALLOC
+	andcc	reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO
+	tne	trap_PseudoAtomic
+
+        /* Reset the lisp stack. */
+        /* Note: OCFP is in one of the locals, it gets preserved across C. */
+        mov     reg_CFP, reg_CSP
+        mov     reg_OCFP, reg_CFP
+
+#ifdef v8plus
+	ldx	[%fp - 8 - 1*8], %o2
+	ldx	[%fp - 8 - 2*8], %o3
+	ldx	[%fp - 8 - 3*8], %o4
+	ldx	[%fp - 8 - 4*8], %o5
+	ldx	[%fp - 8 - 5*8], %o6
+	ldx	[%fp - 8 - 6*8], %o7
+#endif		
+        /* And back into lisp. */
+        ret
+        nop
+
+	SET_SIZE(call_into_c)
+
+#if 0
+/* undefined_tramp and closure_tramp are now Lisp assembly routines.
+ * so we don't need these anymore.  Leave them here for a bit so 
+ * we can look at the "real" versions for a while.  But eventually,
+ * remove these.
+ */
+        .global _undefined_tramp
+	FUNCDEF(_undefined_tramp)
+        .align  8
+        .byte   0
+_undefined_tramp:
+        .byte   0, 0, type_FunctionHeader
+        .word   _undefined_tramp
+        .word   NIL
+        .word   NIL
+        .word   NIL
+        .word   NIL
+
+	b	1f
+        unimp   trap_Cerror
+        /* Number of argument bytes */
+        .byte	4
+        .byte	UNDEFINED_SYMBOL_ERROR
+        /* Escape to create 16bit number from following two bytes, 
+	   in little-endian order */
+        .byte	254
+        /* SC_OFFSET(sc_DescriptorReg,reg_FDEFN) */
+	.byte	SC_OFFSET_LO(sc_DescriptorReg,reg_FDEFN_NUM)
+	.byte	SC_OFFSET_HI(sc_DescriptorReg,reg_FDEFN_NUM)
+		
+	.align	4
+1:
+	ld	[reg_FDEFN+FDEFN_RAW_ADDR_OFFSET], reg_CODE
+	jmp	reg_CODE+FUNCTION_CODE_OFFSET
+	nop
+	SET_SIZE(_undefined_tramp)
+
+	.global	_closure_tramp
+	FUNCDEF(_closure_tramp)
+	.align	8
+	.byte	0
+_closure_tramp:
+	.byte	0, 0, type_FunctionHeader
+	.word	_closure_tramp
+	.word	NIL
+        .word   NIL
+	.word	NIL
+	.word	NIL
+
+	ld	[reg_FDEFN+FDEFN_FUNCTION_OFFSET], reg_LEXENV
+	ld	[reg_LEXENV+CLOSURE_FUNCTION_OFFSET], reg_CODE
+	jmp	reg_CODE+FUNCTION_CODE_OFFSET
+	nop
+	SET_SIZE(_closure_tramp)
+#endif
+
+
+/*
+ * Function-end breakpoint magic.
+ */
+
+	.text
+	.align	8
+	.global	function_end_breakpoint_guts
+function_end_breakpoint_guts:
+	.word	type_ReturnPcHeader
+	b	1f
+	nop
+	mov	reg_CSP, reg_OCFP
+	add	4, reg_CSP, reg_CSP
+	mov	4, reg_NARGS
+	mov	reg_NIL, reg_A1
+	mov	reg_NIL, reg_A2
+	mov	reg_NIL, reg_A3
+	mov	reg_NIL, reg_A4
+	mov	reg_NIL, reg_A5
+1:
+
+	.global	function_end_breakpoint_trap
+function_end_breakpoint_trap:
+	unimp	trap_FunctionEndBreakpoint
+	b	1b
+	nop
+
+	.global	function_end_breakpoint_end
+function_end_breakpoint_end:
+
+	.global flush_icache
+	FUNCDEF(flush_icache)
+flush_icache:
+        add %o0,%o1,%o2
+1:      iflush %o0			! flush instruction cache
+        add %o0,8,%o0
+        cmp %o0,%o2
+        blt 1b
+        nop
+	retl				! return from leaf routine
+        nop
+	SET_SIZE(flush_icache)
+
+        .global do_pending_interrupt
+	FUNCDEF(do_pending_interrupt)
+do_pending_interrupt:
+	unimp trap_PendingInterrupt
+	retl
+	nop
+	SET_SIZE(do_pending_interrupt)
+
+#ifdef trap_DynamicSpaceOverflowError
+	.global do_dynamic_space_overflow_error
+	FUNCDEF(do_dynamic_space_overflow_error)
+do_dynamic_space_overflow_error:	
+	unimp trap_DynamicSpaceOverflowError
+	retl
+	nop
+	SET_SIZE(do_dynamic_space_overflow_error)		
+#endif				
+
+#ifdef trap_DynamicSpaceOverflowWarning
+	.global do_dynamic_space_overflow_warning
+	FUNCDEF(do_dynamic_space_overflow_warning)
+do_dynamic_space_overflow_warning:	
+	unimp trap_DynamicSpaceOverflowWarning
+	retl
+	nop
+	SET_SIZE(do_dynamic_space_overflow_warning)		
+#endif				
+		
+#ifdef LINKAGE_TABLE
+/*
+ * Call into C code to resolve a linkage entry.
+ *
+ * We get here by Lisp calling call_into_c with an address of the
+ * desired function which is contained in the register reg_CFUNC (aka
+ * %i4, aka %r28).  This is the address of the entry in the linkage
+ * table, which is what we need to figure out what function we really
+ * wanted.
+ *
+ * Note that because we get here from call_into_c, all necessary live
+ * registers have been saved, including FP registers.  Hence, no need
+ * to save them.
+ */
+	.global lazy_resolve_linkage
+	.global resolve_linkage_tramp
+	FUNCDEF(resolve_linkage_tramp)
+resolve_linkage_tramp:
+	/*
+	 * At this point, all of the global %g registers have been
+	 * saved by call_into_c, so we can use them as temps.  %g2,
+	 * aka reg_NIL, aka null-tn is a good choice.  reg_L0 contains
+	 * the address of the jmpl instruction in the linkage jump
+	 * table.  (See sparc-arch.c.)
+	 */
+
+	mov	reg_L0, reg_NIL
+		
+	/* 
+	 * New stack frame so the %o regs become %i.  We can't touch
+	 * the original %o because they contain the parameters to the
+	 * function!
+	 */
+	save	%sp, -FRAMESIZE, %sp
+
+	/* %g2 tells where we came from in the linkage table */
+	call	lazy_resolve_linkage
+	mov	reg_NIL, %o0		! in the delay slot
+
+	mov	%o0, reg_NIL
+	restore	%sp, FRAMESIZE, %sp
+
+	/* And away we go! */
+	jmp	reg_NIL
+	nop
+	
+	SET_SIZE(resolve_linkage_tramp)						
+		
+	.global undefined_foreign_symbol_trap
+	FUNCDEF(undefined_foreign_symbol_trap)
+/*
+ * When we get called, %o0 contains the address of the data_vector object 
+ * which is a string naming the bad symbol.
+ */
+undefined_foreign_symbol_trap:
+	/*
+	   Need to restore all the global registers with the Lisp values that 
+	   were saved away in call_into_c.  (This routine is only called from 
+	   os_link_one_symbol, which is called from resolve_linkage_tramp, which 
+	   is called from call_into_c.)
+
+	   The global registers are volatile across function calls, so who
+	   knows what values have been they contain now!
+		
+	*/
+
+	load(current_dynamic_space_free_pointer, reg_ALLOC)
+        load(current_binding_stack_pointer, reg_BSP)
+        load(current_control_stack_pointer, reg_CSP)
+        load(current_control_frame_pointer, reg_CFP)
+		
+	set	NIL, reg_NIL
+
+	mov	%o0, reg_A0			
+	unimp	trap_Error
+	.byte	4	/* Number of argument bytes */
+	.byte	UNDEFINED_FOREIGN_SYMBOL_ERROR
+        /* Escape to create 16bit number from following two bytes, in 
+	   little-endian order */
+        .byte	254
+	.byte	SC_OFFSET_LO(sc_DescriptorReg, reg_A0_NUM)
+	.byte	SC_OFFSET_HI(sc_DescriptorReg, reg_A0_NUM)
+	.align	4
+					
+#endif
+/*
+ * Save the FPU state.  %o0 contains a pointer to where we can 
+ * store our state.
+ */			
+
+/* 
+ * Note we only save the 16 double-float registers (which saves
+ * the 32 single-float values too, I think).  If we're compiling for 
+ * a sparc v9, the Lisp code can actually use all 32 double-float 
+ * registers.  For later.
+ */
+	.global fpu_save
+	FUNCDEF(fpu_save)
+fpu_save:			
+	std	%f0, [%o0 + 4*0]
+	std	%f2, [%o0 + 4*2]	
+	std	%f4, [%o0 + 4*4]	
+	std	%f6, [%o0 + 4*6]	
+	std	%f8, [%o0 + 4*8]	
+	std	%f10, [%o0 + 4*10]	
+	std	%f12, [%o0 + 4*12]	
+	std	%f14, [%o0 + 4*14]	
+	std	%f16, [%o0 + 4*16]	
+	std	%f18, [%o0 + 4*18]	
+	std	%f20, [%o0 + 4*20]	
+	std	%f22, [%o0 + 4*22]	
+	std	%f24, [%o0 + 4*24]	
+	std	%f26, [%o0 + 4*26]	
+	std	%f28, [%o0 + 4*28]
+	std	%f30, [%o0 + 4*30]	
+#ifdef FEATURE_SPARC_V9
+	std	%f32, [%o0 + 4*32]	
+	std	%f34, [%o0 + 4*34]	
+	std	%f36, [%o0 + 4*36]	
+	std	%f38, [%o0 + 4*38]	
+	std	%f40, [%o0 + 4*40]	
+	std	%f42, [%o0 + 4*42]	
+	std	%f44, [%o0 + 4*44]	
+	std	%f46, [%o0 + 4*46]	
+	std	%f48, [%o0 + 4*48]	
+	std	%f50, [%o0 + 4*50]	
+	std	%f52, [%o0 + 4*52]	
+	std	%f54, [%o0 + 4*54]	
+	std	%f56, [%o0 + 4*56]	
+	std	%f58, [%o0 + 4*58]	
+	std	%f60, [%o0 + 4*60]	
+	std	%f62, [%o0 + 4*62]	
+	st	%fsr, [%o0 + 4*64]
+#else
+	st	%fsr, [%o0 + 4*32]
+#endif
+	retl
+	nop
+	SET_SIZE(fpu_save)						
+
+	.global fpu_restore
+	FUNCDEF(fpu_restore)
+fpu_restore:			
+	ldd	[%o0 + 4*0], %f0
+	ldd	[%o0 + 4*2], %f2	
+	ldd	[%o0 + 4*4], %f4	
+	ldd	[%o0 + 4*6], %f6	
+	ldd	[%o0 + 4*8], %f8	
+	ldd	[%o0 + 4*10], %f10	
+	ldd	[%o0 + 4*12], %f12	
+	ldd	[%o0 + 4*14], %f14	
+	ldd	[%o0 + 4*16], %f16	
+	ldd	[%o0 + 4*18], %f18	
+	ldd	[%o0 + 4*20], %f20	
+	ldd	[%o0 + 4*22], %f22	
+	ldd	[%o0 + 4*24], %f24	
+	ldd	[%o0 + 4*26], %f26	
+	ldd	[%o0 + 4*28], %f28
+	ldd	[%o0 + 4*30], %f30	
+#ifdef FEATURE_SPARC_V9
+	ldd	[%o0 + 4*32], %f32	
+	ldd	[%o0 + 4*34], %f34	
+	ldd	[%o0 + 4*36], %f36	
+	ldd	[%o0 + 4*38], %f38	
+	ldd	[%o0 + 4*40], %f40	
+	ldd	[%o0 + 4*42], %f42	
+	ldd	[%o0 + 4*44], %f44	
+	ldd	[%o0 + 4*46], %f46	
+	ldd	[%o0 + 4*48], %f48	
+	ldd	[%o0 + 4*50], %f50	
+	ldd	[%o0 + 4*52], %f52	
+	ldd	[%o0 + 4*54], %f54	
+	ldd	[%o0 + 4*56], %f56	
+	ldd	[%o0 + 4*58], %f58	
+	ldd	[%o0 + 4*60], %f60	
+	ldd	[%o0 + 4*62], %f62	
+	ld	[%o0 + 4*64], %fsr
+#else
+	ld	[%o0 + 4*32], %fsr
+#endif
+	retl
+	nop
+	SET_SIZE(fpu_restore)						
+
+	.global save_context
+	FUNCDEF(save_context)
+save_context:
+	ta	ST_FLUSH_WINDOWS	! flush register windows
+	retl				! return from leaf routine
+	nop
+	SET_SIZE(save_context)
+/*
+ * Local variables:
+ * tab-width: 8
+ * End:
+ */						
+