diff --git a/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp b/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..feb611059929ece9aae5b477ff6dc361d7dc0978 --- /dev/null +++ b/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp @@ -0,0 +1,245 @@ +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "PPC" "OLD-PPC") +(setf (c:backend-name c:*native-backend*) "OLD-PPC") + +(c::new-backend "PPC" + ;; Features to add here + '(:ppc + :new-assembler + :conservative-float-type + :hash-new + :random-mt19937 + :darwin :bsd + :cmu :cmu19 :cmu19c + :relative-package-names ; Relative package names from Allegro + :linkage-table + :modular-arith + :double-double ; Double-double float support + :gencgc ; Generational gc + ) + ;; Features to remove from current *features* here + '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro + :propagate-fun-type :propagate-float-type :constrain-float-type + :openbsd :freebsd :glibc2 :linux :pentium :elf :mp + :stack-checking :heap-overflow-check + :cgc :long-float :new-random :small)) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + (concatenate 'string "_" name)) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Things needed to cross-compile double-double changes. +(in-package "KERNEL") + +(eval-when (compile load eval) +(c:defknown double-double-float-p (t) + boolean + (c:movable c:foldable c:flushable)) +) + +(eval-when (compile load eval) + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant type-test-ordering + '(fixnum single-float double-float integer #+long-float long-float + double-double-float bignum + complex ratio)) + )) + +(eval-when (compile load eval) + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant float-formats + '(double-double-float long-float double-float single-float short-float)))) + +(in-package "LISP") +(define-fop (fop-double-double-float 67) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let ((hi-lo (fast-read-u-integer 4)) + (hi-hi (fast-read-s-integer 4)) + (lo-lo (fast-read-u-integer 4)) + (lo-hi (fast-read-s-integer 4))) + (kernel::make-double-double-float + (make-double-float hi-hi hi-lo) + (make-double-float lo-hi lo-lo))) + (done-with-fast-read-byte)))) +;; End changes for double-double +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:ppc/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/ppc/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm))))) + syms)))) + (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS + #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-PPC:SIMPLE-BIT-VECTOR-TYPE + OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE + OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET + )) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + (concatenate 'string "_" name)) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. + +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-ppc::any-reg ht) + (gethash 'ppc::any-reg ht))) + +;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is +;; available in both the OLD-PPC and new PPC package. (I don't know +;; why this is needed, but it seems to be.) +(let ((ht (c::backend-template-names c::*target-backend*))) + (dolist (syms '((old-ppc::move-double-to-int-arg + ppc::move-double-to-int-arg) + (old-ppc::move-single-to-int-arg + ppc::move-single-to-int-arg))) + (destructuring-bind (old new) + syms + (setf (gethash old + ht) + (gethash new ht))))) diff --git a/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp b/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7285f3eff88382b2594402684bf3774a01424290 --- /dev/null +++ b/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp @@ -0,0 +1,280 @@ +;;;; This is the cross-compile script for adding the +;;;; double-double-float type for sparc. +;;;; +;;;; Use the standard src/tools/cross-build-world.sh script with this +;;;; cross-compile script to generate a double-double-float build. +;;;; Something like +;;;; +;;;; src/tools/cross-build-world.sh xtarget xcross <this-file> <19c binary> +;;;; +;;;; Once that has been done, you still need to do a full set of +;;;; builds to get one with double-double-float integrated in. Use +;;;; the boot-2006-06-1.lisp bootstrap file for that. Something like: +;;;; +;;;; src/tools/build.sh -C "sun4_solaris_sunc" -o "xtarget/lisp/lisp -noinit" +;;;; + +(in-package :cl-user) + +;;; Rename the SPARC package and backend so that new-backend does the +;;; right thing. +(rename-package "SPARC" "OLD-SPARC") +(setf (c:backend-name c:*native-backend*) "OLD-SPARC") + +(c::new-backend "SPARC" + ;; Features to add here + '(:sparc + :sparc-v9 ; For Ultrasparc processors + :complex-fp-vops ; Some slightly faster FP vops on complex numbers + :linkage-table + :stack-checking ; Throw error if we run out of stack + :heap-overflow-check ; Throw error if we run out of heap + :gencgc ; Generational GC + :relative-package-names ; Relative package names from Allegro + :conservative-float-type + :hash-new + :random-mt19937 ; MT-19937 generator + :cmu ; Announce this is CMUCL + :cmu19 :cmu19c ; Current version identifier + :modular-arith ; Modular arithmetic + :double-double ; Add double-double-float support. + ) + ;; Features to remove from current *features* here + '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 + ;; Other architectures we aren't using. + :x86 :x86-bootstrap + :alpha :osf1 :mips + ;; Really old stuff that should have been removed long ago. + :propagate-fun-type :propagate-float-type :constrain-float-type + ;; Other OSes were not using + :openbsd :freebsd :glibc2 :linux + :pentium + :long-float + :new-random + :small)) + +;;; May need to add some symbols to *features* and +;;; sys::*runtime-features* as well. This might be needed even if we +;;; have those listed above, because of the code checks for things in +;;; *features* and not in the backend-features.. So do that here. + + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +;; When compiling the compiler, vm:fixup-code-object and +;; vm:sanctify-for-execution are undefined. Import these to get rid +;; of that error. +(import 'old-sparc::fixup-code-object) +(import 'old-sparc::sanctify-for-execution) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Things needed to cross-compile double-double changes. +(in-package "KERNEL") + +(eval-when (compile load eval) +(c:defknown double-double-float-p (t) + boolean + (c:movable c:foldable c:flushable)) +) + +(eval-when (compile load eval) + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant type-test-ordering + '(fixnum single-float double-float integer #+long-float long-float + double-double-float bignum + complex ratio)) + )) + +(eval-when (compile load eval) + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant float-formats + '(double-double-float long-float double-float single-float short-float)))) + +(in-package "LISP") +(define-fop (fop-double-double-float 67) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let ((hi-lo (fast-read-u-integer 4)) + (hi-hi (fast-read-s-integer 4)) + (lo-lo (fast-read-u-integer 4)) + (lo-hi (fast-read-s-integer 4))) + (kernel::make-double-double-float + (make-double-float hi-hi hi-lo) + (make-double-float lo-hi lo-lo))) + (done-with-fast-read-byte)))) + +;; End changes for double-double +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package :cl-user) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:sparc/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/sparc/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm))))) + syms)))) + (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS + OLD-SPARC:LOWTAG-BITS + #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE + OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE + OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET + OLD-SPARC:DOUBLE-FLOAT-DIGITS + old-sparc:single-float-digits + )) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; Sometimes during cross-compile sparc::any-reg isn't defined during +;; cross-compile. +;; +;; hack, hack, hack: Make old-sparc::any-reg the same as +;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg +;; to the hash table with the same value as sparc::any-reg. +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-sparc::any-reg ht) + (gethash 'sparc::any-reg ht))) diff --git a/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp b/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ebf334427202a4229844448c75fea38239946460 --- /dev/null +++ b/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp @@ -0,0 +1,223 @@ +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "X86" "OLD-X86") +(setf (c:backend-name c:*native-backend*) "OLD-X86") + +(c::new-backend "X86" + ;; Features to add here + '(:x86 :i486 :pentium + :stack-checking + :heap-overflow-check + :relative-package-names + :mp + :gencgc + :conservative-float-type + :hash-new :random-mt19937 + :linux :glibc2 :glibc2.1 + :cmu :cmu19 :cmu19c + :double-double ; double-double-float + ) + ;; Features to remove from current *features* here + '(:x86-bootstrap :alpha :osf1 :mips + :propagate-fun-type :propagate-float-type :constrain-float-type + :openbsd :freebsd :glibc2 :linux + :long-float :new-random :small)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Things needed to cross-compile double-double changes. +(in-package "KERNEL") + +(eval-when (compile load eval) +(c:defknown double-double-float-p (t) + boolean + (c:movable c:foldable c:flushable)) +) + +(eval-when (compile load eval) + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant type-test-ordering + '(fixnum single-float double-float integer #+long-float long-float + double-double-float bignum + complex ratio)) + )) + +(eval-when (compile load eval) + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant float-formats + '(double-double-float long-float double-float single-float short-float)))) + +(in-package "LISP") +(define-fop (fop-double-double-float 67) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let ((hi-lo (fast-read-u-integer 4)) + (hi-hi (fast-read-s-integer 4)) + (lo-lo (fast-read-u-integer 4)) + (lo-hi (fast-read-s-integer 4))) + (kernel::make-double-double-float + (make-double-float hi-hi hi-lo) + (make-double-float lo-hi lo-lo))) + (done-with-fast-read-byte)))) + +;; End changes for double-double +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package :cl-user) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:x86/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/x86/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm))))) + syms)))) + (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS + #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-X86:SIMPLE-BIT-VECTOR-TYPE + OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE + OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET + )) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-x86::any-reg ht) + (gethash 'x86::any-reg ht))) diff --git a/bootfiles/19c/boot-2006-06-1.lisp b/bootfiles/19c/boot-2006-06-1.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e1bf88461948383072dc6bc7d28d100b3d1d7a48 --- /dev/null +++ b/bootfiles/19c/boot-2006-06-1.lisp @@ -0,0 +1,47 @@ +;;;; Bootstrap file for doing a full build from a cross-compile for +;;;; double-double-float support. This needs to be done using the +;;;; build from the cross-compile for double-double-float. See +;;;; boot-2006-06-1-cross-dd-sparc.lisp for more info. +(in-package :cl-user) +(pushnew :double-double *features*) +(setf lisp::*enable-package-locked-errors* nil) + +;;; This is a hack. I need make-double-double-float, +;;; double-double-hi, double-double-lo, and %double-double-float to +;;; work. For some reason, the cross-compile makes these known +;;; functions be infinite loops, but if we compile them here and setf +;;; fdefinition we get workingness. +(defun %foo (x y) + (declare (double-float x y)) + (kernel:%make-double-double-float x y)) +(compile '%foo) + + + +(defun foo-hi (x) + (declare (type kernel:double-double-float x)) + (kernel:double-double-hi x)) +(compile 'foo-hi) +(defun foo-lo (x) + (declare (type kernel:double-double-float x)) + (kernel:double-double-lo x)) +(compile 'foo-lo) +(defun %coerce-foo (x) + (if (typep x 'kernel:double-double-float) + x + (kernel:make-double-double-float (float x 1d0) 0d0))) +(compile '%foo) + +(setf (fdefinition 'kernel::%make-double-double-float) #'%foo) +(setf (fdefinition 'kernel::double-double-hi) #'foo-hi) +(setf (fdefinition 'kernel::double-double-lo) #'foo-lo) +(setf (fdefinition 'kernel::%double-double-float) #'%coerce-foo) + +(in-package "KERNEL") +(defun make-double-double-float (hi lo) + ;; Make sure the parts make sense for a double-double + (if (or (float-infinity-p hi) (float-nan-p hi)) + (%make-double-double-float hi lo) + (multiple-value-bind (s e) + (c::two-sum hi lo) + (%make-double-double-float s e)))) diff --git a/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp b/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ee31b24d530c79ebafcb66f2ce3f0ff244f5b782 --- /dev/null +++ b/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp @@ -0,0 +1,277 @@ +;;; +;;; Cross-compile script to add (simple-array double-double-float (*)). +;;; +;;; Use the standard cross-build-world.sh with this file to +;;; cross-compile. For this to work, you need a binary that already +;;; has double-double-float support, including reader support. (A +;;; build from the double-double-reader-branch will do nicely.) Then +;;; do a normal full build using the cross-compiled build to get a +;;; binary with support for 1D simple arrays of double-double-float. + +(in-package :cl-user) + +;;; Rename the PPC package and backend so that new-backend does the +;;; right thing. +(rename-package "PPC" "OLD-PPC") +(setf (c:backend-name c:*native-backend*) "OLD-PPC") + +(c::new-backend "PPC" + ;; Features to add here + '(:ppc + :new-assembler + :conservative-float-type + :hash-new + :random-mt19937 + :darwin :bsd + :cmu :cmu19 :cmu19c + :relative-package-names ; Relative package names from Allegro + :linkage-table + :modular-arith + :double-double ; Double-double float support + :gencgc ; Generational gc + ) + ;; Features to remove from current *features* here + '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro + :propagate-fun-type :propagate-float-type :constrain-float-type + :openbsd :freebsd :glibc2 :linux :pentium :elf :mp + :stack-checking :heap-overflow-check + :cgc :long-float :new-random :small)) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + (concatenate 'string "_" name)) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Things needed to cross-compile double-double changes. +(in-package "C") + +(eval-when (compile load eval) +(defknown simple-array-double-double-float-p (t) + boolean + (movable foldable flushable)) +(defknown complex-double-double-float-p (t) + boolean + (movable foldable flushable)) +(defknown simple-array-complex-double-double-float-p (t) + boolean + (movable foldable flushable)) +) + +(in-package "LISP") +(define-fop (fop-double-double-float-vector 88) + (let* ((length (read-arg 4)) + (result (make-array length :element-type 'double-double-float))) + (read-n-bytes *fasl-file* result 0 (* length 4 4)) + result)) + +(define-fop (fop-complex-double-double-float 89) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let* ((real-hi-lo (fast-read-u-integer 4)) + (real-hi-hi (fast-read-s-integer 4)) + (real-lo-lo (fast-read-u-integer 4)) + (real-lo-hi (fast-read-s-integer 4)) + (re (kernel::make-double-double-float + (make-double-float real-hi-hi real-hi-lo) + (make-double-float real-lo-hi real-lo-lo))) + (imag-hi-lo (fast-read-u-integer 4)) + (imag-hi-hi (fast-read-s-integer 4)) + (imag-lo-lo (fast-read-u-integer 4)) + (imag-lo-hi (fast-read-s-integer 4)) + (im (kernel::make-double-double-float + (make-double-float imag-hi-hi imag-hi-lo) + (make-double-float imag-lo-hi imag-lo-lo)))) + (complex re im)) + (done-with-fast-read-byte)))) + +(define-fop (fop-complex-double-double-float-vector 90) + (let* ((length (read-arg 4)) + (result (make-array length :element-type '(complex double-double-float)))) + (read-n-bytes *fasl-file* result 0 (* length 4 8)) + result)) + + +;; End changes for double-double +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package "CL-USER") + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:ppc/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/ppc/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm))))) + syms)))) + (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS + #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-PPC:SIMPLE-BIT-VECTOR-TYPE + OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE + OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET + OLD-PPC:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-PPC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-PPC:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-PPC:SINGLE-FLOAT-EXPONENT-BYTE + OLD-PPC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-PPC:SINGLE-FLOAT-SIGNIFICAND-BYTE + )) + +;; Modular arith hacks +(setf (fdefinition 'vm::ash-left-mod32) #'old-ppc::ash-left-mod32) +(setf (fdefinition 'vm::lognot-mod32) #'old-ppc::lognot-mod32) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + (concatenate 'string "_" name)) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. + +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-ppc::any-reg ht) + (gethash 'ppc::any-reg ht))) + +;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is +;; available in both the OLD-PPC and new PPC package. (I don't know +;; why this is needed, but it seems to be.) +(let ((ht (c::backend-template-names c::*target-backend*))) + (dolist (syms '((old-ppc::move-double-to-int-arg + ppc::move-double-to-int-arg) + (old-ppc::move-single-to-int-arg + ppc::move-single-to-int-arg))) + (destructuring-bind (old new) + syms + (setf (gethash old + ht) + (gethash new ht))))) diff --git a/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp b/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7280567834dc11cb40272db8994d910a7371e183 --- /dev/null +++ b/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp @@ -0,0 +1,307 @@ +;;;; This is the cross-compile script for adding the (complex +;;;; double-double-float), (simple-array double-double-float (*)), and +;;;; (simple-array (complex double-double-float) (*)) types for sparc. +;;;; +;;;; Use the standard src/tools/cross-build-world.sh script with this +;;;; cross-compile script to generate a double-double-float build. +;;;; Something like +;;;; +;;;; src/tools/cross-build-world.sh xtarget xcross <this-file> <dd-reader> +;;;; +;;;; I think this has to be built using a version that has reader +;;;; support for double-double-float. I didn't try it any othe way. +;;;; +;;;; Once that has been done, you still need to do a full set of +;;;; builds to get these new types completely integrated in. Don't +;;;; need any special bootstrap files for this, so +;;;; +;;;; src/tools/build.sh -C "sun4_solaris_sunc" -o "xtarget/lisp/lisp -noinit" +;;;; + +(in-package :cl-user) + +;;; Rename the SPARC package and backend so that new-backend does the +;;; right thing. +(rename-package "SPARC" "OLD-SPARC") +(setf (c:backend-name c:*native-backend*) "OLD-SPARC") + +(c::new-backend "SPARC" + ;; Features to add here + '(:sparc + :sparc-v9 ; For Ultrasparc processors + :complex-fp-vops ; Some slightly faster FP vops on complex numbers + :linkage-table + :stack-checking ; Throw error if we run out of stack + :heap-overflow-check ; Throw error if we run out of heap + :gencgc ; Generational GC + :relative-package-names ; Relative package names from Allegro + :conservative-float-type + :hash-new + :random-mt19937 ; MT-19937 generator + :cmu ; Announce this is CMUCL + :cmu19 :cmu19c ; Current version identifier + :modular-arith ; Modular arithmetic + :double-double ; Add double-double-float support. + ) + ;; Features to remove from current *features* here + '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 + ;; Other architectures we aren't using. + :x86 :x86-bootstrap + :alpha :osf1 :mips + ;; Really old stuff that should have been removed long ago. + :propagate-fun-type :propagate-float-type :constrain-float-type + ;; Other OSes were not using + :openbsd :freebsd :glibc2 :linux + :pentium + :long-float + :new-random + :small)) + +;;; May need to add some symbols to *features* and +;;; sys::*runtime-features* as well. This might be needed even if we +;;; have those listed above, because of the code checks for things in +;;; *features* and not in the backend-features.. So do that here. + + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +;; When compiling the compiler, vm:fixup-code-object and +;; vm:sanctify-for-execution are undefined. Import these to get rid +;; of that error. +(import 'old-sparc::fixup-code-object) +(import 'old-sparc::sanctify-for-execution) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Things needed to cross-compile double-double changes. +(in-package "C") +(pushnew :double-double *features*) +(defknown simple-array-double-double-float-p (t) + boolean + (movable foldable flushable)) + +(defknown complex-double-double-float-p (t) + boolean + (movable foldable flushable)) + +(defknown simple-array-complex-double-double-float-p (t) + boolean + (movable foldable flushable)) + +(in-package "LISP") +#+double-double +(define-fop (fop-double-double-float-vector 88) + (let* ((length (read-arg 4)) + (result (make-array length :element-type 'double-double-float))) + (read-n-bytes *fasl-file* result 0 (* length 4 4)) + result)) + +#+double-double +(define-fop (fop-complex-double-double-float 89) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let* ((real-hi-lo (fast-read-u-integer 4)) + (real-hi-hi (fast-read-s-integer 4)) + (real-lo-lo (fast-read-u-integer 4)) + (real-lo-hi (fast-read-s-integer 4)) + (re (kernel::make-double-double-float + (make-double-float real-hi-hi real-hi-lo) + (make-double-float real-lo-hi real-lo-lo))) + (imag-hi-lo (fast-read-u-integer 4)) + (imag-hi-hi (fast-read-s-integer 4)) + (imag-lo-lo (fast-read-u-integer 4)) + (imag-lo-hi (fast-read-s-integer 4)) + (im (kernel::make-double-double-float + (make-double-float imag-hi-hi imag-hi-lo) + (make-double-float imag-lo-hi imag-lo-lo)))) + (complex re im)) + (done-with-fast-read-byte)))) + +#+double-double +(define-fop (fop-complex-double-double-float-vector 90) + (let* ((length (read-arg 4)) + (result (make-array length :element-type '(complex double-double-float)))) + (read-n-bytes *fasl-file* result 0 (* length 4 8)) + result)) + +;; End changes for double-double +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package :cl-user) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:sparc/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/sparc/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm))))) + syms)))) + (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS + OLD-SPARC:LOWTAG-BITS + #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + #+double-double OLD-SPARC:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE + OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE + OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET + OLD-SPARC:DOUBLE-FLOAT-DIGITS + old-sparc:single-float-digits + OLD-SPARC:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-SPARC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-SPARC:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-SPARC:SINGLE-FLOAT-EXPONENT-BYTE + OLD-SPARC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-SPARC:SINGLE-FLOAT-SIGNIFICAND-BYTE + )) + +;; Modular arith hacks +(setf (fdefinition 'vm::ash-left-mod32) #'old-sparc::ash-left-mod32) +(setf (fdefinition 'vm::lognot-mod32) #'old-sparc::lognot-mod32) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; Sometimes during cross-compile sparc::any-reg isn't defined during +;; cross-compile. +;; +;; hack, hack, hack: Make old-sparc::any-reg the same as +;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg +;; to the hash table with the same value as sparc::any-reg. +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-sparc::any-reg ht) + (gethash 'sparc::any-reg ht))) diff --git a/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp b/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp new file mode 100644 index 0000000000000000000000000000000000000000..faf219bea2d3cf56610be85c9293e9d4d80f904a --- /dev/null +++ b/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp @@ -0,0 +1,254 @@ +;;; Cross-compile script for adding (complex double-double-float), +;;; (simple-array double-double-float (*)) and (simple-array (complex +;;; double-double-float) (*)). +;;; +;;; Use this to cross-compile from a version that supports +;;; double-double-float type with reader support. Once this is done, +;;; do a full rebuild to get a version with support for these new +;;; types. + +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "X86" "OLD-X86") +(setf (c:backend-name c:*native-backend*) "OLD-X86") + +(c::new-backend "X86" + ;; Features to add here + '(:x86 :i486 :pentium + :stack-checking + :heap-overflow-check + :relative-package-names + :mp + :gencgc + :conservative-float-type + :hash-new :random-mt19937 + :linux :glibc2 :glibc2.1 + :cmu :cmu19 :cmu19c + :double-double ; double-double-float + ) + ;; Features to remove from current *features* here + '(:x86-bootstrap :alpha :osf1 :mips + :propagate-fun-type :propagate-float-type :constrain-float-type + :openbsd :freebsd :glibc2 :linux + :long-float :new-random :small)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Things needed to cross-compile double-double changes. +(in-package "C") + +(eval-when (compile load eval) +(defknown simple-array-double-double-float-p (t) + boolean + (movable foldable flushable)) +(defknown double-double-float-p (t) + boolean + (movable foldable flushable)) +(defknown complex-double-double-float-p (t) + boolean + (movable foldable flushable)) +(defknown simple-array-complex-double-double-float-p (t) + boolean + (movable foldable flushable)) +) + +(in-package "LISP") +(define-fop (fop-double-double-float-vector 88) + (let* ((length (read-arg 4)) + (result (make-array length :element-type 'double-double-float))) + (read-n-bytes *fasl-file* result 0 (* length 4 4)) + result)) + +(define-fop (fop-complex-double-double-float 89) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let* ((real-hi-lo (fast-read-u-integer 4)) + (real-hi-hi (fast-read-s-integer 4)) + (real-lo-lo (fast-read-u-integer 4)) + (real-lo-hi (fast-read-s-integer 4)) + (re (kernel::make-double-double-float + (make-double-float real-hi-hi real-hi-lo) + (make-double-float real-lo-hi real-lo-lo))) + (imag-hi-lo (fast-read-u-integer 4)) + (imag-hi-hi (fast-read-s-integer 4)) + (imag-lo-lo (fast-read-u-integer 4)) + (imag-lo-hi (fast-read-s-integer 4)) + (im (kernel::make-double-double-float + (make-double-float imag-hi-hi imag-hi-lo) + (make-double-float imag-lo-hi imag-lo-lo)))) + (complex re im)) + (done-with-fast-read-byte)))) + +(define-fop (fop-complex-double-double-float-vector 90) + (let* ((length (read-arg 4)) + (result (make-array length :element-type '(complex double-double-float)))) + (read-n-bytes *fasl-file* result 0 (* length 4 8)) + result)) + +;; End changes for double-double +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package :cl-user) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:x86/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/x86/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm))))) + syms)))) + (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS + #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-X86:SIMPLE-BIT-VECTOR-TYPE + OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE + OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET + OLD-X86:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-X86:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-X86:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-X86:SINGLE-FLOAT-EXPONENT-BYTE + OLD-X86:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-X86:SINGLE-FLOAT-SIGNIFICAND-BYTE + )) + +;; Modular arith hacks +(setf (fdefinition 'vm::ash-left-mod32) #'old-x86::ash-left-mod32) +(setf (fdefinition 'vm::lognot-mod32) #'old-x86::lognot-mod32) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-x86::any-reg ht) + (gethash 'x86::any-reg ht))) diff --git a/code/array.lisp b/code/array.lisp index 09077ad849a795dab55fab68c14f738cffcb231a..0ed77832899698f3ca92b4673b9fdd04399a61b2 100644 --- a/code/array.lisp +++ b/code/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/code/array.lisp,v 1.39 2005/04/13 11:59:23 pwerkowski Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.40 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -137,6 +137,9 @@ #+long-float (long-float (values #.vm:simple-array-long-float-type #+x86 96 #+sparc 128)) + #+double-double + (double-double-float + (values #.vm::simple-array-double-double-float-type 128)) ((complex single-float) (values #.vm:simple-array-complex-single-float-type 64)) ((complex double-float) @@ -144,6 +147,9 @@ #+long-float ((complex long-float) (values #.vm:simple-array-complex-long-float-type #+x86 192 #+sparc 256)) + #+double-double + ((complex double-double-float) + (values #.vm::simple-array-complex-double-double-float-type 256)) (t (values #.vm:simple-vector-type #.vm:word-bits)))) (defun %complex-vector-type-code (type) @@ -339,9 +345,11 @@ single-float double-float #+long-float long-float + #+double-double double-double-float (complex single-float) (complex double-float) - #+long-float (complex long-float))))) + #+long-float (complex long-float) + #+double-double (complex double-double-float))))) (defun data-vector-set (array index new-value) (with-array-data ((vector array) (index index) (end)) @@ -372,9 +380,11 @@ single-float double-float #+long-float long-float + #+double-double double-double-float (complex single-float) (complex double-float) - #+long-float (complex long-float))))) + #+long-float (complex long-float) + #+double-double (complex double-double-float))))) @@ -535,10 +545,14 @@ (vm:simple-array-double-float-type 'double-float) #+long-float (vm:simple-array-long-float-type 'long-float) + #+double-double + (vm::simple-array-double-double-float-type 'double-double-float) (vm:simple-array-complex-single-float-type '(complex single-float)) (vm:simple-array-complex-double-float-type '(complex double-float)) #+long-float (vm:simple-array-complex-long-float-type '(complex long-float)) + #+double-double + (vm::simple-array-complex-double-double-float-type '(complex double-double-float)) ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type) (with-array-data ((array array) (start) (end)) (declare (ignore start end)) @@ -864,13 +878,19 @@ ((simple-array double-float (*)) (coerce 0 'double-float)) #+long-float ((simple-array long-float (*)) (coerce 0 'long-float)) + #+double-double + ((simple-array double-double-float (*)) + (coerce 0 'double-double-float)) ((simple-array (complex single-float) (*)) (coerce 0 '(complex single-float))) ((simple-array (complex double-float) (*)) (coerce 0 '(complex double-float))) #+long-float ((simple-array (complex long-float) (*)) - (coerce 0 '(complex long-float)))))) + (coerce 0 '(complex long-float))) + #+double-double + ((simple-array (complex double-double-float) (*)) + (coerce 0 '(complex double-double-float)))))) ;; Only arrays have fill-pointers, but vectors have their length parameter ;; in the same place. (setf (%array-fill-pointer vector) new-size) diff --git a/code/bignum.lisp b/code/bignum.lisp index 4265486a135d69ec85c9095bded768ced39c4f6c..2519acc7a5ddc333d6e5188c4f356149541cd7f0 100644 --- a/code/bignum.lisp +++ b/code/bignum.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/code/bignum.lisp,v 1.40 2004/08/31 00:19:41 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.41 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1872,6 +1872,22 @@ down to individual words.") (%bignum-ref bits 2) (%bignum-ref bits 1))) +;;; +#+double-double +(defun double-double-from-bits (bits exp plusp) + (declare (fixnum exp) + (optimize (ext:inhibit-warnings 3))) + ;; Extract the 105 bits we want. The low 52 goes to the low + ;; double-float, and the remaining bits go to the high double-float. + ;; That's a total of 4 words. + (let* ((bits (ash bits -32)) + (lo (ldb (byte vm:double-float-digits 0) bits)) + (hi (ldb (byte vm:double-float-digits vm:double-float-digits) bits)) + (exp (- exp vm:double-float-bias))) + (kernel:make-double-double-float + (scale-float (float hi 1d0) (+ exp 53 -106)) + (scale-float (float lo 1d0) (- exp 106))))) + ;;; BIGNUM-TO-FLOAT -- Interface ;;; @@ -1918,6 +1934,13 @@ down to individual words.") bits (check-exponent len vm:long-float-bias vm:long-float-normal-exponent-max) + plusp)) + #+double-double + (double-double-float + (double-double-from-bits + bits + (check-exponent len vm:double-float-bias + vm:double-float-normal-exponent-max) plusp)))) (check-exponent (exp bias max) (declare (type bignum-index len)) diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp index ad8f58853230903472eb04a29b8ac10d524351a3..2c9d2b8b4f9a262e146835fd5b1b9da78aeaeeb0 100644 --- a/code/byte-interp.lisp +++ b/code/byte-interp.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/code/byte-interp.lisp,v 1.44 2003/08/27 16:09:11 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.45 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -408,7 +408,7 @@ ;;;; Inlines. (eval-when (compile eval) - (setq ext:*inline-expansion-limit* 100)) + (setq ext:*inline-expansion-limit* 400)) (defmacro expand-into-inlines () (declare (optimize (inhibit-warnings 3))) diff --git a/code/class.lisp b/code/class.lisp index 7c359b3fa0708187b33b9ce049a25be21090d57d..ea9e6fec875f5ed092a145fe8fc0d88ba099b604 100644 --- a/code/class.lisp +++ b/code/class.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/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.59 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -773,6 +773,14 @@ :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) + #+double-double + (simple-array-double-double-float + :translation (simple-array double-double-float (*)) + :codes (#.vm::simple-array-double-double-float-type) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence generic-vector + generic-array mutable-sequence mutable-collection + generic-sequence collection)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) :codes (#.vm:simple-array-complex-single-float-type) @@ -795,6 +803,14 @@ :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) + #+double-double + (simple-array-complex-double-double-float + :translation (simple-array (complex double-double-float) (*)) + :codes (#.vm::simple-array-complex-double-double-float-type) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence generic-vector + generic-array mutable-sequence mutable-collection + generic-sequence collection)) (generic-string :state :read-only :inherits (mutable-sequence mutable-collection generic-sequence @@ -829,6 +845,10 @@ :translation (complex long-float) :inherits (complex number generic-number) :codes (#.vm:complex-long-float-type)) + #+double-double + (complex-double-double-float + :translation (complex double-double-float) + :inherits (complex number generic-number)) (real :translation real :inherits (number generic-number)) (float :translation float :inherits (real number generic-number)) (single-float @@ -844,6 +864,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)) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 21dd47ecb82880bbbc301b4fa0a44b2558fcf5fd..40684cfcdbc23ec34469f60baf457d78894eb56b 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.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/code/debug-int.lisp,v 1.122 2006/01/23 14:11:02 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.123 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -3150,6 +3150,16 @@ The result is a symbol or nil if the routine cannot be found." #+long-float (#.vm:long-reg-sc-number (escaped-float-value long-float)) + #+double-double + (#.vm:double-double-reg-sc-number + (if escaped + (kernel:%make-double-double-float + (vm:sigcontext-float-register + escaped (c:sc-offset-offset sc-offset) 'double-float) + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) + 'double-float)) + :invalid-value-for-unescaped-register-storage)) (#.vm:complex-single-reg-sc-number (if escaped (complex @@ -3177,6 +3187,24 @@ The result is a symbol or nil if the routine cannot be found." escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4) 'long-float)) :invalid-value-for-unescaped-register-storage)) + #+double-double + (#.vm:complex-double-double-reg-sc-number + (if escaped + (complex + (kernel:%make-double-double-float + (vm:sigcontext-float-register + escaped (c:sc-offset-offset sc-offset) 'double-float) + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) + 'double-float)) + (kernel:%make-double-double-float + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4 #+sparc 1) + 'double-float) + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 6 #-sparc 3) + 'double-float))) + :invalid-value-for-unescaped-register-storage)) (#.vm:single-stack-sc-number (with-nfp (nfp) (system:sap-ref-single nfp (* (c:sc-offset-offset sc-offset) @@ -3190,6 +3218,15 @@ The result is a symbol or nil if the routine cannot be found." (with-nfp (nfp) (system:sap-ref-long nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))) + #+double-double + ((#.vm:double-double-stack-sc-number + (with-nfp (nfp) + (kernel:%make-double-double-float + (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) + vm:word-bytes)) + (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) + 2) + vm:word-bytes)))))) (#.vm:complex-single-stack-sc-number (with-nfp (nfp) (complex @@ -3307,6 +3344,16 @@ The result is a symbol or nil if the routine cannot be found." #+long-float (#.vm:long-reg-sc-number (escaped-float-value long-float)) + #+double-double + (#.vm:double-double-reg-sc-number + (if escaped + (kernel:%make-double-double-float + (vm:sigcontext-float-register + escaped (c:sc-offset-offset sc-offset) 'double-float) + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) 1) + 'double-float)) + :invalid-value-for-unescaped-register-storage)) (#.vm:complex-single-reg-sc-number (escaped-complex-float-value single-float)) (#.vm:complex-double-reg-sc-number @@ -3324,6 +3371,24 @@ The result is a symbol or nil if the routine cannot be found." (#.vm:long-stack-sc-number (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3) vm:word-bytes)))) + #+double-double + (#.vm:complex-double-double-reg-sc-number + (if escaped + (complex + (kernel:%make-double-double-float + (vm:sigcontext-float-register + escaped (c:sc-offset-offset sc-offset) 'double-float) + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) + 'double-float)) + (kernel:%make-double-double-float + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4 #+sparc 1) + 'double-float) + (vm:sigcontext-float-register + escaped (+ (c:sc-offset-offset sc-offset) #+sparc 6 #-sparc 3) + 'double-float))) + :invalid-value-for-unescaped-register-storage)) (#.vm:complex-single-stack-sc-number (complex (system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset)) @@ -3343,6 +3408,15 @@ The result is a symbol or nil if the routine cannot be found." vm:word-bytes))) (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 6) vm:word-bytes))))) + #+double-double + ((#.vm:double-double-stack-sc-number + (with-nfp (nfp) + (kernel:%make-double-double-float + (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) + vm:word-bytes)) + (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) + 2) + vm:word-bytes)))))) (#.vm:control-stack-sc-number (kernel:stack-ref fp (c:sc-offset-offset sc-offset))) (#.vm:base-char-stack-sc-number diff --git a/code/exports.lisp b/code/exports.lisp index f5538511f03698bf6c35b0ea20b7f59a24589a6f..11dc88423302004ee3b03386b944e1c26f272957 100644 --- a/code/exports.lisp +++ b/code/exports.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/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.252 2006/06/30 18:41:22 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,29 @@ #+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" + "SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE" + + "COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-FILLER-SLOT" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-REAL-HI-SLOT" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-REAL-LO-SLOT" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-IMAG-HI-SLOT" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-IMAG-LO-SLOT" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-SIZE" + "COMPLEX-DOUBLE-DOUBLE-REG-SC-NUMBER" + "COMPLEX-DOUBLE-DOUBLE-STACK-SC-NUMBER" + + "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE" + )) (defpackage "CONDITIONS") (intern "DISASSEMBLE" "LISP") @@ -1186,6 +1210,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 +1388,9 @@ "BINARY-TEXT-STREAM" "READ-VECTOR" "WRITE-VECTOR" - "INVALID-FASL")) + "INVALID-FASL") + #+double-double + (:export "DOUBLE-DOUBLE-FLOAT")) (defpackage "STREAM" (:import-from "SYSTEM" "LISP-STREAM") @@ -1739,7 +1767,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 +2187,23 @@ "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" + "%MAKE-DOUBLE-DOUBLE-FLOAT" + "%DOUBLE-DOUBLE-FLOAT" + "OBJECT-NOT-DOUBLE-DOUBLE-FLOAT-ERROR" + "SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-P" + "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-ERROR" + "COMPLEX-DOUBLE-DOUBLE-FLOAT-P" + "OBJECT-NOT-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR" + + "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P" + "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR")) (dolist (name diff --git a/code/float.lisp b/code/float.lisp index cfae17915e136297beee38e499b5c041237e7cdd..bcc5bb6a942ba49c48bebcf80e9ba9451d84cd7f 100644 --- a/code/float.lisp +++ b/code/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/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.32 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -80,6 +80,19 @@ (dpb (ash sig -32) vm:double-float-significand-byte (if (zerop sign) 0 -1))) (ldb (byte 32 0) sig))) + +#+double-double +(defun double-double-from-bits (sign exp sig) + (declare (type bit sign) (type (unsigned-byte #.vm:double-double-float-digits) sig) + (type (unsigned-byte 11) exp)) + (let ((lo (ldb (byte vm:double-float-digits 0) sig)) + (hi (ldb (byte vm:double-float-digits vm:double-float-digits) sig))) + ;; We can't return a double-double because exp might be very + ;; small, and the low part of the double-double would get scaled + ;; to 0. So we return both parts and expect the caller to figure + ;; out what to do. + (values (scale-float (float (* hi (- 1 (* 2 sign))) 1d0) #.(- vm:double-float-digits)) + (scale-float (float lo 1d0) #.(- vm:double-float-digits))))) ;;; #+(and long-float x86) (defun long-from-bits (sign exp sig) @@ -240,7 +253,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 +278,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 +289,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 +299,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 +311,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 +358,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 +370,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 +384,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 +544,21 @@ (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)) + (if (zerop (double-double-lo x)) + (values (ash hi-int 53) (- hi-exp 53) sign) + (multiple-value-bind (lo-int lo-exp lo-sign) + (integer-decode-float (double-double-lo x)) + ;; We have x = 2^e1*i1 + 2^e2*i2 + ;; = 2^e2*(2^(e1-e2)*i1 + i2) + (values (+ (* lo-sign lo-int) + (ash hi-int (- hi-exp lo-exp))) + lo-exp + sign))))) ;;; INTEGER-DECODE-LONG-FLOAT -- Internal ;;; @@ -557,7 +601,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)) @@ -685,6 +732,16 @@ lo) biased sign))))) +;;; DECODE-DOUBLE-DOUBLE-FLOAT -- Public +#+double-double +(defun decode-double-double-float (x) + (declare (type double-double-float x)) + (multiple-value-bind (hi-frac hi-exp sign) + (decode-float (double-double-hi x)) + (values (make-double-double-float hi-frac + (scale-float (double-double-lo x) (- hi-exp))) + hi-exp + (coerce sign 'double-double-float)))) ;;; DECODE-FLOAT -- Public ;;; @@ -703,7 +760,10 @@ (decode-double-float f)) #+long-float ((long-float) - (decode-long-float f)))) + (decode-long-float f)) + #+double-double + ((double-double-float) + (decode-double-double-float f)))) ;;;; SCALE-FLOAT: @@ -821,6 +881,14 @@ (declare (long-float x) (fixnum exp)) (scale-float x exp)) +#+double-double +(defun scale-double-double-float (x exp) + (declare (type double-double-float x) (fixnum exp)) + (let ((hi (double-double-hi x)) + (lo (double-double-lo x))) + (make-double-double-float (scale-double-float hi exp) + (scale-double-float lo exp)))) + ;;; SCALE-FLOAT -- Public ;;; ;;; Dispatch to the correct type-specific scale-float function. @@ -835,7 +903,10 @@ (scale-double-float f ex)) #+long-float ((long-float) - (scale-long-float f ex)))) + (scale-long-float f ex)) + #+double-double + ((double-double-float) + (scale-double-double-float f ex)))) ;;;; Converting to/from floats: @@ -846,8 +917,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 @@ -857,7 +930,9 @@ (macrolet ((frob (name type) `(defun ,name (x) (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 fixnum)) (coerce x ',type)) ((bignum) @@ -867,7 +942,9 @@ (frob %single-float single-float) (frob %double-float double-float) #+long-float - (frob %long-float long-float)) + (frob %long-float long-float) + #+(and nil double-double) + (frob %double-double-float double-double-float)) ;;; FLOAT-RATIO -- Internal @@ -908,9 +985,32 @@ (len (integer-length bits))) (cond ((> len digits) (assert (= len (the fixnum (1+ digits)))) - (scale-float (floatit (ash bits -1)) (1+ scale))) + (multiple-value-bind (f0 f1) + (floatit (ash bits -1)) + #|| + (format t "1: f0, f1 = ~A ~A~%" f0 f1) + (format t " scale = ~A~%" (1+ scale)) + ||# + (if f1 + (make-double-double-float + (scale-float f0 (1+ scale)) + (scale-float f1 (+ 1 scale #.(- vm:double-float-digits)))) + (scale-float f0 (1+ scale))))) (t - (scale-float (floatit bits) scale))))) + (multiple-value-bind (f0 f1) + (floatit bits) + #|| + (format t "2: f0, f1 = ~A ~A~%" f0 f1) + (format t " scale = ~A~%" scale) + (format t "scale-float f0 = ~A~%" (scale-float f0 scale)) + (when f1 + (format t "scale-float f1 = ~A~%" (scale-float f1 (- scale 53)))) + ||# + (if f1 + (make-double-double-float + (scale-float f0 scale) + (scale-float f1 (- scale #.vm:double-float-digits))) + (scale-float f0 scale))))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format @@ -920,7 +1020,10 @@ (double-from-bits sign vm:double-float-bias bits)) #+long-float (long-float - (long-from-bits sign vm:long-float-bias bits)))))) + (long-from-bits sign vm:long-float-bias bits)) + #+double-double + (double-double-float + (double-double-from-bits sign vm:double-float-bias bits)))))) (loop (multiple-value-bind (fraction-and-guard rem) (truncate shifted-num den) @@ -1030,7 +1133,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 @@ -1061,7 +1172,20 @@ rounding modes & do ieee round-to-integer. shifted))) (if (minusp number) (- rounded) - rounded))))))) + rounded))))) + #+double-double + ((double-double-float) + (multiple-value-bind (bits exp) + (integer-decode-float number) + (let* ((shifted (ash bits exp)) + (rounded (if (and (minusp exp) + (not (zerop (logand bits + (ash 1 (- -1 exp)))))) + (1+ shifted) + shifted))) + (if (minusp number) + (- rounded) + rounded)))))) (declaim (maybe-inline %unary-ftruncate/single-float %unary-ftruncate/double-float)) @@ -1156,6 +1280,11 @@ rounding modes & do ieee round-to-integer. (setf hi (logandc2 hi (- (ash 1 (- frac-bits 32)) 1))))) (kernel:make-double-float hi lo)))))) +#+double-double +(defun %unary-ftruncate/double-double-float (x) + ;; We should do something like what we do for double-double-float, + ;; but I'm lazy right now. + (coerce (truncate x) 'double-double-float)) ;;; %UNARY-FTRUNCATE -- Interface ;;; @@ -1179,7 +1308,10 @@ rounding modes & do ieee round-to-integer. ((single-float) (%unary-ftruncate/single-float number)) ((double-float) - (%unary-ftruncate/double-float number)))) + (%unary-ftruncate/double-float number)) + #+double-double + ((double-double-float) + (%unary-ftruncate/double-double-float number)))) @@ -1188,7 +1320,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) diff --git a/code/format.lisp b/code/format.lisp index 7dc8887f4c3673b0af337951366c97177174be35..4716c9c9db6cfa674d2681b4f8fd58f498ded4f8 100644 --- a/code/format.lisp +++ b/code/format.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/code/format.lisp,v 1.69 2006/05/01 16:10:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.70 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1189,7 +1189,9 @@ (single-float #\f) (double-float #\d) (short-float #\s) - (long-float #\l)))) + (long-float #\l) + #+double-double + (double-double-float #\w)))) ;;;Here we prevent the scale factor from shifting all significance out of ;;;a number to the right. We allow insignificant zeroes to be shifted in diff --git a/code/hash-new.lisp b/code/hash-new.lisp index fcd27df77dfa07ff31b1f13efd01d588b49e87c8..4071dbe57090fdc9b610b55e9f9326883b3282fa 100644 --- a/code/hash-new.lisp +++ b/code/hash-new.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/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.37 2006/06/30 18:41:22 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) diff --git a/code/interr.lisp b/code/interr.lisp index 1af99126c194cbb1900e8b80074aa4b1eadc8c2a..19981ead3fb5aa93827ba10f4368988cdd4e3431 100644 --- a/code/interr.lisp +++ b/code/interr.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/code/interr.lisp,v 1.44 2005/09/09 19:36:34 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.45 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -125,6 +125,13 @@ :datum object :expected-type 'long-float)) +#+double-double +(deferr object-not-double-double-float-error (object) + (error 'type-error + :function-name name + :datum object + :expected-type 'double-double-float)) + (deferr object-not-simple-string-error (object) (error 'type-error :function-name name @@ -412,6 +419,13 @@ :datum object :expected-type '(simple-array double-float (*)))) +#+double-double +(deferr object-not-simple-array-double-double-float-error (object) + (error 'type-error + :function-name name + :datum object + :expected-type '(simple-array double-double-float (*)))) + (deferr object-not-simple-array-complex-single-float-error (object) (error 'type-error :function-name name @@ -431,6 +445,13 @@ :datum object :expected-type '(simple-array (complex long-float) (*)))) +#+double-double +(deferr object-not-simple-array-complex-double-double-float-error (object) + (error 'type-error + :function-name name + :datum object + :expected-type '(simple-array (complex double-double-float) (*)))) + (deferr object-not-complex-error (object) (error 'type-error :function-name name @@ -462,6 +483,13 @@ :datum object :expected-type '(complex long-float))) +#+double-double +(deferr object-not-complex-double-double-float-error (object) + (error 'type-error + :function-name name + :datum object + :expected-type '(complex double-double-float))) + (deferr object-not-weak-pointer-error (object) (error 'type-error :function-name name diff --git a/code/irrat-dd.lisp b/code/irrat-dd.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c1602762a590f6af4eb2ea82b2304c54f2d2f38a --- /dev/null +++ b/code/irrat-dd.lisp @@ -0,0 +1,1836 @@ +;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat-dd.lisp,v 1.2 2006/06/30 18:41:22 rtoy Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains all the irrational functions for double-double +;;; float. The algorithms and coefficients come from the Cephes math +;;; library. See http://www.moshier.net/#Cephes and +;;; http://www.netlib.org/cephes/. +;;; +;;; Author: Raymond Toy. +;;; + +(in-package "KERNEL") + +;;;; Random constants, utility functions. + +#+nil +(defconstant max-log + 1.1356523406294143949491931077970764891253w4 + "log(most-positive-double-double-float)") + +#+nil +(defconstant min-log + -1.143276959615573793352782661133116431383730w4 + "log(least-positive-double-double-float") + +(defconstant max-log + 7.0978271289338399678773454114191w2 + "log(most-positive-double-double-float)") + +(defconstant min-log + -7.4444007192138126231410729844608w2 + "log(least-positive-double-double-float") + + +(defconstant loge2 + 0.6931471805599453094172321214581765680755001w0 + "log(2)") + +(defconstant log2e + 1.442695040888963407359924681001892137426646w0 + "Log base 2 of e") + +(defconstant log2ea + 4.4269504088896340735992468100189213742664595w-1 + "log2(e)-1") + +(defconstant dd-pi + 3.141592653589793238462643383279502884197169w0 + "Pi") + +(defconstant dd-pi/2 + 1.570796326794896619231321691639751442098585w0 + "Pi/2") + +(defconstant dd-pi/4 + 0.7853981633974483096156608458198757210492923w0 + "Pi/4") + +;; log2-c1 and log-c2 are log(2) arranged in such a way that log2-c1 + +;; log2-c2 is log(2) to an accuracy greater than double-double-float. +(defconstant log2-c1 + 6.93145751953125w-1) + +(defconstant log2-c2 + 1.428606820309417232121458176568075500134w-6) + +(defconstant sqrt-1/2 + 0.7071067811865475244008443621048490392848w0 + "Sqrt(2)") + +;; Evaluate polynomial +(defun poly-eval (x coef) + (declare (type double-double-float x) + (type (simple-array double-double-float (*)) coef)) + ;; y = C0 + C1*x + C2*x^2 + ... + ;; + ;; But coefficients are stored in reverse (descending powers) order: + ;; coef[0] = CN, ..., coef[N] = C0. + (let ((y 0w0)) + (declare (type double-double-float y)) + (loop for c across coef do + (setf y (+ (* y x) + c))) + y)) + +(defun poly-eval-1 (x coef) + (declare (type double-double-float x) + (type (simple-array double-double-float (*)) coef)) + ;; Like poly-eval, except it assumes coef[N] = 1 and is omitted. + (let ((y 1w0)) + (declare (type double-double-float y)) + (loop for c across coef do + (setf y (+ (* y x) + c))) + y)) + + +;;; dd-%expm1 +;;; +;;; exp(x)-1 +;;; Range reduction is accomplished by separating the argument +;;; into an integer k and fraction f such that +;;; +;;; x k f +;;; e = 2 e. +;;; +;;; An expansion x + .5 x^2 + x^3 R(x) approximates exp(f) - 1 +;;; in the basic range [-0.5 ln 2, 0.5 ln 2]. +;;; +;;; +;;; ACCURACY: +;;; +;;; Relative error: +;;; arithmetic domain # trials peak rms +;;; IEEE -79,+MAXLOG 100,000 1.7e-34 4.5e-35 +;;; + +(let ((p (make-array 8 :element-type 'double-double-float + :initial-contents '( + -4.888737542888633647784737721812546636240w-1 + 4.401308817383362136048032038528753151144w1 + -1.716772506388927649032068540558788106762w3 + 4.578962475841642634225390068461943438441w4 + -7.212432713558031519943281748462837065308w5 + 8.944630806357575461578107295909719817253w6 + -5.722847283900608941516165725053359168840w7 + 2.943520915569954073888921213330863757240w8))) + (q (make-array 8 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 + 1.766112549341972444333352727998584753865w9 + -7.848989743695296475743081255027098295771w8 + 1.615869009634292424463780387327037251069w8 + -2.019684072836541751428967854947019415698w7 + 1.682912729190313538934190635536631941751w6 + -9.615511549171441430850103489315371768998w4 + 3.697714952261803935521187272204485251835w3 + -8.802340681794263968892934703309274564037w1))) + ;; ln 2^-114 + (minarg -7.9018778583833765273564461846232128760607w1)) + (declare (type double-double-float minarg)) + ;; exp(x) - 1 = x + 0.5*x^2+x^3*P(x)/Q(x), for -log(2)/2 < x < + ;; log(2)/2, where the coefficients of P and Q are given Pn and Qn + ;; above. Theoretical peak relative error = 8.1e-36. + (defun dd-%expm1 (x) + "exp(x) - 1" + (declare (type double-double-float x) + (optimize (speed 3))) + ;; Range reduction is accomplished by separating the argument + ;; into an integer k and fraction f such that + ;; + ;; x k f + ;; e = 2 e. + ;; + ;; An expansion x + .5 x^2 + x^3 R(x) approximates exp(f) - 1 + ;; in the basic range [-0.5 ln 2, 0.5 ln 2]. + (when (> x max-log) + (return-from dd-%expm1 + (kernel:%make-double-double-float #.ext:double-float-positive-infinity + #.ext:double-float-positive-infinity))) + (when (< x minarg) + (return-from dd-%expm1 -1w0)) + + ;; Express x = ln(2)*(k+remainder), remainder not exceeding 1/2 + (let* ((xx (+ log2-c1 log2-c2)) + (k (floor (+ 1/2 (/ (the (double-double-float * 710w0) x) xx)))) + (px (coerce k 'double-double-float)) + (qx 0w0)) + (declare (type double-double-float xx px qx)) + ;; remainder times ln 2 + (decf x (* px log2-c1)) + (decf x (* px log2-c2)) + + ;; Approximate exp(remainder*ln(2)) + #+nil + (setf px (* x + (+ p0 + (* x + (+ p1 + (* x + (+ p2 + (* x + (+ p3 + (* x + (+ p4 + (* x + (+ p5 + (* x + (+ p6 + (* x p7)))))))))))))))) + #+nil + (setf qx (+ q0 + (* x + (+ q1 + (* x + (+ q2 + (* x + (+ q3 + (* x + (+ q4 + (* x + (+ q5 + (* x + (+ q6 + (* x + (+ x q7)))))))))))))))) + (setf px (poly-eval x p)) + (setf qx (poly-eval-1 x q)) + (setf xx (* x x)) + (setf qx (+ x (+ (* 0.5w0 xx) + (/ (* xx px) + qx)))) + ;; exp(x) = exp(k*ln(2))*exp(remainder*ln(2)) = 2^k*exp(remainder*ln(2)) + ;; + ;; We have qx = exp(remainder*ln(2))-1, so exp(x) - 1 = + ;; 2^k*(qx+1)-1 = 2^k*qx + 2^k - 1 + (setf px (scale-float 1w0 k)) + (+ (* px qx) + (- px 1))))) + +;;; dd-%exp +;;; exp(x) +;;; Range reduction is accomplished by separating the argument +;;; into an integer k and fraction f such that +;;; +;;; x k f +;;; e = 2 e. +;;; +;;; A Pade' form of degree 2/3 is used to approximate exp(f) - 1 +;;; in the basic range [-0.5 ln 2, 0.5 ln 2]. +;;; +;;; +;;; ACCURACY: +;;; +;;; Relative error: +;;; arithmetic domain # trials peak rms +;;; IEEE +-MAXLOG 100,000 2.6e-34 8.6e-35 +;;; +;;; +;;; Error amplification in the exponential function can be +;;; a serious matter. The error propagation involves +;;; exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ), +;;; which shows that a 1 lsb error in representing X produces +;;; a relative error of X times 1 lsb in the function. +;;; While the routine gives an accurate result for arguments +;;; that are exactly represented by a long double precision +;;; computer number, the result contains amplified roundoff +;;; error for large arguments not exactly represented. + +(let ((p (make-array 5 :element-type 'double-double-float + :initial-contents + '( + 3.279723985560247033712687707263393506266w-10 + 6.141506007208645008909088812338454698548w-7 + 2.708775201978218837374512615596512792224w-4 + 3.508710990737834361215404761139478627390w-2 + 9.999999999999999999999999999999999998502w-1 + ))) + (q (make-array 6 :element-type 'double-double-float + :initial-contents + '( + 2.980756652081995192255342779918052538681w-12 + 1.771372078166251484503904874657985291164w-8 + 1.504792651814944826817779302637284053660w-5 + 3.611828913847589925056132680618007270344w-3 + 2.368408864814233538909747618894558968880w-1 + 2.000000000000000000000000000000000000150w0 + ))) + ;; C1 + C2 = ln 2 + (c1 (- log2-c1)) + (c2 (- log2-c2))) + (declare (type double-double-float c1 c2)) + ;; p and q are Pade coefficients for exp(x) - 1. Theoretical peak + ;; relative error = 2.2e-37, relative peak error spread = 9.2e-38. + (defun dd-%exp (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (when (> x max-log) + (return-from dd-%exp + (kernel:%make-double-double-float #.ext:double-float-positive-infinity + #.ext:double-float-positive-infinity))) + (when (< x min-log) + (return-from dd-%exp 0w0)) + ;; Express + ;; exp(x) = exp(g)*2^n + ;; = exp(g)*exp(n*log(2)) + ;; = exp(g + n * log2) + (let* ((n (floor (+ 0.5w0 (* x log2e)))) + (px (coerce n 'double-double-float))) + (declare (type double-double-float px)) + (incf x (* px c1)) + (incf x (* px c2)) + ;; Rational approx for exponential of fractional part: + ;; exp(x) = 1+2*x*p(x^2)/(q(x^2)-p(x^2)) + ;; + ;; [The above comment seems not to match the code below. But + ;; perhaps q(x) isn't what I think it is.] + (let ((xx (* x x))) + (setf px (* x (poly-eval xx p))) + (setf xx (poly-eval xx q)) + (setf x (/ px (- xx px))) + (setf x (+ 1 x x)) + (scale-float x n))))) + + +;;; dd-%log +;;; log(x), natural logarithm. +;;; The argument is separated into its exponent and fractional +;;; parts. If the exponent is between -1 and +1, the logarithm +;;; of the fraction is approximated by +;;; +;;; log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). +;;; +;;; Otherwise, setting z = 2(x-1)/x+1), +;;; +;;; log(x) = z + z**3 P(z)/Q(z). +;;; +;;; +;;; +;;; ACCURACY: +;;; +;;; Relative error: +;;; arithmetic domain # trials peak rms +;;; IEEE exp(+-MAXLOGL) 36,000 9.5e-35 4.1e-35 +;;; + +(let ((p (make-array 13 :element-type 'double-double-float + :initial-contents + '(1.538612243596254322971797716843006400388w-6 + 4.998469661968096229986658302195402690910w-1 + 2.321125933898420063925789532045674660756w1 + 4.114517881637811823002128927449878962058w2 + 3.824952356185897735160588078446136783779w3 + 2.128857716871515081352991964243375186031w4 + 7.594356839258970405033155585486712125861w4 + 1.797628303815655343403735250238293741397w5 + 2.854829159639697837788887080758954924001w5 + 3.007007295140399532324943111654767187848w5 + 2.014652742082537582487669938141683759923w5 + 7.771154681358524243729929227226708890930w4 + 1.313572404063446165910279910527789794488w4))) + (q (make-array 12 :element-type 'double-double-float + :initial-contents + '( + ;; 1.000000000000000000000000000000000000000w0 + 4.839208193348159620282142911143429644326w1 + 9.104928120962988414618126155557301584078w2 + 9.147150349299596453976674231612674085381w3 + 5.605842085972455027590989944010492125825w4 + 2.248234257620569139969141618556349415120w5 + 6.132189329546557743179177159925690841200w5 + 1.158019977462989115839826904108208787040w6 + 1.514882452993549494932585972882995548426w6 + 1.347518538384329112529391120390701166528w6 + 7.777690340007566932935753241556479363645w5 + 2.626900195321832660448791748036714883242w5 + 3.940717212190338497730839731583397586124w4))) + (r (make-array 6 :element-type 'double-double-float + :initial-contents + '(-8.828896441624934385266096344596648080902w-1 + 8.057002716646055371965756206836056074715w1 + -2.024301798136027039250415126250455056397w3 + 2.048819892795278657810231591630928516206w4 + -8.977257995689735303686582344659576526998w4 + 1.418134209872192732479751274970992665513w5 + ))) + (s (make-array 6 :element-type 'double-double-float + :initial-contents + '( ;; 1.000000000000000000000000000000000000000w0 + -1.186359407982897997337150403816839480438w2 + 3.998526750980007367835804959888064681098w3 + -5.748542087379434595104154610899551484314w4 + 4.001557694070773974936904547424676279307w5 + -1.332535117259762928288745111081235577029w6 + 1.701761051846631278975701529965589676574w6)))) + ;; p and q are coefficients in the expansion for log(1+x) = x - + ;; x^2/2 + x^3*p(x)/q(x), where 1/sqrt(2) <= 1+x < sqrt(2). + ;; Theoretical peak relative error = 5.3e-37, relative peak error + ;; spread = 2.3e-14. + ;; + ;; R and S are coefficients for log(x) = z + z^3*r(z^2)/s(z^2), + ;; where z = 2*(x-1)/(x+1), where 1/sqrt(2) <= x < sqrt(2). + ;; Theoretical peak relative error = 1.1e-35, relative peak error + ;; spread 1.1e-9. + ;; + ;; + (defun dd-%log (x) + (declare (type double-double-float x) + (optimize (speed 3))) + ;; Separate mantissa from exponent + (multiple-value-bind (x e) + (decode-float x) + (declare (type double-double-float x) + (type double-float-exponent e)) + (let ((z 0w0) + (y 0w0)) + (declare (type double-double-float z y)) + ;; Logarithm using log(x) = z + z^3*P(z^2)/Q(z^2); where z = 2*(x-1)/x + 1; + (cond ((or (> e 2) + (< e -2)) + (cond ((< x sqrt-1/2) + ;; 2*(2*x-1)/(2*x+1) + (decf e) + (setf z (- x 0.5w0)) + (setf y (+ (* 0.5w0 z) 0.5w0))) + (t + ;; 2*(x-1)/(x+1) + (setf z (- x 0.5w0)) + (decf z 0.5w0) + (setf y (+ (* 0.5w0 x) 0.5w0)))) + (setf x (/ z y)) + (setf z (* x x)) + (setf z (* x (/ (* z (poly-eval z r)) + (poly-eval-1 z s)))) + (incf z (* e log2-c2)) + (incf z x) + (incf z (* e log2-c1))) + (t + ;; Log using log(1+x) = x - 0.5*x^2+x^3*p(x)/q(x) + (cond ((< x sqrt-1/2) + (decf e) + (setf x (- (scale-float x 1) 1))) + (t + (decf x))) + (setf z (* x x)) + (setf y (* x (* z (/ (poly-eval x p) + (poly-eval-1 x q))))) + (incf y (* e log2-c2)) + ;; z = y - 0.5*z + (setf z (- y (scale-float z -1))) + (incf z x) + (incf z (* e log2-c1)) + )))))) + +;;; dd-%log1p(x) +;;; log(1+x) +;;; +;;; The argument 1+x is separated into its exponent and fractional +;;; parts. If the exponent is between -1 and +1, the logarithm +;;; of the fraction is approximated by +;;; +;;; log(1+x) = x - 0.5 x^2 + x^3 P(x)/Q(x). +;;; +;;; Otherwise, setting z = 2(x-1)/x+1), +;;; +;;; log(x) = z + z^3 P(z)/Q(z). +;;; +;;; +;;; +;;; ACCURACY: +;;; +;;; Relative error: +;;; arithmetic domain # trials peak rms +;;; IEEE -1, 8 100000 1.9e-34 4.3e-35 + +(let ((p (make-array 13 :element-type 'double-double-float + :initial-contents '( + 1.538612243596254322971797716843006400388w-6 + 4.998469661968096229986658302195402690910w-1 + 2.321125933898420063925789532045674660756w1 + 4.114517881637811823002128927449878962058w2 + 3.824952356185897735160588078446136783779w3 + 2.128857716871515081352991964243375186031w4 + 7.594356839258970405033155585486712125861w4 + 1.797628303815655343403735250238293741397w5 + 2.854829159639697837788887080758954924001w5 + 3.007007295140399532324943111654767187848w5 + 2.014652742082537582487669938141683759923w5 + 7.771154681358524243729929227226708890930w4 + 1.313572404063446165910279910527789794488w4 + ))) + (q (make-array 12 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 + 4.839208193348159620282142911143429644326w1 + 9.104928120962988414618126155557301584078w2 + 9.147150349299596453976674231612674085381w3 + 5.605842085972455027590989944010492125825w4 + 2.248234257620569139969141618556349415120w5 + 6.132189329546557743179177159925690841200w5 + 1.158019977462989115839826904108208787040w6 + 1.514882452993549494932585972882995548426w6 + 1.347518538384329112529391120390701166528w6 + 7.777690340007566932935753241556479363645w5 + 2.626900195321832660448791748036714883242w5 + 3.940717212190338497730839731583397586124w4 + ))) + (r (make-array 6 :element-type 'double-double-float + :initial-contents '(-8.828896441624934385266096344596648080902w-1 + 8.057002716646055371965756206836056074715w1 + -2.024301798136027039250415126250455056397w3 + 2.048819892795278657810231591630928516206w4 + -8.977257995689735303686582344659576526998w4 + 1.418134209872192732479751274970992665513w5 + ))) + (s (make-array 6 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 + -1.186359407982897997337150403816839480438w2 + 3.998526750980007367835804959888064681098w3 + -5.748542087379434595104154610899551484314w4 + 4.001557694070773974936904547424676279307w5 + -1.332535117259762928288745111081235577029w6 + 1.701761051846631278975701529965589676574w6 + ))) +) + ;; Coefficients for log(1+x) = x - x^2 / 2 + x^3 P(x)/Q(x) + ;; 1/sqrt(2) <= 1+x < sqrt(2) + ;; Theoretical peak relative error = 5.3e-37, + ;; relative peak error spread = 2.3e-14 + (defun dd-%log1p (xm1) + (declare (type double-double-float xm1)) + (let ((x (+ xm1 1)) + (z 0w0) + (y 0w0)) + (declare (type double-double-float x y z) + (optimize (speed 3))) + (multiple-value-bind (x e) + (decode-float x) + (declare (type double-double-float x) + (type double-float-exponent e)) + (cond ((or (> e 2) + (< e -2)) + ;; Log using log(x) = z + z^3*P(z^2)/Q(z^2) + (cond ((< x sqrt-1/2) + (decf e) + (setf z (- x 0.5w0)) + (setf y (+ 0.5w0 (* 0.5w0 z)))) + (t + (setf z (- x 0.5w0)) + (decf z 0.5w0) + (setf y (+ 0.5w0 (* 0.5w0 x))))) + (setf x (/ z y)) + (setf z (* x x)) + (setf z (* x (/ (* z (poly-eval z r)) + (poly-eval-1 z s)))) + (incf z (* e log2-c2)) + (incf z x) + (incf z (* e log2-c1))) + (t + ;; Log using log(1+x) = x - 0.5*x^2 + x^3*p(x)/q(x) + (cond ((< x sqrt-1/2) + (decf e) + (if (/= e 0) + (setf x (- (* 2 x) 1)) + (setf x xm1))) + (t + (if (/= e 0) + (decf x 1) + (setf x xm1)))) + (setf z (* x x)) + (setf y (* x (/ (* z (poly-eval x p)) + (poly-eval-1 x q)))) + (incf y (* e log2-c2)) + (setf z (- y (* 0.5w0 z))) + (incf z x) + (incf z (* e log2-c1)))))))) + +(let ((P (make-array 6 :element-type 'double-double-float + :initial-contents '( + 1.622194395724068297909052717437740288268w3 + 1.124862584587770079742188354390171794549w6 + 3.047548980769660162696832999871894196102w8 + 3.966215348072348368191433063260384329745w10 + 2.375869584584371194838551715348965605295w12 + 6.482835792103233269752264509192030816323w13 + ))) + (Q (make-array 6 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + -9.101683853129357776079049616394849086007w2 + 4.486400519836461218634448973793765123186w5 + -1.492531313030440305095318968983514314656w8 + 3.457771488856930054902696708717192082887w10 + -5.193289868803472640225483235513427062460w12 + 3.889701475261939961851358705515223019890w14)))) + (defun dd-%sinh (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (let ((a (abs x))) + (declare (type double-double-float a)) + (cond ((> a 1) + (setf a (dd-%exp a)) + (setf a (- (* 0.5w0 a) (/ 0.5w0 a))) + (if (< x 0) + (- a) + a)) + (t + (setf a (* a a)) + (let ((pp (poly-eval a p)) + (qq (poly-eval-1 a q))) + (+ x (* x a + (/ pp qq))))))))) + +#+nil +(defun dd-%sinh (x) + (declare (type double-double-float x)) + (let ((a (abs x))) + (declare (type double-double-float a)) + (cond ((> a 1) + (setf a (dd-%exp a)) + (setf a (- (* 0.5w0 a) (/ 0.5w0 a))) + (if (< x 0) + (- a) + a)) + (t + ;; Use sinh(x) = 1/2*(D(x)+D(x)/(1+D(x))), here D(x) = + ;; exp(x)-1. + (let ((d (dd-%expm1 x))) + (* 0.5w0 (+ d (/ d (+ 1 d))))))))) + +(defun dd-%cosh (x) + (declare (type double-double-float x)) + (let ((y (dd-%exp x))) + (scale-float (+ y (/ y)) -1))) + +(let ((P (make-array 6 :element-type 'double-double-float + :initial-contents '(-6.505693197948351084912624750702492767503w-6 + -9.804083860188429726356968570322356183383w-1 + -5.055287638900473250703725789725376004355w2 + -7.307477148073823966594990496301416814519w4 + -3.531606586182691280701462523692471322688w6 + -4.551377146142783468144190926206842300707w7 + ))) + (Q (make-array 5 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + 5.334865598460027935735737253027154828002w2 + 8.058475607422391042912151298751537172870w4 + 4.197073523796142343374222405869721575491w6 + 6.521134551226147545983467868553677881771w7 + 1.365413143842835040443257277862054198329w8)))) + (defun dd-%tanh (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (let ((z (abs x))) + (declare (type double-double-float z)) + (cond ((> z (* 0.5w0 max-log)) + (if (> x 0) + 1w0 + -1w0)) + ((> z 0.625w0) + (let ((s (dd-%exp (* 2 z)))) + (setf z (- 1 (/ 2 (+ s 1)))) + (if (minusp x) + (- z) + z))) + (t + (let* ((s (* x x))) + (declare (optimize speed)) + (setf z (/ (poly-eval s p) + (poly-eval-1 s q))) + (setf z (* x s z)) + (+ x z))))))) + +(let ((P (make-array 10 :element-type 'double-double-float + :initial-contents '( + -9.217569843805850417698565442251656375681w-1 + 5.321929116410615470118183794063211260728w1 + -9.139522976807685333981548145417830690552w2 + 7.204314536952949779101646454146682033772w3 + -3.097809640165146436529075324081668598891w4 + 7.865376554210973897486215630898496100534w4 + -1.211716814094785128366087489224821937203w5 + 1.112669508789123834670923967462068457013w5 + -5.600242872292477863751728708249167956542w4 + 1.188901082233997739779618679364295772810w4 + ))) + (Q (make-array 10 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + -6.807348436010016270202879229504392062418w1 + 1.386763299649315831625106608182196351693w3 + -1.310805752656879543134785263832907269320w4 + 6.872174720355764193772953852564737816928w4 + -2.181008360536226513009076189881617939380w5 + 4.362736119602298592874941767284979857248w5 + -5.535251007539393347687001489396152923502w5 + 4.321594849688346708841188057241308805551w5 + -1.894075056489862952285849974761239845873w5 + 3.566703246701993219338856038092901974725w4 + )))) + (defun dd-%atanh (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (cond ((minusp x) + (- (the double-double-float (dd-%atanh (- x))))) + ((< x 1w-12) + x) + ((< x 0.5w0) + (let ((z (* x x))) + (+ x (* x z (/ (poly-eval z p) + (poly-eval-1 z q)))))) + (t + (* 0.5w0 (dd-%log (/ (+ 1 x) + (- 1 x)))))))) + + +(let ((P (make-array 9 :element-type 'double-double-float + :initial-contents '( + -8.104404283317298189545629468767571317688w-1 + -4.954206127425209147110732546633675599008w1 + -8.438175619831548439550086251740438689853w2 + -6.269710069245210459536983820505214648057w3 + -2.418935474493501382372711518024193326434w4 + -5.208121780431312783866941311277024486498w4 + -6.302755086521614763280617114866439227971w4 + -4.003566436224198252093684987323233921339w4 + -1.037690841528359305134494613113086980551w4 + ))) + (Q (make-array 9 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + 8.175806439951395194771977809279448392548w1 + 1.822215299975696008284027212745010251320w3 + 1.772040003462901790853111853838978236828w4 + 9.077625379864046240143413577745818879353w4 + 2.675554475070211205153169988669677418808w5 + 4.689758557916492969463473819426544383586w5 + 4.821923684550711724710891114802924039911w5 + 2.682316388947175963642524537892687560973w5 + 6.226145049170155830806967678679167550122w4)))) + (defun dd-%asinh (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (cond ((minusp x) + (- (the double-double-float (dd-%asinh (- x))))) + #+nil + ((> x 1w10) + (+ loge2 (dd-%log x))) + ((< x 0.5w0) + (let* ((z (* x x)) + (a (* z (/ (poly-eval z p) + (poly-eval-1 z q))))) + (+ (* a x) x))) + (t + (dd-%log (+ x (sqrt (1+ (* x x))))))))) + +(let ((P (make-array 10 :element-type 'double-double-float + :initial-contents '( + 1.895467874386341763387398084072833727168w-1 + 6.443902084393244878979969557171256604767w1 + 3.914593556594721458616408528941154205393w3 + 9.164040999602964494412169748897754668733w4 + 1.065909694792026382660307834723001543839w6 + 6.899169896709615182428217047370629406305w6 + 2.599781868717579447900896150777162652518w7 + 5.663733059389964024656501196827345337766w7 + 6.606302846870644033621560858582696134512w7 + 3.190482951215438078279772140481195200593w7 + ))) + (Q (make-array 9 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + 1.635418024331924674147953764918262009321w2 + 7.290983678312632723073455563799692165828w3 + 1.418207894088607063257675159183397062114w5 + 1.453154285419072886840913424715826321357w6 + 8.566841438576725234955968880501739464425w6 + 3.003448667795089562511136059766833630017w7 + 6.176592872899557661256383958395266919654w7 + 6.872176426138597206811541870289420510034w7 + 3.190482951215438078279772140481195226621w7 + )))) + (defun dd-%acosh (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (cond ((> x 1w17) + (+ loge2 (dd-%log x))) + (t + (let ((z (- x 1))) + (cond ((< z 0.5w0) + (* (sqrt (* 2 z)) + (/ (poly-eval z p) + (poly-eval-1 z q)))) + (t + (dd-%log (+ x (sqrt (* z (+ 1 x)))))))))))) + +(let ((P (make-array 10 :element-type 'double-double-float + :initial-contents '( + -8.067112765482705313585175280952515549833w-1 + 4.845649797786849136525020822000172350977w1 + -8.510195404865297879959793548843395926847w2 + 6.815196841370292688574521445731895826485w3 + -2.967135182120339728996157454994675519735w4 + 7.612250656518818109652985996692466409670w4 + -1.183360579752620455689557157684221905030w5 + 1.095432262510413338755837156377401348063w5 + -5.554124580991113991999636773382495788705w4 + 1.187132626694762543537732514905488896985w4 + ))) + (Q (make-array 10 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + -8.005471061732009595694099899234272342478w1 + 1.817324228942812880965069608562483918025w3 + -1.867017317425756524289537002141956583706w4 + 1.048196619402464497478959760337779705622w5 + -3.527040897897253459022458866536165564103w5 + 7.426302422018858001691440351763370029242w5 + -9.863068411558756277454631976667880674474w5 + 8.025654653926121907774766642393757364326w5 + -3.653000557802254281954969843055623398839w5 + 7.122795760168575261226395089432959614179w4 + )))) + (defun dd-%asin (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (cond ((minusp x) + (- (the double-double-float (dd-%asin (- x))))) + #+nil + ((< x 1w-8) + x) + (t + (let ((flag nil) + (z 0w0) + (zz 0w0)) + (declare (type double-double-float z zz)) + (cond ((> x 0.5w0) + (setf zz (- 0.5w0 x)) + (setf zz (scale-float (+ zz 0.5w0) -1)) + (setf z (sqrt zz)) + (setf flag t)) + (t + (setf z x) + (setf zz (* z z)) + (setf flag nil))) + (let ((p (* zz (/ (poly-eval zz p) + (poly-eval-1 zz q))))) + (setf z (+ (* z p) z)) + (when flag + (setf z (+ z z)) + (setf z (- dd-pi/2 z))) + z)))))) + +(defun dd-%acos (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (cond ((< x -0.5w0) + (- dd-pi + (* 2 (dd-%asin (sqrt (* 0.5w0 (+ 1 x))))))) + ((> x 0.5w0) + (* 2 (dd-%asin (sqrt (* 0.5w0 (- 1w0 x)))))) + (t + (- dd-pi/2 (dd-%asin x))))) + +(let ((P (make-array 9 :element-type 'double-double-float + :initial-contents '( + -6.635810778635296712545011270011752799963w-4 + -8.768423468036849091777415076702113400070w-1 + -2.548067867495502632615671450650071218995w1 + -2.497759878476618348858065206895055957104w2 + -1.148164399808514330375280133523543970854w3 + -2.792272753241044941703278827346430350236w3 + -3.696264445691821235400930243493001671932w3 + -2.514829758941713674909996882101723647996w3 + -6.880597774405940432145577545328795037141w2 + ))) + (Q (make-array 8 :element-type 'double-double-float + :initial-contents '( + ;; 1.000000000000000000000000000000000000000w0 */ + 3.566239794444800849656497338030115886153w1 + 4.308348370818927353321556740027020068897w2 + 2.494680540950601626662048893678584497900w3 + 7.928572347062145288093560392463784743935w3 + 1.458510242529987155225086911411015961174w4 + 1.547394317752562611786521896296215170819w4 + 8.782996876218210302516194604424986107121w3 + 2.064179332321782129643673263598686441900w3 + ))) + + ;; tan( 3*pi/8 ) + (T3P8 2.414213562373095048801688724209698078569672w0) + ;; tan( pi/8 ) + (TP8 0.414213562373095048801688724209698078569672w0)) + (declare (type double-double-float t3p8 tp8)) + (defun dd-%atan (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (when (minusp x) + (return-from dd-%atan (- (the double-double-float (dd-%atan (- x)))))) + ;; range reduction + (let ((y 0w0)) + (declare (type double-double-float y)) + (cond ((> x t3p8) + (setf y dd-pi/2) + (setf x (/ -1 x))) + ((> x tp8) + (setf y dd-pi/4) + (setf x (/ (- x 1) + (+ x 1)))) + (t + (setf y 0w0))) + ;; Rational form in x^2 + (let ((z (* x x))) + (setf y (+ y + (* (/ (poly-eval z p) + (poly-eval-1 z q)) + z x) + x)) + y)))) + +(defun dd-%atan2 (y x) + (declare (type double-double-float x y) + (optimize (speed 3))) + (let ((code 0) + (w 0w0)) + (declare (type (integer 0 3) code) + (type double-double-float w)) + (when (minusp x) + (setf code 2)) + (when (minusp y) + (setf code (logior code 1))) + (when (zerop x) + (unless (zerop (logand code 1)) + (return-from dd-%atan2 (- dd-pi/2))) + (when (zerop y) + (return-from dd-%atan2 0w0)) + (return-from dd-%atan2 dd-pi/2)) + (when (zerop y) + (return-from dd-%atan2 + (if (zerop (logand code 2)) + 0w0 + dd-pi))) + (setf w (ecase code + (0 0w0) + (1 0w0) + (2 dd-pi) + (3 (- dd-pi)))) + + (+ w (dd-%atan (/ y x))))) + + +;; +;; Here are the fractional digits of pi, in hex. +;; +;; 243f6a8885 a308d31319 8a2e037073 44a4093822 299f31d008 2efa98ec4e 6c89452821 e638d01377 be5466cf34 e90c6cc0ac +;; 29b7c97c50 dd3f84d5b5 b547091792 16d5d98979 fb1bd1310b a698dfb5ac 2ffd72dbd0 1adfb7b8e1 afed6a267e 96ba7c9045 +;; +;; We want to express pi/4 in 3 parts such that the sum of the parts +;; is exactly the value of pi to the higher precision. For +;; double-double, we want 53 bits in each part. +;; +;; pi/4 in hex is +;; +;; C90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F2411 +;; +;; +#|| +(let* ((frac #xC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F2411) + (len (integer-length frac))) + (format t "len = ~D bits~%" len) + (format t "pi/4 ~,,' ,106:b~%" (ldb (byte (* 4 106) (- len (* 4 106))) frac))) +-> +pi/4 11001001000011111101101010100010001000010110100011000 01000110100110001001100011001100010100010111000000011 01110000011100110100010010100100000010010011100000100 01000101001100111110011000111010000000010000010111011 + +||# +;; d1 = (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106) +;; d2 = (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106)) +;; d3 = (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106)) +;; d4 = (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106)) + +;; sin(x) = x + x^3 P(x^2) +;; Theoretical peak relative error = 5.6e-39 +;; relative peak error spread = 1.7e-9 + +(defconstant sincof + (make-array 12 :element-type 'double-double-float + :initial-contents + '( + 6.410290407010279602425714995528976754871w-26 + -3.868105354403065333804959405965295962871w-23 + 1.957294039628045847156851410307133941611w-20 + -8.220635246181818130416407184286068307901w-18 + 2.811457254345322887443598804951004537784w-15 + -7.647163731819815869711749952353081768709w-13 + 1.605904383682161459812515654720205050216w-10 + -2.505210838544171877505034150892770940116w-8 + 2.755731922398589065255731765498970284004w-6 + -1.984126984126984126984126984045294307281w-4 + 8.333333333333333333333333333333119885283w-3 + -1.666666666666666666666666666666666647199w-1 + ))) + +;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2)) +;; Theoretical peak relative error = 2.1e-37, +;; relative peak error spread = 1.4e-8 + +(defconstant coscof + (make-array 11 :element-type 'double-double-float + :initial-contents + '( + 1.601961934248327059668321782499768648351w-24 + -8.896621117922334603659240022184527001401w-22 + 4.110317451243694098169570731967589555498w-19 + -1.561920696747074515985647487260202922160w-16 + 4.779477332386900932514186378501779328195w-14 + -1.147074559772972328629102981460088437917w-11 + 2.087675698786809897637922200570559726116w-9 + -2.755731922398589065255365968070684102298w-7 + 2.480158730158730158730158440896461945271w-5 + -1.388888888888888888888888888765724370132w-3 + 4.166666666666666666666666666666459301466w-2 + ))) + +(defconstant dp1 + (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106)) + +(defconstant dp2 + (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106))) + +(defconstant dp3 + (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106))) + +(defconstant dp4 + (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106))) + +(defun dd-%sin (x) + (declare (type double-double-float x)) + (when (minusp x) + (return-from dd-%sin (- (the double-double-float (dd-%sin (- x)))))) + ;; y = integer part of x/(pi/4). + (let* ((y (float (floor (/ x dd-pi/4)) 1w0)) + (z (scale-float y -4))) + (declare (type double-double-float y z)) + (setf z (float (floor z) 1w0)) ; integer part of y/8 + (setf z (- y (scale-float z 4))) ; y - 16*(y/16) + + (let ((j (truncate z)) + (sign 1)) + (unless (zerop (logand j 1)) + (incf j) + (incf y)) + (setf j (logand j 7)) + + (when (> j 3) + (setf sign (- sign)) + (decf j 4)) + + ;; Extended precision modular arithmetic + (setf z (- (- (- x (* y dp1)) + (* y dp2)) + (* y dp3))) + (let ((zz (* z z))) + (if (or (= j 1) + (= j 2)) + (setf y (+ (- 1 (scale-float zz -1)) + (* zz zz (poly-eval zz coscof)))) + (setf y (+ z (* z (* zz (poly-eval zz sincof)))))) + (if (< sign 0) + (- y) + y))))) + +(defun dd-%cos (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (when (minusp x) + (return-from dd-%cos (dd-%cos (- x)))) + ;; y = integer part of x/(pi/4). + (let* ((y (float (floor (/ x dd-pi/4)) 1w0)) + (z (scale-float y -4))) + (declare (type double-double-float y z)) + (setf z (float (floor z) 1w0)) ; integer part of y/8 + (setf z (- y (scale-float z 4))) ; y - 16*(y/16) + + (let ((i (truncate z)) + (j 0) + (sign 1)) + (declare (type (integer 0 7) j) + (type (integer -1 1) sign)) + (unless (zerop (logand i 1)) + (incf i) + (incf y)) + (setf j (logand i 7)) + + (when (> j 3) + (setf sign (- sign)) + (decf j 4)) + (when (> j 1) + (setf sign (- sign))) + + ;; Extended precision modular arithmetic. This is basically + ;; computing x - y*(pi/4) accurately so that |z| < pi/4. + (setf z (- (- (- x (* y dp1)) + (* y dp2)) + (* y dp3))) + (let ((zz (* z z))) + (if (or (= j 1) + (= j 2)) + (setf y (+ z (* z (* zz (poly-eval zz sincof))))) + (setf y (+ (- 1 (scale-float zz -1)) + (* zz (poly-eval zz coscof) zz)))) + (if (< sign 0) + (- y) + y))))) + +(let ((P (make-array 6 :element-type 'double-double-float + :initial-contents + '( + -9.889929415807650724957118893791829849557w-1 + 1.272297782199996882828849455156962260810w3 + -4.249691853501233575668486667664718192660w5 + 5.160188250214037865511600561074819366815w7 + -2.307030822693734879744223131873392503321w9 + 2.883414728874239697964612246732416606301w10 + ))) + (Q (make-array 6 :element-type 'double-double-float + :initial-contents + '( + ;; 1.000000000000000000000000000000000000000w0 */ + -1.317243702830553658702531997959756728291w3 + 4.529422062441341616231663543669583527923w5 + -5.733709132766856723608447733926138506824w7 + 2.758476078803232151774723646710890525496w9 + -4.152206921457208101480801635640958361612w10 + 8.650244186622719093893836740197250197602w10 + )))) + (defun dd-tancot (xx cotflag) + (declare (type double-double-float xx) + (optimize (speed 3))) + (let ((x 0w0) + (sign 1)) + (declare (type double-double-float x) + (type (integer -1 1) sign)) + (cond ((minusp xx) + (setf x (- xx)) + (setf sign -1)) + (t + (setf x xx))) + (let* ((y (float (floor (/ x dd-pi/4)) 1w0)) + (z (scale-float y -4)) + (j 0)) + (declare (type double-double-float y z) + (type fixnum j)) + (setf z (float (floor z) 1w0)) + (setf z (- y (scale-float z 4))) + + (setf j (truncate z)) + + (unless (zerop (logand j 1)) + (incf j) + (incf y)) + + (setf z (- (- (- x (* y dp1)) + (* y dp2)) + (* y dp3))) + (let ((zz (* z z))) + (if (> zz 1w-40) + (setf y (+ z + (* z (* zz (/ (poly-eval zz p) + (poly-eval-1 zz q)))))) + (setf y z)) + (if (not (zerop (logand j 2))) + (if cotflag + (setf y (- y)) + (setf y (/ -1 y))) + (if cotflag + (setf y (/ y)))) + (if (< sign 0) + (- y) + y)))))) + +(defun dd-%tan (x) + (declare (type double-double-float x)) + (dd-tancot x nil)) + +;;; dd-%log2 +;;; Base 2 logarithm. + +(let ((P (make-array 13 :element-type 'double-double-float + :initial-contents + '( + 1.538612243596254322971797716843006400388w-6 + 4.998469661968096229986658302195402690910w-1 + 2.321125933898420063925789532045674660756w1 + 4.114517881637811823002128927449878962058w2 + 3.824952356185897735160588078446136783779w3 + 2.128857716871515081352991964243375186031w4 + 7.594356839258970405033155585486712125861w4 + 1.797628303815655343403735250238293741397w5 + 2.854829159639697837788887080758954924001w5 + 3.007007295140399532324943111654767187848w5 + 2.014652742082537582487669938141683759923w5 + 7.771154681358524243729929227226708890930w4 + 1.313572404063446165910279910527789794488w4 + ))) + (Q (make-array 12 :element-type 'double-double-float + :initial-contents + '( + ;; 1.000000000000000000000000000000000000000w0 + 4.839208193348159620282142911143429644326w1 + 9.104928120962988414618126155557301584078w2 + 9.147150349299596453976674231612674085381w3 + 5.605842085972455027590989944010492125825w4 + 2.248234257620569139969141618556349415120w5 + 6.132189329546557743179177159925690841200w5 + 1.158019977462989115839826904108208787040w6 + 1.514882452993549494932585972882995548426w6 + 1.347518538384329112529391120390701166528w6 + 7.777690340007566932935753241556479363645w5 + 2.626900195321832660448791748036714883242w5 + 3.940717212190338497730839731583397586124w4 + ))) + ;; Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), + ;; where z = 2(x-1)/(x+1) + ;; 1/sqrt(2) <= x < sqrt(2) + ;; Theoretical peak relative error = 1.1e-35, + ;; relative peak error spread 1.1e-9 + (R (make-array 6 :element-type 'double-double-float + :initial-contents + '( + -8.828896441624934385266096344596648080902w-1 + 8.057002716646055371965756206836056074715w1 + -2.024301798136027039250415126250455056397w3 + 2.048819892795278657810231591630928516206w4 + -8.977257995689735303686582344659576526998w4 + 1.418134209872192732479751274970992665513w5 + ))) + (S (make-array 6 :element-type 'double-double-float + :initial-contents + '( + ;; 1.000000000000000000000000000000000000000w0 */ + -1.186359407982897997337150403816839480438w2 + 3.998526750980007367835804959888064681098w3 + -5.748542087379434595104154610899551484314w4 + 4.001557694070773974936904547424676279307w5 + -1.332535117259762928288745111081235577029w6 + 1.701761051846631278975701529965589676574w6 + )))) + (defun dd-%log2 (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (multiple-value-bind (x e) + (decode-float x) + (declare (type double-double-float x) + (type double-float-exponent e)) + (let ((z 0w0) + (y 0w0)) + (declare (type double-double-float z y)) + (cond ((or (> e 2) + (< e -2)) + (cond ((< x sqrt-1/2) + ;; 2*(2*x-1)/(2*x+1) + (decf e) + (setf z (- x 0.5w0)) + (setf y (+ (* 0.5w0 z) 0.5w0))) + (t + ;; 2*(x-1)/(x+1) + (setf z (- x 0.5w0)) + (decf z 0.5w0) + (setf y (+ (* 0.5w0 z) 0.5w0)))) + (setf x (/ z y)) + (setf z (* x x)) + (setf y (* x (/ (* z (poly-eval z r)) + (poly-eval-1 z s))))) + (t + (cond ((< x sqrt-1/2) + (decf e) + (setf x (- (scale-float x 1) 1))) + (t + (decf x))) + (setf z (* x x)) + (setf y (* x (/ (* z (poly-eval x p)) + (poly-eval-1 x q)))) + (decf y (scale-float z -1)))) + ;; Multiply log of fraction by log2(e) and base 2 exponent by 1 + ;; + ;; This sequence of operations is critical + (setf z (* y log2ea)) + (setf z (+ z (* x log2ea))) + (setf z (+ z y)) + (setf z (+ z x)) + (setf z (+ z e)) + z)))) + +;;; dd-%exp2 +;;; 2^x + +(let ((P (make-array 5 :element-type 'double-double-float + :initial-contents + '( + 1.587171580015525194694938306936721666031w2 + 6.185032670011643762127954396427045467506w5 + 5.677513871931844661829755443994214173883w8 + 1.530625323728429161131811299626419117557w11 + 9.079594442980146270952372234833529694788w12 + ))) + (Q (make-array 5 :element-type 'double-double-float + :initial-contents + '( + ;; 1.000000000000000000000000000000000000000w0 */ + 1.236602014442099053716561665053645270207w4 + 2.186249607051644894762167991800811827835w7 + 1.092141473886177435056423606755843616331w10 + 1.490560994263653042761789432690793026977w12 + 2.619817175234089411411070339065679229869w13 + )))) + (defun dd-%exp2 (x) + (declare (type double-double-float x) + (optimize (speed 3))) + (when (>= x 1024w0) + (return-from dd-%exp2 + (%make-double-double-float ext:double-float-positive-infinity + ext:double-float-positive-infinity))) + (when (<= x -1024w0) + (return-from dd-%exp2 0w0)) + (multiple-value-bind (n x) + (floor (the (double-double-float -1024w0 1024w0) x)) + (declare (type double-double-float x)) + (let* ((xx (* x x)) + (px (* x (poly-eval xx p)))) + (setf x (/ px (- (poly-eval-1 xx q) px))) + (setf x (+ 1 (scale-float x 1))) + (scale-float x n))))) + +;;; dd-%powil +;;; x^n where n is an integer + +(defun dd-%powil (x nn) + (declare (type double-double-float x) + (fixnum nn) + (optimize (speed 3))) + (when (zerop x) + (return-from dd-%powil + (cond ((zerop nn) + 1w0) + ((minusp nn) + (%make-double-double-float ext:double-float-positive-infinity + ext:double-float-positive-infinity)) + (t + 0w0)))) + (when (zerop nn) + (return-from dd-%powil 1w0)) + + (let ((asign 0) + (sign 0) + (n nn)) + (declare (type (integer -1 0) asign sign) + (fixnum n)) + (when (minusp x) + (setf asign -1) + (setf x (- x))) + (cond ((minusp nn) + (setf sign -1) + (setf n (- nn))) + (t + (setf sign 0) + (setf n nn))) + ;; Overflow detection + + ;; Calculate approximate log of answer + (multiple-value-bind (s lx) + (decode-float x) + (declare (type double-double-float s) + (type double-float-exponent lx)) + (let ((e (* n (1- lx)))) + (cond ((or (zerop e) + (> e 64) + (< e -64)) + (setf s (/ (- s 7.0710678118654752w-1) + (+ s 7.0710678118654752w-1))) + (setf s (* (+ (- (* 2.9142135623730950w0 s) + 0.5w0) + lx) + nn log2e))) + (t + (setf s (* loge2 e)))) + (when (> s max-log) + ;; Overflow. What to do? + (error "Overflow")) + (when (< s min-log) + (return-from dd-%powil 0w0)) + + ;; Handle denormal answer + (when (< s (- 2 max-log)) + (setf x (/ x)) + (setf sign 0)) + + ;; First bit of the power + (let ((y 0w0)) + (declare (type double-double-float y)) + (cond ((zerop (logand n 1)) + (setf y 1w0) + (setf asign 0)) + (t + (setf y x))) + (let ((w x)) + (declare (type double-double-float w)) + (setf n (ash n -1)) + (loop while (not (zerop n)) + do + (setf w (* w w)) + (unless (zerop (logand n 1)) + (setf y (* y w))) + (setf n (ash n -1)))) + ;; Odd power of a negative number + (unless (zerop asign) + (setf y (- y))) + + (unless (zerop sign) + (setf y (/ y))) + y))))) + + +;;; dd-real-pow +;;; x^y, for x and y real, and real result. + +(defun dd-real-pow (x y) + (declare (type double-double-float x y) + (optimize (speed 3))) + (let ((nflg 0) + (w (floor y))) + ;; nflg = 1 if x < 0 raised to integer power + (when (and (= w y) + (< (abs w) 32768)) + (return-from dd-real-pow (dd-%powil x w))) + + (when (<= x 0) + (cond ((zerop x) + (if (zerop y) + ;; 0^0 + (return-from dd-real-pow 1w0) + ;; 0^y + (return-from dd-real-pow 0w0))) + (t + (when (/= w y) + ;; noninteger power of negative number + (let ((p (the double-double-float (dd-real-pow (abs x) y))) + (y*pi (* y dd-pi))) + (return-from dd-real-pow (complex (* p (dd-%cos y*pi)) + (* p (dd-%sin y*pi)))))) + + ;; For negative x, find out if the integer exponent is odd or even. + (let ((w (scale-float y -1))) + (declare (type double-double-float w)) + (setf w (ffloor w)) + (setf w (scale-float w 1)) + (when (/= w y) + (setf nflg 1)) + (setf x (abs x)))))) + (let ((z (dd-%log2 x))) + (declare (type double-double-float z)) + (setf z (dd-%exp2 (* y z))) + (unless (zerop nflg) + (setf z (- z))) + z))) + +(defun dd-%pow (x y) + (declare (type double-double-float x y)) + (dd-real-pow x y)) + + +;; These are essentially the same as in irrat.lisp, but very slightly +;; modified to operate on double-double-floats. +(defun dd-cssqs (z) + ;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The + ;; result is r + i*k, where k is an integer. + + ;; Save all FP flags + (let ((x (float (realpart z) 1w0)) + (y (float (imagpart z) 1w0))) + ;; Would this be better handled using an exception handler to + ;; catch the overflow or underflow signal? For now, we turn all + ;; traps off and look at the accrued exceptions to see if any + ;; signal would have been raised. + (with-float-traps-masked (:underflow :overflow) + (let ((rho (+ (square x) (square y)))) + (declare (optimize (speed 3) (space 0))) + (cond ((and (or (float-nan-p rho) + (float-infinity-p rho)) + (or (float-infinity-p (abs x)) + (float-infinity-p (abs y)))) + (values (%make-double-double-float ext:double-float-positive-infinity 0w0) + 0)) + ((let ((threshold #.(/ least-positive-double-float + double-float-epsilon)) + (traps (ldb vm::float-sticky-bits + (vm:floating-point-modes)))) + ;; Overflow raised or (underflow raised and rho < + ;; lambda/eps) + (or (not (zerop (logand vm:float-overflow-trap-bit traps))) + (and (not (zerop (logand vm:float-underflow-trap-bit traps))) + (< rho threshold)))) + ;; If we're here, neither x nor y are infinity and at + ;; least one is non-zero.. Thus logb returns a nice + ;; integer. + (let ((k (- (logb-finite (max (abs x) (abs y)))))) + (values (+ (square (scalb x k)) + (square (scalb y k))) + (- k)))) + (t + (values rho 0))))))) + +(defun dd-complex-sqrt (z) + "Principle square root of Z + +Z may be any number, but the result is always a complex." + (declare (number z)) + (multiple-value-bind (rho k) + (dd-cssqs z) + (declare (type (or (member 0w0) (double-double-float 0w0)) rho) + (type fixnum k)) + (let ((x (float (realpart z) 1.0w0)) + (y (float (imagpart z) 1.0w0)) + (eta 0w0) + (nu 0w0)) + (declare (type double-double-float x y eta nu)) + + (locally + ;; space 0 to get maybe-inline functions inlined. + (declare (optimize (speed 3) (space 0))) + + (if (not (float-nan-p x)) + (setf rho (+ (scalb (abs x) (- k)) (sqrt rho)))) + + (cond ((oddp k) + (setf k (ash k -1))) + (t + (setf k (1- (ash k -1))) + (setf rho (+ rho rho)))) + + (setf rho (scalb (sqrt rho) k)) + + (setf eta rho) + (setf nu y) + + (when (/= rho 0d0) + (when (not (float-infinity-p (abs nu))) + (setf nu (/ (/ nu rho) 2d0))) + (when (< x 0d0) + (setf eta (abs nu)) + (setf nu (float-sign y rho)))) + (complex eta nu))))) + +(defun dd-complex-log-scaled (z j) + "Compute log(2^j*z). + +This is for use with J /= 0 only when |z| is huge." + (declare (number z) + (fixnum j)) + ;; The constants t0, t1, t2 should be evaluated to machine + ;; precision. In addition, Kahan says the accuracy of log1p + ;; influences the choices of these constants but doesn't say how to + ;; choose them. We'll just assume his choices matches our + ;; implementation of log1p. + (let ((t0 #.(/ 1 (sqrt 2.0w0))) + (t1 1.2w0) + (t2 3w0) + (ln2 #.(log 2w0)) + (x (float (realpart z) 1.0w0)) + (y (float (imagpart z) 1.0w0))) + (multiple-value-bind (rho k) + (dd-cssqs z) + (declare (optimize (speed 3))) + (let ((beta (max (abs x) (abs y))) + (theta (min (abs x) (abs y)))) + (complex (if (and (zerop k) + (< t0 beta) + (or (<= beta t1) + (< rho t2))) + (/ (dd-%log1p (+ (* (- beta 1.0d0) + (+ beta 1.0d0)) + (* theta theta))) + 2d0) + (+ (/ (log rho) 2d0) + (* (+ k j) ln2))) + (atan y x)))))) + +(defun dd-complex-log (z) + "Log of Z = log |Z| + i * arg Z + +Z may be any number, but the result is always a complex." + (declare (number z)) + (dd-complex-log-scaled z 0)) + +;; Let us note the following "strange" behavior. atanh 1.0d0 is +;; +infinity, but the following code returns approx 176 + i*pi/4. The +;; reason for the imaginary part is caused by the fact that arg i*y is +;; never 0 since we have positive and negative zeroes. + +(defun dd-complex-atanh (z) + "Compute atanh z = (log(1+z) - log(1-z))/2" + (declare (number z)) + (if (and (realp z) (< z -1)) + ;; atanh is continuous in quadrant III in this case. + (dd-complex-atanh (complex z -0f0)) + (let* ( ;; Constants + (theta (/ (sqrt most-positive-double-float) 4.0w0)) + (rho (/ 4.0w0 (sqrt most-positive-double-float))) + (half-pi dd-pi/2) + (rp (float (realpart z) 1.0w0)) + (beta (float-sign rp 1.0w0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0w0)))) + (eta 0.0w0) + (nu 0.0w0)) + ;; Shouldn't need this declare. + (declare (double-double-float x y)) + (locally + (declare (optimize (speed 3))) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0w0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4w0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (dd-%log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (dd-%atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (dd-%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (dd-%atan2 (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (complex (* beta eta) + (- (* beta nu))))))) + +(defun dd-complex-tanh (z) + "Compute tanh z = sinh z / cosh z" + (declare (number z)) + (let ((x (float (realpart z) 1.0w0)) + (y (float (imagpart z) 1.0w0))) + (locally + ;; space 0 to get maybe-inline functions inlined + (declare (optimize (speed 3) (space 0))) + (cond ((> (abs x) + #-(or linux hpux) #.(/ (%asinh most-positive-double-float) 4d0) + ;; This is more accurate under linux. + #+(or linux hpux) #.(/ (+ (%log 2.0d0) + (%log most-positive-double-float)) 4d0)) + (complex (float-sign x) + (float-sign y))) + (t + (let* ((tv (dd-%tan y)) + (beta (+ 1.0d0 (* tv tv))) + (s (sinh x)) + (rho (sqrt (+ 1.0d0 (* s s))))) + (if (float-infinity-p (abs tv)) + (complex (/ rho s) + (/ tv)) + (let ((den (+ 1.0d0 (* beta s s)))) + (complex (/ (* beta rho s) + den) + (/ tv den)))))))))) + +;; Kahan says we should only compute the parts needed. Thus, the +;; realpart's below should only compute the real part, not the whole +;; complex expression. Doing this can be important because we may get +;; spurious signals that occur in the part that we are not using. +;; +;; However, we take a pragmatic approach and just use the whole +;; expression. + +;; NOTE: The formula given by Kahan is somewhat ambiguous in whether +;; it's the conjugate of the square root or the square root of the +;; conjugate. This needs to be checked. + +;; I checked. It doesn't matter because (conjugate (sqrt z)) is the +;; same as (sqrt (conjugate z)) for all z. This follows because +;; +;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z). +;; +;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z) +;; +;; and these two expressions are equal if and only if arg conj z = +;; -arg z, which is clearly true for all z. + +;; NOTE: The rules of Common Lisp says that if you mix a real with a +;; complex, the real is converted to a complex before performing the +;; operation. However, Kahan says in this paper (pg 176): +;; +;; (iii) Careless handling can turn infinity or the sign of zero into +;; misinformation that subsequently disappears leaving behind +;; only a plausible but incorrect result. That is why compilers +;; must not transform z-1 into z-(1+i*0), as we have seen above, +;; nor -(-x-x^2) into (x+x^2), as we shall see below, lest a +;; subsequent logarithm or square root produce a non-zero +;; imaginary part whose sign is opposite to what was intended. +;; +;; The interesting examples are too long and complicated to reproduce +;; here. We refer the reader to his paper. +;; +;; The functions below are intended to handle the cases where a real +;; is mixed with a complex and we don't want CL complex contagion to +;; occur.. + +(declaim (inline 1+z 1-z z-1 z+1)) +(defun dd-1+z (z) + (complex (+ 1 (realpart z)) (imagpart z))) +(defun dd-1-z (z) + (complex (- 1 (realpart z)) (- (imagpart z)))) +(defun dd-z-1 (z) + (complex (- (realpart z) 1) (imagpart z))) +(defun dd-z+1 (z) + (complex (+ (realpart z) 1) (imagpart z))) + +(defun dd-complex-acos (z) + "Compute acos z = pi/2 - asin z + +Z may be any number, but the result is always a complex." + (declare (number z)) + (if (and (realp z) (> z 1)) + ;; acos is continuous in quadrant IV in this case. + (complex-acos (complex z -0f0)) + (let ((sqrt-1+z (complex-sqrt (1+z z))) + (sqrt-1-z (complex-sqrt (1-z z)))) + (cond ((zerop (realpart sqrt-1+z)) + ;; Same as below, but we compute atan ourselves (because we + ;; have atan +/- infinity). + (complex + (if (minusp (float-sign (* (realpart sqrt-1-z) + (realpart sqrt-1+z)))) + (- dd-pi) + dd-pi) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))) + (t + (complex (* 2 (atan (/ (realpart sqrt-1-z) + (realpart sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))))))) + +(defun dd-complex-acosh (z) + "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) + +Z may be any number, but the result is always a complex." + (declare (number z)) + (let* ((sqrt-z-1 (complex-sqrt (z-1 z))) + (sqrt-z+1 (complex-sqrt (z+1 z)))) + ;; We need to handle the case where real part of sqrt-z+1 is zero, + ;; because division by zero with double-double-floats doesn't + ;; produce infinity. + (cond ((zerop (realpart sqrt-z+1)) + ;; Same as below, but we compute atan ourselves (because we + ;; have atan +/- infinity). + (complex (asinh (realpart (* (conjugate sqrt-z-1) + sqrt-z+1))) + (if (minusp (float-sign (* (imagpart sqrt-z-1) + (realpart sqrt-z+1)))) + (- dd-pi) + dd-pi))) + (t + (complex (asinh (realpart (* (conjugate sqrt-z-1) + sqrt-z+1))) + (* 2 (atan (/ (imagpart sqrt-z-1) + (realpart sqrt-z+1))))))))) + + +(defun dd-complex-asin (z) + "Compute asin z = asinh(i*z)/i + +Z may be any number, but the result is always a complex." + (declare (number z)) + (if (and (realp z) (> z 1)) + ;; asin is continuous in quadrant IV in this case. + (dd-complex-asin (complex z -0f0)) + (let* ((sqrt-1-z (complex-sqrt (1-z z))) + (sqrt-1+z (complex-sqrt (1+z z))) + (den (realpart (* sqrt-1-z sqrt-1+z)))) + (cond ((zerop den) + ;; Like below but we handle atan part ourselves. + (complex (if (minusp (float-sign den)) + (- dd-pi/2) + dd-pi/2) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z))))) + (t + (with-float-traps-masked (:divide-by-zero) + ;; We get a invalid operation here when z is real and |z| > 1. + (complex (atan (/ (realpart z) + (realpart (* sqrt-1-z sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z)))))))))) + +(defun dd-complex-asinh (z) + "Compute asinh z = log(z + sqrt(1 + z*z)) + +Z may be any number, but the result is always a complex." + (declare (number z)) + ;; asinh z = -i * asin (i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (complex-asin iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defun dd-complex-atan (z) + "Compute atan z = atanh (i*z) / i + +Z may be any number, but the result is always a complex." + (declare (number z)) + ;; atan z = -i * atanh (i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (complex-atanh iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defun dd-complex-tan (z) + "Compute tan z = -i * tanh(i * z) + +Z may be any number, but the result is always a complex." + (declare (number z)) + ;; tan z = -i * tanh(i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (complex-tanh iz))) + (complex (imagpart result) + (- (realpart result))))) diff --git a/code/irrat.lisp b/code/irrat.lisp index 997e04538a59f2b9e5746ebc5a932fcb8a2aa223..25087903e93d6c07a14be4827273574a2118e94b 100644 --- a/code/irrat.lisp +++ b/code/irrat.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/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.46 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -46,7 +46,10 @@ `((((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) + (,(symbolicate "DD-" function) ,var)))) ); eval-when (compile load eval) @@ -361,16 +364,25 @@ (real-expt base power 'double-float)) ((double-float single-float) (real-expt base power 'double-float)) + #+double-double + (((foreach fixnum (or bignum ratio) single-float double-float double-double-float) + double-double-float) + (dd-%pow (coerce base 'double-double-float) power)) + #+double-double + ((double-double-float + (foreach fixnum (or bignum ratio) single-float double-float)) + (dd-%pow base (coerce power 'double-double-float))) (((foreach (complex rational) (complex float)) rational) (* (expt (abs base) power) (cis (* power (phase base))))) - (((foreach fixnum (or bignum ratio) single-float double-float) + (((foreach fixnum (or bignum ratio) single-float double-float + #+double-double double-double-float) complex) (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (log base))))) (((foreach (complex float) (complex rational)) - (foreach complex double-float single-float)) + (foreach complex double-float single-float #+double-double double-double-float)) (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (log base))))))))) @@ -422,6 +434,14 @@ (((foreach single-float fixnum bignum ratio) double-float) (/ (log (coerce number 'double-float)) (log base))) + #+double-double + ((double-double-float + (foreach double-double-float double-float single-float fixnum bignum ratio)) + (/ (log number) (log (coerce base 'double-double-float)))) + #+double-double + (((foreach double-float single-float fixnum bignum ratio) + double-double-float) + (/ (log (coerce number 'double-double-float)) (log base))) (((foreach single-float fixnum bignum ratio) (foreach single-float fixnum bignum ratio)) ;; Converting everything to double-float helps the @@ -481,6 +501,12 @@ (complex (log (- number)) (coerce pi '(dispatch-type number))) (coerce (%log (coerce number 'double-float)) '(dispatch-type number)))) + #+double-double + ((double-double-float) + (let ((hi (kernel:double-double-hi number))) + (if (< (float-sign hi) 0d0) + (complex (dd-%log (- number)) dd-pi) + (dd-%log number)))) ((complex) (complex-log number))))) @@ -496,8 +522,15 @@ (complex-sqrt number) (coerce (%sqrt (coerce number 'double-float)) '(dispatch-type number)))) - ((complex) - (complex-sqrt number)))) + #+double-double + ((double-double-float) + (if (minusp number) + (dd-complex-sqrt number) + (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)))) ;;;; Trigonometic and Related Functions @@ -505,8 +538,25 @@ (defun abs (number) "Returns the absolute value of the number." (number-dispatch ((number number)) - (((foreach single-float double-float fixnum rational)) + (((foreach single-float double-float fixnum rational + #+double-double double-double-float)) (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))) + #+(and nil 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 +568,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 +591,11 @@ (if (minusp (float-sign number)) (coerce pi 'double-float) 0.0d0)) + #+double-double + (double-double-float + (if (minusp (float-sign number)) + dd-pi + 0w0)) (complex (atan (imagpart number) (realpart number))))) @@ -588,7 +646,14 @@ (>= number (coerce -1 '(dispatch-type number))))) (coerce (%asin (coerce number 'double-float)) '(dispatch-type number)) - (complex-asin number))) + (complex-asin number))) + #+double-double + ((double-double-float) + (if (or (float-nan-p number) + (and (<= number 1w0) + (>= number -1w0))) + (dd-%asin number) + (dd-complex-asin number))) ((complex) (complex-asin number)))) @@ -605,7 +670,14 @@ (>= number (coerce -1 '(dispatch-type number))))) (coerce (%acos (coerce number 'double-float)) '(dispatch-type number)) - (complex-acos number))) + (complex-acos number))) + #+double-double + ((double-double-float) + (if (or (float-nan-p number) + (and (<= number 1w0) + (>= number -1w0))) + (dd-%acos number) + (complex-acos number))) ((complex) (complex-acos number)))) @@ -634,7 +706,15 @@ (((foreach single-float fixnum bignum ratio) (foreach single-float fixnum bignum ratio)) (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float)) - 'single-float)))) + 'single-float)) + #+double-double + ((double-double-float + (foreach double-double-float double-float single-float fixnum bignum ratio)) + (dd-%atan2 y (coerce x 'double-double-float))) + #+double-double + (((foreach double-float single-float fixnum bignum ratio) + double-double-float) + (dd-%atan2 (coerce y 'double-double-float) x)))) (number-dispatch ((y number)) (handle-reals %atan y) ((complex) @@ -687,6 +767,11 @@ (complex-acosh number) (coerce (%acosh (coerce number 'double-float)) '(dispatch-type number)))) + #+double-double + ((double-double-float) + (if (< number 1w0) + (complex-acosh number) + (dd-%acosh number))) ((complex) (complex-acosh number)))) @@ -704,6 +789,12 @@ (complex-atanh number) (coerce (%atanh (coerce number 'double-float)) '(dispatch-type number)))) + #+double-double + ((double-double-float) + (if (or (> number 1w0) + (< number -1w0)) + (complex-atanh number) + (dd-%atanh (coerce number 'double-double-float)))) ((complex) (complex-atanh number)))) @@ -773,7 +864,7 @@ (declaim (inline square)) (defun square (x) - (declare (double-float x)) + (declare (float x)) (* x x)) ;; If you have these functions in libm, perhaps they should be used @@ -784,7 +875,7 @@ (defun scalb (x n) "Compute 2^N * X without compute 2^N first (use properties of the underlying floating-point format" - (declare (type double-float x) + (declare (type float x) (type double-float-exponent n)) (scale-float x n)) @@ -792,7 +883,7 @@ underlying floating-point format" (defun logb-finite (x) "Same as logb but X is not infinity and non-zero and not a NaN, so that we can always return an integer" - (declare (type double-float x)) + (declare (type float x)) (multiple-value-bind (signif expon sign) (decode-float x) (declare (ignore signif sign)) @@ -809,7 +900,7 @@ For the special cases, the following values are used: +/- infinity +infinity 0 -infinity " - (declare (type double-float x)) + (declare (type float x)) (cond ((float-nan-p x) x) ((float-infinity-p x) @@ -817,7 +908,7 @@ For the special cases, the following values are used: ((zerop x) ;; The answer is negative infinity, but we are supposed to ;; signal divide-by-zero, so do the actual division - (/ -1.0d0 x) + (/ -1 x) ) (t (logb-finite x)))) @@ -884,6 +975,9 @@ and Y are coerced to single-float." Z may be any number, but the result is always a complex." (declare (number z)) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-sqrt (dd-complex-sqrt z))) (multiple-value-bind (rho k) (cssqs z) (declare (type (or (member 0d0) (double-float 0d0)) rho) @@ -960,6 +1054,9 @@ This is for use with J /= 0 only when |z| is huge." Z may be any number, but the result is always a complex." (declare (number z)) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-log (dd-complex-log-scaled z 0))) (complex-log-scaled z 0)) ;; Let us note the following "strange" behavior. atanh 1.0d0 is @@ -970,6 +1067,10 @@ Z may be any number, but the result is always a complex." (defun complex-atanh (z) "Compute atanh z = (log(1+z) - log(1-z))/2" (declare (number z)) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-atanh (dd-complex-atanh z))) + (if (and (realp z) (< z -1)) ;; atanh is continuous in quadrant III in this case. (complex-atanh (complex z -0f0)) @@ -1030,6 +1131,10 @@ Z may be any number, but the result is always a complex." (defun complex-tanh (z) "Compute tanh z = sinh z / cosh z" (declare (number z)) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-tanh (dd-complex-tanh z))) + (let ((x (float (realpart z) 1.0d0)) (y (float (imagpart z) 1.0d0))) (locally @@ -1113,6 +1218,9 @@ Z may be any number, but the result is always a complex." Z may be any number, but the result is always a complex." (declare (number z)) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-acos (dd-complex-acos z))) (if (and (realp z) (> z 1)) ;; acos is continuous in quadrant IV in this case. (complex-acos (complex z -0f0)) @@ -1143,6 +1251,9 @@ Z may be any number, but the result is always a complex." Z may be any number, but the result is always a complex." (declare (number z)) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-asin (dd-complex-asin z))) (if (and (realp z) (> z 1)) ;; asin is continuous in quadrant IV in this case. (complex-asin (complex z -0f0)) @@ -1160,6 +1271,9 @@ Z may be any number, but the result is always a complex." Z may be any number, but the result is always a complex." (declare (number z)) ;; asinh z = -i * asin (i*z) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-asinh (dd-complex-asinh z))) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-asin iz))) (complex (imagpart result) @@ -1171,6 +1285,9 @@ Z may be any number, but the result is always a complex." Z may be any number, but the result is always a complex." (declare (number z)) ;; atan z = -i * atanh (i*z) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-atan (dd-complex-atan z))) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-atanh iz))) (complex (imagpart result) @@ -1182,6 +1299,9 @@ Z may be any number, but the result is always a complex." Z may be any number, but the result is always a complex." (declare (number z)) ;; tan z = -i * tanh(i*z) + #+double-double + (when (typep z '(or double-double-float (complex double-double-float))) + (return-from complex-tan (dd-complex-tan z))) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-tanh iz))) (complex (imagpart result) diff --git a/code/kernel.lisp b/code/kernel.lisp index ad4e52eb299b103b0106ca1f24cfda382ff4f4eb..eb517322cfe6d2be1332e5a76a570e11a7918f14 100644 --- a/code/kernel.lisp +++ b/code/kernel.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/code/kernel.lisp,v 1.15 2005/06/19 02:48:08 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.16 2006/06/30 18:41:22 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -141,6 +141,31 @@ #+long-float (defun make-long-float (exp hi #+sparc mid lo) (make-long-float exp hi #+sparc mid lo)) + +#+double-double +(defun %make-double-double-float (hi lo) + (%make-double-double-float hi lo)) + +#+double-double +(declaim (inline make-double-double-float)) +#+double-double +(defun make-double-double-float (hi lo) + ;; Make sure the parts make sense for a double-double + (declare (double-float hi lo) + (inline float-infinity-p float-nan-p)) + (if (or (float-infinity-p hi) (float-nan-p hi)) + (%make-double-double-float hi lo) + (multiple-value-bind (s e) + (c::two-sum hi lo) + (%make-double-double-float s e)))) + +#+double-double +(defun double-double-hi (x) + (double-double-hi x)) +#+double-double +(defun double-double-lo (x) + (double-double-lo x)) + (defun single-float-bits (x) (single-float-bits x)) (defun double-float-high-bits (x) (double-float-high-bits x)) (defun double-float-low-bits (x) (double-float-low-bits x)) diff --git a/code/lispinit.lisp b/code/lispinit.lisp index 28eb09647d1bb64e9a53903020dd5f6d5dd43b5b..4cd582c65608e34dc5d368e9546e19ea62c19fff 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.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/code/lispinit.lisp,v 1.75 2004/10/19 20:13:30 cwang Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.76 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -41,6 +41,9 @@ #+heap-overflow-check (sys:register-lisp-runtime-feature :heap-overflow-check) +#+double-double +(sys:register-lisp-feature :double-double) + ;;; Make the error system enable interrupts. (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum diff --git a/code/load.lisp b/code/load.lisp index 061e3fd23c1f982b1495e2a17523933e29ac3ef3..badc00ead527d494d9f52e13cbe691ef9d1485d7 100644 --- a/code/load.lisp +++ b/code/load.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/code/load.lisp,v 1.90 2005/04/14 20:52:03 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.91 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -874,6 +874,53 @@ (make-long-float exp hi #+sparc mid lo)) (done-with-fast-read-byte)))) +#+double-double +(define-fop (fop-double-double-float 67) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let ((hi-lo (fast-read-u-integer 4)) + (hi-hi (fast-read-s-integer 4)) + (lo-lo (fast-read-u-integer 4)) + (lo-hi (fast-read-s-integer 4))) + (kernel::make-double-double-float + (make-double-float hi-hi hi-lo) + (make-double-float lo-hi lo-lo))) + (done-with-fast-read-byte)))) + +#+double-double +(define-fop (fop-double-double-float-vector 88) + (let* ((length (read-arg 4)) + (result (make-array length :element-type 'double-double-float))) + (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 4)) + result)) + +#+double-double +(define-fop (fop-complex-double-double-float 89) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (let* ((real-hi-lo (fast-read-u-integer 4)) + (real-hi-hi (fast-read-s-integer 4)) + (real-lo-lo (fast-read-u-integer 4)) + (real-lo-hi (fast-read-s-integer 4)) + (re (kernel::make-double-double-float + (make-double-float real-hi-hi real-hi-lo) + (make-double-float real-lo-hi real-lo-lo))) + (imag-hi-lo (fast-read-u-integer 4)) + (imag-hi-hi (fast-read-s-integer 4)) + (imag-lo-lo (fast-read-u-integer 4)) + (imag-lo-hi (fast-read-s-integer 4)) + (im (kernel::make-double-double-float + (make-double-float imag-hi-hi imag-hi-lo) + (make-double-float imag-lo-hi imag-lo-lo)))) + (complex re im)) + (done-with-fast-read-byte)))) + +#+double-double +(define-fop (fop-complex-double-double-float-vector 90) + (let* ((length (read-arg 4)) + (result (make-array length :element-type '(complex double-double-float)))) + (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 8)) + result)) ;;;; Loading lists: diff --git a/code/numbers.lisp b/code/numbers.lisp index 0ba4c361b7d320e9325af0910f6ce2398d5385fe..eebad8419159a188daaca6ccbaa0848a7267d740 100644 --- a/code/numbers.lisp +++ b/code/numbers.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/code/numbers.lisp,v 1.60 2004/09/08 16:09:28 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.61 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -76,7 +76,8 @@ ;;; probable first.) ;;; (defconstant type-test-ordering - '(fixnum single-float double-float integer #+long-float long-float bignum + '(fixnum single-float double-float integer #+long-float long-float + #+double-double double-double-float bignum complex ratio)) ;;; Type-Test-Order -- Internal @@ -167,8 +168,59 @@ ;;;; Binary operation dispatching utilities: +;; These are helper functions to get two-arg arithmetic working. +#+double-double +(progn +(defun dd-+ (a b) + (multiple-value-bind (x y) + (c::add-dd (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b)) + (make-double-double-float x y))) + +(defun dd-- (a b) + (multiple-value-bind (x y) + (c::sub-dd (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b)) + (make-double-double-float x y))) + +(defun dd-* (a b) + (multiple-value-bind (x y) + (c::mul-dd (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b)) + (make-double-double-float x y))) + +(defun dd-/ (a b) + (multiple-value-bind (x y) + (c::div-dd (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b)) + (make-double-double-float x y))) +) + + (eval-when (compile eval) +#+double-double +(defun dd-contagion (op) + (case op + (+ 'dd-+) + (- 'dd--) + (* 'dd-*) + (/ 'dd-/) + (otherwise op))) + +#+double-double +(defun dd-contagion (op) + op) + + ;;; FLOAT-CONTAGION -- Internal ;;; ;;; Return NUMBER-DISPATCH forms for rational X float. @@ -176,9 +228,11 @@ (defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio))) `(((single-float single-float) (,op ,x ,y)) (((foreach ,@rat-types) - (foreach single-float double-float #+long-float long-float)) + (foreach single-float double-float #+long-float long-float + #+double-double double-double-float)) (,op (coerce ,x '(dispatch-type ,y)) ,y)) - (((foreach single-float double-float #+long-float long-float) + (((foreach single-float double-float #+long-float long-float + #+double-double double-double-float) (foreach ,@rat-types)) (,op ,x (coerce ,y '(dispatch-type ,x)))) #+long-float @@ -187,6 +241,12 @@ #+long-float ((long-float (foreach single-float double-float)) (,op ,x (coerce ,y 'long-float))) + #+double-double + (((foreach single-float double-float double-double-float) double-double-float) + (,(dd-contagion op) (coerce ,x 'double-double-float) ,y)) + #+double-double + ((double-double-float (foreach single-float double-float)) + (,(dd-contagion op) ,x (coerce ,y 'double-double-float))) (((foreach single-float double-float) double-float) (,op (coerce ,x 'double-float) ,y)) ((double-float single-float) @@ -225,6 +285,10 @@ ((and (typep realpart 'long-float) (typep imagpart 'long-float)) (truly-the (complex long-float) (complex realpart imagpart))) + #+double-double + ((and (typep realpart 'double-double-float) + (typep imagpart 'double-double-float)) + (truly-the (complex double-double-float) (complex realpart imagpart))) ((and (typep realpart 'double-float) (typep imagpart 'double-float)) (truly-the (complex double-float) (complex realpart imagpart))) @@ -281,6 +345,9 @@ #+long-float ((subtypep spec 'long-float) 'long-float) + #+double-double + ((subtypep spec 'double-double-float) + 'double-double-float) ((subtypep spec 'rational) 'rational) ((subtypep spec 'real) @@ -310,6 +377,11 @@ (typep imagpart 'long-float)) (truly-the (complex long-float) (complex realpart imagpart))) + #+double-double + ((and (typep realpart 'double-double-float) + (typep imagpart 'double-double-float)) + (truly-the (complex double-double-float) + (complex realpart imagpart))) ((and (typep realpart 'double-float) (typep imagpart 'double-float)) (truly-the (complex double-float) @@ -331,6 +403,9 @@ #+long-float ((complex long-float) (truly-the long-float (realpart number))) + #+double-double + ((complex double-double-float) + (truly-the double-double-float (realpart number))) ((complex double-float) (truly-the double-float (realpart number))) ((complex single-float) @@ -346,6 +421,9 @@ #+long-float ((complex long-float) (truly-the long-float (imagpart number))) + #+double-double + ((complex double-double-float) + (truly-the double-double-float (imagpart number))) ((complex double-float) (truly-the double-float (imagpart number))) ((complex single-float) @@ -445,7 +523,9 @@ (,op (imagpart x) (imagpart y)))) (((foreach bignum fixnum ratio single-float double-float - #+long-float long-float) complex) + #+long-float long-float + #+double-double double-double-float) + complex) (complex (,op x (realpart y)) (,op 0 (imagpart y)))) ((complex (or rational float)) @@ -516,7 +596,8 @@ (iy (imagpart y))) (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) (((foreach bignum fixnum ratio single-float double-float - #+long-float long-float) + #+long-float long-float + #+double-double double-double-float) complex) (complex*real y x)) ((complex (or rational float)) @@ -630,6 +711,11 @@ (number-dispatch ((n number)) (((foreach fixnum single-float double-float #+long-float long-float)) (%negate n)) + #+double-double + ((double-double-float) + (multiple-value-bind (hi lo) + (c::neg-dd (kernel:double-double-hi n) (kernel:double-double-lo n)) + (kernel:make-double-double-float hi lo))) ((bignum) (negate-bignum n)) ((ratio) @@ -666,7 +752,8 @@ ((bignum bignum) (bignum-truncate number divisor)) - (((foreach single-float double-float #+long-float long-float) + (((foreach single-float double-float #+long-float long-float + #+double-double double-double-float) (or rational single-float)) (if (eql divisor 1) (let ((res (%unary-truncate number))) @@ -678,6 +765,12 @@ #+long-float (((foreach double-float single-float) long-float) (truncate-float long-float)) + #+double-double + ((double-double-float (or single-float double-float)) + (truncate-float double-double-float)) + #+double-double + (((foreach single-float double-float) double-double-float) + (truncate-float double-double-float)) ((double-float (or single-float double-float)) (truncate-float double-float)) ((single-float double-float) @@ -784,7 +877,7 @@ (multiple-value-bind (q r) (truncate number divisor) (values (float q) r))) - (((foreach single-float double-float) + (((foreach single-float double-float #+double-double double-double-float) (or rational single-float)) (if (eql divisor 1) (let ((res (%unary-ftruncate number))) @@ -795,8 +888,15 @@ ((single-float double-float) (truncate-float double-float)) (((foreach fixnum bignum ratio) - (foreach single-float double-float)) - (truncate-float (dispatch-type divisor)))))) + (foreach single-float double-float #+double-double double-double-float)) + (truncate-float (dispatch-type divisor))) + #+double-double + ((double-double-float (or single-float double-float double-double-float)) + (truncate-float double-double-float)) + #+double-double + (((foreach single-float double-float) + double-double-float) + (truncate-float double-double-float))))) (defun ffloor (number &optional (divisor 1)) @@ -910,8 +1010,42 @@ (declare (list nlist)) (if (< (car nlist) result) (setq result (car nlist))))) +;; These are helper functions to get two-arg comparison working +#+double-double +(progn +(defun dd-< (a b) + (c::dd< (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) +(defun dd-> (a b) + (c::dd> (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) +(defun dd-= (a b) + (c::dd= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) +) + (eval-when (compile eval) +;; This is a hack to get two-arg comparison functions going. Convert +;; the op to equivalent dd op. Once the deftransforms are in place, +;; these should go away. +#+nil +(defun dd-op (op) + (case op + (< 'dd-<) + (> 'dd->) + (= 'dd-=) + (otherwise op))) + +(defun dd-op (op) + op) + (defun basic-compare (op) `(((fixnum fixnum) (,op x y)) @@ -922,11 +1056,19 @@ #+long-float ((long-float (foreach single-float double-float)) (,op x (coerce y 'long-float))) + #+double-double + (((foreach single-float double-float double-double-float) double-double-float) + (,(dd-op op) (coerce x 'double-double-float) y)) + #+double-double + ((double-double-float (foreach single-float double-float)) + (,(dd-op op) x (coerce y 'double-double-float))) (((foreach single-float double-float) double-float) (,op (coerce x 'double-float) y)) ((double-float single-float) (,op x (coerce y 'double-float))) - (((foreach single-float double-float #+long-float long-float) rational) + (((foreach single-float double-float #+long-float long-float + #+double-double double-double-float) + rational) ;; Comparing infinity against any rational produces the same ;; answer as comparing infinity against 0. Comparison against ;; zero is quite common, so add a special case for that. @@ -993,7 +1135,9 @@ (and (= (realpart x) (realpart y)) (= (imagpart x) (imagpart y)))) (((foreach fixnum bignum ratio single-float double-float - #+long-float long-float) complex) + #+long-float long-float + #+double-double double-double-float) + complex) (and (= x (realpart y)) (zerop (imagpart y)))) ((complex (or float rational)) diff --git a/code/pred.lisp b/code/pred.lisp index 35b3c38b6262e7a6fffc031d9713a66ec6c8ab36..0a43965155dcd531a2333ff07e82d271cedfdfe1 100644 --- a/code/pred.lisp +++ b/code/pred.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/code/pred.lisp,v 1.59 2003/06/06 12:22:33 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.60 2006/06/30 18:41:22 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -16,7 +16,10 @@ (in-package "KERNEL") (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p - %typep class-cell-typep)) + %typep class-cell-typep)) + +#+double-double +(export '(double-double-float-p)) (in-package "SYSTEM") (export '(system-area-pointer system-area-pointer-p)) @@ -57,8 +60,10 @@ complex-double-float-p complex-float-p #+long-float complex-long-float-p + #+double-double complex-double-double-float-p complex-rational-p complex-single-float-p + #+double-double double-double-float-p double-float-p fdefn-p fixnump @@ -101,9 +106,11 @@ simple-array-single-float-p simple-array-double-float-p #+long-float simple-array-long-float-p + #+double-double simple-array-double-double-float-p simple-array-complex-single-float-p simple-array-complex-double-float-p #+long-float simple-array-complex-long-float-p + #+double-double simple-array-complex-double-double-float-p ))) (macrolet @@ -223,6 +230,7 @@ (single-float (typep num 'single-float)) (double-float (typep num 'double-float)) (long-float (typep num 'long-float)) + (double-double-float (typep num 'double-double-float)) ((nil) (floatp num)))) ((nil) t))) (flet ((bound-test (val) diff --git a/code/print.lisp b/code/print.lisp index b993f158f338674b039ea79495eca228d9940f2f..9c5739f3c890111b9ed1f8afdd0efb10d515e01c 100644 --- a/code/print.lisp +++ b/code/print.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/code/print.lisp,v 1.110 2006/05/01 16:10:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.111 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1570,7 +1570,7 @@ radix-R. If you have a power-list then pass it in as PL." ;;; out a large factor, since there is more negative exponent range than ;;; positive range. ;;; -(defun scale-exponent (original-x) +(defun scale-exponent-double (original-x) (let* ((x (coerce original-x 'long-float))) (multiple-value-bind (sig exponent) (decode-float x) @@ -1596,6 +1596,44 @@ radix-R. If you have a power-list then pass it in as PL." ((>= z 0.1l0) (values (float z original-x) ex)))))))))) +;; Like scale-exponent-double but for double-double-float. +(defun scale-exponent-double-double (original-x) + (let* ((x original-x)) + (multiple-value-bind (sig exponent) + (decode-float x) + (declare (ignore sig)) + (if (= x 0) + (values (float 0 original-x) 1) + (let* ((ex (round (* exponent (log 2l0 10)))) + (x (if (minusp ex) + (if (float-denormalized-p x) + #-long-float + (* x (expt 10 16) (expt 10 (- (- ex) 16))) + #+long-float + (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) + (* x 10 (expt 10 (- (- ex) 1)))) + (/ x 10 (expt 10 (1- ex)))))) + (do ((d 10 (* d 10)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y 1) + (do ((m 10 (* m 10)) + (z y (* y m)) + (ex ex (1- ex))) + ((>= (* 10 z) 1) + (values (float z original-x) ex)))))))))) + +#-double-double +(defun scale-exponent (original-x) + (scale-exponent-double original-x)) + +#+double-double +(defun scale-exponent (original-x) + ;; We split this into two types because we don't want + ;; double-double-float to slow down printing double-floats. + (if (typep original-x 'double-double-float) + (scale-exponent-double-double original-x) + (scale-exponent-double original-x))) ;;;; Entry point for the float printer. @@ -1642,7 +1680,9 @@ radix-R. If you have a power-list then pass it in as PL." (single-float #\f) (double-float #\d) (short-float #\s) - (long-float #\L)) + (long-float #\L) + #+double-double + (double-double-float #\w)) exp)))) @@ -1656,7 +1696,9 @@ radix-R. If you have a power-list then pass it in as PL." (single-float "SINGLE-FLOAT") (double-float "DOUBLE-FLOAT") (short-float "SHORT-FLOAT") - (long-float "LONG-FLOAT"))) + (long-float "LONG-FLOAT") + #+double-double + (double-double-float "DOUBLE-DOUBLE-FLOAT"))) ;;; OUTPUT-FLOAT-INFINITY -- Internal @@ -1712,6 +1754,13 @@ radix-R. If you have a power-list then pass it in as PL." (output-float-infinity x stream)) ((float-nan-p x) (output-float-nan x stream)) + #+(and nil double-double) + ((typep x 'double-double-float) + ;; This is a temporary hack until we get more double-double float + ;; stuff in place so that we don't need this. And being able to + ;; print double-double's now is quite handy while we debug the + ;; rest of the code. + (output-double-double-float x stream)) (t (let ((x (cond ((minusp (float-sign x)) (write-char #\- stream) @@ -1727,12 +1776,67 @@ radix-R. If you have a power-list then pass it in as PL." output-float-free-format-exponent-min output-float-free-format-exponent-max))))))) +#+double-double +(defun output-double-double-float (x stream) + (dd->string (kernel:double-double-hi x) + (kernel:double-double-lo x) + stream)) + +;;; The code below for printing double-double's was written by Richard +;;; Fateman. Used with permission. + +#+double-double +(defvar *dd-digits-to-show* 33) + +#+double-double +(defun dd->lisp (a0 a1) + "Convert a DD number to a lisp rational" + (declare (double-float a0 a1)) + (+ (rational a0) (rational a1))) + +#+double-double +;; r rational number >=0 +;; n number of digits +(defun decimalize (r n &optional (base 10)) + (let* ((expon (if (= r 0) + 0 + (floor (cl::log (cl::abs r) base)))) + (frac (round (* (cl::abs r) + (expt base (- n expon)))))) + (values (signum r) + frac + (if (= frac 0) + 0 + (cl::1+ expon))))) + +#+double-double +(defun dd->string (x0 x1 stream) + "Print out a double-double to a string" + (cond ((and (zerop x0) (zerop x1)) + (format stream "0.dd0")) + (t + (multiple-value-bind (s r e h) + (decimalize (dd->lisp x0 x1) *dd-digits-to-show* 10) + ;; This is slightly modified from Richard Fateman's version to + ;; print numbers in the format x.xxddee instead of 0.xxddee. + (let ((out (string-right-trim "0" + (subseq (setf h (format nil "~A~%" r)) + 0 + (min (length h) *dd-digits-to-show*))))) + (format stream "~A~A.~Aw~S" + (if (< s 0) "-" "") + (aref out 0) + (subseq out 1) + (1- e))))))) + ;; Smallest possible (unbiased) exponents (defconstant double-float-min-e (nth-value 1 (decode-float least-positive-double-float))) (defconstant single-float-min-e (nth-value 1 (decode-float least-positive-single-float))) +#+double-double +(defconstant double-double-float-min-e double-float-min-e) ;;; Implementation of Figure 1 from "Printing Floating-Point Numbers ;;; Quickly and Accurately", by Burger and Dybvig, 1996. As the @@ -1758,7 +1862,9 @@ radix-R. If you have a power-list then pass it in as PL." (min-e (etypecase v (single-float single-float-min-e) - (double-float double-float-min-e)))) + (double-float double-float-min-e) + #+double-double + (double-double-float double-double-float-min-e)))) (multiple-value-bind (f e) (integer-decode-float v) (let ( ;; FIXME: these even tests assume normal IEEE rounding diff --git a/code/reader.lisp b/code/reader.lisp index 0d023757f83fe96b61676bd937c56f8025552197..cab4a3446728c543599f1e1316f681655b7ab266 100644 --- a/code/reader.lisp +++ b/code/reader.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/code/reader.lisp,v 1.60 2006/02/19 19:33:49 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.61 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -275,6 +275,10 @@ (set-secondary-attribute #\d #.constituent-expt) (set-secondary-attribute #\s #.constituent-expt) (set-secondary-attribute #\l #.constituent-expt) + #+double-double + (progn + (set-secondary-attribute #\W #.constituent-expt) + (set-secondary-attribute #\w #.constituent-expt)) ;; See CLHS 2.1.4.2 for the list of constituent characters that are ;; invalid constituent characters. (set-secondary-attribute #\Space #.constituent-invalid) @@ -1374,7 +1378,9 @@ ;;;; Number reading functions. (defmacro exponent-letterp (letter) - `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d))) + `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d + #+double-double #\w + #+double-double #\W))) (defvar *integer-reader-safe-digits* @@ -1565,7 +1571,9 @@ the end of the stream." (#\S 'short-float) (#\F 'single-float) (#\D 'double-float) - (#\L 'long-float))) + (#\L 'long-float) + #+double-double + (#\W 'kernel:double-double-float))) num) (setq num (make-float-aux (* (expt 10 exponent) number) divisor float-format stream)) diff --git a/code/room.lisp b/code/room.lisp index 4565b777ddcaa7d6495809fa200d8a0d0a2bce3b..ac299bc2ed5f0f7e63ca0415e044bf29d37821d0 100644 --- a/code/room.lisp +++ b/code/room.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/code/room.lisp,v 1.34 2004/10/19 20:12:45 cwang Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.35 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -91,7 +91,12 @@ (simple-array-single-float-type . 2) (simple-array-double-float-type . 3) (simple-array-complex-single-float-type . 3) - (simple-array-complex-double-float-type . 4))) + (simple-array-complex-double-float-type . 4) + #+double-double + (simple-array-double-double-float-type . 4) + #+double-double + (simple-array-complex-double-double-float-type . 5) + )) (let ((name (car stuff)) (size (cdr stuff))) (setf (svref *meta-room-info* (symbol-value name)) @@ -477,6 +482,12 @@ ((#.bignum-type #.single-float-type #.double-float-type + #+double-double + #.double-double-float-type + #.complex-single-float-type + #.complex-double-float-type + #+double-double + #.complex-double-double-float-type #.simple-string-type #.simple-bit-vector-type #.simple-array-unsigned-byte-2-type @@ -490,8 +501,12 @@ #.simple-array-signed-byte-32-type #.simple-array-single-float-type #.simple-array-double-float-type + #+double-double + #.simple-array-double-double-float-type #.simple-array-complex-single-float-type - #.simple-array-complex-double-float-type) + #.simple-array-complex-double-float-type + #+double-double + #.simple-array-complex-double-double-float-type) (incf non-descriptor-headers) (incf non-descriptor-bytes (- size word-bytes))) ((#.list-pointer-type @@ -510,7 +525,10 @@ #.symbol-header-type #.sap-type #.weak-pointer-type - #.instance-header-type) + #.instance-header-type + #.fdefn-type + #+gencgc + #.scavenger-hook-type) (incf descriptor-words (truncate size word-bytes))) (t (error "Bogus type: ~D" type)))) diff --git a/code/seq.lisp b/code/seq.lisp index 4988b069ef34876cea28d9852bffe1f1b09cb390..ada87a026c5f9259e85e221ee521628b5170f1d2 100644 --- a/code/seq.lisp +++ b/code/seq.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/code/seq.lisp,v 1.52 2005/02/25 18:21:21 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.53 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1014,6 +1014,9 @@ #+long-float ((csubtypep type (specifier-type 'long-float)) (output-type-or-lose (%long-float object))) + #+double-double + ((csubtypep type (specifier-type 'double-double-float)) + (output-type-or-lose (%double-double-float object))) ((csubtypep type (specifier-type 'float)) (output-type-or-lose (%single-float object))) ((csubtypep type (specifier-type '(complex single-float))) @@ -1026,6 +1029,10 @@ ((csubtypep type (specifier-type '(complex long-float))) (complex (%long-float (realpart object)) (%long-float (imagpart object)))) + #+double-double + ((csubtypep type (specifier-type '(complex double-double-float))) + (complex (%double-double-float (realpart object)) + (%double-double-float (imagpart object)))) ((csubtypep type (specifier-type '(complex float))) (complex (%single-float (realpart object)) (%single-float (imagpart object)))) diff --git a/code/type.lisp b/code/type.lisp index 2d1f221fed4598f3cf93e6f09019e468fa721c36..3089dc99f22bf1b14cab72b96394808b3563c2e9 100644 --- a/code/type.lisp +++ b/code/type.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/code/type.lisp,v 1.71 2005/05/09 15:56:03 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.72 2006/06/30 18:41:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1894,7 +1894,8 @@ ;;; (eval-when (compile load eval) (defconstant float-formats - '(long-float double-float single-float short-float))) + '(#+double-double double-double-float + long-float double-float single-float short-float))) ;;; The type of a float format. ;;; @@ -2214,6 +2215,8 @@ (double-float (specifier-type '(complex double-float))) #+long-float (long-float (specifier-type '(complex long-float))) + #+double-double + (double-double-float (specifier-type '(complex double-double-float))) (rational (specifier-type '(complex rational))) (t (specifier-type '(complex real)))))) (let ((ctype (specifier-type typespec))) @@ -2411,7 +2414,9 @@ ,(coerced-float-bound high 'single-float)) (double-float ,(coerced-float-bound low 'double-float) ,(coerced-float-bound high 'double-float)) - #+long-float ,(error "stub: no long float support yet")))) + #+long-float ,(error "stub: no long float support yet") + ;; This needs to be fixed so that we can compute the bounds + #+double-double (double-double-float * *)))) (defmacro define-float-format (f) `(def-bounded-type ,f float ,f)) @@ -2420,6 +2425,8 @@ (define-float-format single-float) (define-float-format double-float) (define-float-format long-float) +#+double-double +(define-float-format double-double-float) (defun numeric-types-intersect (type1 type2) (declare (type numeric-type type1 type2)) @@ -2589,12 +2596,15 @@ ((nil) ;; A double-float with any real number is a ;; double-float. - #-long-float + #-(and long-float (not double-double)) (if (eq format1 'double-float) 'double-float nil) ;; A long-float with any real number is a ;; long-float. - #+long-float - (if (eq format1 'long-float) 'long-float nil))) + #+(and long-float (not double-double)) + (if (eq format1 'long-float) 'long-float nil) + #+(and (not long-float) double-double) + (if (eq format1 'double-double-float) 'double-double-float nil) + )) :complexp (if (or (eq complexp1 :complex) (eq complexp2 :complex)) :complex diff --git a/code/typedefs.lisp b/code/typedefs.lisp index 49df2042234920ecc270f44e9218b20ea2261476..321ca4aae24bb98737b823b6342b8057d89def07 100644 --- a/code/typedefs.lisp +++ b/code/typedefs.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/code/typedefs.lisp,v 1.13 2003/04/23 15:19:41 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.14 2006/06/30 18:41:22 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -27,7 +27,8 @@ hash-table integer keyword list long-float nil null number package pathname random-state ratio rational real readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector - single-float standard-char stream string base-char symbol t vector)) + single-float standard-char stream string base-char symbol t vector + #+double-double double-double-float)) ;;; Def-Type-Translator -- Interface diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp index a7fbe4078ce8eb1eafb90ea6e0b3c52eccab8911..8e880245cb881244479d7bc116815a5ef4cbfa4c 100644 --- a/compiler/array-tran.lisp +++ b/compiler/array-tran.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/array-tran.lisp,v 1.40 2005/05/09 13:06:59 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.41 2006/06/30 18:41:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -245,6 +245,9 @@ (double-float 0.0d0 64 vm:simple-array-double-float-type) #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128 vm:simple-array-long-float-type) + #+double-double + (double-double-float 0w0 128 + vm::simple-array-double-double-float-type) (bit 0 1 vm:simple-bit-vector-type) ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type) ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type) @@ -262,6 +265,9 @@ #+long-float ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256 vm:simple-array-complex-long-float-type) + #+double-double + ((complex double-double-float) #C(0.0w0 0.0w0) 256 + vm::simple-array-complex-double-double-float-type) (t 0 32 vm:simple-vector-type))) ;;; MAKE-ARRAY -- source-transform. diff --git a/compiler/dump.lisp b/compiler/dump.lisp index ad189020bdc6141fc7ce2451bea50c9aaeb5abba..e7052734854f684e74692d7eff7322bb2109e29f 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.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/dump.lisp,v 1.81 2005/02/15 18:15:10 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.82 2006/06/30 18:41:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1092,6 +1092,22 @@ (dump-var-signed exp-bits 4 file)) (t (error "Unable to dump long-float"))))) + +#+double-double +(defun dump-double-double-float (float file) + ;; Dump out 2 double-floats + (flet ((dump-double (x) + (declare (double-float x)) + (dump-unsigned-32 (double-float-low-bits x) file) + (dump-var-signed (double-float-high-bits x) 4 file))) + (dump-double (kernel:double-double-hi float)) + (dump-double (kernel:double-double-lo float)))) + +#+double-double +(defun dump-complex-double-double-float (z file) + ;; Dump out 2 double-double-floats + (dump-double-double-float (realpart z) file) + (dump-double-double-float (imagpart z) file)) ;;; Or a complex... @@ -1116,6 +1132,10 @@ (dump-fop 'lisp::fop-complex-long-float file) (dump-long-float (realpart x) file) (dump-long-float (imagpart x) file)) + #+double-double + ((complex double-double-float) + (dump-fop 'lisp::fop-complex-double-double-float file) + (dump-complex-double-double-float x file)) (t (sub-dump-object (realpart x) file) (sub-dump-object (imagpart x) file) @@ -1153,7 +1173,11 @@ #+long-float (long-float (dump-fop 'lisp::fop-long-float file) - (dump-long-float x file)))) + (dump-long-float x file)) + #+double-double + (double-double-float + (dump-fop 'lisp::fop-double-double-float file) + (dump-double-double-float x file)))) ;;;; Symbol Dumping: @@ -1372,6 +1396,10 @@ ((simple-array long-float (*)) (dump-long-float-vector simple-version file) (eq-save-object x file)) + #+double-double + ((simple-array double-double-float (*)) + (dump-double-double-float-vector simple-version file) + (eq-save-object x file)) ((simple-array (complex single-float) (*)) (dump-complex-single-float-vector simple-version file) (eq-save-object x file)) @@ -1382,6 +1410,10 @@ ((simple-array (complex long-float) (*)) (dump-complex-long-float-vector simple-version file) (eq-save-object x file)) + #+double-double + ((simple-array (complex double-double-float) (*)) + (dump-complex-double-double-float-vector simple-version file) + (eq-save-object x file)) (t (dump-i-vector simple-version file) (eq-save-object x file))))) @@ -1494,6 +1526,15 @@ vec (* length vm:word-bytes #+x86 3 #+sparc 4) (* vm:word-bytes #+x86 3 #+sparc 4) file))) +#+double-double +(defun dump-double-double-float-vector (vec file) + (let* ((length (length vec)) + (element-size (* 4 vm:word-bytes)) + (bytes (* length element-size))) + (dump-fop 'lisp::fop-double-double-float-vector file) + (dump-unsigned-32 length file) + (dump-data-maybe-byte-swapping vec bytes element-size file))) + ;;; DUMP-COMPLEX-SINGLE-FLOAT-VECTOR -- internal. ;;; (defun dump-complex-single-float-vector (vec file) @@ -1512,6 +1553,15 @@ (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2 2) (* vm:word-bytes 2) file))) +#+double-double +(defun dump-complex-double-double-float-vector (vec file) + (let* ((length (length vec)) + (element-size (* 8 vm:word-bytes)) + (bytes (* length element-size))) + (dump-fop 'lisp::fop-complex-double-double-float-vector file) + (dump-unsigned-32 length file) + (dump-data-maybe-byte-swapping vec bytes element-size file))) + ;;; DUMP-COMPLEX-LONG-FLOAT-VECTOR -- internal. ;;; #+long-float diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index e8f4c09a08a108793e4322fba43e52cc42990f2b..5da2e8db7cb792ce1b422199b7db3df0ab9c72c9 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.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/float-tran.lisp,v 1.104 2005/06/26 17:21:04 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.105 2006/06/30 18:41:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -37,12 +37,53 @@ (deftransform %double-float ((n) (double-float) * :when :both) 'n) +#+double-double +(progn +(defknown %double-double-float (real) + double-double-float + (movable foldable flushable)) + +(deftransform float ((n prototype) (* double-double-float) * :when :both) + '(%double-double-float n)) + +(deftransform %double-float ((n) (double-double-float) * :when :both) + '(double-double-hi n)) + +(deftransform %single-float ((n) (double-double-float) * :when :both) + '(float (double-double-hi n) 1f0)) + +(deftransform %double-double-float ((n) (double-double-float) * :when :both) + 'n) + +#+nil +(defun %double-double-float (n) + (make-double-double-float (float n 1d0) 0d0)) + +(defun %double-double-float (n) + (typecase n + (fixnum + (make-double-double-float (float n 1d0) 0d0)) + (single-float + (make-double-double-float (float n 1d0) 0d0)) + (double-float + (make-double-double-float (float n 1d0) 0d0)) + (double-double-float + n) + (bignum + (bignum:bignum-to-float n 'double-double-float)) + (ratio + (kernel::float-ratio n 'double-double-float)))) +); progn + (deftransform coerce ((n type) (* *) * :when :both) (unless (constant-continuation-p type) (give-up)) `(the ,(continuation-value type) ,(let ( (tspec (specifier-type (continuation-value type))) ) - (cond ((csubtypep tspec (specifier-type 'double-float)) + (cond #+double-double + ((csubtypep tspec (specifier-type 'double-double-float)) + '(%double-double-float n)) + ((csubtypep tspec (specifier-type 'double-float)) '(%double-float n)) ((csubtypep tspec (specifier-type 'float)) '(%single-float n)) @@ -254,6 +295,26 @@ (values (signed-byte 32) (unsigned-byte 32)) (movable foldable flushable)) +#+double-double +(progn +(defknown double-double-float-p (t) + boolean + (movable foldable flushable)) + +(defknown %make-double-double-float (double-float double-float) + double-double-float + (movable foldable flushable)) + + +(defknown double-double-hi (double-double-float) + double-float + (movable foldable flushable)) + +(defknown double-double-lo (double-double-float) + double-float + (movable foldable flushable)) + +) ; progn (deftransform float-sign ((float &optional float2) (single-float &optional single-float) *) @@ -372,10 +433,17 @@ ;; that might occur. We can ignore underflows which become ;; zeros. (set-bound - (handler-case - (scale-float (bound-value x) n) - (floating-point-overflow () - nil)) + (let ((value (handler-case + (scale-float (bound-value x) n) + (floating-point-overflow () + nil)))) + ;; This check is necessary for ppc because the current + ;; implementation on ppc doesn't signal floating-point + ;; overflow. (How many other places do we need to check + ;; for this?) + (if (and (floatp value) (float-infinity-p value)) + nil + value)) (consp x)))) (when (and (numeric-type-p f) (numeric-type-p ex)) (let ((f-lo (numeric-type-low f)) @@ -395,7 +463,8 @@ ;; might get bounds like 0 and fh*2^nh < 0. Our bounds are ;; backwards. Thus, swap the bounds to get the correct ;; bounds. - (when (and new-lo new-hi (< new-hi new-lo)) + (when (and new-lo new-hi (< (bound-value new-hi) + (bound-value new-lo))) (rotatef new-lo new-hi)) (make-numeric-type :class (numeric-type-class f) :format (numeric-type-format f) @@ -1291,7 +1360,7 @@ ;;; Define some transforms for complex operations. We do this in lieu ;;; of complex operation VOPs. Some architectures have vops, though. ;;; -#-complex-fp-vops +#-(and (not double-double) complex-fp-vops) (macrolet ((frob (type) `(progn ;; Negation @@ -1377,9 +1446,11 @@ ))) (frob single-float) - (frob double-float)) + (frob double-float) + #+double-double + (frob double-double-float)) -#+complex-fp-vops +#+(and (not double-double) complex-fp-vops) (macrolet ((frob (type) `(progn @@ -1487,3 +1558,506 @@ (specifier-type `(complex ,(or (numeric-type-format arg) 'float)))) #'cis)) + +;;; Support for double-double floats +;;; +;;; The algorithms contained herein are based on the code written by +;;; Yozo Hida. See http://www.cs.berkeley.edu/~yozo/ for more +;;; information. + +#+double-double +(progn + +(declaim (inline quick-two-sum)) +(defun quick-two-sum (a b) + "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" + (declare (double-float a b)) + (let* ((s (+ a b)) + (e (- b (- s a)))) + (values s e))) + +(declaim (inline two-sum)) +(defun two-sum (a b) + "Computes fl(a+b) and err(a+b)" + (declare (double-float a b)) + (let* ((s (+ a b)) + (v (- s a)) + (e (+ (- a (- s v)) + (- b v)))) + (values s e))) + +(declaim (inline add-dd)) +(defun add-dd (a0 a1 b0 b1) + "Add the double-double A0,A1 to the double-double B0,B1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3))) + (multiple-value-bind (s1 s2) + (two-sum a0 b0) + (declare (double-float s1 s2)) + (multiple-value-bind (t1 t2) + (two-sum a1 b1) + (declare (double-float t1 t2)) + (incf s2 t1) + (multiple-value-bind (s1 s2) + (quick-two-sum s1 s2) + (declare (double-float s1 s2)) + (incf s2 t2) + (quick-two-sum s1 s2))))) + +(deftransform + ((a b) (vm::double-double-float vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (add-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (kernel:%make-double-double-float hi lo))) + +(declaim (inline quick-two-diff)) +(defun quick-two-diff (a b) + "Compute fl(a-b) and err(a-b), assuming |a| >= |b|" + (declare (double-float a b)) + (let ((s (- a b))) + (values s (- (- a s) b)))) + +(declaim (inline two-diff)) +(defun two-diff (a b) + "Compute fl(a-b) and err(a-b)" + (declare (double-float a b)) + (let* ((s (- a b)) + (v (- s a)) + (e (- (- a (- s v)) + (+ b v)))) + (values s e))) + +(declaim (inline sub-dd)) +(defun sub-dd (a0 a1 b0 b1) + "Subtract the double-double B0,B1 from A0,A1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3))) + (multiple-value-bind (s1 s2) + (two-diff a0 b0) + (declare (double-float s2)) + (multiple-value-bind (t1 t2) + (two-diff a1 b1) + (incf s2 t1) + (multiple-value-bind (s1 s2) + (quick-two-sum s1 s2) + (declare (double-float s2)) + (incf s2 t2) + (quick-two-sum s1 s2))))) + +(declaim (inline sub-d-dd)) +(defun sub-d-dd (a b0 b1) + "Compute double-double = double - double-double" + (declare (double-float a b0 b1) + (optimize (speed 3) (safety 0))) + (multiple-value-bind (s1 s2) + (two-diff a b0) + (declare (double-float s2)) + (decf s2 b1) + (quick-two-sum s1 s2))) + +(declaim (inline sub-dd-d)) +(defun sub-dd-d (a0 a1 b) + "Subtract the double B from the double-double A0,A1" + (declare (double-float a0 a1 b) + (optimize (speed 3) (safety 0))) + (multiple-value-bind (s1 s2) + (two-diff a0 b) + (declare (double-float s2)) + (incf s2 a1) + (quick-two-sum s1 s2))) + +(deftransform - ((a b) (vm::double-double-float vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (sub-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (kernel:%make-double-double-float hi lo))) + +(deftransform - ((a b) (double-float vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (sub-d-dd a + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (kernel:%make-double-double-float hi lo))) + +(deftransform - ((a b) (vm::double-double-float double-float) *) + `(multiple-value-bind (hi lo) + (sub-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + b) + (kernel:%make-double-double-float hi lo))) + +(declaim (inline two-prod)) +(defun two-prod (a b) + "Compute fl(a*b) and err(a*b)" + (declare (double-float a b)) + (let ((p (* a b))) + (multiple-value-bind (a-hi a-lo) + (split a) + ;;(format t "a-hi, a-lo = ~S ~S~%" a-hi a-lo) + (multiple-value-bind (b-hi b-lo) + (split b) + ;;(format t "b-hi, b-lo = ~S ~S~%" b-hi b-lo) + (let ((e (+ (+ (- (* a-hi b-hi) p) + (* a-hi b-lo) + (* a-lo b-hi)) + (* a-lo b-lo)))) + (values p e)))))) + +(declaim (inline split)) +;; This algorithm is the version given by Yozo Hida. It has problems +;; with overflow because we multiply by 1+2^27. +;; +;; But be very careful about replacing this with a new algorithm. The +;; values computed here are very important to get the rounding right. +;; If you change this, the rounding may be different, which will +;; affect other parts of the algorithm. +;; +;; I (rtoy) tried a different algorithm that split the number in two +;; as described, but without overflow. However, that caused +;; -9.4294948327242751340284975915175w0/1w14 to return a value that +;; wasn't really close to -9.4294948327242751340284975915175w-14. +;; +;; This also means we can't print numbers like 1w308 with the current +;; printing algorithm, or even divide 1w308 by 10. +#+nil +(defun split (a) + "Split the double-float number a into a-hi and a-lo such that a = + a-hi + a-lo and a-hi contains the upper 26 significant bits of a and + a-lo contains the lower 26 bits." + (declare (double-float a)) + (let* ((tmp (* a (+ 1 (expt 2 27)))) + (a-hi (- tmp (- tmp a))) + (a-lo (- a a-hi))) + (values a-hi a-lo))) + + +(defun split (a) + "Split the double-float number a into a-hi and a-lo such that a = + a-hi + a-lo and a-hi contains the upper 26 significant bits of a and + a-lo contains the lower 26 bits." + (declare (double-float a) + (optimize (speed 3))) + ;; This splits the number a into 2 halves of 26 bits each, but the + ;; halves are, I think, supposed to be properly rounded in an IEEE + ;; fashion. + ;; + ;; For numbers that are very large, we use a different algorithm. + ;; For smaller numbers, we can use the original algorithm of Yozo + ;; Hida. + (if (> (abs a) (scale-float 1d0 (- 1023 27))) + ;; I've tested this algorithm against Yozo's method for 1 + ;; billion randomly generated double-floats between 2^(-995) and + ;; 2^996, and identical results are obtained. For numbers that + ;; are very small, this algorithm produces different numbers + ;; because of underflow. For very large numbers, we, of course + ;; produce different results because Yozo's method causes + ;; overflow. + (let* ((tmp (* a (+ 1 (scale-float 1d0 -27)))) + (as (* a (scale-float 1d0 -27))) + (a-hi (* (- tmp (- tmp as)) (expt 2 27))) + (a-lo (- a a-hi))) + (values a-hi a-lo)) + ;; Yozo's algorithm. + (let* ((tmp (* a (+ 1 (expt 2 27)))) + (a-hi (- tmp (- tmp a))) + (a-lo (- a a-hi))) + (values a-hi a-lo)))) + + +(declaim (inline two-prod)) +(defun two-prod (a b) + "Compute fl(a*b) and err(a*b)" + (declare (double-float a b)) + (let ((p (* a b))) + (multiple-value-bind (a-hi a-lo) + (split a) + ;;(format t "a-hi, a-lo = ~S ~S~%" a-hi a-lo) + (multiple-value-bind (b-hi b-lo) + (split b) + ;;(format t "b-hi, b-lo = ~S ~S~%" b-hi b-lo) + (let ((e (+ (+ (- (* a-hi b-hi) p) + (* a-hi b-lo) + (* a-lo b-hi)) + (* a-lo b-lo)))) + (values p e)))))) + +(declaim (inline two-sqr)) +(defun two-sqr (a) + "Compute fl(a*a) and err(a*b). This is a more efficient + implementation of two-prod" + (declare (double-float a)) + (let ((q (* a a))) + (multiple-value-bind (a-hi a-lo) + (split a) + (values q (+ (+ (- (* a-hi a-hi) q) + (* 2 a-hi a-lo)) + (* a-lo a-lo)))))) + +(declaim (inline mul-dd-d)) +(defun mul-dd-d (a0 a1 b) + (declare (double-float a0 a1 b) + (optimize (speed 3))) + (multiple-value-bind (p1 p2) + (two-prod a0 b) + (declare (double-float p2)) + ;;(format t "mul-dd-d p1,p2 = ~A ~A~%" p1 p2) + (incf p2 (* a1 b)) + ;;(format t "mul-dd-d p2 = ~A~%" p2) + (quick-two-sum p1 p2))) + +(declaim (inline mul-dd)) +(defun mul-dd (a0 a1 b0 b1) + "Multiply the double-double A0,A1 with B0,B1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3))) + (multiple-value-bind (p1 p2) + (two-prod a0 b0) + (declare (double-float p1 p2)) + (incf p2 (* a0 b1)) + (incf p2 (* a1 b0)) + (multiple-value-bind (p1 p2) + (quick-two-sum p1 p2) + (values p1 p2)))) + +(declaim (inline add-dd-d)) +(defun add-dd-d (a0 a1 b) + "Add the double-double A0,A1 to the double B" + (declare (double-float a0 a1 b) + (optimize (speed 3))) + (multiple-value-bind (s1 s2) + (two-sum a0 b) + (declare (double-float s1 s2)) + (incf s2 a1) + (quick-two-sum s1 s2))) + +(declaim (inline sqr-dd)) +(defun sqr-dd (a0 a1) + (declare (double-float a0 a1) + (optimize (speed 3))) + (multiple-value-bind (p1 p2) + (two-sqr a0) + (declare (double-float p1 p2)) + (incf p2 (* 2 a0 a1)) + ;; Hida's version of sqr (qd-2.1.210) has the following line for + ;; the sqr function. But if you compare this with mul-dd, this + ;; doesn't exist there, and if you leave it in, it produces + ;; results that are different from using mul-dd to square a value. + #+nil + (incf p2 (* a1 a1)) + (quick-two-sum p1 p2))) + +(deftransform + ((a b) (vm::double-double-float (or integer single-float double-float)) *) + `(multiple-value-bind (hi lo) + (add-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (kernel:%make-double-double-float hi lo))) + +(deftransform + ((a b) ((or integer single-float double-float) vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (add-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b) + (float a 1d0)) + (kernel:%make-double-double-float hi lo))) + +#+nil +(deftransform * ((a b) (vm::double-double-float vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (mul-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (kernel:%make-double-double-float hi lo))) + +(deftransform * ((a b) (vm::double-double-float vm::double-double-float) * :node node) + ;; non-const-same-leaf-ref-p is stolen from two-arg-derive-type. + (flet ((non-const-same-leaf-ref-p (x y) + ;; Just like same-leaf-ref-p, but we don't care if the + ;; value of the leaf is constant or not. + (declare (type continuation x y)) + (let ((x-use (continuation-use x)) + (y-use (continuation-use y))) + (and (ref-p x-use) + (ref-p y-use) + (eq (ref-leaf x-use) (ref-leaf y-use)))))) + (destructuring-bind (arg1 arg2) + (combination-args node) + ;; If the two args to * are the same, we square the number + ;; instead of multiply. Squaring is simpler than a full + ;; multiply. + (if (non-const-same-leaf-ref-p arg1 arg2) + `(multiple-value-bind (hi lo) + (sqr-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (kernel:%make-double-double-float hi lo)) + `(multiple-value-bind (hi lo) + (mul-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (kernel:%make-double-double-float hi lo)))))) + +(deftransform * ((a b) (vm::double-double-float (or integer single-float double-float)) *) + `(multiple-value-bind (hi lo) + (mul-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (kernel:%make-double-double-float hi lo))) + +(deftransform * ((a b) ((or integer single-float double-float) vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (mul-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b) + (float a 1d0)) + (kernel:%make-double-double-float hi lo))) + +(declaim (inline div-dd)) +(defun div-dd (a0 a1 b0 b1) + "Divide the double-double A0,A1 by B0,B1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3)) + (inline sub-dd)) + (let ((q1 (/ a0 b0))) + ;; (q1b0, q1b1) = q1*(b0,b1) + ;;(format t "q1 = ~A~%" q1) + (multiple-value-bind (q1b0 q1b1) + (mul-dd-d b0 b1 q1) + ;;(format t "q1*b = ~A ~A~%" q1b0 q1b1) + (multiple-value-bind (r0 r1) + ;; r = a - q1 * b + (sub-dd a0 a1 q1b0 q1b1) + ;;(format t "r = ~A ~A~%" r0 r1) + (let ((q2 (/ r0 b0))) + (multiple-value-bind (q2b0 q2b1) + (mul-dd-d b0 b1 q2) + (multiple-value-bind (r0 r1) + ;; r = r - (q2*b) + (sub-dd r0 r1 q2b0 q2b1) + (declare (ignore r1)) + (let ((q3 (/ r0 b0))) + (multiple-value-bind (q1 q2) + (quick-two-sum q1 q2) + (add-dd-d q1 q2 q3)))))))))) + +(declaim (inline div-dd-d)) +(defun div-dd-d (a0 a1 b) + (declare (double-float a0 a1 b) + (optimize (speed 3))) + (let ((q1 (/ a0 b))) + ;; q1 = approx quotient + ;; Now compute a - q1 * b + (multiple-value-bind (p1 p2) + (two-prod q1 b) + (multiple-value-bind (s e) + (two-diff a0 p1) + (declare (double-float e)) + (incf e a1) + (decf e p2) + ;; Next approx + (let ((q2 (/ (+ s e) b))) + (quick-two-sum q1 q2)))))) + +(deftransform / ((a b) (vm::double-double-float vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (div-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (kernel:%make-double-double-float hi lo))) + +(deftransform / ((a b) (vm::double-double-float (or integer single-float double-float)) *) + `(multiple-value-bind (hi lo) + (div-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (kernel:%make-double-double-float hi lo))) + +(declaim (inline sqr-d)) +(defun sqr-d (a) + "Square" + (declare (double-float a) + (optimize (speed 3))) + (two-sqr a)) + +(declaim (inline mul-d-d)) +(defun mul-d-d (a b) + (two-prod a b)) + +(declaim (inline sqrt-dd)) +(defun sqrt-dd (a0 a1) + (declare (type (double-float 0d0) a0) + (double-float a1) + (optimize (speed 3))) + ;; Strategy: Use Karp's trick: if x is an approximation to sqrt(a), + ;; then + ;; + ;; y = a*x + (a-(a*x)^2)*x/2 + ;; + ;; is an approximation that is accurate to twice the accuracy of x. + ;; Also, the multiplication (a*x) and [-]*x can be done with only + ;; half the precision. + (if (and (zerop a0) (zerop a1)) + (values a0 a1) + (let* ((x (/ (sqrt a0))) + (ax (* a0 x))) + (multiple-value-bind (s0 s1) + (sqr-d ax) + (multiple-value-bind (s2) + (sub-dd a0 a1 s0 s1) + (multiple-value-bind (p0 p1) + (mul-d-d s2 (* x 0.5d0)) + (add-dd-d p0 p1 ax))))))) + +(deftransform sqrt ((a) (vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (sqrt-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (kernel:%make-double-double-float hi lo))) + +(declaim (inline neg-dd)) +(defun neg-dd (a0 a1) + (declare (double-float a0 a1) + (optimize (speed 3))) + (values (- a0) (- a1))) + +(declaim (inline abs-dd)) +(defun abs-dd (a0 a1) + (declare (double-float a0 a1) + (optimize (speed 3))) + (if (minusp a0) + (neg-dd a0 a1) + (values a0 a1))) + +(deftransform abs ((a) (vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (abs-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (kernel:%make-double-double-float hi lo))) + +(deftransform %negate ((a) (vm::double-double-float) *) + `(multiple-value-bind (hi lo) + (neg-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (kernel:%make-double-double-float hi lo))) + +(declaim (inline dd=)) +(defun dd= (a0 a1 b0 b1) + (and (= a0 b0) + (= a1 b1))) + +(declaim (inline dd<)) +(defun dd< (a0 a1 b0 b1) + (or (< a0 b0) + (and (= a0 b0) + (< a1 b1)))) + +(declaim (inline dd>)) +(defun dd> (a0 a1 b0 b1) + (or (> a0 b0) + (and (= a0 b0) + (> a1 b1)))) + +(deftransform = ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) + + +(deftransform < ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd< (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) + + +(deftransform > ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd> (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) + +) ; progn double-double diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp index fde0c57b245cc7d6a3f600d81d116c1b31c0b1a8..b2664f86cd46ef9d72cfc0c2b18ac6a0a6c9a653 100644 --- a/compiler/generic/interr.lisp +++ b/compiler/generic/interr.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/generic/interr.lisp,v 1.12 2002/08/28 13:29:27 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.13 2006/06/30 18:41:23 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -61,6 +61,9 @@ #+long-float (object-not-long-float "Object is not of type LONG-FLOAT.") + #+double-double + (object-not-double-double-float + "Object is not of type DOUBLE-DOUBLE-FLOAT.") (object-not-simple-string "Object is not of type SIMPLE-STRING.") (object-not-simple-bit-vector @@ -155,6 +158,9 @@ #+long-float (object-not-simple-array-long-float "Object is not of type (SIMPLE-ARRAY LONG-FLOAT (*)).") + #+double-double + (object-not-simple-array-double-double-float + "Object is not of type (SIMPLE-ARRAY DOUBLE-DOUBLE-FLOAT (*)).") (object-not-simple-array-complex-single-float "Object is not of type (SIMPLE-ARRAY (COMPLEX SINGLE-FLOAT) (*)).") (object-not-simple-array-complex-double-float @@ -162,6 +168,9 @@ #+long-float (object-not-simple-array-complex-long-float "Object is not of type (SIMPLE-ARRAY (COMPLEX LONG-FLOAT) (*)).") + #+double-double + (object-not-simple-array-complex-double-double-float + "Object is not of type (SIMPLE-ARRAY (COMPLEX DOUBLE-DOUBLE-FLOAT) (*)).") (object-not-complex "Object is not of type COMPLEX.") (object-not-complex-rational @@ -175,6 +184,9 @@ #+long-float (object-not-complex-long-float "Object is not of type (COMPLEX LONG-FLOAT).") + #+double-double + (object-not-complex-double-double-float + "Object is not of type (COMPLEX DOUBLE-DOUBLE-FLOAT)") (object-not-weak-pointer "Object is not a WEAK-POINTER.") (object-not-instance diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index 6178f1253cf6e313995426b14eb1cde32e77f477..ff0ed7b7941793c8443d31e4d73666c0f0b471ea 100644 --- a/compiler/generic/new-genesis.lisp +++ b/compiler/generic/new-genesis.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.78 2006/05/20 01:48:51 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.79 2006/06/30 18:41:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -482,6 +482,29 @@ (write-indexed des (+ 2 vm:long-float-value-slot) exp-bits)) (:big-endian (error "Long-Float not supported"))) + des)) + #+double-double + (double-double-float + (let* ((des (allocate-unboxed-object *dynamic* vm:word-bits + (1- vm:double-double-float-size) + vm:double-double-float-type)) + (hi (kernel:double-double-hi num)) + (lo (kernel:double-double-lo num)) + (hi-high-bits (make-random-descriptor (double-float-high-bits hi))) + (hi-low-bits (make-random-descriptor (double-float-low-bits hi))) + (lo-high-bits (make-random-descriptor (double-float-high-bits lo))) + (lo-low-bits (make-random-descriptor (double-float-low-bits lo)))) + (ecase (c:backend-byte-order c:*backend*) + (:little-endian + (write-indexed des vm:double-double-float-lo-slot lo-low-bits) + (write-indexed des (+ 1 vm:double-double-float-lo-slot) lo-high-bits) + (write-indexed des vm:double-double-float-hi-slot hi-low-bits) + (write-indexed des (+ 1 vm:double-double-float-hi-slot) hi-high-bits)) + (:big-endian + (write-indexed des vm:double-double-float-hi-slot hi-high-bits) + (write-indexed des (+ 1 vm:double-double-float-hi-slot) hi-low-bits) + (write-indexed des vm:double-double-float-lo-slot lo-high-bits) + (write-indexed des (1+ vm:double-double-float-lo-slot) lo-low-bits))) des)))) (defun complex-single-float-to-core (num) @@ -522,6 +545,55 @@ (write-indexed des (1+ vm:complex-double-float-imag-slot) low-bits)))) des)) +#+double-double +(defun complex-double-double-float-to-core (num) + (declare (type (complex double-double-float) num)) + (let ((des (allocate-unboxed-object *dynamic* vm:word-bits + (1- vm::complex-double-double-float-size) + vm::complex-double-double-float-type))) + (let* ((real (kernel:double-double-hi (realpart num))) + (high-bits (make-random-descriptor (double-float-high-bits real))) + (low-bits (make-random-descriptor (double-float-low-bits real)))) + (ecase (c:backend-byte-order c:*backend*) + (:little-endian + (write-indexed des vm:complex-double-double-float-real-hi-slot low-bits) + (write-indexed des (1+ vm:complex-double-double-float-real-hi-slot) high-bits)) + (:big-endian + (write-indexed des vm:complex-double-double-float-real-hi-slot high-bits) + (write-indexed des (1+ vm:complex-double-double-float-real-hi-slot) low-bits)))) + (let* ((real (kernel:double-double-lo (realpart num))) + (high-bits (make-random-descriptor (double-float-high-bits real))) + (low-bits (make-random-descriptor (double-float-low-bits real)))) + (ecase (c:backend-byte-order c:*backend*) + (:little-endian + (write-indexed des vm:complex-double-double-float-real-lo-slot low-bits) + (write-indexed des (1+ vm:complex-double-double-float-real-lo-slot) high-bits)) + (:big-endian + (write-indexed des vm:complex-double-double-float-real-lo-slot high-bits) + (write-indexed des (1+ vm:complex-double-double-float-real-lo-slot) low-bits)))) + (let* ((imag (kernel:double-double-hi (imagpart num))) + (high-bits (make-random-descriptor (double-float-high-bits imag))) + (low-bits (make-random-descriptor (double-float-low-bits imag)))) + (ecase (c:backend-byte-order c:*backend*) + (:little-endian + (write-indexed des vm:complex-double-double-float-imag-hi-slot low-bits) + (write-indexed des (1+ vm:complex-double-double-float-imag-hi-slot) high-bits)) + (:big-endian + (write-indexed des vm:complex-double-double-float-imag-hi-slot high-bits) + (write-indexed des (1+ vm:complex-double-double-float-imag-hi-slot) low-bits)))) + (let* ((imag (kernel:double-double-lo (imagpart num))) + (high-bits (make-random-descriptor (double-float-high-bits imag))) + (low-bits (make-random-descriptor (double-float-low-bits imag)))) + (ecase (c:backend-byte-order c:*backend*) + (:little-endian + (write-indexed des vm:complex-double-double-float-imag-lo-slot low-bits) + (write-indexed des (1+ vm:complex-double-double-float-imag-lo-slot) high-bits)) + (:big-endian + (write-indexed des vm:complex-double-double-float-imag-lo-slot high-bits) + (write-indexed des (1+ vm:complex-double-double-float-imag-lo-slot) low-bits)))) + des)) + + (defun number-to-core (number) "Copy the given number to the core, or flame out if we can't deal with it." (typecase number @@ -536,6 +608,8 @@ #+long-float ((complex long-float) (error "~S isn't a cold-loadable number at all!" number)) + #+double-double + ((complex double-double-float) (complex-double-double-float-to-core number)) (complex (number-pair-to-core (number-to-core (realpart number)) (number-to-core (imagpart number)) vm:complex-type)) @@ -1384,6 +1458,9 @@ (not-cold-fop fop-complex-single-float-vector) (not-cold-fop fop-complex-double-float-vector) #+long-float (not-cold-fop fop-complex-long-float-vector) +;; Why is this not-cold-fop? I'm just cargo-culting this. +#+double-double (not-cold-fop fop-double-double-float-vector) +#+double-double (not-cold-fop fop-complex-double-double-float-vector) (define-cold-fop (fop-array) (let* ((rank (read-arg 4)) @@ -1460,12 +1537,16 @@ (cold-number fop-single-float) (cold-number fop-double-float) +#+double-double +(cold-number fop-double-double-float) (cold-number fop-integer) (cold-number fop-small-integer) (cold-number fop-word-integer) (cold-number fop-byte-integer) (cold-number fop-complex-single-float) (cold-number fop-complex-double-float) +#+double-double +(cold-number fop-complex-double-double-float) #+long-float (define-cold-fop (fop-long-float) @@ -1555,6 +1636,24 @@ imag-low-bits) des))))) +#+(and nil double-double) +(define-cold-fop (fop-double-double-float) + ;; Double-double format + (prepare-for-fast-read-byte *fasl-file* + (let* ((des (allocate-unboxed-object *dynamic* vm:word-bits + (1- vm:double-double-float-size) + vm:double-double-float-type)) + (hi-high-bits (make-random-descriptor (fast-read-s-integer 4))) + (hi-low-bits (make-random-descriptor (fast-read-u-integer 4))) + (lo-high-bits (make-random-descriptor (fast-read-s-integer 4))) + (lo-low-bits (make-random-descriptor (fast-read-s-integer 4)))) + (done-with-fast-read-byte) + (write-indexed des vm:double-double-float-hi-slot hi-high-bits) + (write-indexed des (1+ vm:double-double-float-hi-slot) hi-low-bits) + (write-indexed des vm:double-double-float-lo-slot lo-high-bits) + (write-indexed des (1+ vm:double-double-float-lo-slot) lo-low-bits) + des))) + (define-cold-fop (fop-ratio) (let ((den (pop-stack))) (number-pair-to-core (pop-stack) den vm:ratio-type))) diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp index 1c3138b61869424ad570acdb77d3951a349cefcf..fd45d33d2409ebde8cb365f608191048348a865e 100644 --- a/compiler/generic/objdef.lisp +++ b/compiler/generic/objdef.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/generic/objdef.lisp,v 1.59 2005/04/08 04:11:01 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.60 2006/06/30 18:41:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -34,7 +34,6 @@ code-header-type function-header-type closure-header-type closure-function-header-type return-pc-header-type byte-code-function-type byte-code-closure-type - dylan-function-header-type value-cell-header-type symbol-header-type base-char-type sap-type unbound-marker-type weak-pointer-type instance-header-type funcallable-instance-header-type @@ -47,6 +46,9 @@ simple-array-complex-double-float-type simple-array-complex-long-float-type)) +#+double-double +(export '(double-double-float double-double-float-type)) + (in-package "KERNEL") (export '(%make-funcallable-instance #+gengc funcallable-instance-entry-point @@ -115,10 +117,12 @@ single-float double-float #+long-float long-float + #+double-double double-double-float complex complex-single-float complex-double-float #+long-float complex-long-float + #+double-double complex-double-double-float simple-array simple-string @@ -136,9 +140,11 @@ simple-array-single-float simple-array-double-float #+long-float simple-array-long-float + #+double-double simple-array-double-double-float simple-array-complex-single-float simple-array-complex-double-float #+long-float simple-array-complex-long-float + #+double-double simple-array-complex-double-double-float complex-string complex-bit-vector complex-vector @@ -150,7 +156,7 @@ funcallable-instance-header byte-code-function byte-code-closure - dylan-function-header + #-double-double dylan-function-header closure-function-header #-gengc return-pc-header #+gengc forwarding-pointer @@ -529,3 +535,21 @@ #+sparc (filler) (real :c-type "long double" :length #+x86 3 #+sparc 4) (imag :c-type "long double" :length #+x86 3 #+sparc 4)) + +#+double-double +(define-primitive-object (double-double-float + :lowtag other-pointer-type + :header double-double-float-type) + (filler) + (hi :c-type "double" :length 2) + (lo :c-type "double" :length 2)) + +#+double-double +(define-primitive-object (complex-double-double-float + :lowtag other-pointer-type + :header complex-double-double-float-type) + (filler) + (real-hi :c-type "double" :length 2) + (real-lo :c-type "double" :length 2) + (imag-hi :c-type "double" :length 2) + (imag-lo :c-type "double" :length 2)) diff --git a/compiler/generic/primtype.lisp b/compiler/generic/primtype.lisp index 52ef540144390c86ebe4d2e70785c014e82d49e9..55d64bc44736f374ebbe31705852d00a16ce6d04 100644 --- a/compiler/generic/primtype.lisp +++ b/compiler/generic/primtype.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/generic/primtype.lisp,v 1.24 2004/05/24 23:15:31 cwang Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.25 2006/06/30 18:41:23 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -105,6 +105,10 @@ (def-primitive-type double-float (double-reg descriptor-reg)) #+long-float (def-primitive-type long-float (long-reg descriptor-reg)) + +#+double-double +(def-primitive-type double-double-float (double-double-reg descriptor-reg)) + (def-primitive-type complex-single-float (complex-single-reg descriptor-reg) :type (complex single-float)) (def-primitive-type complex-double-float (complex-double-reg descriptor-reg) @@ -112,6 +116,9 @@ #+long-float (def-primitive-type complex-long-float (complex-long-reg descriptor-reg) :type (complex long-float)) +#+double-double +(def-primitive-type complex-double-double-float (complex-double-double-reg descriptor-reg) + :type (complex double-double-float)) ;;; Primitive other-pointer array types. ;;; @@ -142,6 +149,9 @@ :type (simple-array single-float (*))) (def-primitive-type simple-array-double-float (descriptor-reg) :type (simple-array double-float (*))) +#+double-double +(def-primitive-type simple-array-double-double-float (descriptor-reg) + :type (simple-array double-double-float (*))) #+long-float (def-primitive-type simple-array-long-float (descriptor-reg) :type (simple-array long-float (*))) @@ -152,6 +162,9 @@ #+long-float (def-primitive-type simple-array-complex-long-float (descriptor-reg) :type (simple-array (complex long-float) (*))) +#+double-double +(def-primitive-type simple-array-complex-double-double-float (descriptor-reg) + :type (simple-array (complex double-double-float) (*))) ;;; Note: The complex array types are not inclueded, 'cause it is pointless to ;;; restrict VOPs to them. @@ -198,10 +211,13 @@ (single-float . simple-array-single-float) (double-float . simple-array-double-float) #+long-float (long-float . simple-array-long-float) + #+double-double + (double-double-float . simple-array-double-double-float) ((complex single-float) . simple-array-complex-single-float) ((complex double-float) . simple-array-complex-double-float) #+long-float ((complex long-float) . simple-array-complex-long-float) + #+double-double ((complex double-double-float) . simple-array-complex-double-double-float) (t . simple-vector)) "An a-list for mapping simple array element types to their corresponding primitive types.") @@ -344,6 +360,10 @@ (long-float (values (primitive-type-or-lose 'long-float *backend*) exact)) + #+double-double + (double-double-float + (values (primitive-type-or-lose 'double-double-float *backend*) + exact)) (t (any))))) (t @@ -365,6 +385,11 @@ (values (primitive-type-or-lose 'complex-long-float *backend*) exact)) + #+double-double + (double-double-float + (values (primitive-type-or-lose 'complex-double-double-float + *backend*) + exact)) (t (part-of complex)))) (part-of complex))) diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp index f6159b2a0d66735fc1d31b57fac56f64eed48319..63cf8cd493ad4a633f9f357b6797158b96c0f444 100644 --- a/compiler/generic/vm-fndb.lisp +++ b/compiler/generic/vm-fndb.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/generic/vm-fndb.lisp,v 1.65 2004/05/24 23:20:47 cwang Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.66 2006/06/30 18:41:23 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -48,8 +48,11 @@ (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p long-float-p + #+double-double double-double-float-p complex-rational-p complex-float-p complex-single-float-p complex-double-float-p #+long-float complex-long-float-p + #+double-double + complex-double-double-float-p base-char-p %standard-char-p %instancep array-header-p simple-array-p simple-array-unsigned-byte-2-p simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p @@ -61,9 +64,13 @@ simple-array-complex-single-float-p simple-array-complex-double-float-p #+long-float simple-array-complex-long-float-p + #+double-double simple-array-double-double-float-p system-area-pointer-p realp unsigned-byte-32-p signed-byte-32-p weak-pointer-p scavenger-hook-p code-component-p lra-p - funcallable-instance-p) + funcallable-instance-p + #+double-double double-double-float-p + #+double-double simple-array-double-double-float-p + #+double-double simple-array-complex-double-double-float-p) (t) boolean (movable foldable flushable)) diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp index 75197867117a2a2aebc552203d7f8c8d12f4b09d..7688825809f8f9309ed467c0918b4bbd9c054366 100644 --- a/compiler/generic/vm-type.lisp +++ b/compiler/generic/vm-type.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/generic/vm-type.lisp,v 1.43 2003/10/13 11:24:14 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.44 2006/06/30 18:41:23 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -97,8 +97,10 @@ (signed-byte 8) (signed-byte 16) (signed-byte 30) (signed-byte 32) (complex single-float) (complex double-float) #+long-float (complex long-float) + #+double-double (complex double-double-float) base-char single-float double-float - #+long-float long-float)) + #+long-float long-float + #+double-double double-double-float)) (deftype unboxed-array (&optional dims) (collect ((types (list 'or))) @@ -120,11 +122,12 @@ ;;; Return the symbol that describes the format of Float. ;;; (defun float-format-name (x) - (declare (float x) (values symbol)) + (declare #+nil(float x) (values symbol)) (etypecase x (single-float 'single-float) (double-float 'double-float) - #+long-float (long-float 'long-float))) + #+long-float (long-float 'long-float) + #+double-double (double-double-float 'double-double-float))) ;;; Specialize-Array-Type -- Internal ;;; diff --git a/compiler/generic/vm-typetran.lisp b/compiler/generic/vm-typetran.lisp index dc08a69afd9290f4d10ea7409d892b8b8d16b8b2..f93bab595a26984d5b363f9ac76906ee6da32772 100644 --- a/compiler/generic/vm-typetran.lisp +++ b/compiler/generic/vm-typetran.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/generic/vm-typetran.lisp,v 1.16 1998/07/24 17:22:32 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.17 2006/06/30 18:41:23 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -31,9 +31,13 @@ (define-type-predicate complex-single-float-p (complex single-float)) #+long-float (define-type-predicate complex-long-float-p (complex long-float)) +#+double-double +(define-type-predicate complex-double-double-float-p (complex double-double-float)) (define-type-predicate double-float-p double-float) (define-type-predicate fixnump fixnum) (define-type-predicate long-float-p long-float) +#+double-double +(define-type-predicate double-double-float-p double-double-float) (define-type-predicate ratiop ratio) (define-type-predicate short-float-p short-float) (define-type-predicate single-float-p single-float) @@ -63,6 +67,10 @@ #+long-float (define-type-predicate simple-array-long-float-p (simple-array long-float (*))) +#+(and t double-double) +(define-type-predicate simple-array-double-double-float-p + (simple-array double-double-float (*))) + (define-type-predicate simple-array-complex-single-float-p (simple-array (complex single-float) (*))) (define-type-predicate simple-array-complex-double-float-p @@ -70,6 +78,9 @@ #+long-float (define-type-predicate simple-array-complex-long-float-p (simple-array (complex long-float) (*))) +#+(and t double-double) +(define-type-predicate simple-array-complex-double-double-float-p + (simple-array (complex double-double-float) (*))) (define-type-predicate system-area-pointer-p system-area-pointer) (define-type-predicate unsigned-byte-32-p (unsigned-byte 32)) (define-type-predicate signed-byte-32-p (signed-byte 32)) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index fc6607ac8cff2d96c4104edf29071ad0fa66a5e6..145999b5c1e034cdc45ea9e91afe98dfd49bc640 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.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/ir1util.lisp,v 1.109 2004/12/16 21:55:37 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.110 2006/06/30 18:41:23 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -1615,7 +1615,7 @@ (ref-leaf (continuation-use (basic-combination-fun call)))) -(defvar *inline-expansion-limit* 200 +(defvar *inline-expansion-limit* 400 "An upper limit on the number of inline function calls that will be expanded in any given code object (single function or block compilation.)") diff --git a/compiler/ppc/array.lisp b/compiler/ppc/array.lisp index 94824c4cd92514e8af7aac57860449df4e4021a3..343f42826f8acb9449c683b371630a5bd913827d 100644 --- a/compiler/ppc/array.lisp +++ b/compiler/ppc/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.6 2006/01/18 15:21:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.7 2006/06/30 18:41:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -614,3 +614,121 @@ (:results (result :scs (signed-reg))) (:result-types tagged-num)) + +#+double-double +(progn +(define-vop (data-vector-ref/simple-array-double-double-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 vm::simple-array-double-double-float positive-fixnum) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (double-double-reg-hi-tn value))) + (inst slwi offset index 2) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lfdx real-tn object offset)) + (let ((imag-tn (double-double-reg-lo-tn value))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst lfdx imag-tn object offset)))) + +(define-vop (data-vector-set/simple-array-double-double-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 (double-double-reg) :target result)) + (:arg-types vm::simple-array-double-double-float positive-fixnum + double-double-float) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (double-double-reg-hi-tn value)) + (result-real (double-double-reg-hi-tn result))) + (inst slwi offset index 2) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (let ((value-imag (double-double-reg-lo-tn value)) + (result-imag (double-double-reg-lo-tn result))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag))))) + +(define-vop (data-vector-ref/simple-array-complex-double-double-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-double-double-float positive-fixnum) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-double-reg-real-hi-tn value))) + (inst slwi offset index 3) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lfdx real-tn object offset)) + (let ((real-tn (complex-double-double-reg-real-lo-tn value))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst lfdx real-tn object offset)) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn value))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst lfdx imag-tn object offset)) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn value))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst lfdx imag-tn object offset)))) + +(define-vop (data-vector-set/simple-array-complex-double-double-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-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float positive-fixnum + complex-double-double-float) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result))) + (inst slwi offset index 3) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (let ((value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag))) + (let ((value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag))))) + +) diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp index 59682cc6daeb6987fde8cfdeb25e9cb2113d90a9..e883e559e38cec8011474c2b4b4ce1d8b339af9b 100644 --- a/compiler/ppc/float.lisp +++ b/compiler/ppc/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.5 2005/11/17 03:33:45 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.6 2006/06/30 18:41:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -141,6 +141,21 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) :offset (1+ (tn-offset x)))) +#+double-double +(progn +(defun complex-double-double-reg-real-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-double-reg-real-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 1 (tn-offset x)))) +(defun complex-double-double-reg-imag-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) +(defun complex-double-double-reg-imag-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 3 (tn-offset x)))) +) (define-move-function (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) @@ -180,6 +195,35 @@ (inst stfd imag-tn nfp (+ offset (* 2 vm:word-bytes)))))) +#+double-double +(progn +(define-move-function (load-complex-double-double 4) (vop x y) + ((complex-double-double-stack) (complex-double-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((value-tn (complex-double-double-reg-real-hi-tn y))) + (inst lfd value-tn nfp offset)) + (let ((value-tn (complex-double-double-reg-real-lo-tn y))) + (inst lfd value-tn nfp (+ offset (* 2 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-hi-tn y))) + (inst lfd value-tn nfp (+ offset (* 4 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-lo-tn y))) + (inst lfd value-tn nfp (+ offset (* 6 vm:word-bytes)))))) + +(define-move-function (store-complex-double-double 4) (vop x y) + ((complex-double-double-reg) (complex-double-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((value-tn (complex-double-double-reg-real-hi-tn x))) + (inst stfd value-tn nfp offset)) + (let ((value-tn (complex-double-double-reg-real-lo-tn x))) + (inst stfd value-tn nfp (+ offset (* 2 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stfd value-tn nfp (+ offset (* 4 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stfd value-tn nfp (+ offset (* 6 vm:word-bytes)))))) + +) ;;; ;;; Complex float register to register moves. ;;; @@ -221,6 +265,32 @@ (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) +#+double-double +(define-vop (complex-double-double-move) + (:args (x :scs (complex-double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y)))) + (:note "complex double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (inst fmr y-real x-real)) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (inst fmr y-real x-real)) + (let ((x-real (complex-double-double-reg-imag-hi-tn x)) + (y-real (complex-double-double-reg-imag-hi-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (inst fmr y-imag x-imag))))) +;;; +#+double-double +(define-move-vop complex-double-double-move :move + (complex-double-double-reg) (complex-double-double-reg)) ;;; ;;; Move from a complex float to a descriptor register allocating a @@ -268,6 +338,37 @@ (define-move-vop move-from-complex-double :move (complex-double-reg) (descriptor-reg)) +#+double-double +(define-vop (move-from-complex-double-double) + (:args (x :scs (complex-double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "complex double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr vm::complex-double-double-float-type + vm::complex-double-double-float-size)) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (inst stfd real-tn y (- (* vm::complex-double-double-float-real-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (inst stfd real-tn y (- (* vm::complex-double-double-float-real-lo-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stfd imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stfd imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +#+double-double +(define-move-vop move-from-complex-double-double :move + (complex-double-double-reg) (descriptor-reg)) + ;;; ;;; Move from a descriptor to a complex float register @@ -301,6 +402,27 @@ (descriptor-reg) (complex-double-reg)) +#+double-double +(define-vop (move-to-complex-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-double-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-double-reg-real-hi-tn y))) + (inst lfd real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes) + other-pointer-type))) + (let ((real-tn (complex-double-double-reg-real-lo-tn y))) + (inst lfd real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn y))) + (inst lfd imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn y))) + (inst lfd imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes) + other-pointer-type))))) +#+double-double +(define-move-vop move-to-complex-double-double :move + (descriptor-reg) (complex-double-double-reg)) ;;; ;;; Complex float move-argument vop ;;; @@ -352,9 +474,47 @@ (define-move-vop move-complex-double-float-argument :move-argument (complex-double-reg descriptor-reg) (complex-double-reg)) +#+double-double +(define-vop (move-complex-double-double-float-argument) + (:args (x :scs (complex-double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg)))) + (:results (y)) + (:note "complex long-float argument move") + (:generator 2 + (sc-case y + (complex-double-double-reg + (unless (location= x y) + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (inst fmr y-real x-real)) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-double-double-reg-imag-hi-tn x)) + (y-imag (complex-double-double-reg-imag-hi-tn y))) + (inst fmr y-imag x-imag)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (inst fmr y-imag x-imag)))) + (complex-double-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (inst stfd real-tn nfp offset)) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (inst stfd real-tn nfp (+ offset (* 2 word-bytes)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stfd imag-tn nfp (+ offset (* 4 word-bytes)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stfd imag-tn nfp (+ offset (* 6 word-bytes))))))))) + +#+long-float +(define-move-vop move-complex-long-float-argument :move-argument + (complex-long-reg descriptor-reg) (complex-long-reg)) (define-move-vop move-argument :move-argument - (single-reg double-reg complex-single-reg complex-double-reg) + (single-reg double-reg complex-single-reg complex-double-reg + #+double-double double-double-reg + #+double-double complex-double-double-reg) (descriptor-reg)) @@ -930,3 +1090,273 @@ (:variant :imag)) +;;; Support for double-double floats + +#+double-double +(progn +(deftransform eql ((x y) (double-double-float double-double-float)) + '(and (eql (double-double-hi x) (double-double-hi y)) + (eql (double-double-lo x) (double-double-lo y)))) + +(defun double-double-reg-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) + +(defun double-double-reg-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (1+ (tn-offset x)))) + +(define-move-function (load-double-double 4) (vop x y) + ((double-double-stack) (double-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn y))) + (inst lfd hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn y))) + (inst lfd lo-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +(define-move-function (store-double-double 4) (vop x y) + ((double-double-reg) (double-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stfd hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stfd lo-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +;;; Double-double float register to register moves + +(define-vop (double-double-move) + (:args (x :scs (double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (double-double-reg) :load-if (not (location= x y)))) + (:note "double-double float move") + (:generator 0 + (unless (location= x y) + ;; Note the double-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (inst fmr y-hi x-hi)) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (inst fmr y-lo x-lo))))) +;;; +(define-move-vop double-double-move :move + (double-double-reg) (double-double-reg)) + +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. + +(define-vop (move-from-double-double) + (:args (x :scs (double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "double double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr vm::double-double-float-type + vm::double-double-float-size)) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stfd hi-tn y (- (* vm::double-double-float-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stfd lo-tn y (- (* vm::double-double-float-lo-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-double-double :move + (double-double-reg) (descriptor-reg)) + +;;; Move from a descriptor to a double-double float register + +(define-vop (move-to-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (double-double-reg))) + (:note "pointer to double float coercion") + (:generator 2 + (let ((hi-tn (double-double-reg-hi-tn y))) + (inst lfd hi-tn x (- (* double-double-float-hi-slot word-bytes) + other-pointer-type))) + (let ((lo-tn (double-double-reg-lo-tn y))) + (inst lfd lo-tn x (- (* double-double-float-lo-slot word-bytes) + other-pointer-type))))) + +(define-move-vop move-to-double-double :move + (descriptor-reg) (double-double-reg)) + +;;; double-double float move-argument vop + +(define-vop (move-double-double-float-argument) + (:args (x :scs (double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y double-double-reg)))) + (:results (y)) + (:note "double double-float argument move") + (:generator 2 + (sc-case y + (double-double-reg + (unless (location= x y) + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (inst fmr y-hi x-hi)) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (inst fmr y-lo x-lo)))) + (double-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stfd hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stfd lo-tn nfp (+ offset (* 2 word-bytes))))))))) + +(define-move-vop move-double-double-float-argument :move-argument + (double-double-reg descriptor-reg) (double-double-reg)) + + +(define-vop (make/double-double-float) + (:args (hi :scs (double-reg) :target r + :load-if (not (location= hi r))) + (lo :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (double-double-reg) :from (:argument 0) + :load-if (not (sc-is r double-double-stack)))) + (:result-types double-double-float) + (:translate kernel::%make-double-double-float) + (:note "inline double-double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (sc-case r + (double-double-reg + (let ((r-hi (double-double-reg-hi-tn r))) + (unless (location= hi r-hi) + (inst fmr r-hi hi))) + (let ((r-lo (double-double-reg-lo-tn r))) + (unless (location= lo r-lo) + (inst fmr r-lo lo)))) + (double-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= hi r) + (inst stfd hi nfp offset)) + (inst stfd lo nfp (+ offset (* 2 vm:word-bytes)))))))) + +(define-vop (double-double-float-value) + (:args (x :scs (double-double-reg) :target r + :load-if (not (sc-is x double-double-stack)))) + (:arg-types double-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (double-double-reg + (let ((value-tn (ecase slot + (:hi (double-double-reg-hi-tn x)) + (:lo (double-double-reg-lo-tn x))))) + (unless (location= value-tn r) + (inst fmr r value-tn)))) + (double-double-stack + (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot + (:hi 0) + (:lo 2)) + (tn-offset x)) + vm:word-bytes)))))) + +(define-vop (hi/double-double-float double-double-float-value) + (:translate kernel::double-double-hi) + (:note "double-double float high part") + (:variant :hi)) + +(define-vop (lo/double-double-float double-double-float-value) + (:translate kernel::double-double-lo) + (:note "double-double float low part") + (:variant :lo)) + +(define-vop (make-complex-double-double-float) + (:translate complex) + (:args (real :scs (double-double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-double-reg) :to :save)) + (:arg-types double-double-float double-double-float) + (:results (r :scs (complex-double-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-double-stack)))) + (:result-types complex-double-double-float) + (:note "inline complex double-double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-double-reg + (let ((r-real (complex-double-double-reg-real-hi-tn r)) + (real-hi (double-double-reg-hi-tn real))) + (inst fmr r-real real-hi)) + (let ((r-real (complex-double-double-reg-real-lo-tn r)) + (real-lo (double-double-reg-lo-tn real))) + (inst fmr r-real real-lo)) + (let ((r-imag (complex-double-double-reg-imag-hi-tn r)) + (imag-hi (double-double-reg-hi-tn imag))) + (inst fmr r-imag imag-hi)) + (let ((r-imag (complex-double-double-reg-imag-lo-tn r)) + (imag-lo (double-double-reg-lo-tn imag))) + (inst fmr r-imag imag-lo))) + (complex-double-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (let ((r-real (complex-double-double-reg-real-hi-tn r))) + (inst stfd r-real nfp offset)) + (let ((r-real (complex-double-double-reg-real-lo-tn r))) + (inst stfd r-real nfp (+ offset (* 2 vm:word-bytes)))) + (let ((r-imag (complex-double-double-reg-imag-hi-tn r))) + (inst stfd r-imag nfp (+ offset (* 4 vm:word-bytes)))) + (let ((r-imag (complex-double-double-reg-imag-lo-tn r))) + (inst stfd r-imag nfp (+ offset (* 6 vm:word-bytes))))))))) + +(define-vop (complex-double-double-float-value) + (:args (x :scs (complex-double-double-reg) :target r + :load-if (not (sc-is x complex-double-double-stack)))) + (:arg-types complex-double-double-float) + (:results (r :scs (double-double-reg))) + (:result-types double-double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-hi-tn x)) + (:imag (complex-double-double-reg-imag-hi-tn x)))) + (r-hi (double-double-reg-hi-tn r))) + (unless (location= value-tn r-hi) + (inst fmr r-hi value-tn))) + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-lo-tn x)) + (:imag (complex-double-double-reg-imag-lo-tn x)))) + (r-lo (double-double-reg-lo-tn r))) + (unless (location= value-tn r-lo) + (inst fmr r-lo value-tn)))) + (complex-double-double-stack + (let ((r-hi (double-double-reg-hi-tn r))) + (inst lfd r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4)) + (tn-offset x)) + vm:word-bytes))) + (let ((r-lo (double-double-reg-lo-tn r))) + (inst lfd r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6)) + (tn-offset x)) + vm:word-bytes))))))) + +(define-vop (realpart/complex-double-double-float complex-double-double-float-value) + (:translate realpart) + (:note "complex double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-double-float complex-double-double-float-value) + (:translate imagpart) + (:note "complex double float imagpart") + (:variant :imag)) + +); progn diff --git a/compiler/ppc/insts.lisp b/compiler/ppc/insts.lisp index f6a1fbb213f65f36ec80aba7783997070479cdc0..6038a026bdb5ac7d405c36ed39c8bf62ef168d3d 100644 --- a/compiler/ppc/insts.lisp +++ b/compiler/ppc/insts.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.18 2006/03/18 05:17:49 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.19 2006/06/30 18:41:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -104,10 +104,12 @@ single-float double-float #+long-float long-float + #+double-double double-double-float complex complex-single-float complex-double-float #+long-float complex-long-float + #+double-double complex-double-double-float simple-array simple-string @@ -125,9 +127,11 @@ simple-array-single-float simple-array-double-float #+long-float simple-array-long-float + #+double-double simple-array-double-double-float simple-array-complex-single-float simple-array-complex-double-float #+long-float simple-array-complex-long-float + #+double-double simple-array-complex-double-double-float complex-string complex-bit-vector complex-vector @@ -139,7 +143,7 @@ funcallable-instance-header byte-code-function byte-code-closure - dylan-function-header + #-double-double dylan-function-header closure-function-header #-gengc return-pc-header #+gengc forwarding-pointer diff --git a/compiler/ppc/parms.lisp b/compiler/ppc/parms.lisp index 98398beecba682fe1fc673e1ed457d5441beb3c0..38578c4815d4a8f33830804e3e9c3bc19484302e 100644 --- a/compiler/ppc/parms.lisp +++ b/compiler/ppc/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.11 2006/05/07 23:50:00 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.12 2006/06/30 18:41:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -60,6 +60,8 @@ float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) +#+double-double +(export '(double-double-float-digits)) @@ -103,6 +105,9 @@ (defconstant double-float-digits (+ (byte-size double-float-significand-byte) word-bits 1)) +#+double-double +(defconstant double-double-float-digits + (* 2 double-float-digits)) (defconstant float-inexact-trap-bit (ash 1 0)) (defconstant float-divide-by-zero-trap-bit (ash 1 1)) diff --git a/compiler/ppc/type-vops.lisp b/compiler/ppc/type-vops.lisp index f20f9edb2f91fcbcc3c0fced79b4a49ba691e58c..e70570ec0a01e8213e2d6a6eceeac7919f5c15e3 100644 --- a/compiler/ppc/type-vops.lisp +++ b/compiler/ppc/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/type-vops.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/type-vops.lisp,v 1.3 2006/06/30 18:41:24 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -114,14 +114,16 @@ (def-type-vops complexp check-complex complex object-not-complex-error vm:complex-type - complex-single-float-type complex-double-float-type) + complex-single-float-type complex-double-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops complex-rational-p check-complex-rational nil object-not-complex-rational-error complex-type) (def-type-vops complex-float-p check-complex-float nil object-not-complex-float-error - complex-single-float-type complex-double-float-type) + complex-single-float-type complex-double-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops complex-single-float-p check-complex-single-float complex-single-float object-not-complex-single-float-error @@ -131,12 +133,23 @@ complex-double-float object-not-complex-double-float-error complex-double-float-type) +#+double-double +(def-type-vops complex-double-double-float-p check-complex-double-double-float + complex-double-double-float object-not-complex-double-double-float-error + vm::complex-double-double-float-type) + + (def-type-vops single-float-p check-single-float single-float object-not-single-float-error vm:single-float-type) (def-type-vops double-float-p check-double-float double-float object-not-double-float-error vm:double-float-type) +#+double-double +(def-type-vops double-double-float-p check-double-double-float + double-double-float object-not-double-double-float-error + vm:double-double-float-type) + (def-type-vops simple-string-p check-simple-string simple-string object-not-simple-string-error vm:simple-string-type) @@ -208,6 +221,11 @@ simple-array-double-float object-not-simple-array-double-float-error vm:simple-array-double-float-type) +#+double-double +(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float + simple-array-double-double-float object-not-simple-array-double-double-float-error + vm::simple-array-double-double-float-type) + (def-type-vops simple-array-complex-single-float-p check-simple-array-complex-single-float simple-array-complex-single-float @@ -220,6 +238,13 @@ object-not-simple-array-complex-double-float-error simple-array-complex-double-float-type) +#+double-double +(def-type-vops simple-array-complex-double-double-float-p + check-simple-array-complex-double-double-float + simple-array-complex-double-double-float + object-not-simple-array-complex-double-double-float-error + vm::simple-array-complex-double-double-float-type) + (def-type-vops base-char-p check-base-char base-char object-not-base-char-error vm:base-char-type) @@ -265,8 +290,10 @@ simple-array-signed-byte-8-type simple-array-signed-byte-16-type simple-array-signed-byte-30-type simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type + #+double-double vm::simple-array-double-double-float-type simple-array-complex-single-float-type simple-array-complex-double-float-type + #+double-double vm::simple-array-complex-double-double-float-type complex-string-type complex-bit-vector-type complex-vector-type) (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error @@ -277,8 +304,10 @@ simple-array-signed-byte-8-type simple-array-signed-byte-16-type simple-array-signed-byte-30-type simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type + #+double-double vm::simple-array-double-double-float-type simple-array-complex-single-float-type - simple-array-complex-double-float-type) + simple-array-complex-double-float-type + #+double-double vm::simple-array-complex-double-double-float-type) (def-type-vops arrayp check-array nil object-not-array-error simple-array-type simple-string-type simple-bit-vector-type @@ -288,15 +317,20 @@ simple-array-signed-byte-8-type simple-array-signed-byte-16-type simple-array-signed-byte-30-type simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type + #+double-double vm::simple-array-double-double-float-type simple-array-complex-single-float-type simple-array-complex-double-float-type + #+double-double vm::simple-array-complex-double-double-float-type complex-string-type complex-bit-vector-type complex-vector-type complex-array-type) (def-type-vops numberp check-number nil object-not-number-error even-fixnum-type odd-fixnum-type bignum-type ratio-type - single-float-type double-float-type complex-type - complex-single-float-type complex-double-float-type) + single-float-type double-float-type + #+double-double vm:double-double-float-type + complex-type + complex-single-float-type complex-double-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops rationalp check-rational nil object-not-rational-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) @@ -305,11 +339,13 @@ 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 + #+double-double vm:double-double-float-type) (def-type-vops realp check-real nil object-not-real-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type - vm:single-float-type vm:double-float-type) + vm:single-float-type vm:double-float-type + #+double-double vm:double-double-float-type) ;;;; Other integer ranges. diff --git a/compiler/ppc/vm.lisp b/compiler/ppc/vm.lisp index b7d438f09bd56a2f96db96e35b789498d9d7e4da..51d1eaaa19647b1a7ae88b2242d142d5e9b8b0fa 100644 --- a/compiler/ppc/vm.lisp +++ b/compiler/ppc/vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.4 2005/12/11 03:45:36 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.5 2006/06/30 18:41:24 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -150,9 +150,13 @@ (single-stack non-descriptor-stack) ; single-floats (double-stack non-descriptor-stack :element-size 2 :alignment 2) ; double floats. + #+double-double + (double-double-stack non-descriptor-stack :element-size 4 :alignment 2) (complex-single-stack non-descriptor-stack :element-size 2) (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) + #+double-double + (complex-double-double-stack non-descriptor-stack :element-size 8 :alignment 4) ;; **** Things that can go in the integer registers. @@ -227,20 +231,37 @@ :save-p t :alternate-scs (double-stack)) + ;; Non-descriptor double-double floats + #+double-double + (double-double-reg float-registers + :locations #.(loop for i from 0 to 30 by 2 collect i) + :element-size 2 :alignment 2 + :constant-scs () + :save-p t + :alternate-scs (double-double-stack)) + (complex-single-reg float-registers :locations #.(loop for i from 0 to 30 by 2 collect i) - :element-size 2 + :element-size 2 :alignment 2 :constant-scs () :save-p t :alternate-scs (complex-single-stack)) (complex-double-reg float-registers :locations #.(loop for i from 0 to 30 by 2 collect i) - :element-size 2 + :element-size 2 :alignment 2 :constant-scs () :save-p t :alternate-scs (complex-double-stack)) + #+double-double + (complex-double-double-reg float-registers + :locations #.(loop for i from 0 to 30 by 4 collect i) + :element-size 4 :alignment 4 + :constant-scs () + :save-p t + :alternate-scs (complex-double-double-stack)) + ;; A catch or unwind block. (catch-block control-stack :element-size vm:catch-block-size)) diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp index ecc102e2dd67cdc2075eabcd5496adb0154bea44..02b34cc863d26337a9fcdebb7ce3da965a628668 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.32 2003/11/05 15:14:53 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.33 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -948,3 +948,280 @@ (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:variant 0 vm:other-pointer-type)) + + +#+double-double +(progn +(define-vop (data-vector-ref/simple-array-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-double-double-float positive-fixnum) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((hi-tn (double-double-reg-hi-tn value))) + (inst slln offset index 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf hi-tn object offset)) + (let ((lo-tn (double-double-reg-lo-tn value))) + (inst add offset (* 2 vm:word-bytes)) + (inst lddf lo-tn object offset)))) + +(define-vop (data-vector-ref-c/simple-array-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-double-double-float (:constant index)) + (:info index) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (hi-tn (double-double-reg-hi-tn value)) + (lo-tn (double-double-reg-lo-tn value))) + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst lddf hi-tn object offset) + (inst lddf lo-tn object (+ offset 8))) + (t + (inst li temp offset) + (inst lddf hi-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf lo-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-double-double-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 (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float positive-fixnum + double-double-float) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-hi (double-double-reg-hi-tn value)) + (result-hi (double-double-reg-hi-tn result))) + (inst slln offset index 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value-hi object offset) + (unless (location= result-hi value-hi) + (move-double-reg result-hi value-hi))) + (let ((value-lo (double-double-reg-lo-tn value)) + (result-lo (double-double-reg-lo-tn result))) + (inst add offset (* 2 vm:word-bytes)) + (inst stdf value-lo object offset) + (unless (location= result-lo value-lo) + (move-double-reg result-lo value-lo))))) + +(define-vop (data-vector-set-c/simple-array-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float + (:constant index) + double-double-float) + (:info index) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-hi (double-double-reg-hi-tn value)) + (result-hi (double-double-reg-hi-tn result)) + (value-lo (double-double-reg-lo-tn value)) + (result-lo (double-double-reg-lo-tn result)) + (offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst stdf value-hi object offset) + (inst stdf value-lo object (+ offset 8))) + (t + (inst li temp offset) + (inst stdf value-hi object temp) + (inst add temp 8) + (inst stdf value-lo object temp))) + (unless (location= result-hi value-hi) + (move-double-reg result-hi value-hi)) + (unless (location= result-lo value-lo) + (move-double-reg result-lo value-lo))))) + +(define-vop (data-vector-ref/simple-array-complex-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-double-float positive-fixnum) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-double-reg-real-hi-tn value))) + (inst slln offset index 3) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf real-tn object offset)) + (let ((real-tn (complex-double-double-reg-real-lo-tn value))) + (inst add offset (* 2 vm:word-bytes)) + (inst lddf real-tn object offset)) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn value))) + (inst add offset (* 2 vm:word-bytes)) + (inst lddf imag-tn object offset)) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn value))) + (inst add offset (* 2 vm:word-bytes)) + (inst lddf imag-tn object offset)))) + +(define-vop (data-vector-ref-c/simple-array-complex-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-complex-double-double-float (:constant index)) + (:info index) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (real-hi-tn (complex-double-double-reg-real-hi-tn value)) + (imag-hi-tn (complex-double-double-reg-imag-hi-tn value)) + (real-lo-tn (complex-double-double-reg-real-lo-tn value)) + (imag-lo-tn (complex-double-double-reg-imag-lo-tn value))) + (cond ((typep (+ offset (* 6 vm:word-bytes)) '(signed-byte 13)) + (inst lddf real-hi-tn object offset) + (inst lddf real-lo-tn object (+ offset (* 2 vm:word-bytes))) + (inst lddf imag-hi-tn object (+ offset (* 4 vm:word-bytes))) + (inst lddf imag-lo-tn object (+ offset (* 6 vm:word-bytes)))) + (t + (inst li temp offset) + (inst lddf real-hi-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf real-lo-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf imag-hi-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf imag-lo-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-complex-double-double-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-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float positive-fixnum + complex-double-double-float) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result))) + (inst slln offset index 3) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value-real object offset) + (unless (location= result-real value-real) + (move-double-reg result-real value-real))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result))) + (inst add offset (* 2 vm:word-bytes)) + (inst stdf value-real object offset) + (unless (location= result-real value-real) + (move-double-reg result-real value-real))) + (let ((value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result))) + (inst add offset (* 2 vm:word-bytes)) + (inst stdf value-imag object offset) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))) + (let ((value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result))) + (inst add offset (* 2 vm:word-bytes)) + (inst stdf value-imag object offset) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + +(define-vop (data-vector-set-c/simple-array-complex-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (complex-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float + (:constant index) + complex-double-double-float) + (:info index) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result)) + (value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result)) + (offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst stdf value-real object offset) + (inst stdf value-imag object (+ offset 8))) + (t + (inst li temp offset) + (inst stdf value-real object temp) + (inst add temp 8) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result)) + (value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result)) + (offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset (* 6 vm:word-bytes)) '(signed-byte 13)) + (inst stdf value-real object (+ offset (* 4 vm:word-bytes))) + (inst stdf value-imag object (+ offset (* 6 vm:word-bytes)))) + (t + (inst add temp 8) + (inst stdf value-real object temp) + (inst add temp 8) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + + +) diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp index 7b336a01f3d4e2bf426d889691a9f9a362389d87..e8fa21a7212fc1b12fbbf0311ef50d8eb9203407 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.44 2004/03/29 18:47:03 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.45 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -106,7 +106,8 @@ ;;; on the :sparc-v9 feature. (defun move-double-reg (dst src) (cond ((backend-featurep :sparc-v9) - (inst fmovd dst src)) + (unless (location= dst src) + (inst fmovd dst src))) (t (dotimes (i 2) (let ((dst (make-random-tn :kind :normal @@ -284,6 +285,21 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) :offset (+ (tn-offset x) 4))) +#+double-double +(progn +(defun complex-double-double-reg-real-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-double-reg-real-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) +(defun complex-double-double-reg-imag-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 4 (tn-offset x)))) +(defun complex-double-double-reg-imag-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 6 (tn-offset x)))) +) (define-move-function (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) @@ -343,6 +359,36 @@ (let ((imag-tn (complex-long-reg-imag-tn x))) (store-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes)))))) +#+double-double +(progn +(define-move-function (load-complex-double-double 4) (vop x y) + ((complex-double-double-stack) (complex-double-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((value-tn (complex-double-double-reg-real-hi-tn y))) + (inst lddf value-tn nfp offset)) + (let ((value-tn (complex-double-double-reg-real-lo-tn y))) + (inst lddf value-tn nfp (+ offset (* 2 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-hi-tn y))) + (inst lddf value-tn nfp (+ offset (* 4 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-lo-tn y))) + (inst lddf value-tn nfp (+ offset (* 6 vm:word-bytes)))))) + +(define-move-function (store-complex-double-double 4) (vop x y) + ((complex-double-double-reg) (complex-double-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((value-tn (complex-double-double-reg-real-hi-tn x))) + (inst stdf value-tn nfp offset)) + (let ((value-tn (complex-double-double-reg-real-lo-tn x))) + (inst stdf value-tn nfp (+ offset (* 2 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stdf value-tn nfp (+ offset (* 4 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stdf value-tn nfp (+ offset (* 6 vm:word-bytes)))))) + +) + ;;; ;;; Complex float register to register moves. ;;; @@ -405,6 +451,33 @@ (define-move-vop complex-long-move :move (complex-long-reg) (complex-long-reg)) +#+double-double +(define-vop (complex-double-double-move) + (:args (x :scs (complex-double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y)))) + (:note "complex double-double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (move-double-reg y-real x-real)) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (move-double-reg y-real x-real)) + (let ((x-real (complex-double-double-reg-imag-hi-tn x)) + (y-real (complex-double-double-reg-imag-hi-tn y))) + (move-double-reg y-real x-real)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (move-double-reg y-imag x-imag))))) +;;; +#+double-double +(define-move-vop complex-double-double-move :move + (complex-double-double-reg) (complex-double-double-reg)) + ;;; ;;; Move from a complex float to a descriptor register allocating a ;;; new complex float object in the process. @@ -471,6 +544,36 @@ (define-move-vop move-from-complex-long :move (complex-long-reg) (descriptor-reg)) +#+double-double +(define-vop (move-from-complex-double-double) + (:args (x :scs (complex-double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note "complex double-double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm::complex-double-double-float-type + vm::complex-double-double-float-size)) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (inst stdf real-tn y (- (* vm::complex-double-double-float-real-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (inst stdf real-tn y (- (* vm::complex-double-double-float-real-lo-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +#+double-double +(define-move-vop move-from-complex-double-double :move + (complex-double-double-reg) (descriptor-reg)) + ;;; ;;; Move from a descriptor to a complex float register ;;; @@ -518,6 +621,28 @@ (define-move-vop move-to-complex-long :move (descriptor-reg) (complex-long-reg)) +#+double-double +(define-vop (move-to-complex-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-double-reg))) + (:note "pointer to complex double-double float coercion") + (:generator 2 + (let ((real-tn (complex-double-double-reg-real-hi-tn y))) + (inst lddf real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes) + other-pointer-type))) + (let ((real-tn (complex-double-double-reg-real-lo-tn y))) + (inst lddf real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn y))) + (inst lddf imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn y))) + (inst lddf imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes) + other-pointer-type))))) +#+double-double +(define-move-vop move-to-complex-double-double :move + (descriptor-reg) (complex-double-double-reg)) + ;;; ;;; Complex float move-argument vop ;;; @@ -591,14 +716,48 @@ (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))))))))) + +#+double-double +(define-vop (move-complex-double-double-float-argument) + (:args (x :scs (complex-double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg)))) + (:results (y)) + (:note "complex double-double float argument move") + (:generator 2 + (sc-case y + (complex-double-double-reg + (unless (location= x y) + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (move-double-reg y-real x-real)) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (move-double-reg y-real x-real)) + (let ((x-imag (complex-double-double-reg-imag-hi-tn x)) + (y-imag (complex-double-double-reg-imag-hi-tn y))) + (move-long-reg y-imag x-imag)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (move-long-reg y-imag x-imag)))) + (complex-double-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (store-long-reg real-tn nfp offset)) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (store-long-reg real-tn nfp (+ offset (* 2 word-bytes)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (store-long-reg imag-tn nfp (+ offset (* 4 word-bytes)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (store-long-reg imag-tn nfp (+ offset (* 6 word-bytes))))))))) #+long-float (define-move-vop move-complex-long-float-argument :move-argument (complex-long-reg descriptor-reg) (complex-long-reg)) (define-move-vop move-argument :move-argument - (single-reg double-reg #+long-float long-reg - complex-single-reg complex-double-reg #+long-float complex-long-reg) + (single-reg double-reg #+long-float long-reg #+double-double double-double-reg + complex-single-reg complex-double-reg #+long-float complex-long-reg + #+double-double complex-double-double-reg) (descriptor-reg)) @@ -840,6 +999,11 @@ (= (long-float-high-bits x) (long-float-high-bits y)) (= (long-float-exp-bits x) (long-float-exp-bits y)))) +#+double-double +(deftransform eql ((x y) (double-double-float double-double-float)) + '(and (eql (double-double-hi x) (double-double-hi y)) + (eql (double-double-lo x) (double-double-lo y)))) + ;;;; Conversion: @@ -2755,3 +2919,271 @@ (let ((fs1 (and fop rs1 (sigcontext-float-register scp rs1 format))) (fs2 (and fop rs2 (sigcontext-float-register scp rs2 format)))) (values fop (remove nil (list fs1 fs2)))))) + +;;; Support for double-double floats + +#+double-double +(progn +(defun double-double-reg-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) + +(defun double-double-reg-lo-tn (x) + ;; The low tn is 2 more than the offset because double regs are + ;; even. + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) + +(define-move-function (load-double-double 4) (vop x y) + ((double-double-stack) (double-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn y))) + (inst lddf hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn y))) + (inst lddf lo-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +(define-move-function (store-double-double 4) (vop x y) + ((double-double-reg) (double-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stdf hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stdf lo-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +;;; Double-double float register to register moves + +(define-vop (double-double-move) + (:args (x :scs (double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (double-double-reg) :load-if (not (location= x y)))) + (:note "double-double float move") + (:generator 0 + (unless (location= x y) + ;; Note the double-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (move-double-reg y-hi x-hi)) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (move-double-reg y-lo x-lo))))) +;;; +(define-move-vop double-double-move :move + (double-double-reg) (double-double-reg)) + +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. + +(define-vop (move-from-double-double) + (:args (x :scs (double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note "double-double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm::double-double-float-type + vm::double-double-float-size)) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stdf hi-tn y (- (* vm::double-double-float-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stdf lo-tn y (- (* vm::double-double-float-lo-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-double-double :move + (double-double-reg) (descriptor-reg)) + +;;; Move from a descriptor to a double-double float register + +(define-vop (move-to-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (double-double-reg))) + (:note "pointer to double-double float coercion") + (:generator 2 + (let ((hi-tn (double-double-reg-hi-tn y))) + (inst lddf hi-tn x (- (* double-double-float-hi-slot word-bytes) + other-pointer-type))) + (let ((lo-tn (double-double-reg-lo-tn y))) + (inst lddf lo-tn x (- (* double-double-float-lo-slot word-bytes) + other-pointer-type))))) + +(define-move-vop move-to-double-double :move + (descriptor-reg) (double-double-reg)) + +;;; double-double float move-argument vop + +(define-vop (move-double-double-float-argument) + (:args (x :scs (double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y double-double-reg)))) + (:results (y)) + (:note "double-double float argument move") + (:generator 2 + (sc-case y + (double-double-reg + (unless (location= x y) + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (move-double-reg y-hi x-hi)) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (move-double-reg y-lo x-lo)))) + (double-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stdf hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stdf lo-tn nfp (+ offset (* 2 word-bytes))))))))) + +(define-move-vop move-double-double-float-argument :move-argument + (double-double-reg descriptor-reg) (double-double-reg)) + + +(define-vop (make/double-double-float) + (:args (hi :scs (double-reg) :target res + :load-if (not (location= hi res))) + (lo :scs (double-reg))) + (:results (res :scs (double-double-reg) :from (:argument 0) + :load-if (not (sc-is res double-double-stack)))) + (:arg-types double-float double-float) + (:result-types double-double-float) + (:translate kernel::%make-double-double-float) + (:note "inline double-double float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case res + (double-double-reg + (let ((res-hi (double-double-reg-hi-tn res))) + (unless (location= res-hi hi) + (move-double-reg res-hi hi))) + (let ((res-lo (double-double-reg-lo-tn res))) + (unless (location= res-lo lo) + (move-double-reg res-lo lo)))) + (double-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset res) vm:word-bytes))) + (unless (location= hi res) + (inst stdf hi nfp offset)) + (inst stdf lo nfp (+ offset (* 2 vm:word-bytes)))))))) + +(define-vop (double-double-float-value) + (:args (x :scs (double-double-reg) :target r + :load-if (not (sc-is x double-double-stack)))) + (:arg-types double-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (double-double-reg + (let ((value-tn (ecase slot + (:hi (double-double-reg-hi-tn x)) + (:lo (double-double-reg-lo-tn x))))) + (unless (location= value-tn r) + (move-double-reg r value-tn)))) + (double-double-stack + (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:hi 0) (:lo 2)) + (tn-offset x)) + vm:word-bytes)))))) + +(define-vop (hi/double-double-value double-double-float-value) + (:translate kernel::double-double-hi) + (:note "double-double high part") + (:variant :hi)) + +(define-vop (lo/double-double-value double-double-float-value) + (:translate kernel::double-double-lo) + (:note "double-double low part") + (:variant :lo)) + + +(define-vop (make-complex-double-double-float) + (:translate complex) + (:args (real :scs (double-double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-double-reg) :to :save)) + (:arg-types double-double-float double-double-float) + (:results (r :scs (complex-double-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-double-stack)))) + (:result-types complex-double-double-float) + (:note "inline complex double-double float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-double-reg + (let ((r-real (complex-double-double-reg-real-hi-tn r)) + (real-hi (double-double-reg-hi-tn real))) + (move-double-reg r-real real-hi)) + (let ((r-real (complex-double-double-reg-real-lo-tn r)) + (real-lo (double-double-reg-lo-tn real))) + (move-double-reg r-real real-lo)) + (let ((r-imag (complex-double-double-reg-imag-hi-tn r)) + (imag-hi (double-double-reg-hi-tn imag))) + (move-double-reg r-imag imag-hi)) + (let ((r-imag (complex-double-double-reg-imag-lo-tn r)) + (imag-lo (double-double-reg-lo-tn imag))) + (move-double-reg r-imag imag-lo))) + (complex-double-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (let ((r-real (complex-double-double-reg-real-hi-tn r))) + (inst stdf r-real nfp offset)) + (let ((r-real (complex-double-double-reg-real-lo-tn r))) + (inst stdf r-real nfp (+ offset (* 2 vm:word-bytes)))) + (let ((r-imag (complex-double-double-reg-imag-hi-tn r))) + (inst stdf r-imag nfp (+ offset (* 4 vm:word-bytes)))) + (let ((r-imag (complex-double-double-reg-imag-lo-tn r))) + (inst stdf r-imag nfp (+ offset (* 6 vm:word-bytes))))))))) + +(define-vop (complex-double-double-float-value) + (:args (x :scs (complex-double-double-reg) :target r + :load-if (not (sc-is x complex-double-double-stack)))) + (:arg-types complex-double-double-float) + (:results (r :scs (double-double-reg))) + (:result-types double-double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-hi-tn x)) + (:imag (complex-double-double-reg-imag-hi-tn x)))) + (r-hi (double-double-reg-hi-tn r))) + (unless (location= value-tn r-hi) + (move-double-reg r-hi value-tn))) + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-lo-tn x)) + (:imag (complex-double-double-reg-imag-lo-tn x)))) + (r-lo (double-double-reg-lo-tn r))) + (unless (location= value-tn r-lo) + (move-double-reg r-lo value-tn)))) + (complex-double-double-stack + (let ((r-hi (double-double-reg-hi-tn r))) + (inst lddf r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4)) + (tn-offset x)) + vm:word-bytes))) + (let ((r-lo (double-double-reg-lo-tn r))) + (inst lddf r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6)) + (tn-offset x)) + vm:word-bytes))))))) + +(define-vop (realpart/complex-double-double-float complex-double-double-float-value) + (:translate realpart) + (:note "complex double-double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-double-float complex-double-double-float-value) + (:translate imagpart) + (:note "complex double-double float imagpart") + (:variant :imag)) + +); progn + diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp index c24754392c066ed56f337d1d792b890858a59ca8..46e4f82bd645cccbc94de9533c5c57f9aa9de433 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.52 2005/03/17 22:12:57 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.53 2006/06/30 18:41:32 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -158,10 +158,12 @@ about function addresses and register values.") single-float double-float #+long-float long-float + #+double-double double-double-float complex complex-single-float complex-double-float #+long-float complex-long-float + #+double-double complex-double-double-float simple-array simple-string @@ -179,9 +181,11 @@ about function addresses and register values.") simple-array-single-float simple-array-double-float #+long-float simple-array-long-float + #+double-double simple-array-double-double-float simple-array-complex-single-float simple-array-complex-double-float #+long-float simple-array-complex-long-float + #+double-double simple-array-complex-double-double-float complex-string complex-bit-vector complex-vector @@ -193,7 +197,7 @@ about function addresses and register values.") funcallable-instance-header byte-code-function byte-code-closure - dylan-function-header + #-double-double dylan-function-header closure-function-header #-gengc return-pc-header #+gengc forwarding-pointer diff --git a/compiler/sparc/macros.lisp b/compiler/sparc/macros.lisp index 98f1d0e9dd4cbddaa729e633c1157e8b40913912..e3d8a9b50e37d1e82ee2afd1ad2b4984f3934560 100644 --- a/compiler/sparc/macros.lisp +++ b/compiler/sparc/macros.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/macros.lisp,v 1.33 2004/08/12 21:21:00 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.34 2006/06/30 18:41:32 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.33 2004/08/12 21:21:00 rtoy Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.34 2006/06/30 18:41:32 rtoy Rel $ ;;; ;;; This file contains various useful macros for generating SPARC code. ;;; @@ -454,7 +454,8 @@ (list base-char-type unbound-marker-type)) (defconstant function-subtypes - (list funcallable-instance-header-type dylan-function-header-type + (list funcallable-instance-header-type + #-double-double dylan-function-header-type function-header-type closure-function-header-type closure-header-type)) diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp index d41e56b4320826c40833e127995c99cb2b177077..3fcff8c38a0b444733fd5db5108db18075b0614f 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.50 2004/01/09 04:52:19 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.51 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -77,6 +77,8 @@ float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) +#+double-double +(export '(double-double-float-digits)) (eval-when (compile load eval) @@ -149,6 +151,10 @@ (defconstant long-float-digits (+ (byte-size long-float-significand-byte) word-bits 1)) +#+double-double +(defconstant double-double-float-digits + (* 2 double-float-digits)) + (defconstant float-inexact-trap-bit (ash 1 0)) (defconstant float-divide-by-zero-trap-bit (ash 1 1)) (defconstant float-underflow-trap-bit (ash 1 2)) diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp index bdcf3ff96a08bdcd17694c03d4b8e6d545a58c41..506313919178f22229caacddfebd163d0bc8db66 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.24 2005/02/07 23:23:34 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.25 2006/06/30 18:41:32 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -84,7 +84,8 @@ (def-type-vops complexp check-complex complex object-not-complex-error vm:complex-type vm:complex-single-float-type - vm:complex-double-float-type #+long-float vm:complex-long-float-type) + vm:complex-double-float-type #+long-float vm:complex-long-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops complex-rational-p check-complex-rational nil object-not-complex-rational-error vm:complex-type) @@ -92,7 +93,8 @@ (def-type-vops complex-float-p check-complex-float nil object-not-complex-float-error vm:complex-single-float-type vm:complex-double-float-type - #+long-float vm:complex-long-float-type) + #+long-float vm:complex-long-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops complex-single-float-p check-complex-single-float complex-single-float object-not-complex-single-float-error @@ -107,6 +109,11 @@ complex-long-float object-not-complex-long-float-error vm:complex-long-float-type) +#+double-double +(def-type-vops complex-double-double-float-p check-complex-double-double-float + complex-double-double-float object-not-complex-double-double-float-error + vm::complex-double-double-float-type) + (def-type-vops single-float-p check-single-float single-float object-not-single-float-error vm:single-float-type) @@ -117,6 +124,11 @@ (def-type-vops long-float-p check-long-float long-float object-not-long-float-error vm:long-float-type) +#+double-double +(def-type-vops double-double-float-p check-double-double-float + double-double-float object-not-double-double-float-error + vm:double-double-float-type) + (def-type-vops simple-string-p check-simple-string simple-string object-not-simple-string-error vm:simple-string-type) @@ -193,6 +205,11 @@ simple-array-long-float object-not-simple-array-long-float-error vm:simple-array-long-float-type) +#+double-double +(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float + simple-array-double-double-float object-not-simple-array-double-double-float-error + vm::simple-array-double-double-float-type) + (def-type-vops simple-array-complex-single-float-p check-simple-array-complex-single-float simple-array-complex-single-float @@ -212,6 +229,13 @@ object-not-simple-array-complex-long-float-error vm:simple-array-complex-long-float-type) +#+double-double +(def-type-vops simple-array-complex-double-double-float-p + check-simple-array-complex-double-double-float + simple-array-complex-double-double-float + object-not-simple-array-complex-double-double-float-error + vm::simple-array-complex-double-double-float-type) + (def-type-vops base-char-p check-base-char base-char object-not-base-char-error vm:base-char-type) @@ -258,9 +282,11 @@ simple-array-signed-byte-30-type simple-array-signed-byte-32-type vm:simple-array-single-float-type vm:simple-array-double-float-type #+long-float vm:simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type vm:simple-array-complex-single-float-type vm:simple-array-complex-double-float-type #+long-float vm:simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type) (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error @@ -272,9 +298,12 @@ simple-array-signed-byte-30-type simple-array-signed-byte-32-type vm:simple-array-single-float-type vm:simple-array-double-float-type #+long-float vm:simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type vm:simple-array-complex-single-float-type vm:simple-array-complex-double-float-type - #+long-float vm:simple-array-complex-long-float-type) + #+long-float vm:simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type + ) (def-type-vops arrayp check-array nil object-not-array-error vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type @@ -285,17 +314,21 @@ simple-array-signed-byte-30-type simple-array-signed-byte-32-type vm:simple-array-single-float-type vm:simple-array-double-float-type #+long-float vm:simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type vm:simple-array-complex-single-float-type vm:simple-array-complex-double-float-type #+long-float vm:simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type vm:complex-array-type) (def-type-vops numberp check-number nil object-not-number-error vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + #+double-double vm:double-double-float-type vm:complex-type vm:complex-single-float-type vm:complex-double-float-type - #+long-float vm:complex-long-float-type) + #+long-float vm:complex-long-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops rationalp check-rational nil object-not-rational-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) @@ -304,11 +337,13 @@ vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) (def-type-vops floatp check-float nil object-not-float-error - vm:single-float-type vm:double-float-type #+long-float vm:long-float-type) + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + #+double-double vm:double-double-float-type) (def-type-vops realp check-real nil object-not-real-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type - vm:single-float-type vm:double-float-type #+long-float vm:long-float-type) + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + #+double-double vm:double-double-float-type) ;;;; Other integer ranges. diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp index a25e4def4690213d2658690512f3563a7cbc725a..587f07d10f80949a20c6f528c1c0e5ef14a00f9c 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.25 2005/02/11 14:45:28 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.26 2006/06/30 18:41:32 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -183,6 +183,8 @@ :element-size 2 :alignment 2) ; double floats. #+long-float (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats. + #+double-double + (double-double-stack non-descriptor-stack :element-size 4 :alignment 2) ;; complex-single-floats (complex-single-stack non-descriptor-stack :element-size 2) ;; complex-double-floats. @@ -191,6 +193,9 @@ ;; complex-long-floats. (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4) + #+double-double + (complex-double-double-stack non-descriptor-stack :element-size 8 :alignment 4) + ;; **** Things that can go in the integer registers. ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing @@ -302,6 +307,16 @@ :save-p t :alternate-scs (long-stack)) + ;; Non-descriptor double-double floats + #+double-double + (double-double-reg float-registers + :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64 + by 4 collect i) + :element-size 4 :alignment 4 + :constant-scs () + :save-p t + :alternate-scs (double-double-stack)) + (complex-single-reg float-registers :locations #.(loop for i from 0 to 31 by 2 collect i) :element-size 2 :alignment 2 @@ -328,6 +343,15 @@ :save-p t :alternate-scs (complex-long-stack)) + #+double-double + (complex-double-double-reg float-registers + :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64 + by 8 collect i) + :element-size 8 :alignment 8 + :constant-scs () + :save-p t + :alternate-scs (complex-double-double-stack)) + ;; A catch or unwind block. (catch-block control-stack :element-size vm:catch-block-size) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index adec075b9824df74b5a664c6f8171175812bde85..e41683bdd07869d45e0b5647095458246d5791c6 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.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/srctran.lisp,v 1.161 2006/01/17 18:00:33 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.162 2006/06/30 18:41:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -405,10 +405,11 @@ (zerop (bound-value lo)) (= (bound-value lo) (bound-value hi))) ;; At this point lo = hi = +/- 0.0. - (cond ((eql (bound-value lo) (bound-value hi)) - ;; Both bounds are the same kind of signed 0. The - ;; sign of the zero tells us the sign of the - ;; interval. + (cond ((or (eql (bound-value lo) (bound-value hi)) + (integerp (bound-value hi))) + ;; Both bounds are the same kind of signed 0. Or + ;; the high bound is an exact 0. The sign of the + ;; zero tells us the sign of the interval. (if (= (float-sign (bound-value lo)) -1) '- '+)) @@ -1143,6 +1144,12 @@ (when (null (set-difference '(-0l0 0l0) members)) (push (specifier-type '(long-float 0l0 0l0)) misc-types) (setf members (set-difference members '(-0l0 0l0)))) + #+double-double-2 + (let ((pzero (kernel:make-double-double-float 0d0 0d0)) + (nzero (kernel:make-double-double-float -0d0 0d0))) + (when (null (set-difference (list pzero nzero) members)) + (push (specifier-type (list 'kernel:double-double-float pzero pzero)) misc-types) + (setf members (set-difference members (list nzero pzero))))) (when (null (set-difference '(-0d0 0d0) members)) (push (specifier-type '(double-float 0d0 0d0)) misc-types) (setf members (set-difference members '(-0d0 0d0)))) @@ -1643,14 +1650,16 @@ (values 'integer nil)) (rational (values 'rational nil)) - ((or single-float double-float #+long-float long-float) + ((or single-float double-float #+long-float long-float + #+double-double double-double-float) (values 'float rem-type)) (float (values 'float nil)) (real (values nil nil))) (when (member rem-type '(float single-float double-float - #+long-float long-float)) + #+long-float long-float + #+double-double double-double-float)) (setf rem (interval-func #'(lambda (x) (coerce x rem-type)) rem))) @@ -1806,7 +1815,8 @@ (rem (,r-name divisor-interval)) (result-type (rem-result-type number-type divisor-type))) (when (member result-type '(float single-float double-float - #+long-float long-float)) + #+long-float long-float + #+double-double double-double-float)) ;; Make sure the limits on the interval have the right type. (setf rem (interval-func #'(lambda (x) (coerce x result-type)) @@ -3226,12 +3236,14 @@ (member format1 '(short-float single-float))) #-long-float ((double-float long-float) 'T) - #+long-float + #+(or long-float double-double) (double-float (member format1 '(short-float single-float double-float))) #+long-float - (long-float 'T)))) + (long-float 'T) + #+double-double + (double-double-float 't)))) ((and (eq class1 'float) (member class2 '(integer rational))) Nil) (t diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp index c2ae130c5cf2c0a0addf3b97f262745bb10bd6ba..351393cde9019a15a406798111543a02017e8dbd 100644 --- a/compiler/x86/array.lisp +++ b/compiler/x86/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.18 2003/08/03 11:27:45 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.19 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1578,3 +1578,363 @@ (define-vop (get-vector-subtype get-header-data)) (define-vop (set-vector-subtype set-header-data)) + +#+double-double +(progn +(define-vop (data-vector-ref/simple-array-double-double-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-double-double-float positive-fixnum) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((hi-tn (double-double-reg-hi-tn value))) + (with-empty-tn@fp-top (hi-tn) + (inst fldd (make-ea :dword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (let ((lo-tn (double-double-reg-lo-tn value))) + (with-empty-tn@fp-top (lo-tn) + (inst fldd (make-ea :dword :base object :index index :scale 4 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type))))))) + +#+nil +(define-vop (data-vector-ref-c/simple-array-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-double-double-float (:constant index)) + (:info index) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (hi-tn (double-double-reg-hi-tn value)) + (lo-tn (double-double-reg-lo-tn value))) + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst lddf hi-tn object offset) + (inst lddf lo-tn object (+ offset 8))) + (t + (inst li temp offset) + (inst lddf hi-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf lo-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-double-double-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 (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float positive-fixnum + double-double-float) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (double-double-reg-hi-tn value)) + (result-real (double-double-reg-hi-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fstd (make-ea :dword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :dword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (double-double-reg-lo-tn value)) + (result-imag (double-double-reg-lo-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :dword :base object :index index :scale 4 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + +#+nil +(define-vop (data-vector-set-c/simple-array-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float + (:constant index) + double-double-float) + (:info index) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-hi (double-double-reg-hi-tn value)) + (result-hi (double-double-reg-hi-tn result)) + (value-lo (double-double-reg-lo-tn value)) + (result-lo (double-double-reg-lo-tn result)) + (offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst stdf value-hi object offset) + (inst stdf value-lo object (+ offset 8))) + (t + (inst li temp offset) + (inst stdf value-hi object temp) + (inst add temp 8) + (inst stdf value-lo object temp))) + (unless (location= result-hi value-hi) + (move-double-reg result-hi value-hi)) + (unless (location= result-lo value-lo) + (move-double-reg result-lo value-lo))))) + +(define-vop (data-vector-ref/simple-array-complex-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-double-float positive-fixnum) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-double-reg-real-hi-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea :dword :base object :index index :scale 8 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (let ((real-tn (complex-double-double-reg-real-lo-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type))))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 16) + vm:other-pointer-type))))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 24) + vm:other-pointer-type))))))) + +#+nil +(define-vop (data-vector-ref-c/simple-array-complex-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-complex-double-double-float (:constant index)) + (:info index) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (real-hi-tn (complex-double-double-reg-real-hi-tn value)) + (imag-hi-tn (complex-double-double-reg-imag-hi-tn value)) + (real-lo-tn (complex-double-double-reg-real-lo-tn value)) + (imag-lo-tn (complex-double-double-reg-imag-lo-tn value))) + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst lddf real-hi-tn object offset) + (inst lddf imag-hi-tn object (+ offset (* 2 vm:word-bytes))) + (inst lddf real-lo-tn object (+ offset (* 4 vm:word-bytes))) + (inst lddf real-lo-tn object (+ offset (* 6 vm:word-bytes)))) + (t + (inst li temp offset) + (inst lddf real-hi-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf imag-hi-tn object temp) + (inst lddf real-lo-tn object temp) + (inst add temp (* 2 vm:word-bytes)) + (inst lddf imag-lo-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-complex-double-double-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-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float positive-fixnum + complex-double-double-float) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fstd (make-ea :dword :base object :index index :scale 8 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :dword :base object :index index :scale 8 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (inst fstd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + 8) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + 8) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 16) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)) + (let ((value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 24) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + +#+nil +(define-vop (data-vector-set-c/simple-array-complex-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (complex-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float + (:constant index) + complex-double-double-float) + (:info index) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) +;; (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result)) + (value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result)) + (offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset 8) '(signed-byte 13)) + (inst stdf value-real object offset) + (inst stdf value-imag object (+ offset 8))) + (t + (inst li temp offset) + (inst stdf value-real object temp) + (inst add temp 8) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result)) + (value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result)) + (offset (+ (* index 16) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset (* 6 vm:word-bytes)) '(signed-byte 13)) + (inst stdf value-real object (+ offset (* 4 vm:word-bytes))) + (inst stdf value-imag object (+ offset (* 6 vm:word-bytes)))) + (t + (inst add temp 8) + (inst stdf value-real object temp) + (inst add temp 8) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + +) diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp index 40c7f6eb1332c739169c3645cc3e71ef1f7dac89..e4e2515cf8f4d9b1a5186d21aef6747e842023b2 100644 --- a/compiler/x86/float.lisp +++ b/compiler/x86/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.41 2003/07/03 02:14:58 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.42 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -61,7 +61,20 @@ (ea-for-xf-desc tn vm:complex-long-float-real-slot)) #+long-float (defun ea-for-clf-imag-desc (tn) - (ea-for-xf-desc tn vm:complex-long-float-imag-slot))) + (ea-for-xf-desc tn vm:complex-long-float-imag-slot)) + #+double-double + (defun ea-for-cddf-real-hi-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-real-hi-slot)) + #+double-double + (defun ea-for-cddf-real-lo-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-real-lo-slot)) + #+double-double + (defun ea-for-cddf-imag-hi-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-imag-hi-slot)) + #+double-double + (defun ea-for-cddf-imag-lo-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-imag-lo-slot)) + ) (macrolet ((ea-for-xf-stack (tn kind) `(make-ea @@ -86,7 +99,13 @@ (:single 1) (:double 2) (:long 3)) - (ecase ,slot (:real 1) (:imag 2)))) + (ecase ,slot + (:real 1) + (:imag 2) + (:real-hi 1) + (:real-lo 2) + (:imag-hi 3) + (:imag-lo 4)))) vm:word-bytes))))) (defun ea-for-csf-real-stack (tn &optional (base ebp-tn)) (ea-for-cxf-stack tn :single :real base)) @@ -103,7 +122,21 @@ (ea-for-cxf-stack tn :long :real base)) #+long-float (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn)) - (ea-for-cxf-stack tn :long :imag base))) + (ea-for-cxf-stack tn :long :imag base)) + + #+double-double + (defun ea-for-cddf-real-hi-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :double :real-hi base)) + #+double-double + (defun ea-for-cddf-real-lo-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :double :real-lo base)) + #+double-double + (defun ea-for-cddf-imag-hi-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :double :imag-hi base)) + #+double-double + (defun ea-for-cddf-imag-lo-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :double :imag-lo base)) + ) ;;; Abstract out the copying of a FP register to the FP stack top, and ;;; provide two alternatives for its implementation. Note: it's not @@ -236,6 +269,21 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) :offset (1+ (tn-offset x)))) +#+double-double +(progn +(defun complex-double-double-reg-real-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-double-reg-real-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 1 (tn-offset x)))) +(defun complex-double-double-reg-imag-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) +(defun complex-double-double-reg-imag-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 3 (tn-offset x)))) +) ;;; x is source, y is destination (define-move-function (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) @@ -308,6 +356,49 @@ (store-long-float (ea-for-clf-imag-stack y)) (inst fxch imag-tn))) +#+double-double +(progn +(define-move-function (load-complex-double-double 4) (vop x y) + ((complex-double-double-stack) (complex-double-double-reg)) + (let ((real-tn (complex-double-double-reg-real-hi-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cddf-real-hi-stack x)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cddf-real-lo-stack x)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cddf-imag-hi-stack x)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cddf-imag-lo-stack x))))) + +(define-move-function (store-complex-double-double 4) (vop x y) + ((complex-double-double-reg) (complex-double-double-stack)) + ;; FIXME: These may not be right!!!! + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cddf-real-hi-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cddf-real-hi-stack y)) + (inst fxch real-tn)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cddf-real-lo-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cddf-real-lo-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cddf-imag-hi-stack y)) + (inst fxch imag-tn)) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cddf-imag-lo-stack y)) + (inst fxch imag-tn))) +) ;;;; Move VOPs: @@ -557,6 +648,31 @@ (define-move-vop move-from-complex-long :move (complex-long-reg) (descriptor-reg)) +#+double-double +(define-vop (move-from-complex-double-double) + (:args (x :scs (complex-double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "complex double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm::complex-double-double-float-type + vm::complex-double-double-float-size node) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (with-tn@fp-top(real-tn) + (inst fstd (ea-for-cddf-real-hi-desc y)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (with-tn@fp-top(real-tn) + (inst fstd (ea-for-cddf-real-lo-desc y)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (with-tn@fp-top(imag-tn) + (inst fstd (ea-for-cddf-imag-hi-desc y)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (with-tn@fp-top(imag-tn) + (inst fstd (ea-for-cddf-imag-lo-desc y))))))) +;;; +#+double-double +(define-move-vop move-from-complex-double-double :move + (complex-double-double-reg) (descriptor-reg)) ;;; ;;; Move from a descriptor to a complex float register ;;; @@ -724,9 +840,76 @@ (frob move-complex-long-float-argument complex-long-reg complex-long-stack :long)) +#+double-double +(define-vop (move-complex-double-double-float-argument) + (:args (x :scs (complex-double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg)))) + (:results (y)) + (:note "complex double-double-float argument move") + (:generator 2 + (sc-case y + (complex-double-double-reg + (unless (location= x y) + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-double-reg-imag-hi-tn x)) + (y-imag (complex-double-double-reg-imag-hi-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)))) + (complex-double-double-stack + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cddf-real-hi-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cddf-real-hi-stack y)) + (inst fxch real-tn)))) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cddf-real-lo-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cddf-real-lo-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cddf-imag-hi-stack y)) + (inst fxch imag-tn)) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cddf-imag-lo-stack y)) + (inst fxch imag-tn)))) + )) + (define-move-vop move-argument :move-argument (single-reg double-reg #+long-float long-reg - complex-single-reg complex-double-reg #+long-float complex-long-reg) + #+double-double double-double-reg + complex-single-reg complex-double-reg #+long-float complex-long-reg + #+double-double complex-double-double-reg) (descriptor-reg)) @@ -1206,6 +1389,12 @@ (= (long-float-high-bits x) (long-float-high-bits y)) (= (long-float-exp-bits x) (long-float-exp-bits y)))) +#+double-double +(deftransform eql ((x y) (double-double-float double-double-float)) + '(and (eql (double-double-hi x) (double-double-hi y)) + (eql (double-double-lo x) (double-double-lo y)))) + + (define-vop (=/float) (:args (x) (y)) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) @@ -4641,3 +4830,410 @@ (:note "inline dummy FP register bias") (:ignore x) (:generator 0)) + +;;; Support for double-double floats + +#+double-double +(progn + +(defun double-double-reg-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) + +(defun double-double-reg-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (1+ (tn-offset x)))) + +(define-move-function (load-double-double 4) (vop x y) + ((double-double-stack) (double-double-reg)) + (let ((real-tn (double-double-reg-hi-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cdf-real-stack x)))) + (let ((imag-tn (double-double-reg-lo-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cdf-imag-stack x))))) + +(define-move-function (store-double-double 4) (vop x y) + ((double-double-reg) (double-double-stack)) + (let ((real-tn (double-double-reg-hi-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cdf-real-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cdf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (double-double-reg-lo-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cdf-imag-stack y)) + (inst fxch imag-tn))) + +;;; Double-double float register to register moves + +(define-vop (double-double-move) + (:args (x :scs (double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (double-double-reg) :load-if (not (location= x y)))) + (:note "double-double float move") + (:generator 0 + (unless (location= x y) + ;; Note the double-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (cond ((zerop (tn-offset y-hi)) + (copy-fp-reg-to-fr0 x-hi)) + ((zerop (tn-offset x-hi)) + (inst fstd y-hi)) + (t + (inst fxch x-hi) + (inst fstd y-hi) + (inst fxch x-hi)))) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (inst fxch x-lo) + (inst fstd y-lo) + (inst fxch x-lo))))) +;;; +(define-move-vop double-double-move :move + (double-double-reg) (double-double-reg)) + +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. + +(define-vop (move-from-double-double) + (:args (x :scs (double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "double double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:double-double-float-type + vm:double-double-float-size node) + (let ((real-tn (double-double-reg-hi-tn x))) + (with-tn@fp-top(real-tn) + (inst fstd (ea-for-cdf-real-desc y)))) + (let ((imag-tn (double-double-reg-lo-tn x))) + (with-tn@fp-top(imag-tn) + (inst fstd (ea-for-cdf-imag-desc y))))))) +;;; +(define-move-vop move-from-double-double :move + (double-double-reg) (descriptor-reg)) + +;;; Move from a descriptor to a double-double float register + +(define-vop (move-to-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (double-double-reg))) + (:note "pointer to double-double-float coercion") + (:generator 2 + (let ((real-tn (double-double-reg-hi-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cdf-real-desc x)))) + (let ((imag-tn (double-double-reg-lo-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cdf-imag-desc x)))))) + +(define-move-vop move-to-double-double :move + (descriptor-reg) (double-double-reg)) + +;;; double-double float move-argument vop + +(define-vop (move-double-double-float-argument) + (:args (x :scs (double-double-reg) :target y) + (fp :scs (any-reg) :load-if (not (sc-is y double-double-reg)))) + (:results (y)) + (:note "double double-float argument move") + (:generator 2 + (sc-case y + (double-double-reg + (unless (location= x y) + (let ((x-real (double-double-reg-hi-tn x)) + (y-real (double-double-reg-hi-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (double-double-reg-lo-tn x)) + (y-imag (double-double-reg-lo-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)))) + (double-double-stack + (let ((hi-tn (double-double-reg-hi-tn x))) + (cond ((zerop (tn-offset hi-tn)) + (inst fstd (ea-for-cdf-real-stack y fp))) + (t + (inst fxch hi-tn) + (inst fstd (ea-for-cdf-real-stack y fp)) + (inst fxch hi-tn)))) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst fxch lo-tn) + (inst fstd (ea-for-cdf-imag-stack y fp)) + (inst fxch lo-tn)))))) + +(define-move-vop move-double-double-float-argument :move-argument + (double-double-reg descriptor-reg) (double-double-reg)) + + +(define-vop (move-to-complex-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-double-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-double-reg-real-hi-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cddf-real-hi-desc x)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cddf-real-lo-desc x)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cddf-imag-hi-desc x)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cddf-imag-lo-desc x)))))) + +(define-move-vop move-to-complex-double-double :move + (descriptor-reg) (complex-double-double-reg)) + + +(define-vop (make/double-double-float) + (:args (hi :scs (double-reg) :target r + :load-if (not (location= hi r))) + (lo :scs (double-reg) :to :save)) + (:results (r :scs (double-double-reg) :from (:argument 0) + :load-if (not (sc-is r double-double-stack)))) + (:arg-types double-float double-float) + (:result-types double-double-float) + (:translate kernel::%make-double-double-float) + (:note "inline double-double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (double-double-reg + (let ((r-real (double-double-reg-hi-tn r))) + (unless (location= hi r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 hi)) + ((zerop (tn-offset hi)) + (inst fstd r-real)) + (t + (inst fxch hi) + (inst fstd r-real) + (inst fxch hi))))) + (let ((r-imag (double-double-reg-lo-tn r))) + (unless (location= lo r-imag) + (cond ((zerop (tn-offset lo)) + (inst fstd r-imag)) + (t + (inst fxch lo) + (inst fstd r-imag) + (inst fxch lo)))))) + (double-double-stack + (unless (location= hi r) + (cond ((zerop (tn-offset hi)) + (inst fstd (ea-for-cdf-real-stack r))) + (t + (inst fxch hi) + (inst fstd (ea-for-cdf-real-stack r)) + (inst fxch hi)))) + (inst fxch lo) + (inst fstd (ea-for-cdf-imag-stack r)) + (inst fxch lo))))) + +(define-vop (double-double-value) + (:args (x :target r)) + (:results (r)) + (:variant-vars offset) + (:policy :fast-safe) + (:generator 3 + (cond ((sc-is x double-double-reg) + (let ((value-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ offset (tn-offset x))))) + (unless (location= value-tn r) + (cond ((zerop (tn-offset r)) + (copy-fp-reg-to-fr0 value-tn)) + ((zerop (tn-offset value-tn)) + (inst fstd r)) + (t + (inst fxch value-tn) + (inst fstd r) + (inst fxch value-tn)))))) + ((sc-is r double-reg) + (let ((ea (sc-case x + (double-double-stack + (ecase offset + (0 (ea-for-cdf-real-stack x)) + (1 (ea-for-cdf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-cdf-real-desc x)) + (1 (ea-for-cdf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldd ea)))) + (t (error "double-double-value VOP failure"))))) + + +(define-vop (hi/double-double-value double-double-value) + (:translate kernel::double-double-hi) + (:args (x :scs (double-double-reg double-double-stack descriptor-reg) + :target r)) + (:arg-types double-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:note "double-double high part") + (:variant 0)) + +(define-vop (lo/double-double-value double-double-value) + (:translate kernel::double-double-lo) + (:args (x :scs (double-double-reg double-double-stack descriptor-reg) + :target r)) + (:arg-types double-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:note "double-double low part") + (:variant 1)) + +(define-vop (make-complex-double-double-float) + (:translate complex) + (:args (real :scs (double-double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-double-reg) :to :save)) + (:arg-types double-double-float double-double-float) + (:results (r :scs (complex-double-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-double-stack)))) + (:result-types complex-double-double-float) + (:note "inline complex double-double-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-double-double-reg + (let ((r-real (complex-double-double-reg-real-hi-tn r)) + (a-real (double-double-reg-hi-tn real))) + (unless (location= a-real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 a-real)) + ((zerop (tn-offset a-real)) + (inst fstd r-real)) + (t + (inst fxch a-real) + (inst fstd r-real) + (inst fxch a-real))))) + (let ((r-real (complex-double-double-reg-real-lo-tn r)) + (a-real (double-double-reg-lo-tn real))) + (unless (location= a-real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 a-real)) + ((zerop (tn-offset a-real)) + (inst fstd r-real)) + (t + (inst fxch a-real) + (inst fstd r-real) + (inst fxch a-real))))) + (let ((r-imag (complex-double-double-reg-imag-hi-tn r)) + (a-imag (double-double-reg-hi-tn imag))) + (unless (location= a-imag r-imag) + (cond ((zerop (tn-offset a-imag)) + (inst fstd r-imag)) + (t + (inst fxch a-imag) + (inst fstd r-imag) + (inst fxch a-imag))))) + (let ((r-imag (complex-double-double-reg-imag-lo-tn r)) + (a-imag (double-double-reg-lo-tn imag))) + (unless (location= a-imag r-imag) + (cond ((zerop (tn-offset a-imag)) + (inst fstd r-imag)) + (t + (inst fxch a-imag) + (inst fstd r-imag) + (inst fxch a-imag)))))) + (complex-double-double-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (inst fstd (ea-for-cddf-real-hi-stack r))) + (t + (inst fxch real) + (inst fstd (ea-for-cddf-real-hi-stack r)) + (inst fxch real)))) + (cond ((zerop (tn-offset real)) + (inst fstd (ea-for-cddf-real-lo-stack r))) + (t + (inst fxch real) + (inst fstd (ea-for-cddf-real-lo-stack r)) + (inst fxch real))) + (let ((imag-val (complex-double-double-reg-imag-hi-tn imag))) + (inst fxch imag-val) + (inst fstd (ea-for-cddf-imag-hi-stack r)) + (inst fxch imag-val)) + (let ((imag-val (complex-double-double-reg-imag-lo-tn imag))) + (inst fxch imag-val) + (inst fstd (ea-for-cddf-imag-lo-stack r)) + (inst fxch imag-val)))))) + +(define-vop (complex-double-double-float-value) + (:args (x :scs (complex-double-double-reg) :target r + :load-if (not (sc-is x complex-double-double-stack)))) + (:arg-types complex-double-double-float) + (:results (r :scs (double-double-reg))) + (:result-types double-double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:generator 3 + (sc-case x + (complex-double-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-hi-tn x)) + (:imag (complex-double-double-reg-imag-hi-tn x)))) + (r-hi (double-double-reg-hi-tn r))) + (unless (location= value-tn r-hi) + (cond ((zerop (tn-offset r-hi)) + (copy-fp-reg-to-fr0 value-tn)) + ((zerop (tn-offset value-tn)) + (inst fstd r-hi)) + (t + (inst fxch value-tn) + (inst fstd r-hi) + (inst fxch value-tn))))) + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-lo-tn x)) + (:imag (complex-double-double-reg-imag-lo-tn x)))) + (r-lo (double-double-reg-lo-tn r))) + (unless (location= value-tn r-lo) + (cond ((zerop (tn-offset r-lo)) + (copy-fp-reg-to-fr0 value-tn)) + ((zerop (tn-offset value-tn)) + (inst fstd r-lo)) + (t + (inst fxch value-tn) + (inst fstd r-lo) + (inst fxch value-tn)))))) + (complex-double-double-stack + (let ((r-hi (double-double-reg-hi-tn r))) + (with-empty-tn@fp-top (r-hi) + (inst fld (ecase slot + (:real (ea-for-cddf-real-hi-stack x)) + (:imag (ea-for-cddf-imag-hi-stack x)))))) + (let ((r-lo (double-double-reg-lo-tn r))) + (with-empty-tn@fp-top (r-lo) + (inst fld (ecase slot + (:real (ea-for-cddf-real-lo-stack x)) + (:imag (ea-for-cddf-imag-lo-stack x)))))))))) + +(define-vop (realpart/complex-double-double-float complex-double-double-float-value) + (:translate realpart) + (:note "complex float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-double-float complex-double-double-float-value) + (:translate imagpart) + (:note "complex float imagpart") + (:variant :imag)) + +); progn diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp index 336bf4c44614f37fd80e5da6c948b8be4d0788a3..f801a7d7f879a2c8c7fbe4a7826c5e0b1431fb0b 100644 --- a/compiler/x86/parms.lisp +++ b/compiler/x86/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.28 2004/07/07 15:03:11 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.29 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -85,6 +85,8 @@ float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) +#+double-double +(export '(double-double-float-digits)) (eval-when (compile load eval) @@ -143,6 +145,10 @@ (defconstant long-float-digits (+ (byte-size long-float-significand-byte) word-bits 1)) +#+double-double +(defconstant double-double-float-digits + (* 2 double-float-digits)) + ;;; pfw -- from i486 microprocessor programmers reference manual (defconstant float-invalid-trap-bit (ash 1 0)) (defconstant float-denormal-trap-bit (ash 1 1)) diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp index 6dbf364c65edd46ea816eb186ffe289520c342f2..0adfb159886df51750f8a2e9a64988ab93cfddcc 100644 --- a/compiler/x86/type-vops.lisp +++ b/compiler/x86/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.12 1998/07/24 17:22:43 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.13 2006/06/30 18:41:32 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -32,7 +32,7 @@ (defparameter function-header-types - (list funcallable-instance-header-type dylan-function-header-type + (list funcallable-instance-header-type byte-code-function-type byte-code-closure-type function-header-type closure-function-header-type closure-header-type)) @@ -354,7 +354,8 @@ (def-type-vops complexp check-complex complex object-not-complex-error complex-type complex-single-float-type complex-double-float-type - #+long-float complex-long-float-type) + #+long-float complex-long-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops complex-rational-p check-complex-rational nil object-not-complex-rational-error complex-type) @@ -362,7 +363,8 @@ (def-type-vops complex-float-p check-complex-float nil object-not-complex-float-error complex-single-float-type complex-double-float-type - #+long-float complex-long-float-type) + #+long-float complex-long-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops complex-single-float-p check-complex-single-float complex-single-float object-not-complex-single-float-error @@ -377,6 +379,11 @@ complex-long-float object-not-complex-long-float-error complex-long-float-type) +#+double-double +(def-type-vops complex-double-double-float-p check-complex-double-double-float + complex-double-double-float object-not-complex-double-double-float-error + vm::complex-double-double-float-type) + (def-type-vops single-float-p check-single-float single-float object-not-single-float-error single-float-type) @@ -387,6 +394,11 @@ (def-type-vops long-float-p check-long-float long-float object-not-long-float-error long-float-type) +#+double-double +(def-type-vops double-double-float-p check-double-double-float + double-double-float object-not-double-double-float-error + vm:double-double-float-type) + (def-type-vops simple-string-p check-simple-string simple-string object-not-simple-string-error simple-string-type) @@ -463,6 +475,11 @@ simple-array-long-float object-not-simple-array-long-float-error simple-array-long-float-type) +#+double-double +(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float + simple-array-double-double-float object-not-simple-array-double-double-float-error + vm::simple-array-double-double-float-type) + (def-type-vops simple-array-complex-single-float-p check-simple-array-complex-single-float simple-array-complex-single-float @@ -482,6 +499,13 @@ object-not-simple-array-complex-long-float-error simple-array-complex-long-float-type) +#+double-double +(def-type-vops simple-array-complex-double-double-float-p + check-simple-array-complex-double-double-float + simple-array-complex-double-double-float + object-not-simple-array-complex-double-double-float-error + vm::simple-array-complex-double-double-float-type) + (def-type-vops base-char-p check-base-char base-char object-not-base-char-error base-char-type) @@ -529,9 +553,11 @@ simple-array-signed-byte-30-type simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type #+long-float simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type simple-array-complex-single-float-type simple-array-complex-double-float-type #+long-float simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type complex-string-type complex-bit-vector-type complex-vector-type) (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error @@ -543,9 +569,12 @@ simple-array-signed-byte-30-type simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type #+long-float simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type simple-array-complex-single-float-type simple-array-complex-double-float-type - #+long-float simple-array-complex-long-float-type) + #+long-float simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type + ) (def-type-vops arrayp check-array nil object-not-array-error simple-array-type simple-string-type simple-bit-vector-type @@ -556,17 +585,22 @@ simple-array-signed-byte-30-type simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type #+long-float simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type simple-array-complex-single-float-type simple-array-complex-double-float-type #+long-float simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type complex-string-type complex-bit-vector-type complex-vector-type complex-array-type) (def-type-vops numberp check-number nil object-not-number-error even-fixnum-type odd-fixnum-type bignum-type ratio-type - single-float-type double-float-type #+long-float long-float-type complex-type + single-float-type double-float-type #+long-float long-float-type + #+double-double vm:double-double-float-type + complex-type complex-single-float-type complex-double-float-type - #+long-float complex-long-float-type) + #+long-float complex-long-float-type + #+double-double vm::complex-double-double-float-type) (def-type-vops rationalp check-rational nil object-not-rational-error even-fixnum-type odd-fixnum-type ratio-type bignum-type) @@ -575,11 +609,13 @@ even-fixnum-type odd-fixnum-type bignum-type) (def-type-vops floatp check-float nil object-not-float-error - single-float-type double-float-type #+long-float long-float-type) + single-float-type double-float-type #+long-float long-float-type + #+double-double vm:double-double-float-type) (def-type-vops realp check-real nil object-not-real-error even-fixnum-type odd-fixnum-type ratio-type bignum-type - single-float-type double-float-type #+long-float long-float-type) + single-float-type double-float-type #+long-float long-float-type + #+double-double vm:double-double-float-type) ;;;; Other integer ranges. diff --git a/compiler/x86/vm.lisp b/compiler/x86/vm.lisp index 470fbbaabebf96ecb941c6c93821ab7f273b6d6f..6854212f684c95a14e3d17f0a9c15e28b9ebbab2 100644 --- a/compiler/x86/vm.lisp +++ b/compiler/x86/vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.10 1998/07/24 17:22:44 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.11 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -174,13 +174,17 @@ (sap-stack stack) ; System area pointers. (single-stack stack) ; single-floats (double-stack stack :element-size 2) ; double-floats. + #+double-double + (double-double-stack stack :element-size 4) ; double-double-float #+long-float (long-stack stack :element-size 3) ; long-floats. (complex-single-stack stack :element-size 2) ; complex-single-floats (complex-double-stack stack :element-size 4) ; complex-double-floats #+long-float (complex-long-stack stack :element-size 6) ; complex-long-floats - + #+double-double + (complex-double-double-stack stack :element-size 8) ; complex-double-double-floats + ;; **** Magic SCs. (ignore-me noise) @@ -280,6 +284,14 @@ :save-p t :alternate-scs (long-stack)) + #+double-double + (double-double-reg float-registers + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (double-double-stack)) + (complex-single-reg float-registers :locations (0 2 4 6) :element-size 2 @@ -301,6 +313,13 @@ :constant-scs () :save-p t :alternate-scs (complex-long-stack)) + #+double-double + (complex-double-double-reg float-registers + :locations (0 4) + :element-size 4 + :constant-scs () + :save-p t + :alternate-scs (complex-double-double-stack)) ;; A catch or unwind block. (catch-block stack :element-size vm:catch-block-size) diff --git a/general-info/release-19d.txt b/general-info/release-19d.txt index b357d6788ed7c7cb49787a00287f8ebf4a8b67c9..8e674d046840c9f33dfa6b2bcbd8499078242409 100644 --- a/general-info/release-19d.txt +++ b/general-info/release-19d.txt @@ -52,6 +52,56 @@ New in this release: - When a core file is started, any shared libraries that were loaded when the core was made will be reloaded on startup. If the library cannot be found, several restarts are available. + - Support for the new float type EXT:DOUBLE-DOUBLE-FLOAT. This + includes support for complex numbers with this component type + and simple arrays for this type and complex numbers of this + type. + + A DOUBLE-DOUBLE-FLOAT uses two DOUBLE-FLOAT's to represent a + number with >= 106 bits of precision (about 33 digits). Known + issues: + + * If you are expecting IEEE-style behavior, you don't get it: + - signed zeroes aren't really available. + - overflows don't return infinity but return NaN instead. + - rounding might not be quite the same as IEEE + - SQRT is not accurate to the last bit, as required by IEEE. + * Multiplying by a number very close to + most-positive-double-float will produce an error even if the + result does not overflow. (This is an artifact of how + multiplication is done. I don't have a solution to this.) + * Read/write consistency is not working. (Because conversion + from a bignum to a double-double-float doesn't really + understand the internal double-double-float format.) + * INTEGER-DECODE-FLOAT and SCALE-FLOAT aren't "inverses". + That is, you can't take the result of integer-decode-float + and use scale-float to produce exactly the same number. + This is because of how bignums are converted to + double-doubles. + * FLOAT-DIGITS always returns 106 even though there could be + more bits. (Consider the double-double (1d0,1d-200)). This + will show up in PRINT where the printed result will have way + more than the normal 33 digits or so. But reading such a + number back won't give the same value. + * There is probably more consing than is necessary in many of + the standard Common Lisp functions like floor, ffloor, etc. + * The special functions are not fully tested. I did a few + random spot checks for each function and compared the + results with maxima to verify them. + * The branch cuts for the special functions very likely will + not match the double-float versions, mostly because we don't + have working signed zeroes. + * Type derivation for double-double-floats might not be + working quite right. + * PI is still a double-float. If you want a double-double + version of pi, it's KERNEL:DD-PI. (Soon to be EXT:DD-PI.) + * All double-double operations are inlined by default (unless + *INLINE-EXPANSION-LIMIT* is reached), so functions will tend + to be very large. (Each basic double-double operation takes + some 20 FP instructions). + * There are probably still many bugs where double-double-float + support was overlooked. + * Numerous ANSI compliance fixes: diff --git a/lisp/gencgc.c b/lisp/gencgc.c index fe05365f1ce25a19ea125ad859d3d3358be4044d..67e39115bfd49cf68b1941b9d083ff9a948190ff 100644 --- a/lisp/gencgc.c +++ b/lisp/gencgc.c @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.70 2006/02/04 03:32:31 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.71 2006/06/30 18:41:32 rtoy Exp $ * */ @@ -4234,6 +4234,35 @@ trans_vector_long_float(lispobj object) } #endif +#ifdef type_SimpleArrayDoubleDoubleFloat +static int +size_vector_double_double_float(lispobj * where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 4 + 2, 2); + + return nwords; +} + +static int +scav_vector_double_double_float(lispobj * where, lispobj object) +{ + return size_vector_double_double_float(where); +} + +static lispobj +trans_vector_double_double_float(lispobj object) +{ + gc_assert(Pointerp(object)); + return copy_large_unboxed_object(object, + size_vector_double_double_float((lispobj *) + PTR(object))); +} +#endif #ifdef type_SimpleArrayComplexSingleFloat static int @@ -4341,6 +4370,38 @@ trans_vector_complex_long_float(lispobj object) (object))); } #endif + +#ifdef type_SimpleArrayComplexDoubleDoubleFloat +static int +size_vector_complex_double_double_float(lispobj * where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = length * 8 + 2; + + return nwords; +} + +static int +scav_vector_complex_double_double_float(lispobj * where, lispobj object) +{ + return size_vector_complex_double_double_float(where); +} + +static lispobj +trans_vector_complex_double_double_float(lispobj object) +{ + gc_assert(Pointerp(object)); + return copy_large_unboxed_object(object, + size_vector_complex_double_double_float((lispobj *) + PTR + (object))); +} +#endif + /* Weak Pointers */ @@ -4523,6 +4584,9 @@ gc_init_tables(void) #ifdef type_LongFloat scavtab[type_LongFloat] = scav_unboxed; #endif +#ifdef type_DoubleDoubleFloat + scavtab[type_DoubleDoubleFloat] = scav_unboxed; +#endif scavtab[type_Complex] = scav_boxed; #ifdef type_ComplexSingleFloat scavtab[type_ComplexSingleFloat] = scav_unboxed; @@ -4532,6 +4596,9 @@ gc_init_tables(void) #endif #ifdef type_ComplexLongFloat scavtab[type_ComplexLongFloat] = scav_unboxed; +#endif +#ifdef type_ComplexDoubleDoubleFloat + scavtab[type_ComplexDoubleDoubleFloat] = scav_unboxed; #endif scavtab[type_SimpleArray] = scav_boxed; scavtab[type_SimpleString] = scav_string; @@ -4559,6 +4626,9 @@ gc_init_tables(void) #ifdef type_SimpleArrayLongFloat scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float; #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + scavtab[type_SimpleArrayDoubleDoubleFloat] = scav_vector_double_double_float; +#endif #ifdef type_SimpleArrayComplexSingleFloat scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float; @@ -4569,6 +4639,10 @@ gc_init_tables(void) #endif #ifdef type_SimpleArrayComplexLongFloat scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float; +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + scavtab[type_SimpleArrayComplexDoubleDoubleFloat] = + scav_vector_complex_double_double_float; #endif scavtab[type_ComplexString] = scav_boxed; scavtab[type_ComplexBitVector] = scav_boxed; @@ -4585,13 +4659,17 @@ gc_init_tables(void) scavtab[type_FuncallableInstanceHeader] = scav_closure_header; scavtab[type_ByteCodeFunction] = scav_closure_header; scavtab[type_ByteCodeClosure] = scav_closure_header; +#ifdef type_DylanFunctionHeader scavtab[type_DylanFunctionHeader] = scav_closure_header; +#endif #else scavtab[type_ClosureHeader] = scav_boxed; scavtab[type_FuncallableInstanceHeader] = scav_boxed; scavtab[type_ByteCodeFunction] = scav_boxed; scavtab[type_ByteCodeClosure] = scav_boxed; +#ifdef type_DylanFunctionHeader scavtab[type_DylanFunctionHeader] = scav_boxed; +#endif #endif scavtab[type_ValueCellHeader] = scav_boxed; scavtab[type_SymbolHeader] = scav_boxed; @@ -4622,6 +4700,9 @@ gc_init_tables(void) transother[type_DoubleFloat] = trans_unboxed; #ifdef type_LongFloat transother[type_LongFloat] = trans_unboxed; +#endif +#ifdef type_DoubleDoubleFloat + transother[type_DoubleDoubleFloat] = trans_unboxed; #endif transother[type_Complex] = trans_boxed; #ifdef type_ComplexSingleFloat @@ -4632,6 +4713,9 @@ gc_init_tables(void) #endif #ifdef type_ComplexLongFloat transother[type_ComplexLongFloat] = trans_unboxed; +#endif +#ifdef type_ComplexDoubleDoubleFloat + transother[type_ComplexDoubleDoubleFloat] = trans_unboxed; #endif transother[type_SimpleArray] = trans_boxed_large; transother[type_SimpleString] = trans_string; @@ -4659,6 +4743,9 @@ gc_init_tables(void) #ifdef type_SimpleArrayLongFloat transother[type_SimpleArrayLongFloat] = trans_vector_long_float; #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + transother[type_SimpleArrayDoubleDoubleFloat] = trans_vector_double_double_float; +#endif #ifdef type_SimpleArrayComplexSingleFloat transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float; @@ -4670,6 +4757,10 @@ gc_init_tables(void) #ifdef type_SimpleArrayComplexLongFloat transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float; +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + transother[type_SimpleArrayComplexDoubleDoubleFloat] = + trans_vector_complex_double_double_float; #endif transother[type_ComplexString] = trans_boxed; transother[type_ComplexBitVector] = trans_boxed; @@ -4715,6 +4806,9 @@ gc_init_tables(void) sizetab[type_DoubleFloat] = size_unboxed; #ifdef type_LongFloat sizetab[type_LongFloat] = size_unboxed; +#endif +#ifdef type_DoubleDoubleFloat + sizetab[type_DoubleDoubleFloat] = size_unboxed; #endif sizetab[type_Complex] = size_boxed; #ifdef type_ComplexSingleFloat @@ -4725,6 +4819,9 @@ gc_init_tables(void) #endif #ifdef type_ComplexLongFloat sizetab[type_ComplexLongFloat] = size_unboxed; +#endif +#ifdef type_ComplexDoubleDoubleFloat + sizetab[type_ComplexDoubleDoubleFloat] = size_unboxed; #endif sizetab[type_SimpleArray] = size_boxed; sizetab[type_SimpleString] = size_string; @@ -4752,6 +4849,9 @@ gc_init_tables(void) #ifdef type_SimpleArrayLongFloat sizetab[type_SimpleArrayLongFloat] = size_vector_long_float; #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + sizetab[type_SimpleArrayDoubleDoubleFloat] = size_vector_double_double_float; +#endif #ifdef type_SimpleArrayComplexSingleFloat sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float; @@ -4762,6 +4862,10 @@ gc_init_tables(void) #endif #ifdef type_SimpleArrayComplexLongFloat sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float; +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + sizetab[type_SimpleArrayComplexDoubleDoubleFloat] = + size_vector_complex_double_double_float; #endif sizetab[type_ComplexString] = size_boxed; sizetab[type_ComplexBitVector] = size_boxed; @@ -4909,7 +5013,9 @@ valid_dynamic_space_pointer(lispobj * pointer) case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif if ((size_t) pointer != (size_t) start_addr + type_FunctionPointer) { return FALSE; @@ -4962,7 +5068,9 @@ valid_dynamic_space_pointer(lispobj * pointer) case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif return FALSE; case type_InstanceHeader: @@ -4980,6 +5088,9 @@ valid_dynamic_space_pointer(lispobj * pointer) #endif #ifdef type_ComplexLongFloat case type_ComplexLongFloat: +#endif +#ifdef type_ComplexDoubleDoubleFloat + case type_ComplexDoubleDoubleFloat: #endif case type_SimpleArray: case type_ComplexString: @@ -4995,6 +5106,9 @@ valid_dynamic_space_pointer(lispobj * pointer) case type_DoubleFloat: #ifdef type_LongFloat case type_LongFloat: +#endif +#ifdef type_DoubleDoubleFloat + case type_DoubleDoubleFloat: #endif case type_SimpleString: case type_SimpleBitVector: @@ -5020,6 +5134,9 @@ valid_dynamic_space_pointer(lispobj * pointer) #ifdef type_SimpleArrayLongFloat case type_SimpleArrayLongFloat: #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: +#endif #ifdef type_SimpleArrayComplexSingleFloat case type_SimpleArrayComplexSingleFloat: #endif @@ -5028,6 +5145,9 @@ valid_dynamic_space_pointer(lispobj * pointer) #endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayComplexLongFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: #endif case type_Sap: case type_WeakPointer: @@ -5099,6 +5219,9 @@ maybe_adjust_large_object(lispobj * where) #ifdef type_SimpleArrayLongFloat case type_SimpleArrayLongFloat: #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: +#endif #ifdef type_SimpleArrayComplexSingleFloat case type_SimpleArrayComplexSingleFloat: #endif @@ -5107,6 +5230,9 @@ maybe_adjust_large_object(lispobj * where) #endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayComplexLongFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: #endif unboxed = TRUE; break; @@ -6163,7 +6289,9 @@ verify_space(lispobj * start, size_t words) case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif case type_ValueCellHeader: case type_SymbolHeader: case type_BaseChar: @@ -6237,6 +6365,9 @@ verify_space(lispobj * start, size_t words) #endif #ifdef type_ComplexLongFloat case type_ComplexLongFloat: +#endif +#ifdef type_ComplexDoubleDoubleFloat + case type_ComplexDoubleDoubleFloat: #endif case type_SimpleString: case type_SimpleBitVector: @@ -6259,6 +6390,9 @@ verify_space(lispobj * start, size_t words) #endif case type_SimpleArraySingleFloat: case type_SimpleArrayDoubleFloat: +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: +#endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayLongFloat: #endif @@ -6270,6 +6404,9 @@ verify_space(lispobj * start, size_t words) #endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayComplexLongFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: #endif case type_Sap: case type_WeakPointer: diff --git a/lisp/print.c b/lisp/print.c index 8a6d482195e18b3ac589a0a65e067a8a6b970283..0ee2dfc065aa70364cec007a0d3ed4ebdcabde0e 100644 --- a/lisp/print.c +++ b/lisp/print.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.20 2005/09/15 18:26:52 rtoy Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.21 2006/06/30 18:41:32 rtoy Exp $ */ #include <stdio.h> #include <string.h> @@ -40,6 +40,9 @@ char *subtype_Names[] = { #ifdef type_LongFloat "long float", #endif +#ifdef type_DoubleDoubleFloat + "double-double float", +#endif "complex", #ifdef type_ComplexSingleFloat "complex single float", @@ -49,6 +52,9 @@ char *subtype_Names[] = { #endif #ifdef type_ComplexLongFloat "complex long float", +#endif +#ifdef type_ComplexDoubleDoubleFloat + "complex double-double float", #endif "simple-array", "simple-string", @@ -76,6 +82,9 @@ char *subtype_Names[] = { #ifdef type_SimpleArrayLongFloat "(simple-array long-float (*))", #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + "(simple-array double-double-float (*))", +#endif #ifdef type_SimpleArrayComplexSingleFloat "(simple-array (complex single-float) (*))", #endif @@ -84,6 +93,9 @@ char *subtype_Names[] = { #endif #ifdef type_SimpleArrayComplexLongFloat "(simple-array (complex long-float) (*))", +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + "(simple-array (complex double-double-float) (*))", #endif "complex-string", "complex-bit-vector", @@ -529,6 +541,14 @@ print_otherptr(lispobj obj) break; #endif +#ifdef type_DoubleDoubleFloat + case type_DoubleDoubleFloat: + NEWLINE; + printf("%g %g", ((struct double_double_float *) PTR(obj))->hi, + ((struct double_double_float *) PTR(obj))->lo); + break; +#endif + #ifdef type_ComplexSingleFloat case type_ComplexSingleFloat: NEWLINE; @@ -556,6 +576,18 @@ print_otherptr(lispobj obj) break; #endif +#ifdef type_ComplexDoubleDoubleFloat + case type_ComplexDoubleDoubleFloat: + NEWLINE; + printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->real_hi, + ((struct complex_double_double_float *) PTR(obj))->real_lo); + NEWLINE; + printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->imag_hi, + ((struct complex_double_double_float *) PTR(obj))->imag_lo); + break; +#endif + + case type_SimpleString: NEWLINE; cptr = (char *) (ptr + 1); @@ -610,6 +642,9 @@ print_otherptr(lispobj obj) #ifdef type_SimpleArrayLongFloat case type_SimpleArrayLongFloat: #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: +#endif #ifdef type_SimpleArrayComplexSingleFloat case type_SimpleArrayComplexSingleFloat: #endif @@ -618,6 +653,9 @@ print_otherptr(lispobj obj) #endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayComplexLongFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: #endif case type_ComplexString: case type_ComplexBitVector: diff --git a/lisp/purify.c b/lisp/purify.c index f18237a9cc087e5f7e4f0b51b001c3bbb18927ab..3180cfcad5e9269acf3f97fe01f8af0c9ddf671d 100644 --- a/lisp/purify.c +++ b/lisp/purify.c @@ -10,7 +10,7 @@ and x86/GENCGC stack scavenging, by Douglas Crosher, 1996, 1997, 1998. - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.36 2006/01/18 15:21:26 rtoy Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.37 2006/06/30 18:41:32 rtoy Exp $ */ #include <stdio.h> @@ -143,6 +143,9 @@ maybe_can_move_p(lispobj thing) case type_DoubleFloat: #ifdef type_LongFloat case type_LongFloat: +#endif +#ifdef type_DoubleDoubleFloat + case type_DoubleDoubleFloat: #endif case type_Sap: case type_SimpleVector: @@ -170,6 +173,9 @@ maybe_can_move_p(lispobj thing) #ifdef type_SimpleArrayLongFloat case type_SimpleArrayLongFloat: #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: +#endif #ifdef type_SimpleArrayComplexSingleFloat case type_SimpleArrayComplexSingleFloat: #endif @@ -178,6 +184,9 @@ maybe_can_move_p(lispobj thing) #endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayComplexLongFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: #endif case type_CodeHeader: case type_FunctionHeader: @@ -189,7 +198,9 @@ maybe_can_move_p(lispobj thing) case type_ValueCellHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif case type_WeakPointer: case type_Fdefn: #ifdef type_ScavengerHook @@ -265,7 +276,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr) case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif if ((int) pointer != ((int) start_addr + type_FunctionPointer)) { if (pointer_filter_verbose) fprintf(stderr, "*Wf2: %p %p %lx\n", pointer, @@ -344,7 +357,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr) case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif if (pointer_filter_verbose) fprintf(stderr, "*Wo4: %p %p %lx\n", pointer, start_addr, *start_addr); @@ -368,6 +383,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr) #endif #ifdef type_ComplexLongFloat case type_ComplexLongFloat: +#endif +#ifdef type_ComplexDoubleDoubleFloat + case type_ComplexDoubleDoubleFloat: #endif case type_SimpleArray: case type_ComplexString: @@ -383,6 +401,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr) case type_DoubleFloat: #ifdef type_LongFloat case type_LongFloat: +#endif +#ifdef type_DoubleDoubleFloat + case type_DoubleDoubleFloat: #endif case type_SimpleString: case type_SimpleBitVector: @@ -408,6 +429,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr) #ifdef type_SimpleArrayLongFloat case type_SimpleArrayLongFloat: #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: +#endif #ifdef type_SimpleArrayComplexSingleFloat case type_SimpleArrayComplexSingleFloat: #endif @@ -416,6 +440,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr) #endif #ifdef type_SimpleArrayComplexLongFloat case type_SimpleArrayComplexLongFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: #endif case type_Sap: case type_WeakPointer: @@ -1025,6 +1052,9 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) #ifdef type_LongFloat case type_LongFloat: #endif +#ifdef type_DoubleDoubleFloat + case type_DoubleDoubleFloat: +#endif #ifdef type_ComplexSingleFloat case type_ComplexSingleFloat: #endif @@ -1033,6 +1063,9 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) #endif #ifdef type_ComplexLongFloat case type_ComplexLongFloat: +#endif +#ifdef type_ComplexDoubleDoubleFloat + case type_ComplexDoubleDoubleFloat: #endif case type_Sap: return ptrans_unboxed(thing, header); @@ -1111,6 +1144,11 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) #endif #endif +#ifdef type_SimpleArrayDoubleDoubleFloat + case type_SimpleArrayDoubleDoubleFloat: + return ptrans_vector(thing, 128, 0, FALSE, constant); +#endif + #ifdef type_SimpleArrayComplexSingleFloat case type_SimpleArrayComplexSingleFloat: return ptrans_vector(thing, 64, 0, FALSE, constant); @@ -1131,6 +1169,12 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) #endif #endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: + return ptrans_vector(thing, 256, 0, FALSE, constant); +#endif + + case type_CodeHeader: return ptrans_code(thing); @@ -1293,6 +1337,9 @@ pscav(lispobj * addr, int nwords, boolean constant) case type_DoubleFloat: #ifdef type_LongFloat case type_LongFloat: +#endif +#ifdef type_DoubleDoubleFloat + case type_DoubleDoubleFloat: #endif case type_Sap: /* It's an unboxed simple object. */ @@ -1459,6 +1506,13 @@ pscav(lispobj * addr, int nwords, boolean constant) break; #endif +#ifdef type_SimpleArrayComplexDoubleDoubleFloat + case type_SimpleArrayComplexDoubleDoubleFloat: + vector = (struct vector *) addr; + count = fixnum_value(vector->length) * 8 + 2; + break; +#endif + case type_CodeHeader: #if !(defined(i386) || defined(__x86_64)) gc_abort(); /* No code headers in static space */ @@ -1483,7 +1537,9 @@ pscav(lispobj * addr, int nwords, boolean constant) case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: +#ifdef type_DylanFunctionHeader case type_DylanFunctionHeader: +#endif /* The function self pointer needs special care on the x86 because it is the real entry point. */ { diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp index d266dd85abbd4477284b87f95875b9c66c106705..1dd398197e9232f79b7157cf8ae508b2c12d5da7 100644 --- a/tools/worldbuild.lisp +++ b/tools/worldbuild.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.52 2004/07/25 18:29:10 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.53 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -102,6 +102,8 @@ "target:code/float" "target:code/float-trap" "target:code/irrat" + ,@(when (c::backend-featurep :double-double) + '("target:code/irrat-dd")) "target:code/bignum" "target:code/list" "target:code/hash-new" diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp index 3b99f8d1c9948df394ee7bac27e9e04353a821ba..7547ba6e3f9ac43a1233d64de2075cc85dc5f748 100644 --- a/tools/worldcom.lisp +++ b/tools/worldcom.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.96 2005/09/08 20:49:57 cshapiro Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.97 2006/06/30 18:41:32 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -201,6 +201,8 @@ (comf "target:code/float-trap") (comf "target:code/float") (comf "target:code/irrat") +#+double-double +(comf "target:code/irrat-dd") (comf "target:code/type-boot")