Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv14440
Modified Files: oct.system qd-fun.lisp qd-rep.lisp qd.lisp Log Message: Adjust code so that CMUCL can use arrays to store quad-doubles instead of using a (complex double-double-float).
With these changes, CMUCL uses arrays and (rt:do-tests) passes successfully.
oct.system: o Push :oct-array onto *FEATURES* to use arrays. This is the default if not building on CMUCL.
qd-fun.lisp: o Fix two erroneous uses of zerop on a quad-double in sinh-qd and tanh-qd. o Fix two erroneous uses of + on %quad-double; they should have used ADD-QD instead.
qd-rep.lisp: o Change conditionalization to allow arrays for CMUCL. o Update compiler macros appropriately.
qd.lisp: o Adjust optional target arg appropriately for oct-array feature. o Clean up IGNORE declarations. o Add some more declarations for the target to make CMUCL happier.
--- /project/oct/cvsroot/oct/oct.system 2007/09/16 05:00:00 1.22 +++ /project/oct/cvsroot/oct/oct.system 2007/11/28 20:00:28 1.23 @@ -44,6 +44,16 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (setf ext:*inline-expansion-limit* 1600))
+;; +;; For all Lisps other than CMUCL, oct uses arrays to store the +;; quad-double values. This is denoted by the feature :oct-array. +;; For CMUCL, quad-doubles can be stored in a (complex +;; double-double-float) object, which is an extension in CMUCL. +;; If you want CMUCL to use an array too, add :oct-array to *features*. +;;#-cmu +(pushnew :oct-array *features*) + + (mk:defsystem oct :source-pathname (make-pathname :directory (pathname-directory *load-pathname*)) :components --- /project/oct/cvsroot/oct/qd-fun.lisp 2007/11/07 21:38:10 1.91 +++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/11/28 20:00:28 1.92 @@ -1140,7 +1140,7 @@ (declare (type %quad-double a)) ;; Hart et al. suggests sinh(x) = 1/2*(D(x) + D(x)/(D(x)+1)) ;; where D(x) = exp(x) - 1. This helps for x near 0. - (cond ((zerop a) + (cond ((zerop (qd-0 a)) a) ((float-infinity-p (qd-0 a)) a) @@ -1166,7 +1166,7 @@ "Tanh(a)" (declare (type %quad-double a)) ;; Hart et al. suggests tanh(x) = D(2*x)/(2+D(2*x)) - (cond ((zerop a) + (cond ((zerop (qd-0 a)) a) ((> (abs (qd-0 a)) (/ (+ (log most-positive-double-float) (log 2d0)) @@ -1262,8 +1262,8 @@ (if (minusp-qd a) (neg-qd (asinh-qd (neg-qd a))) (let ((1/a (div-qd (make-qd-d 1d0) a))) - (+ (log-qd a) - (log1p-qd (sqrt-qd (add-qd-d (sqr-qd 1/a) 1d0))))))))) + (add-qd (log-qd a) + (log1p-qd (sqrt-qd (add-qd-d (sqr-qd 1/a) 1d0)))))))))
(defun acosh-qd (a) "Acosh(a)" @@ -1297,9 +1297,9 @@ a) (t (let ((1/a (div-qd (make-qd-d 1d0) a))) - (+ (log-qd a) - (log1p-qd (mul-qd (sqrt-qd (sub-d-qd 1d0 1/a)) - (sqrt-qd (add-d-qd 1d0 1/a))))))))) + (add-qd (log-qd a) + (log1p-qd (mul-qd (sqrt-qd (sub-d-qd 1d0 1/a)) + (sqrt-qd (add-d-qd 1d0 1/a)))))))))
(defun atanh-qd (a) "Atanh(a)" --- /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/23 03:42:24 1.12 +++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/28 20:00:28 1.13 @@ -35,11 +35,13 @@ ;;; return all four values at once.
;; All of the following functions should be inline to reduce consing. +#+(and cmu (not oct-array)) (declaim (inline qd-0 qd-1 qd-2 qd-3 %make-qd-d qd-parts)) -#+cmu + +#+(and cmu (not oct-array)) (progn ;; For CMUCL (at least recent enough versions that support ;; double-double-float), we can use a (complex double-double-float) to @@ -98,7 +100,7 @@
) ; end progn
-#-cmu +#+oct-array (progn ;; For Lisp's without a double-double-float type, I think the best we ;; can do is a simple-array of four double-floats. Even with @@ -175,6 +177,7 @@ (defmacro %store-qd-d (target q0 q1 q2 q3) (let ((dest (gensym "TARGET-"))) `(let ((,dest ,target)) + (declare (type %quad-double ,dest)) (setf (aref ,dest 0) ,q0) (setf (aref ,dest 1) ,q1) (setf (aref ,dest 2) ,q2) @@ -237,12 +240,12 @@
(macrolet ((frob (qd qd-t) - #+cmu + #-oct-array `(define-compiler-macro ,qd (a b &optional c) (if c `(setf ,c (,',qd-t ,a ,b nil)) `(,',qd-t ,a ,b nil))) - #-cmu + #+oct-array `(define-compiler-macro ,qd (a b &optional c) (if c `(,',qd-t ,a ,b ,c) @@ -253,73 +256,73 @@ (frob add-qd-d add-qd-d-t) (frob mul-qd-d mul-qd-d-t))
-#+cmu +#+(and cmu (not oct-array)) (define-compiler-macro sub-qd (a b &optional c) (if c `(setf ,c (add-qd-t ,a (neg-qd ,b) nil)) `(add-qd-t ,a (neg-qd ,b) nil)))
-#-cmu +#-(and cmu (not oct-array)) (define-compiler-macro sub-qd (a b &optional c) (if c `(add-qd-t ,a (neg-qd ,b) ,c) `(add-qd-t ,a (neg-qd ,b) (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu +#+(and cmu (not oct-array)) (define-compiler-macro sqr-qd (a &optional c) (if c `(setf ,c (sqr-qd-t ,a nil)) `(sqr-qd-t ,a nil)))
-#-cmu +#-(and cmu (not oct-array)) (define-compiler-macro sqr-qd (a &optional c) (if c `(sqr-qd-t ,a ,c) `(sqr-qd-t ,a (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu +#+(and cmu (not oct-array)) (define-compiler-macro add-d-qd (a b &optional c) (if c `(setf ,c (add-qd-d ,b ,a)) `(add-qd-d ,b ,a)))
-#-cmu +#-(and cmu (not oct-array)) (define-compiler-macro add-d-qd (a b &optional c) (if c `(add-qd-d ,b ,a ,c) `(add-qd-d ,b ,a (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu +#+(and cmu (not oct-array)) (define-compiler-macro sub-qd-d (a b &optional c) (if c `(setf ,c (add-qd-d ,a (cl:- ,b))) `(add-qd-d ,a (cl:- ,b))))
-#-cmu +#-(and cmu (not oct-array)) (define-compiler-macro sub-qd-d (a b &optional c) (if c `(add-qd-d ,a (cl:- ,b) ,c) `(add-qd-d ,a (cl:- ,b) (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu +#+(and cmu (not oct-array)) (define-compiler-macro sub-d-qd (a b &optional c) (if c `(setf ,c (add-d-qd ,a (neg-qd ,b))) `(add-d-qd ,a (neg-qd ,b))))
-#-cmu +#-(and cmu (not oct-array)) (define-compiler-macro sub-d-qd (a b &optional c) (if c `(add-d-qd ,a (neg-qd ,b) ,c) `(add-d-qd ,a (neg-qd ,b) (%make-qd-d 0d0 0d0 0d0 0d0))))
-#+cmu +#+(and cmu (not oct-array)) (define-compiler-macro neg-qd (a &optional c) (if c `(setf ,c (neg-qd-t ,a nil)) `(neg-qd-t ,a nil)))
-#-cmu +#-(and cmu (not oct-array)) (define-compiler-macro neg-qd (a &optional c) (if c `(neg-qd-t ,a ,c) --- /project/oct/cvsroot/oct/qd.lisp 2007/11/16 19:44:06 1.63 +++ /project/oct/cvsroot/oct/qd.lisp 2007/11/28 20:00:28 1.64 @@ -306,17 +306,17 @@ ;;;; Addition
;; Quad-double + double -(defun add-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun add-qd-d (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (add-qd-d-t a b target))
(defun add-qd-d-t (a b target) "Add a quad-double A and a double-float B" - (declare (type %quad-double a) + (declare (type %quad-double a target) (double-float b) (optimize (speed 3) (space 0)) (inline float-infinity-p) - #+cmu (ignore target)) + #+(and cmu (not oct-array)) (ignore target)) (let* ((c0 0d0) (e c0) (c1 c0) @@ -336,12 +336,12 @@ (%store-qd-d target c0 0d0 0d0 0d0) (%store-qd-d target r0 r1 r2 r3)))))
-(defun add-d-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun add-d-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (declare (double-float a) (type %quad-double b) (optimize (speed 3)) #+cmu (ignore target)) - (add-qd-d b a #-cmu target)) + (add-qd-d b a #+oct-array target))
#+cmu (defun add-qd-dd (a b) @@ -403,15 +403,15 @@ ;; which don't do a very good job with dataflow. CMUCL is one of ;; those compilers.
-(defun add-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun add-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (add-qd-t a b target))
(defun add-qd-t (a b target) - (declare (type %quad-double a b) + (declare (type %quad-double a b target) (optimize (speed 3) (space 0)) - #+cmu + #+(and cmu (not oct-array)) (ignore target)) ;; This is the version that is NOT IEEE. Should we use the IEEE ;; version? It's quite a bit more complicated. @@ -472,18 +472,18 @@ ;; directly. For CMU, we always replace the parameter C with NIL ;; because we don't use it. For other Lisps, we create the necessary ;; object and call add-qd-t. -(defun neg-qd (a &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun neg-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (neg-qd-t a target))
(defun neg-qd-t (a target) - (declare (type %quad-double a) - #+cmu (ignore target)) + (declare (type %quad-double a target) + #+(and cmu (not oct-array)) (ignore target)) (with-qd-parts (a0 a1 a2 a3) a (declare (double-float a0 a1 a2 a3)) (%store-qd-d target (cl:- a0) (cl:- a1) (cl:- a2) (cl:- a3))))
-(defun sub-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun sub-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (declare (type %quad-double a b)) (add-qd-t a (neg-qd b) target))
@@ -493,18 +493,18 @@ (type double-double-float b)) (add-qd-dd a (cl:- b)))
-(defun sub-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun sub-qd-d (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (declare (type %quad-double a) (type double-float b) #+cmu (ignore target)) - (add-qd-d a (cl:- b) #-cmu target)) + (add-qd-d a (cl:- b) #+oct-array target))
-(defun sub-d-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun sub-d-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (declare (type double-float a) (type %quad-double b) - #+cmu (ignore target)) + #+(and cmu (not oct-array)) (ignore target)) ;; a - b = a + (-b) - (add-d-qd a (neg-qd b) #-cmu target)) + (add-d-qd a (neg-qd b) #+oct-array target))
;; Works @@ -514,17 +514,17 @@ ;; Clisp says ;; 14.142135623730950488016887242096980785696718753769480731766797379908L0 ;; -(defun mul-qd-d (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun mul-qd-d (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (mul-qd-d-t a b target))
(defun mul-qd-d-t (a b target) "Multiply quad-double A with B" - (declare (type %quad-double a) + (declare (type %quad-double a target) (double-float b) (optimize (speed 3) (space 0)) (inline float-infinity-p) - #+cmu (ignore target)) + #+(and cmu (not oct-array)) (ignore target)) (multiple-value-bind (p0 q0) (two-prod (qd-0 a) b)
@@ -641,15 +641,15 @@ ;; Clisp says ;; 14.142135623730950488016887242096980785696718753769480731766797379908L0
-(defun mul-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun mul-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (mul-qd-t a b target))
(defun mul-qd-t (a b target) - (declare (type %quad-double a b) + (declare (type %quad-double a b target) (optimize (speed 3) (space 0)) (inline float-infinity-p) - #+cmu + #+(and cmu (not oct-array)) (ignore target)) (with-qd-parts (a0 a1 a2 a3) a @@ -811,15 +811,15 @@ (multiple-value-call #'%make-qd-d (renorm-5 p0 p1 s0 t0 t1))))))))))))))))))))
-(defun sqr-qd (a &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun sqr-qd (a &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (sqr-qd-t a target))
(defun sqr-qd-t (a target) "Square A" - (declare (type %quad-double a) + (declare (type %quad-double a target) (optimize (speed 3) (space 0)) - #+cmu + #+(and cmu (not oct-array)) (ignore target)) (multiple-value-bind (p0 q0) (two-sqr (qd-0 a)) @@ -863,7 +863,7 @@ (%store-qd-d target a0 a1 a2 a3)))))))))
-(defun div-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0))) +(defun div-qd (a b &optional (target #+oct-array (%make-qd-d 0d0 0d0 0d0 0d0))) (div-qd-t a b target))
#+nil @@ -891,11 +891,11 @@ (%store-qd-d target q0 q1 q2 q3)))))))
(defun div-qd-t (a b target) - (declare (type %quad-double a b) + (declare (type %quad-double a b target) (optimize (speed 3) (space 0)) (inline float-infinity-p) - #+cmu + #+(and cmu (not oct-array)) (ignore target)) (let ((a0 (qd-0 a)) (b0 (qd-0 b)))