[oct-cvs] Oct commit: oct qd-rep.lisp qd.lisp
rtoy
rtoy at common-lisp.net
Fri Nov 2 20:11:42 UTC 2007
Update of /project/oct/cvsroot/oct
In directory clnet:/tmp/cvs-serv8022
Modified Files:
Tag: THREE-ARG-BRANCH
qd-rep.lisp qd.lisp
Log Message:
First cut at adding a 3-arg versions of the basic operations to reduce
consing by allowing the third argument to be a place where the result
can be stored. This is intended to help reduce allocation and gc
costs for Lisps that use arrays to represent quad-doubles.
More work is needed to make the compiler macros do the right thing for
CMUCL.
qd-rep.lisp:
o Add %STORE-QD-D to store a quad-double into a place. For CMUCL,
there place argument is ignored and a fresh quad-double is created.
qd.lisp:
o Modify ADD-QD, SUB-QD, MUL-QD, and DIV-QD to take an optional third
argument indicating where the result can be stored. Ignored on
CMUCL.
o Add ADD-QD-T, SUB-QD-T, MUL-QD-T, and DIV-QD-T, which are 3-arg
functions with the third arg always required which is the storage
area to hold the result. Ignored on CMUCL.
o Add compiler macros to convert ADD-QD and friends to ADD-QD-T if the
third arg is always given. The effect is, essentially, inlining
ADD-QD.
--- /project/oct/cvsroot/oct/qd-rep.lisp 2007/10/16 17:09:46 1.10
+++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/11/02 20:11:42 1.10.2.1
@@ -81,6 +81,9 @@
(kernel:%make-double-double-float a2 a3)))
)
+(defmacro %store-qd-d (target q0 q1 q2 q3)
+ (declare (ignore target))
+ `(%make-qd-d ,q0 ,q1, q2, q3))
(defun qd-parts (qd)
"Extract the four doubles comprising a quad-double and return them
@@ -169,6 +172,14 @@
(setf (aref ,a 3) ,a3)
,a)))
+(defmacro %store-qd-d (target q0 q1 q2 q3)
+ (let ((dest (gensym "TARGET-")))
+ `(let ((,dest ,target))
+ (setf (aref ,dest 0) ,q0)
+ (setf (aref ,dest 1) ,q1)
+ (setf (aref ,dest 2) ,q2)
+ (setf (aref ,dest 3) ,q3))))
+
(defun qd-parts (qd)
"Extract the four doubles comprising a quad-double and return them
as multiple values. The most significant double is the first value."
--- /project/oct/cvsroot/oct/qd.lisp 2007/10/18 14:38:11 1.60
+++ /project/oct/cvsroot/oct/qd.lisp 2007/11/02 20:11:42 1.60.2.1
@@ -179,10 +179,12 @@
make-qd-d
add-qd-d add-d-qd add-qd-dd
add-dd-qd
- add-qd
+ add-qd add-qd-t
neg-qd
sub-qd sub-qd-dd sub-qd-d sub-d-qd
- mul-qd-d mul-qd-dd mul-qd
+ mul-qd-d mul-qd-dd
+ mul-qd
+ mul-qd-t
sqr-qd
div-qd div-qd-d div-qd-dd
make-qd-dd
@@ -385,7 +387,11 @@
;; which don't do a very good job with dataflow. CMUCL is one of
;; those compilers.
-(defun add-qd (a b)
+(defun add-qd (a b &optional (target #-cmu (%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)
(optimize (speed 3)
(space 0)))
@@ -407,7 +413,7 @@
(inline float-infinity-p))
(when (float-infinity-p s0)
- (return-from add-qd (%make-qd-d s0 0d0 0d0 0d0)))
+ (return-from add-qd-t (%store-qd-d target s0 0d0 0d0 0d0)))
(let ((v0 (cl:- s0 a0))
(v1 (cl:- s1 a1))
(v2 (cl:- s2 a2))
@@ -441,8 +447,22 @@
(multiple-value-setq (s0 s1 s2 s3)
(renorm-5 s0 s1 s2 s3 t0))
(if (and (zerop a0) (zerop b0))
- (%make-qd-d (+ a0 b0) 0d0 0d0 0d0)
- (%make-qd-d s0 s1 s2 s3)))))))))))
+ (%store-qd-d target (+ a0 b0) 0d0 0d0 0d0)
+ (%store-qd-d target s0 s1 s2 s3)))))))))))
+
+;; Define some compiler macros to transform add-qd to add-qd-t
+;; 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.
+#+cmu
+(define-compiler-macro add-qd (a b &optional c)
+ (if c
+ `(setf c (add-qd-t ,a ,b nil))
+ `(add-qd-t ,a ,b nil)))
+
+#-cmu
+(define-compiler-macro add-qd (a b &optional (c (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(add-qd-t ,a ,b ,c))
(defun neg-qd (a)
(declare (type %quad-double a))
@@ -451,9 +471,19 @@
(declare (double-float a0 a1 a2 a3))
(%make-qd-d (cl:- a0) (cl:- a1) (cl:- a2) (cl:- a3))))
-(defun sub-qd (a b)
+(defun sub-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
(declare (type %quad-double a b))
- (add-qd a (neg-qd b)))
+ (add-qd-t a (neg-qd b) target))
+
+#+cmu
+(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
+(define-compiler-macro sub-qd (a b &optional (c (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(add-qd-t ,a (neg-qd ,b) ,c))
#+cmu
(defun sub-qd-dd (a b)
@@ -602,7 +632,11 @@
;;
;; Clisp says
;; 14.142135623730950488016887242096980785696718753769480731766797379908L0
-(defun mul-qd (a b)
+
+(defun mul-qd (a b &optional (target #-cmu (%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)
(optimize (speed 3)
(space 0))
@@ -617,7 +651,7 @@
(two-prod a0 b0)
#+cmu
(when (float-infinity-p p0)
- (return-from mul-qd (%make-qd-d p0 0d0 0d0 0d0)))
+ (return-from mul-qd-t (%store-qd-d target p0 0d0 0d0 0d0)))
(multiple-value-bind (p1 q1)
(two-prod a0 b1)
(multiple-value-bind (p2 q2)
@@ -662,8 +696,19 @@
(multiple-value-bind (r0 r1 s0 s1)
(renorm-5 p0 p1 s0 s1 s2)
(if (zerop r0)
- (%make-qd-d p0 0d0 0d0 0d0)
- (%make-qd-d r0 r1 s0 s1))))))))))))))
+ (%store-qd-d target p0 0d0 0d0 0d0)
+ (%store-qd-d target r0 r1 s0 s1))))))))))))))
+
+#+cmu
+(define-compiler-macro mul-qd (a b &optional c)
+ (if c
+ `(setf ,c `(mul-qd-t ,a ,b nil))
+ `(mul-qd-t ,a ,b nil)))
+
+#-cmu
+(define-compiler-macro mul-qd (a b &optional (c (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(mul-qd-t ,a ,b ,c))
+
;; This is the non-sloppy version. I think this works just fine, but
;; since qd defaults to the sloppy multiplication version, we do the
@@ -813,7 +858,10 @@
(%make-qd-d a0 a1 a2 a3)))))))))
-(defun div-qd (a b)
+(defun div-qd (a b &optional (target #-cmu (%make-qd-d 0d0 0d0 0d0 0d0)))
+ (div-qd-t a b target))
+
+(defun div-qd-t (a b target)
(declare (type %quad-double a b)
(optimize (speed 3)
(space 0))
@@ -825,14 +873,25 @@
(q1 (cl:/ (qd-0 r) b0)))
(when (float-infinity-p q0)
- (return-from div-qd (%make-qd-d q0 0d0 0d0 0d0)))
+ (return-from div-qd-t (%store-qd-d target q0 0d0 0d0 0d0)))
(setf r (sub-qd r (mul-qd-d b q1)))
(let ((q2 (cl:/ (qd-0 r) b0)))
(setf r (sub-qd r (mul-qd-d b q2)))
(let ((q3 (cl:/ (qd-0 r) b0)))
(multiple-value-bind (q0 q1 q2 q3)
(renorm-4 q0 q1 q2 q3)
- (%make-qd-d q0 q1 q2 q3)))))))
+ (%store-qd-d target q0 q1 q2 q3)))))))
+
+#+cmu
+(define-compiler-macro div-qd (a b &optional c)
+ (if c
+ `(setf ,c `(div-qd-t ,a ,b nil))
+ `(div-qd-t ,a ,b nil)))
+
+#-cmu
+(define-compiler-macro div-qd (a b &optional (c (%make-qd-d 0d0 0d0 0d0 0d0)))
+ `(div-qd-t ,a ,b ,c))
+
(declaim (inline invert-qd))
More information about the oct-cvs
mailing list