diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 00a05e055db805c50d464b81b0c72f949514f97c..940407afd76dda53ece5ac955b32c40758ecceff 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.118 2008/04/03 15:10:47 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.119 2008/04/08 14:15:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -332,6 +332,7 @@ (if (minusp (double-float-high-bits float)) (- ,temp) ,temp))) '(if (minusp (double-float-high-bits float)) -1d0 1d0))) +#+double-double (deftransform float-sign ((float &optional float2) (double-double-float &optional double-double-float) *) (if float2 @@ -1667,11 +1668,13 @@ 0d0) (values r1 r2))))))) -(deftransform + ((a b) (vm::double-double-float vm::double-double-float) *) +(deftransform + ((a b) (vm::double-double-float vm::double-double-float) + * :node node) `(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))) + (add-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) (declaim (inline quick-two-diff)) (defun quick-two-diff (a b) @@ -1753,23 +1756,29 @@ (values (float-sign (- a0 b) 0d0) 0d0) (values r1 r2))))) -(deftransform - ((a b) (vm::double-double-float vm::double-double-float) *) +(deftransform - ((a b) (vm::double-double-float vm::double-double-float) + * :node node) `(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))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform - ((a b) (double-float vm::double-double-float) *) +(deftransform - ((a b) (double-float vm::double-double-float) + * :node node) `(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))) + (sub-d-dd a + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform - ((a b) (vm::double-double-float double-float) *) +(deftransform - ((a b) (vm::double-double-float double-float) + * :node node) `(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))) + (sub-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + b) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) (declaim (inline split)) ;; This algorithm is the version given by Yozo Hida. It has problems @@ -1968,26 +1977,24 @@ (incf p2 (* a1 a1)) (quick-two-sum p1 p2))) -(deftransform + ((a b) (vm::double-double-float (or integer single-float double-float)) *) +(deftransform + ((a b) (vm::double-double-float (or integer single-float double-float)) + * :node node) `(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))) + (add-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform + ((a b) ((or integer single-float double-float) vm::double-double-float) *) +(deftransform + ((a b) ((or integer single-float double-float) vm::double-double-float) + * :node node) `(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))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform * ((a b) (vm::double-double-float vm::double-double-float) * :node node) +(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 @@ -2006,23 +2013,29 @@ (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)) + (truly-the ,(type-specifier (node-derived-type node)) + (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)))))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo))))))) -(deftransform * ((a b) (vm::double-double-float (or integer single-float double-float)) *) +(deftransform * ((a b) (vm::double-double-float (or integer single-float double-float)) + * :node node) `(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))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform * ((a b) ((or integer single-float double-float) vm::double-double-float) *) +(deftransform * ((a b) ((or integer single-float double-float) vm::double-double-float) + * :node node) `(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))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) (declaim (maybe-inline div-dd)) (defun div-dd (a0 a1 b0 b1) @@ -2074,17 +2087,21 @@ (let ((q2 (/ (+ s e) b))) (quick-two-sum q1 q2)))))) -(deftransform / ((a b) (vm::double-double-float vm::double-double-float) *) +(deftransform / ((a b) (vm::double-double-float vm::double-double-float) + * :node node) `(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))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform / ((a b) (vm::double-double-float (or integer single-float double-float)) *) +(deftransform / ((a b) (vm::double-double-float (or integer single-float double-float)) + * :node node) `(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))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) (declaim (inline sqr-d)) (defun sqr-d (a) @@ -2124,10 +2141,12 @@ (mul-d-d s2 (* x 0.5d0)) (add-dd-d p0 p1 ax))))))) -(deftransform sqrt ((a) ((vm::double-double-float 0w0)) *) +(deftransform sqrt ((a) ((vm::double-double-float 0w0)) + * :node node) `(multiple-value-bind (hi lo) - (sqrt-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (kernel:%make-double-double-float hi lo))) + (sqrt-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) (declaim (inline neg-dd)) (defun neg-dd (a0 a1) @@ -2145,15 +2164,19 @@ (neg-dd a0 a1) (values a0 a1))) -(deftransform abs ((a) (vm::double-double-float) *) +(deftransform abs ((a) (vm::double-double-float) + * :node node) `(multiple-value-bind (hi lo) (abs-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (kernel:%make-double-double-float hi lo))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) -(deftransform %negate ((a) (vm::double-double-float) *) +(deftransform %negate ((a) (vm::double-double-float) + * :node node) `(multiple-value-bind (hi lo) (neg-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (kernel:%make-double-double-float hi lo))) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) (declaim (inline dd=)) (defun dd= (a0 a1 b0 b1)