From eb65f3eb243c1eeed85541eb7828f69133176111 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 21 Mar 1998 08:05:25 +0000
Subject: [PATCH] Long-float support for the sparc backend.

---
 compiler/sparc/arith.lisp     |  26 +-
 compiler/sparc/array.lisp     | 115 ++++-
 compiler/sparc/c-call.lisp    |  20 +-
 compiler/sparc/float.lisp     | 813 +++++++++++++++++++++++++++++-----
 compiler/sparc/insts.lisp     | 121 +++--
 compiler/sparc/parms.lisp     |  19 +-
 compiler/sparc/sap.lisp       |  79 ++--
 compiler/sparc/type-vops.lisp |  49 +-
 compiler/sparc/vm.lisp        |  45 +-
 9 files changed, 1073 insertions(+), 214 deletions(-)

diff --git a/compiler/sparc/arith.lisp b/compiler/sparc/arith.lisp
index 65296ea4e..c738c9794 100644
--- a/compiler/sparc/arith.lisp
+++ b/compiler/sparc/arith.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.10 1994/10/31 04:46:41 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.11 1998/03/21 08:05:20 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.10 1994/10/31 04:46:41 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.11 1998/03/21 08:05:20 dtc Exp $
 ;;;
 ;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
 ;;;
@@ -303,6 +303,28 @@
 
       (emit-label done))))
 
+;;; Multiply and Divide.
+
+(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:translate *)
+  (:guard (backend-featurep :sparc-v8))
+  (:generator 4
+    (inst sra temp y 2)
+    (inst smul r x temp)))
+
+(define-vop (fast-*/signed=>signed fast-signed-binop)
+  (:translate *)
+  (:guard (backend-featurep :sparc-v8))
+  (:generator 3
+    (inst smul r x y)))
+
+(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
+  (:translate *)
+  (:guard (backend-featurep :sparc-v8))
+  (:generator 3
+    (inst umul r x y)))
+
 
 ;;;; Binary conditional VOPs:
 
diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp
index dc420ae1e..e6faaf4dc 100644
--- a/compiler/sparc/array.lisp
+++ b/compiler/sparc/array.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.19 1998/03/10 21:42:22 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.20 1998/03/21 08:05:21 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -13,7 +13,7 @@
 ;;;
 ;;; Written by William Lott
 ;;; Signed-array support by Douglas Crosher 1997.
-;;; Complex-float support by Douglas Crosher 1998.
+;;; Complex-float and long-float support by Douglas Crosher 1998.
 ;;;
 (in-package "SPARC")
 
@@ -393,6 +393,43 @@
     (unless (location= result value)
       (move-double-reg result value))))
 
+#+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-long-float positive-fixnum)
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:generator 7
+    (inst sll 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 "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 sll 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.
 
@@ -552,6 +589,56 @@
       (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 "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 sll 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 "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 sll 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)))))
+
 ) ; end progn complex-float
 
 
@@ -573,6 +660,16 @@
 (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))
+;;;
+#+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))
 
 #+complex-float
 (progn
@@ -597,6 +694,20 @@
   (:translate %raw-set-complex-double)
   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
 	      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))
+
 ) ; end progn complex-float
 
 ;;; These vops are useful for accessing the bits of a vector irrespective of
diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp
index bb522e79c..2ba303ffb 100644
--- a/compiler/sparc/c-call.lisp
+++ b/compiler/sparc/c-call.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.11 1994/10/31 04:46:41 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.12 1998/03/21 08:05:21 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -62,6 +62,11 @@
   (declare (ignore type))
   (my-make-wired-tn 'double-float 'double-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)
   (mapcar #'(lambda (type)
 	      (invoke-alien-type-method :result-tn type))
@@ -87,7 +92,8 @@
 	 (arg-types (alien-function-type-arg-types type))
 	 (result-type (alien-function-type-result-type type)))
     (assert (= (length arg-types) (length args)))
-    (if (some #'alien-double-float-type-p arg-types)
+    (if (or (some #'alien-double-float-type-p arg-types)
+	    #+long-float (some #'alien-long-float-type-p arg-types))
 	(collect ((new-args) (lambda-vars) (new-arg-types))
 	  (dolist (type arg-types)
 	    (let ((arg (gensym)))
@@ -97,6 +103,16 @@
 		     (new-args `(double-float-low-bits ,arg))
 		     (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)))))
diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp
index cebddb00a..38071b364 100644
--- a/compiler/sparc/float.lisp
+++ b/compiler/sparc/float.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.22 1998/03/11 17:11:35 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.23 1998/03/21 08:05:22 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -13,7 +13,7 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;; Sparc conversion by William Lott.
-;;; Complex-float support by Douglas Crosher 1998.
+;;; Complex-float and long-float support by Douglas Crosher 1998.
 ;;;
 (in-package "SPARC")
 
@@ -41,6 +41,63 @@
 	(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 ldxf 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 stxf 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:
@@ -49,13 +106,33 @@
 ;;; on the :sparc-v9 feature.
 (defun move-double-reg (dst src)
   (cond ((backend-featurep :sparc-v9)
-	 ;; May need to re-map of the register numbers?
 	 (inst fmovd dst src))
 	(t
-	 (inst fmovs dst src)
-	 (inst fmovs-odd dst src))))
-
-(macrolet ((frob (vop sc double-p)
+	 (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 fmovx 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)
@@ -66,12 +143,15 @@
 		  (:note "float move")
 		  (:generator 0
 		    (unless (location= y x)
-		      ,@(if double-p
-			  `((move-double-reg y x))
-			  `((inst fmovs 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 nil)
-  (frob double-move double-reg t))
+  (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)
@@ -79,12 +159,17 @@
   (:results (y))
   (:note "float to pointer coercion")
   (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:variant-vars double-p size type data)
+  (:variant-vars format size type data)
   (:generator 13
     (with-fixed-allocation (y ndescr type size))
-    (if double-p
-	(inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type))
-	(inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type)))))
+    (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
@@ -93,26 +178,42 @@
 		  (:results (y :scs (descriptor-reg)))
 		  (:variant ,@args))
 		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
-  (frob move-from-single single-reg
-    nil vm:single-float-size vm:single-float-type vm:single-float-value-slot)
-  (frob move-from-double double-reg
-    t vm:double-float-size vm:double-float-type vm:double-float-value-slot))
-
-(macrolet ((frob (name sc double-p value)
+  (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 "pointer to float coercion")
 		  (:generator 2
-		    (inst ,(if double-p 'lddf 'ldf) y x
+		    (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 nil vm:single-float-value-slot)
-  (frob move-to-double double-reg t vm:double-float-value-slot))
+  (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 "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 double-p)
+(macrolet ((frob (name sc stack-sc format)
 	     `(progn
 		(define-vop (,name)
 		  (:args (x :scs (,sc) :target y)
@@ -120,20 +221,42 @@
 			      :load-if (not (sc-is y ,sc))))
 		  (:results (y))
 		  (:note "float argument move")
-		  (:generator ,(if double-p 2 1)
+		  (:generator ,(ecase format (:single 1) (:double 2))
 		    (sc-case y
 		      (,sc
 		       (unless (location= x y)
-			 ,@(if double-p
-			     '((move-double-reg y x))
-			     '((inst fmovs y x)))))
+			 ,@(ecase format
+			     (:single '((inst fmovs y x)))
+			     (:double '((move-double-reg y x))))))
 		      (,stack-sc
 		       (let ((offset (* (tn-offset y) vm:word-bytes)))
-			 (inst ,(if double-p 'stdf 'stf) x nfp offset))))))
+			 (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 nil)
-  (frob move-double-float-argument double-reg double-stack t))
+  (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 "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
@@ -145,7 +268,7 @@
 		  :offset (tn-offset x)))
 (defun complex-single-reg-imag-tn (x)
   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
-		  :offset (+ (tn-offset x) 2)))
+		  :offset (1+ (tn-offset x))))
 
 (defun complex-double-reg-real-tn (x)
   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
@@ -154,6 +277,15 @@
   (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)))
+
 
 (define-move-function (load-complex-single 2) (vop x y)
   ((complex-single-stack) (complex-single-reg))
@@ -192,6 +324,27 @@
     (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))))))
+
 ;;;
 ;;; Complex float register to register moves.
 ;;;
@@ -233,6 +386,27 @@
 (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 "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))
+
 ;;;
 ;;; Move from a complex float to a descriptor register allocating a
 ;;; new complex float object in the process.
@@ -277,6 +451,28 @@
 (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 "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))
+
 ;;;
 ;;; Move from a descriptor to a complex float register
 ;;;
@@ -308,6 +504,22 @@
 (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 "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))
+
 ;;;
 ;;; Complex float move-argument vop
 ;;;
@@ -359,12 +571,39 @@
 (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 "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))
+
 ) ; progn complex-float
 
 
 (define-move-vop move-argument :move-argument
-  (single-reg double-reg
-   #+complex-float complex-single-reg #+complex-float complex-double-reg)
+  (single-reg double-reg #+long-float long-reg
+   #+complex-float complex-single-reg #+complex-float complex-double-reg
+   #+(and complex-float long-float) complex-long-reg)
   (descriptor-reg))
 
 
@@ -386,7 +625,9 @@
 		(:arg-types ,ptype ,ptype)
 		(:result-types ,ptype))))
   (frob single-float-op single-reg single-float)
-  (frob double-float-op double-reg double-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
@@ -403,7 +644,19 @@
   (frob * fmuls */single-float 4 fmuld */double-float 5)
   (frob / fdivs //single-float 12 fdivd //double-float 19))
 
-(macrolet ((frob (name inst translate double-p sc type)
+#+long-float
+(macrolet ((frob (op linst lname lcost)
+	     `(define-vop (,lname long-float-op)
+		  (:translate ,op)
+		  (:generator ,lcost
+		    (inst ,linst r x y)))))
+  (frob + faddx +/long-float 2)
+  (frob - fsubx -/long-float 2)
+  (frob * fmulx */long-float 6)
+  (frob / fdivx //long-float 20))
+
+
+(macrolet ((frob (name inst translate sc type)
 	     `(define-vop (,name)
 		(:args (x :scs (,sc)))
 		(:results (y :scs (,sc)))
@@ -416,13 +669,113 @@
 		(:save-p :compute-only)
 		(:generator 1
 		  (note-this-location vop :internal-error)
-		  (inst ,inst y x)
-		  ,@(when double-p
-		      '((inst fmovs-odd y x)))))))
-  (frob abs/single-float fabss abs nil single-reg single-float)
-  (frob abs/double-float fabss abs t double-reg double-float)
-  (frob %negate/single-float fnegs %negate nil single-reg single-float)
-  (frob %negate/double-float fnegs %negate t double-reg double-float))
+		  (inst ,inst y x)))))
+  (frob abs/single-float fabss abs single-reg single-float)
+  (frob %negate/single-float fnegs %negate single-reg single-float))
+
+(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 "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (cond ((backend-featurep :sparc-v9)
+	   (inst fabsd y x))
+	  (t
+	   (inst fabss y x)
+	   (let ((y-odd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'single-reg *backend*)
+					:offset (+ 1 (tn-offset y))))
+		 (x-odd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'single-reg *backend*)
+					:offset (+ 1 (tn-offset x)))))
+	     (inst fmovs y-odd x-odd))))))
+
+(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 "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (cond ((backend-featurep :sparc-v9)
+	   (inst fnegd y x))
+	  (t
+	   (inst fnegs y x)
+	   (let ((y-odd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'single-reg *backend*)
+					:offset (+ 1 (tn-offset y))))
+		 (x-odd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'single-reg *backend*)
+					:offset (+ 1 (tn-offset x)))))
+	     (inst fmovs y-odd x-odd))))))
+
+#+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 "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (cond ((backend-featurep :sparc-v9)
+	   (inst fabsx 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 "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (cond ((backend-featurep :sparc-v9)
+	   (inst fnegx 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:
@@ -440,7 +793,8 @@
     (note-this-location vop :internal-error)
     (ecase format
       (:single (inst fcmps x y))
-      (:double (inst fcmpd x y)))
+      (:double (inst fcmpd x y))
+      (:long (inst fcmpx x y)))
     (inst nop)
     (inst fb (if not-p nope yep) target)
     (inst nop)))
@@ -451,28 +805,42 @@
 		       (y :scs (,sc)))
 		(:arg-types ,ptype ,ptype))))
   (frob single-float-compare single-reg single-float)
-  (frob double-float-compare double-reg double-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)
+(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)))))
-  (frob < :l :ge </single-float </double-float)
-  (frob > :g :le >/single-float >/double-float)
-  (frob = :eq :ne eql/single-float eql/double-float))
+		  (: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))))
 
 
 ;;;; Conversion:
 
 (macrolet ((frob (name translate inst to-sc to-type)
 	     `(define-vop (,name)
-		(:args (x :scs (signed-reg) :target temp
+		(:args (x :scs (signed-reg) :target stack-temp
 			  :load-if (not (sc-is x signed-stack))))
-		(:temporary (:scs (single-stack)) temp)
+		(: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)
@@ -488,16 +856,18 @@
 			    (inst st x
 				  (current-nfp-tn vop)
 				  (* (tn-offset temp) vm:word-bytes))
-			    temp)
+			    stack-temp)
 			   (signed-stack
 			    x))))
-		    (inst ldf y
+		    (inst ldf temp
 			  (current-nfp-tn vop)
 			  (* (tn-offset stack-tn) vm:word-bytes))
 		    (note-this-location vop :internal-error)
-		    (inst ,inst y y))))))
+		    (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))
+  (frob %double-float/signed %double-float fitod double-reg double-float)
+  #+long-float
+  (frob %long-float/signed %long-float fitox long-reg long-float))
 
 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
 	     `(define-vop (,name)
@@ -515,8 +885,20 @@
 		  (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 fxtos
+    long-reg long-float single-reg single-float)
   (frob %double-float/single-float %double-float fstod
-    single-reg single-float double-reg double-float))
+    single-reg single-float double-reg double-float)
+  #+long-float
+  (frob %double-float/long-float %double-float fxtod
+    long-reg long-float double-reg double-float)
+  #+long-float
+  (frob %long-float/single-float %long-float fstox
+    single-reg single-float long-reg long-float)
+  #+long-float
+  (frob %long-float/double-float %long-float fdtox
+    double-reg double-float long-reg long-float))
 
 (macrolet ((frob (trans from-sc from-type inst)
 	     `(define-vop (,(symbolicate trans "/" from-type))
@@ -546,6 +928,8 @@
 			   (* (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 fxtoi)
   #-sun4
   (frob %unary-round single-reg single-float fstoir)
   #-sun4
@@ -622,6 +1006,36 @@
       (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))))
@@ -647,7 +1061,8 @@
 	  (inst ld 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))))
+	  (loadw bits float vm:single-float-value-slot
+		 vm:other-pointer-type))))
       (signed-stack
        (sc-case float
 	 (single-reg
@@ -657,68 +1072,162 @@
 (define-vop (double-float-high-bits)
   (:args (float :scs (double-reg descriptor-reg)
 		:load-if (not (sc-is float double-stack))))
-  (:results (hi-bits :scs (signed-reg)
-		     :load-if (or (sc-is float descriptor-reg double-stack)
-				  (not (sc-is hi-bits signed-stack)))))
-  (:temporary (:scs (signed-stack)) stack-temp)
+  (: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 hi-bits
-      (signed-reg
-       (sc-case float
-	 (double-reg
-	  (inst stf float (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst ld hi-bits (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes)))
-	 (double-stack
-	  (inst ld 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))))
-      (signed-stack
-       (sc-case float
-	 (double-reg
-	  (inst stf float (current-nfp-tn vop)
-		(* (tn-offset hi-bits) vm:word-bytes))))))))
+    (sc-case float
+      (double-reg
+       (inst stdf float (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes))
+       (inst ld hi-bits (current-nfp-tn vop)
+	     (* (tn-offset stack-temp) vm:word-bytes)))
+      (double-stack
+       (inst ld 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)
-		     :load-if (or (sc-is float descriptor-reg double-stack)
-				  (not (sc-is lo-bits unsigned-stack)))))
-  (:temporary (:scs (unsigned-stack)) stack-temp)
+  (: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 lo-bits
-      (unsigned-reg
-       (sc-case float
-	 (double-reg
-	  (inst stf-odd float (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst ld lo-bits (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes)))
-	 (double-stack
-	  (inst ld 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))))
-      (unsigned-stack
-       (sc-case float
-	 (double-reg
-	  (inst stf-odd float (current-nfp-tn vop)
-		(* (tn-offset lo-bits) vm:word-bytes))))))))
+    (sc-case float
+      (double-reg
+       (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)))
+      (double-stack
+       (inst ld 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)))))
+
+#+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:
@@ -759,6 +1268,7 @@
 
 ;;;; Special functions.
 
+#-long-float
 (define-vop (fsqrt)
   (:args (x :scs (double-reg)))
   (:results (y :scs (double-reg)))
@@ -774,6 +1284,21 @@
     (note-this-location vop :internal-error)
     (inst fsqrtd y x)))
 
+#+long-float
+(define-vop (fsqrt)
+  (:args (x :scs (long-reg)))
+  (:results (y :scs (long-reg)))
+  (:translate %sqrt)
+  (:policy :fast-safe)
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:note "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-this-location vop :internal-error)
+    (inst fsqrtx y x)))
+
 
 ;;;; Complex float VOPs
 
@@ -782,7 +1307,8 @@
 
 (define-vop (make-complex-single-float)
   (:translate complex)
-  (:args (real :scs (single-reg) :target r)
+  (: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)
@@ -803,12 +1329,14 @@
       (complex-single-stack
        (let ((nfp (current-nfp-tn vop))
 	     (offset (* (tn-offset r) vm:word-bytes)))
-	 (inst stf real nfp offset)
+	 (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)
+  (: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)
@@ -829,9 +1357,39 @@
       (complex-double-stack
        (let ((nfp (current-nfp-tn vop))
 	     (offset (* (tn-offset r) vm:word-bytes)))
-	 (inst stdf real nfp offset)
+	 (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 "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) :target r
 	    :load-if (not (sc-is x complex-single-stack))))
@@ -896,4 +1454,39 @@
   (:note "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 "complex long float realpart")
+  (:variant :real))
+
+#+long-float
+(define-vop (imagpart/complex-long-float complex-long-float-value)
+  (:translate imagpart)
+  (:note "complex long float imagpart")
+  (:variant :imag))
+
 ) ; progn complex-float
diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp
index af7f0b5fb..f977cb667 100644
--- a/compiler/sparc/insts.lisp
+++ b/compiler/sparc/insts.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.17 1998/03/11 17:00:26 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.18 1998/03/21 08:05:23 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -36,13 +36,20 @@
 	 (tn-offset tn)
 	 (error "~S isn't a register." tn)))))
 
-(defun fp-reg-tn-encoding (tn &optional odd)
+(defun fp-reg-tn-encoding (tn)
   (declare (type tn tn))
   (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
     (error "~S isn't a floating-point register." tn))
-  (if odd
-      (1+ (tn-offset tn))
-      (tn-offset 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)
 
@@ -59,7 +66,18 @@
 	(unless (zerop (tn-offset loc))
 	  (tn-offset loc)))
        (float-registers
-	(+ (tn-offset loc) 32))
+	(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
@@ -108,7 +126,7 @@
 		  dstate))))
 
 ;;; The extended 6 bit floating point register encoding for the double
-;;; and long instructions of the sparc V9.
+;;; and long instructions of the sparc v9.
 (disassem:define-argument-type fp-ext-reg
   :printer #'(lambda (value stream dstate)
 	       (declare (stream stream) (fixnum value))
@@ -262,7 +280,7 @@
   (opf  :field (byte 9 5))
   (rs2  :field (byte 5 0) :type 'fp-reg))
 
-;;; Double and long float instruction format of the sparc V9.
+;;; Double and long float instruction format of the sparc v9.
 (disassem:define-instruction-format
     (format-binary-ext-fpop 32
      :default-printer '(:name :tab rd ", " rs1 ", " rs2))
@@ -328,7 +346,7 @@
 ;;;; Most of the format-3-instructions.
 
 (defun emit-format-3-inst (segment op op3 dst src1 src2
-				   &key load-store fixup dest-kind odd)
+				   &key load-store fixup dest-kind)
   (unless src2
     (cond ((and (typep src1 'tn) load-store)
 	   (setf src2 0))
@@ -339,13 +357,13 @@
     (tn
      (emit-format-3-reg segment op
 			(if dest-kind
-			    (fp-reg-tn-encoding dst odd)
+			    (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 odd)
+			      (fp-reg-tn-encoding dst)
 			      (reg-tn-encoding dst))
 			  op3 (reg-tn-encoding src1) 1 src2))
     (fixup
@@ -354,7 +372,7 @@
      (note-fixup segment :add src2)
      (emit-format-3-immed segment op
 			  (if dest-kind
-			      (fp-reg-tn-encoding dst odd)
+			      (fp-reg-tn-encoding dst)
 			      (reg-tn-encoding dst))
 			  op3 (reg-tn-encoding src1) 1 0))))
 
@@ -393,13 +411,12 @@
 		 ,(if (or fixup load-store)
 		      '(type (or tn (signed-byte 13) null fixup) src1 src2)
 		      '(type (or tn (signed-byte 13) null) src1 src2)))
-       ,@(unless (eq dest-kind 'odd-fp-reg)
-	   `((:printer format-3-reg
-		       ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
-		       ,printer)
-	     (:printer format-3-immed
-		       ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
-		       ,printer)))
+       (:printer format-3-reg
+		 ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
+	 	 ,printer)
+       (:printer format-3-immed
+	 	 ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
+	 	 ,printer)
        ,@(when flushable
 	   '((:attributes flushable)))
        (:dependencies
@@ -437,8 +454,7 @@
        (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
 				     :load-store ,load-store
 				     :fixup ,fixup
-				     :dest-kind (not (eq ',dest-kind 'reg))
-				     :odd (eq ',dest-kind 'odd-fp-reg))))))
+				     :dest-kind (not (eq ',dest-kind 'reg)))))))
 
 ) ; eval-when (compile eval)
 
@@ -449,15 +465,15 @@
 (define-f3-inst ld #b11 #b000000 :load-store :load)
 (define-f3-inst ldd #b11 #b000011 :load-store :load)
 (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
-(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load)
 (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
+(define-f3-inst ldxf #b11 #b100010 :dest-kind fp-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)
 (define-f3-inst std #b11 #b000111 :load-store :store)
 (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
-(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store)
 (define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
+(define-f3-inst stxf #b11 #b100110 :dest-kind fp-reg :load-store :store) ; v9
 (define-f3-inst ldstub #b11 #b001101 :load-store t)
 (define-f3-inst swap #b11 #b001111 :load-store t)
 (define-f3-inst add #b10 #b000000 :fixup t)
@@ -491,6 +507,18 @@
 (define-f3-inst save #b10 #b111100 :reads :psr :writes :psr)
 (define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr)
 
+(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
 
 
 ;;;; Random instructions.
@@ -856,7 +884,7 @@
 
 (define-unary-fp-inst fitos #b011000100 :reads :fsr)
 (define-unary-ext-fp-inst fitod #b011001000 :reads :fsr)
-(define-unary-ext-fp-inst fitox #b011001100 :reads :fsr)
+(define-unary-ext-fp-inst fitox #b011001100 :reads :fsr)	; v8
 
 (define-unary-fp-inst fstoir #b011000001 :reads :fsr)
 (define-unary-ext-fp-inst fdtoir #b011000010 :reads :fsr)
@@ -864,56 +892,53 @@
 
 (define-unary-fp-inst fstoi #b011010001)
 (define-unary-ext-fp-inst fdtoi #b011010010)
-(define-unary-ext-fp-inst fxtoi #b011010011)
+(define-unary-ext-fp-inst fxtoi #b011010011)	; v8
 
 (define-unary-fp-inst fstod #b011001001 :reads :fsr)
-(define-unary-fp-inst fstox #b011001101 :reads :fsr)
+(define-unary-fp-inst fstox #b011001101 :reads :fsr)	; v8
 (define-unary-fp-inst fdtos #b011000110 :reads :fsr)
-(define-unary-fp-inst fdtox #b011001110 :reads :fsr)
-(define-unary-fp-inst fxtos #b011000111 :reads :fsr)
-(define-unary-fp-inst fxtod #b011001011 :reads :fsr)
+(define-unary-fp-inst fdtox #b011001110 :reads :fsr)	; v8
+(define-unary-fp-inst fxtos #b011000111 :reads :fsr)	; v8
+(define-unary-fp-inst fxtod #b011001011 :reads :fsr)	; v8
 
 (define-unary-fp-inst fmovs #b000000001)
-(define-instruction fmovs-odd (segment dst src1)
-  (:declare (type tn dst src1))
-  (:dependencies (reads dst) (reads src1) (writes dst))
-  (:delay 0)
-  (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst t)
-				#b110100 0 #b000000001
-				(fp-reg-tn-encoding src1 t))))
-(define-unary-ext-fp-inst fmovd #b000000010)	; V9
-(define-unary-ext-fp-inst fmovq #b000000011)	; V9
+(define-unary-ext-fp-inst fmovd #b000000010)	; v9
+(define-unary-ext-fp-inst fmovx #b000000011)	; v9
 
 (define-unary-fp-inst fnegs #b000000101)
-(define-unary-fp-inst fabss #b000001001)
+(define-unary-ext-fp-inst fnegd #b000000110)	; v9
+(define-unary-ext-fp-inst fnegx #b000000111)	; v9
 
-(define-unary-fp-inst fsqrts #b000101001 :reads :fsr)
-(define-unary-ext-fp-inst fsqrtd #b000101010 :reads :fsr)
-(define-unary-ext-fp-inst fsqrtx #b000101011 :reads :fsr)
+(define-unary-fp-inst fabss #b000001001)
+(define-unary-ext-fp-inst fabsd #b000001010)	; v9
+(define-unary-ext-fp-inst fabsx #b000001011)	; v9
 
+(define-unary-fp-inst fsqrts #b000101001 :reads :fsr)		; V7
+(define-unary-ext-fp-inst fsqrtd #b000101010 :reads :fsr)	; V7
+(define-unary-ext-fp-inst fsqrtx #b000101011 :reads :fsr)	; v8
 
 (define-binary-fp-inst fadds #b001000001)
 (define-binary-ext-fp-inst faddd #b001000010)
-(define-binary-ext-fp-inst faddx #b001000011)
+(define-binary-ext-fp-inst faddx #b001000011)	; v8
 (define-binary-fp-inst fsubs #b001000101)
 (define-binary-ext-fp-inst fsubd #b001000110)
-(define-binary-ext-fp-inst fsubx #b001000111)
+(define-binary-ext-fp-inst fsubx #b001000111)	; v8
 
 (define-binary-fp-inst fmuls #b001001001)
 (define-binary-ext-fp-inst fmuld #b001001010)
-(define-binary-ext-fp-inst fmulx #b001001011)
+(define-binary-ext-fp-inst fmulx #b001001011)	; v8
 (define-binary-fp-inst fdivs #b001001101)
 (define-binary-ext-fp-inst fdivd #b001001110)
-(define-binary-ext-fp-inst fdivx #b001001111)
+(define-binary-ext-fp-inst fdivx #b001001111)	; v8
 
 ;;; Float comparison instructions.
 ;;;
 (define-cmp-fp-inst fcmps #b001010001)
 (define-cmp-ext-fp-inst fcmpd #b001010010)
-(define-cmp-ext-fp-inst fcmpx #b001010011)
+(define-cmp-ext-fp-inst fcmpx #b001010011)	; v8
 (define-cmp-fp-inst fcmpes #b001010101)
 (define-cmp-ext-fp-inst fcmped #b001010110)
-(define-cmp-ext-fp-inst fcmpex #b001010111)
+(define-cmp-ext-fp-inst fcmpex #b001010111)	; v8
 
 
 
diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp
index 597db72d3..e58d6915b 100644
--- a/compiler/sparc/parms.lisp
+++ b/compiler/sparc/parms.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.26 1998/03/11 18:04:59 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.27 1998/03/21 08:05:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -63,6 +63,11 @@
 	  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))
@@ -102,12 +107,24 @@
 (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))
 
 (defconstant float-inexact-trap-bit (ash 1 0))
 (defconstant float-divide-by-zero-trap-bit (ash 1 1))
diff --git a/compiler/sparc/sap.lisp b/compiler/sparc/sap.lisp
index 98d7bd4d0..18388e10d 100644
--- a/compiler/sparc/sap.lisp
+++ b/compiler/sparc/sap.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.8 1997/04/26 20:05:05 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.9 1998/03/21 08:05:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -172,13 +172,15 @@
 	 (:results (result :scs (,sc)))
 	 (:result-types ,type)
 	 (:generator 5
-	   (inst ,(ecase size
-		    (:byte (if signed 'ldsb 'ldub))
-		    (:short (if signed 'ldsh 'lduh))
-		    (:long 'ld)
-		    (:single 'ldf)
-		    (:double 'lddf))
-		 result sap offset)))
+	   ,@(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)
@@ -188,13 +190,15 @@
 	 (:results (result :scs (,sc)))
 	 (:result-types ,type)
 	 (:generator 4
-	   (inst ,(ecase size
-		    (:byte (if signed 'ldsb 'ldub))
-		    (:short (if signed 'ldsh 'lduh))
-		    (:long 'ld)
-		    (:single 'ldf)
-		    (:double 'lddf))
-		 result sap offset)))
+	   ,@(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)
@@ -205,20 +209,23 @@
 	 (:results (result :scs (,sc)))
 	 (:result-types ,type)
 	 (:generator 5
-	   (inst ,(ecase size
-		    (:byte 'stb)
-		    (:short 'sth)
-		    (:long 'st)
-		    (:single 'stf)
-		    (:double 'stdf))
-		 value sap offset)
+	   ,@(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
-		  '((inst fmovs result value)
-		    (inst fmovs-odd result value)))
+		  '((move-double-reg result value)))
+		 (:long-float
+		  '((move-long-reg result value)))
 		 (t
 		  '((inst move result value)))))))
        (define-vop (,set-name-c)
@@ -231,20 +238,23 @@
 	 (:results (result :scs (,sc)))
 	 (:result-types ,type)
 	 (:generator 4
-	   (inst ,(ecase size
-		    (:byte 'stb)
-		    (:short 'sth)
-		    (:long 'st)
-		    (:single 'stf)
-		    (:double 'stdf))
-		 value sap offset)
+	   ,@(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
-		  '((inst fmovs result value)
-		    (inst fmovs-odd result value)))
+		  '((move-double-reg result value)))
+		 (:long-float
+		  '((move-long-reg result value)))
 		 (t
 		  '((inst move result value))))))))))
 
@@ -268,6 +278,9 @@
   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)
 
 
 
diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp
index 0e27541ed..258d9ae00 100644
--- a/compiler/sparc/type-vops.lisp
+++ b/compiler/sparc/type-vops.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.17 1998/01/21 05:10:18 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.18 1998/03/21 08:05:25 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -14,7 +14,7 @@
 ;;;
 ;;; Written by William Lott.
 ;;; Signed-array support by Douglas Crosher 1997.
-;;; Complex-float support by Douglas Crosher 1998.
+;;; Complex-float and long-float support by Douglas Crosher 1998.
 ;;;
 (in-package "SPARC")
 
@@ -113,7 +113,8 @@
 (def-type-vops complexp check-complex complex object-not-complex-error
   vm:complex-type
   #+complex-float vm:complex-single-float-type
-  #+complex-float vm:complex-double-float-type)
+  #+complex-float vm:complex-double-float-type
+  #+(and complex-float long-float) vm:complex-long-float-type)
 
 #+complex-float
 (def-type-vops complex-rational-p check-complex-rational nil
@@ -122,7 +123,8 @@
 #+complex-float
 (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)
+  vm:complex-single-float-type vm:complex-double-float-type
+  #+long-float vm:complex-long-float-type)
 
 #+complex-float
 (def-type-vops complex-single-float-p check-complex-single-float
@@ -134,12 +136,21 @@
   complex-double-float object-not-complex-double-float-error
   vm:complex-double-float-type)
 
+#+(and complex-float 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)
+
 (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)
+
 (def-type-vops simple-string-p check-simple-string simple-string
   object-not-simple-string-error vm:simple-string-type)
 
@@ -215,6 +226,11 @@
   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)
+
 #+complex-float
 (def-type-vops simple-array-complex-single-float-p
   check-simple-array-complex-single-float
@@ -229,6 +245,13 @@
   object-not-simple-array-complex-double-float-error
   vm:simple-array-complex-double-float-type)
 
+#+(and complex-float 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)
+
 (def-type-vops base-char-p check-base-char base-char
   object-not-base-char-error vm:base-char-type)
 
@@ -279,8 +302,10 @@
   #+signed-array simple-array-signed-byte-30-type
   #+signed-array 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
   #+complex-float vm:simple-array-complex-single-float-type
   #+complex-float vm:simple-array-complex-double-float-type
+  #+(and complex-float long-float) vm:simple-array-complex-long-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
@@ -293,8 +318,10 @@
   #+signed-array simple-array-signed-byte-30-type
   #+signed-array 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
   #+complex-float vm:simple-array-complex-single-float-type
-  #+complex-float vm:simple-array-complex-double-float-type)
+  #+complex-float vm:simple-array-complex-double-float-type
+  #+(and complex-float long-float) vm:simple-array-complex-long-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
@@ -306,16 +333,20 @@
   #+signed-array simple-array-signed-byte-30-type
   #+signed-array 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
   #+complex-float vm:simple-array-complex-single-float-type
   #+complex-float vm:simple-array-complex-double-float-type
+  #+(and complex-float long-float) vm:simple-array-complex-long-float-type
   vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
   vm:complex-array-type)
 
 (def-type-vops numberp check-number nil object-not-number-error
   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
-  vm:single-float-type vm:double-float-type vm:complex-type
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  vm:complex-type
   #+complex-float vm:complex-single-float-type
-  #+complex-float vm:complex-double-float-type)
+  #+complex-float vm:complex-double-float-type
+  #+(and complex-float long-float) vm:complex-long-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)
@@ -324,11 +355,11 @@
   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)
+  vm:single-float-type vm:double-float-type #+long-float vm:long-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)
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type)
 
 
 ;;;; Other integer ranges.
diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp
index cd232b981..56950890c 100644
--- a/compiler/sparc/vm.lisp
+++ b/compiler/sparc/vm.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.11 1998/03/11 17:11:37 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.12 1998/03/21 08:05:25 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -148,12 +148,17 @@
   (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.
   #+complex-float
   ;; complex-single-floats
   (complex-single-stack non-descriptor-stack :element-size 2)
   #+complex-float
   ;; complex-double-floats.
   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
+  #+(and complex-float long-float)
+  ;; complex-long-floats.
+  (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4)
 
 
   ;; **** Things that can go in the integer registers.
@@ -213,35 +218,61 @@
 
   ;; Non-Descriptor single-floats.
   (single-reg float-registers
-   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+   :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 (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61
+		      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 61
+		      by 4 collect i)
+   :element-size 4 :alignment 4
+   :reserve-locations (28)
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (long-stack))
+
   #+complex-float
   (complex-single-reg float-registers
-   :locations (0 4 8 12 16 20 24 28)
-   :element-size 4
+   :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-float
   (complex-double-reg float-registers
-   :locations (0 4 8 12 16 20 24 28)
-   :element-size 4
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61
+		      by 4 collect i)
+   :element-size 4 :alignment 4
+   :reserve-locations (28)
    :constant-scs ()
    :save-p t
    :alternate-scs (complex-double-stack))
 
+  #+(and complex-float long-float)
+  (complex-long-reg float-registers
+   :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61
+		      by 8 collect i)
+   :element-size 8 :alignment 8
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-long-stack))
+
 
   ;; A catch or unwind block.
   (catch-block control-stack :element-size vm:catch-block-size))
-- 
GitLab