Commit 6bfb74d1 authored by rtoy's avatar rtoy
Browse files

Add basic support for kernel:double-double-float type. The primitive 

type is there, and basic arithmetic operations work as well as PRINT.
But many things do not work: No reader, formatted output, many mixed
type arithmetic operations, special functions are just double-float
values, coerced to double-double-float.

compiler/generic/interr.lisp:
o Add new error

compiler/generic/new-genesis.lisp:
o Dump double-double-float objects (barely tested)

compiler/generic/primtype.lisp:
o Tell compiler about the new primitive type double-double-float.

compiler/generic/vm-fndb.lisp:
o Make double-double-float-p a known function.

compiler/generic/vm-type.lisp:
o Update FLOAT-FORMAT-NAME to include double-double-float

compiler/generic/vm-typetran.lisp:
o Tell compiler about double-double-float type predicate.

compiler/sparc/float.lisp:
o Add necessary vops to move double-double-float args, store and load
  double-double-floats to/from the double-double-stack,
  double-double-reg moves, box and unbox double-double-floats, move
  double-double-floats to and from args
o Add necessary vops to create a double-double-float and to extract
  the high and low parts out of a double-double-float.

compiler/sparc/parms.lisp:
o Define double-double-float-digits

compiler/sparc/type-vops.lisp:
o Define double-double-float type vop
o Adjust number hierarchy to include double-double-float

compiler/sparc/vm.lisp:
o Define the necessary storage class and storage base for the
  double-double-reg and double-double-stack.

lisp/gencgc.c:
o Tell GC about double-double-float objects.

lisp/purify.c:
o Tell purify about double-double-float objects.

code/class.lisp:
o Add the new double-double-float class.

code/exports.lisp:
o Add the necessary symbols to the various packages.  (This is
  important to get right otherwise there's confusion on what symbol
  really represents double-double-float stuff.)

code/float.lisp:
o Implement some of the necessary functions to support
  double-double-float.

code/hash-new.lisp:
o Hash double-double-floats by xor'ing the hashes of each double-float
  part.  (Is that good enough?)

code/irrat.lisp:
o Implement the special functions by calling the double-float versions
  and coercing the result to a double-double-float.  This is needed to
  get type-derivation working, but the precise value isn't that
  important right now.  We'll have to implement them later.

code/kernel.lisp:
o Make make-double-double-float, double-double-hi, and
  double-double-lo known functions.

code/lispinit.lisp:
o Register the :double-double float feature.

code/load.lisp:
o Add FOP for reading double-double-float values from fasls.  (Barely
  tested, if at all.)

code/numbers.lisp:
o Implement basic arithmetic operations for double-double-floats.
  This needs quite a bit of work to clean up, but most things work.

code/pred.lisp:
o Tell the type system about double-double-float type.

code/print.lisp:
o Add very rudimentary printing for double-double-float.  Basically
  copied from code written by Richard Fateman, with permission.

code/seq.lisp:
o Tell coerce how to coerce things to a double-double-float.

code/type.lisp:
o Tell type system about the new float format double-double-float and
  how numeric contagion works with double-double-float.

code/dump.lisp:
o Tell dumper how to dump double-double-float values to a fasl.

compiler/float-tran.lisp:
o Add appropriate deftransforms to handle conversion of things to
  double-double-float and from from double-double-float to other float
  types.
o The basic implmentation of double-double-float arithmetic is also
  here.
o Add deftransforms to tell the compiler how to do basic arithmetic
  and comparisions on double-double-float numbers.

compiler/srctran.lisp:
o Fix a bug in interval-range-info when :low is 0dd0 and :high is 0.
  We weren't returning the right value, which confuses interval-div,
  which caused an infinite loop because we couldn't split the
  numerator into positive and negative parts.
o Tell other parts about double-double-float.
parent 74c61171

code/class.lisp

+6 −1
Original line number Diff line number Diff line
@@ -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/code/class.lisp,v 1.58 2004/10/12 16:53:53 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.58.8.1 2006/06/09 16:04:56 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -844,6 +844,11 @@ 
	   :translation long-float

	   :inherits (float real number generic-number)

	   :codes (#.vm:long-float-type))

	  #+double-double

	  (double-double-float

	   :translation double-double-float

	   :inherits (float real number generic-number)

	   :codes (#.vm::double-double-float-type))

	  (rational

	   :translation rational

	   :inherits (real number generic-number))

code/exports.lisp

+30 −6
Original line number Diff line number Diff line
@@ -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/code/exports.lisp,v 1.251 2006/02/07 01:16:27 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.251.2.1 2006/06/09 16:04:56 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -887,7 +887,9 @@ 
(dolist

    (name

     '("%SP-SET-DEFINITION" "%SP-SET-PLIST" "ARRAY-HEADER-P" "BASE-CHAR-P"

       "DOUBLE-FLOAT-P" "LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P"))

       "DOUBLE-FLOAT-P" "LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P"

       "DOUBLE-DOUBLE-FLOAT-P"

       "DOUBLE-DOUBLE-FLOAT"))

  (intern name "KERNEL"))



(defpackage #+pmax "PMAX"
@@ -1092,7 +1094,16 @@ 
  #+heap-overflow-check

  (:export "DYNAMIC-SPACE-OVERFLOW-ERROR-TRAP"

	   "DYNAMIC-SPACE-OVERFLOW-WARNING-TRAP")

  )

  ;;#+double-double

  (:export "DOUBLE-DOUBLE-FLOAT-TYPE"

	   "DOUBLE-DOUBLE-FLOAT-HI-SLOT"

	   "DOUBLE-DOUBLE-FLOAT-LO-SLOT"

	   "DOUBLE-DOUBLE-FLOAT-FILLER-SLOT"

	   "DOUBLE-DOUBLE-FLOAT-SIZE"

	   "DOUBLE-DOUBLE-REG-SC-NUMBER"

	   "DOUBLE-DOUBLE-STACK-SC-NUMBER"

	   "DOUBLE-DOUBLE-FLOAT-DIGITS"

	   ))



(defpackage "CONDITIONS")

(intern "DISASSEMBLE" "LISP")
@@ -1186,6 +1197,8 @@ 
  (:import-from "LISP" "GET-SETF-METHOD")

  (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*")

  (:import-from "SYSTEM" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P"  "BINARY-TEXT-STREAM")

  #+double-double

  (:import-from "KERNEL" "DOUBLE-DOUBLE-FLOAT")

  (:export   "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*"

	     "DEBUG"

	     "FLOATING-POINT-INEXACT" "FLOAT-ACCURACY"
@@ -1362,7 +1375,9 @@ 


	     "BINARY-TEXT-STREAM" "READ-VECTOR" "WRITE-VECTOR"



	     "INVALID-FASL"))

	     "INVALID-FASL")

  #+nil

  (:export "DOUBLE-DOUBLE-FLOAT"))



(defpackage "STREAM"

  (:import-from "SYSTEM" "LISP-STREAM")
@@ -1739,7 +1754,8 @@ 
(dolist

    (name

     '("*" "ARRAY" "BOOLEAN" "DOUBLE-FLOAT" "FUNCTION" "INTEGER" "LONG-FLOAT"

       "SINGLE-FLOAT" "UNION" "VALUES"))

       "SINGLE-FLOAT" "UNION" "VALUES"

       ))

  (intern name "LISP"))



(defpackage "ALIEN"
@@ -2158,7 +2174,15 @@ 
           "SET-SYMBOL-VALUE-CONDITIONAL"

           "ATOMIC-POP-SYMBOL-VALUE"

           "ATOMIC-PUSHA"

           "ATOMIC-PUSHD"))

           "ATOMIC-PUSHD")

  ;;#+double-double

  (:export "DOUBLE-DOUBLE-FLOAT"

	   "DOUBLE-DOUBLE-FLOAT-P"

	   "DOUBLE-DOUBLE-HI"

	   "DOUBLE-DOUBLE-LO"

	   "MAKE-DOUBLE-DOUBLE-FLOAT"

	   "%DOUBLE-DOUBLE-FLOAT"

	   "OBJECT-NOT-DOUBLE-DOUBLE-FLOAT-ERROR"))



(dolist

    (name

code/float.lisp

+61 −15
Original line number Diff line number Diff line
@@ -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/code/float.lisp,v 1.31 2005/08/25 21:25:09 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.31.4.1 2006/06/09 16:04:57 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -240,7 +240,8 @@ 
     (and (zerop (ldb vm:long-float-exponent-byte (long-float-exp-bits x)))

	  (not (zerop x))))))



(macrolet ((frob (name doc single double #+(and long-float x86) long)

(macrolet ((frob (name doc single double #+(and long-float x86) long

		       #+double-double double-double)

	     `(defun ,name (x)

		,doc

		(number-dispatch ((x float))
@@ -264,7 +265,10 @@ 
		     (declare (ignorable lo))

		     (and (> (ldb vm:long-float-exponent-byte exp)

			     vm:long-float-normal-exponent-max)

			  ,long)))))))

			  ,long)))

		  #+double-double

		  ((double-double-float)

		   ,double-double)))))



  (frob float-infinity-p "Return true if the float X is an infinity (+ or -)."

    (zerop (ldb vm:single-float-significand-byte bits))
@@ -272,7 +276,9 @@ 
	 (zerop lo))

    #+(and long-float x86)

    (and (zerop (ldb vm:long-float-significand-byte hi))

	 (zerop lo)))

	 (zerop lo))

    #+double-double

    (float-infinity-p (double-double-hi x)))



  (frob float-nan-p "Return true if the float X is a NaN (Not a Number)."

    (not (zerop (ldb vm:single-float-significand-byte bits)))
@@ -280,7 +286,9 @@ 
	(not (zerop lo)))

    #+(and long-float x86)

    (or (not (zerop (ldb vm:long-float-significand-byte hi)))

	(not (zerop lo))))

	(not (zerop lo)))

    #+double-double

    (float-nan-p (double-double-hi x)))



  (frob float-trapping-nan-p

    "Return true if the float X is a trapping NaN (Not a Number)."
@@ -290,7 +298,9 @@ 
		   vm:double-float-trapping-nan-bit))

    #+(and long-float x86)

    (zerop (logand (ldb vm:long-float-significand-byte hi)

		   vm:long-float-trapping-nan-bit))))

		   vm:long-float-trapping-nan-bit))

    #+double-double

    (float-trapping-nan-p (double-double-hi x))))





;;; FLOAT-PRECISION  --  Public
@@ -335,7 +345,9 @@ 
	   (single-float (minusp (single-float-bits float1)))

	   (double-float (minusp (double-float-high-bits float1)))

	   #+long-float

	   (long-float (minusp (long-float-exp-bits float1))))

	   (long-float (minusp (long-float-exp-bits float1)))

	   #+double-double

	   (double-double-float (minusp (double-double-hi float1))))

	 (float -1 float1)

	 (float 1 float1))

     (abs float2)))
@@ -345,7 +357,9 @@ 
    ((short-float single-float) vm:single-float-digits)

    ((double-float #-long-float long-float) vm:double-float-digits)

    #+long-float

    (long-float vm:long-float-digits)))

    (long-float vm:long-float-digits)

    #+double-double

    (double-double-float vm:double-double-float-digits)))



(declaim (inline float-digits float-radix))
@@ -357,7 +371,9 @@ 
    ((single-float) vm:single-float-digits)

    ((double-float) vm:double-float-digits)

    #+long-float

    ((long-float) vm:long-float-digits)))

    ((long-float) vm:long-float-digits)

    #+double-double

    ((double-double-float) vm:double-double-float-digits)))



(defun float-radix (f)

  "Returns (as an integer) the radix b of its floating-point
@@ -515,6 +531,17 @@ 
		  (truly-the fixnum (- biased extra-bias))

		  sign)))))



#+double-double

(defun integer-decode-double-double-float (x)

  (declare (type double-double-float x))

  (multiple-value-bind (hi-int hi-exp sign)

      (integer-decode-float (double-double-hi x))

    (multiple-value-bind (lo-int lo-exp)

	(integer-decode-float (double-double-lo x))

      (values (+ lo-int

		 (ash hi-int (- hi-exp lo-exp)))

	      lo-exp

	      sign))))



;;; INTEGER-DECODE-LONG-FLOAT  --  Internal

;;;
@@ -557,7 +584,10 @@ 
     (integer-decode-double-float x))

    #+long-float

    ((long-float)

     (integer-decode-long-float x))))

     (integer-decode-long-float x))

    #+double-double

    ((double-double-float)

     (integer-decode-double-double-float x))))





(declaim (maybe-inline decode-single-float decode-double-float))
@@ -846,8 +876,10 @@ 
  result is the same float format as OTHER."

  (if otherp

      (number-dispatch ((number real) (other float))

	(((foreach rational single-float double-float #+long-float long-float)

	  (foreach single-float double-float #+long-float long-float))

	(((foreach rational single-float double-float #+long-float long-float

		   #+double-double double-double-float)

	  (foreach single-float double-float #+long-float long-float

		   #+double-double double-double-float))

	 (coerce number '(dispatch-type other))))

      (if (floatp number)

	  number
@@ -860,6 +892,9 @@ 
		  (((foreach single-float double-float #+long-float long-float

			     fixnum))

		   (coerce x ',type))

		  #+double-double

		  ((double-double-float)

		   (kernel:double-double-hi x))

		  ((bignum)

		   (bignum-to-float x ',type))

		  ((ratio)
@@ -867,7 +902,9 @@ 
  (frob %single-float single-float)

  (frob %double-float double-float)

  #+long-float

  (frob %long-float long-float))

  (frob %long-float long-float)

  #+double-double

  (frob %double-double-float double-double-float))





;;; FLOAT-RATIO  --  Internal
@@ -1030,7 +1067,15 @@ rounding modes & do ieee round-to-integer. 
	   (let ((res (ash bits exp)))

	     (if (minusp number)

		 (- res)

		 res)))))))

		 res)))))

    #+double-double

    ((double-double-float)

     (multiple-value-bind (bits exp)

	 (integer-decode-double-double-float number)

       (let ((res (ash bits exp)))

	 (if (minusp number)

	     (- res)

	     res))))))





;;; %UNARY-ROUND  --  Interface
@@ -1188,7 +1233,8 @@ rounding modes & do ieee round-to-integer. 
  more efficient than RATIONALIZE, but it assumes that floating-point is

  completely accurate, giving a result that isn't as pretty."

  (number-dispatch ((x real))

    (((foreach single-float double-float #+long-float long-float))

    (((foreach single-float double-float #+long-float long-float

	       #+double-double double-double-float))

     (multiple-value-bind (bits exp)

			  (integer-decode-float x)

       (if (eql bits 0)

code/hash-new.lisp

+6 −1
Original line number Diff line number Diff line
@@ -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/code/hash-new.lisp,v 1.36 2005/10/21 13:09:38 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.36.2.1 2006/06/09 16:04:57 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -973,6 +973,11 @@ 
		       (ash hi (- sxmash-rotate-bits)) hi

		       (ldb sxhash-bits-byte

			    (logxor (ash exp (- sxmash-rotate-bits)) exp))))))

       #+double-double

       (double-double-float

	;; Is this good enough?

	(logxor (internal-sxhash (kernel:double-double-hi s-expr) depth)

		(internal-sxhash (kernel:double-double-lo s-expr) depth)))

       (ratio (logxor (internal-sxhash (numerator s-expr) 0)

		      (internal-sxhash (denominator s-expr) 0)))

       (complex (logxor (internal-sxhash (realpart s-expr) 0)

code/irrat.lisp

+49 −5
Original line number Diff line number Diff line
@@ -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/code/irrat.lisp,v 1.45 2006/05/15 23:56:11 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.45.2.1 2006/06/09 16:04:57 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -46,7 +46,13 @@ 
  `((((foreach fixnum single-float bignum ratio))

     (coerce (,function (coerce ,var 'double-float)) 'single-float))

    ((double-float)

     (,function ,var))))

     (,function ,var))

    #+double-double

    ((double-double-float)

     ;; A hack until we write double-double-float versions of these

     ;; special functions.

     (kernel:make-double-double-float (,function (kernel:double-double-hi ,var))

				      0d0))))



); eval-when (compile load eval)
@@ -481,6 +487,15 @@ 
	     (complex (log (- number)) (coerce pi '(dispatch-type number)))

	     (coerce (%log (coerce number 'double-float))

		     '(dispatch-type number))))

	#+double-double

	((double-double-float)

	 ;; Hack!

	 (let ((hi (kernel:double-double-hi number)))

	   (if (< (float-sign hi)

		  (coerce 0 '(dispatch-type number)))

	       (complex (coerce (log (- hi)) 'kernel:double-double-float)

			(coerce pi '(dispatch-type number)))

	       (coerce (%log hi) '(dispatch-type number)))))

	((complex)

	 (complex-log number)))))
@@ -496,6 +511,11 @@ 
	 (complex-sqrt number)

	 (coerce (%sqrt (coerce number 'double-float))

		 '(dispatch-type number))))

    #+double-double

    ((double-double-float)

     (multiple-value-bind (hi lo)

	 (c::sqrt-dd (kernel:double-double-hi number) (kernel:double-double-lo number))

       (kernel:make-double-double-float hi lo)))

    ((complex)

     (complex-sqrt number))))
@@ -507,6 +527,22 @@ 
  (number-dispatch ((number number))

    (((foreach single-float double-float fixnum rational))

     (abs number))

    #+(and nil double-double)

    ((double-double-float)

     ;; This is a hack until abs deftransform is working

     (multiple-value-bind (hi lo)

	 (c::abs-dd (kernel:double-double-hi number) (kernel:double-double-lo number))

       (kernel:make-double-double-float hi lo)))

    #+double-double

    ((double-double-float)

     ;; This is a hack until abs deftransform is working

     (let ((hi (kernel:double-double-hi number))

	   (lo (kernel:double-double-lo number)))

       (declare (double-float hi lo))

       (when (minusp hi)

	 (setf hi (- hi))

	 (setf lo (- lo)))

       (kernel:make-double-double-float hi lo)))

    ((complex)

     (let ((rx (realpart number))

	   (ix (imagpart number)))
@@ -518,7 +554,10 @@ 
			  (coerce ix 'double-float))

		  'single-float))

	 (double-float

	  (%hypot rx ix)))))))

	  (%hypot rx ix))

	 #+double-double

	 (double-double-float

	  (error "abs complex double-double-float not implemented!")))))))



(defun phase (number)

  "Returns the angle part of the polar representation of a complex number.
@@ -538,6 +577,11 @@ 
     (if (minusp (float-sign number))

	 (coerce pi 'double-float)

	 0.0d0))

    #+double-double

    (double-double-float

     (if (minusp (float-sign number))

	 (coerce pi 'double-double-float)

	 (kernel:make-double-double-float 0d0 0d0)))

    (complex

     (atan (imagpart number) (realpart number)))))