From a2f0af9423366107068a01df40d3eb59c7b03427 Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Sat, 6 Jun 2015 17:42:15 -0700 Subject: [PATCH] Move more double-double items from float-tran to float-tran-dd. --- src/compiler/float-tran-dd.lisp | 78 +++++++++++++++++++++++++++++++++ src/compiler/float-tran.lisp | 8 ++-- 2 files changed, 82 insertions(+), 4 deletions(-) diff --git a/src/compiler/float-tran-dd.lisp b/src/compiler/float-tran-dd.lisp index 622bca780..4b5b1aafa 100644 --- a/src/compiler/float-tran-dd.lisp +++ b/src/compiler/float-tran-dd.lisp @@ -19,6 +19,84 @@ (in-package "C") (intl:textdomain "cmucl") +(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)) + +;; Moved to code/float.lisp, because we need this relatively early in +;; the build process to handle float and real types. +#+nil +(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)))) + +#+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 + +#+double-double +(deftransform float-sign ((float &optional float2) + (double-double-float &optional double-double-float) *) + (if float2 + (let ((temp (gensym))) + `(let ((,temp (abs float2))) + (if (minusp (float-sign (double-double-hi float))) + (- ,temp) + ,temp))) + '(if (minusp (float-sign (double-double-hi float))) -1w0 1w0))) + +#+double-double +(deftransform cis ((x) (double-double-float) *) + `(multiple-value-bind (s c) + (kernel::dd-%sincos x) + (complex c s))) + + + (declaim (inline quick-two-sum)) (defun quick-two-sum (a b) "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 83d4b33f4..5d4e03be7 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -38,7 +38,7 @@ (deftransform %double-float ((n) (double-float) * :when :both) 'n) -#+double-double +#+(and nil double-double) (progn (defknown %double-double-float (real) double-double-float @@ -364,7 +364,7 @@ (values (signed-byte 32) (unsigned-byte 32)) (movable foldable flushable)) -#+double-double +#+(and nil double-double) (progn (defknown double-double-float-p (t) boolean @@ -401,7 +401,7 @@ (if (minusp (double-float-high-bits float)) (- ,temp) ,temp))) '(if (minusp (double-float-high-bits float)) -1d0 1d0))) -#+double-double +#+(and nil double-double) (deftransform float-sign ((float &optional float2) (double-double-float &optional double-double-float) *) (if float2 @@ -778,7 +778,7 @@ (%sincos x) (complex c s))) -#+double-double +#+(and nil double-double) (deftransform cis ((x) (double-double-float) *) `(multiple-value-bind (s c) (kernel::dd-%sincos x) -- GitLab