From rtoy at common-lisp.net Thu Sep 6 02:58:38 2007 From: rtoy at common-lisp.net (rtoy) Date: Wed, 5 Sep 2007 22:58:38 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-class.lisp Message-ID: <20070906025838.719725E0FD@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv23948 Modified Files: qd-class.lisp Log Message: Fix qd-complex printer so it prints out something that is readable. --- /project/oct/cvsroot/oct/qd-class.lisp 2007/08/31 21:13:36 1.24 +++ /project/oct/cvsroot/oct/qd-class.lisp 2007/09/06 02:58:38 1.25 @@ -67,7 +67,7 @@ (make-instance 'qd-real :value (qd-value x))) (defmethod print-object ((qd qd-complex) stream) - (format stream "#q(~<~/qdi::qd-format/ ~/qdi::qd-format/~:@>)" + (format stream "#q(~<#q~/qdi::qd-format/ #q~/qdi::qd-format/~:@>)" (list (qd-real qd) (qd-imag qd)))) From rtoy at common-lisp.net Wed Sep 12 02:03:42 2007 From: rtoy at common-lisp.net (rtoy) Date: Tue, 11 Sep 2007 22:03:42 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct .cvsignore Message-ID: <20070912020342.B195453110@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv13071 Modified Files: .cvsignore Log Message: Ignore fasl. --- /project/oct/cvsroot/oct/.cvsignore 2007/08/27 13:10:50 1.2 +++ /project/oct/cvsroot/oct/.cvsignore 2007/09/12 02:03:42 1.3 @@ -2,3 +2,4 @@ *.sparcf *.x86f *.err +*.fasl From rtoy at common-lisp.net Wed Sep 12 02:31:14 2007 From: rtoy at common-lisp.net (rtoy) Date: Tue, 11 Sep 2007 22:31:14 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-fun.lisp qd-io.lisp qd.lisp Message-ID: <20070912023114.4D6D153114@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv18006 Modified Files: qd-fun.lisp qd-io.lisp qd.lisp Log Message: qd-fun.lisp: o Remove unused var R1 in EXP-QD/REDUCE. o TAN-QD was calling ZEROP instead of ZEROP-QD. o Comment out extra copy of ASINH-QD. qd-io.lisp: o Ignore unused var in QD-PRINT-EXPONENT and QD-READER. qd.lisp: o Remove extra version of DIV-QD. --- /project/oct/cvsroot/oct/qd-fun.lisp 2007/08/25 17:08:48 1.79 +++ /project/oct/cvsroot/oct/qd-fun.lisp 2007/09/12 02:31:14 1.80 @@ -160,8 +160,6 @@ (let* ((k 256) (z (truncate (qd-0 (nint-qd (div-qd a +qd-log2+))))) - (r1 (sub-qd a (mul-qd-d +qd-log2+ (float z 1d0)))) - ;; r as above (r (div-qd-d (sub-qd a (mul-qd-d +qd-log2+ (float z 1d0))) (float k 1d0))) ;; For Taylor series. p = r^2/2, the first term @@ -740,7 +738,7 @@ (defun tan-qd (r) "Tan(r)" (declare (type %quad-double r)) - (if (zerop r) + (if (zerop-qd r) r (tan-qd/sincos r))) @@ -810,6 +808,7 @@ (d (expm1-qd a2))) (div-qd d (add-qd-d d 2d0)))))) +#+(or) (defun asinh-qd (a) "Asinh(a)" (declare (type %quad-double a)) --- /project/oct/cvsroot/oct/qd-io.lisp 2007/08/27 17:49:19 1.14 +++ /project/oct/cvsroot/oct/qd-io.lisp 2007/09/12 02:31:14 1.15 @@ -151,6 +151,7 @@ (scale r s m+ m-))))))) (defun qd-print-exponent (x exp stream) + (declare (ignore x)) (let ((*print-radix* nil)) (format stream "q~D" exp))) @@ -461,6 +462,7 @@ (make-float sign int-part frac-part scale exp))))) (defun qd-reader (stream subchar arg) + (declare (ignore subchar arg)) (read-qd stream)) (defun qd-from-string (string) --- /project/oct/cvsroot/oct/qd.lisp 2007/08/25 17:08:48 1.45 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/12 02:31:14 1.46 @@ -819,7 +819,6 @@ (renorm-5 p0 p1 p2 p3 p4)))))))))) -#-cmu (defun div-qd (a b) (declare (type %quad-double a b) (optimize (speed 3) @@ -840,25 +839,6 @@ (renorm-4 q0 q1 q2 q3) (%make-qd-d q0 q1 q2 q3))))))) -(defun div-qd (a b) - (declare (type %quad-double a b) - (optimize (speed 3) - (space 0))) - (let ((a0 (qd-0 a)) - (b0 (qd-0 b))) - (let* ((q0 (cl:/ a0 b0)) - (r (sub-qd a (mul-qd-d b q0))) - (q1 (cl:/ (qd-0 r) b0))) - (when (float-infinity-p q0) - (return-from div-qd (%make-qd-d 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))))))) - ;; Non-sloppy divide #+(or) (defun div-qd (a b) From rtoy at common-lisp.net Wed Sep 12 21:01:13 2007 From: rtoy at common-lisp.net (rtoy) Date: Wed, 12 Sep 2007 17:01:13 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-complex.lisp qd-methods.lisp qd-package.lisp Message-ID: <20070912210113.6DE365B120@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv9448 Modified Files: qd-complex.lisp qd-methods.lisp qd-package.lisp Log Message: qd-package.lisp: o Rearrange some exports so the CMU ones are all grouped together. o Export new constants pi/2, pi/4, 2pi, and log2. o Export the qd-real and qd-complex types. qd-methods.lisp: o Define new constants for pi/2, pi/4, 2pi, and log2. o Update some of the macrolets to work with a modern-mode lisp, like Allegro. qd-complex.lisp: o Use the new constants as needed. --- /project/oct/cvsroot/oct/qd-complex.lisp 2007/08/31 21:13:36 1.35 +++ /project/oct/cvsroot/oct/qd-complex.lisp 2007/09/12 21:01:13 1.36 @@ -350,7 +350,7 @@ (let ((t0 (/ 1 (sqrt #q2.0q0))) (t1 #q1.2q0) (t2 #q3q0) - (ln2 #.(log #q2.0)) + (ln2 +log2+) (x (realpart z)) (y (imagpart z))) (multiple-value-bind (rho k) @@ -407,7 +407,7 @@ (let* ( ;; Constants (theta (/ (sqrt most-positive-double-float) 4.0d0)) (rho (/ 4.0d0 (sqrt most-positive-double-float))) - (half-pi #.(/ +pi+ 2d0)) + (half-pi +pi/2+) (rp (realpart z)) (beta (float-sign rp)) (x (* beta rp)) --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/08/31 21:13:36 1.55 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/12 21:01:13 1.56 @@ -26,7 +26,24 @@ (in-package #:qd) (defconstant +pi+ - (make-instance 'qd-real :value qdi:+qd-pi+)) + (make-instance 'qd-real :value qdi:+qd-pi+) + "Quad-double value of pi") + +(defconstant +pi/2+ + (make-instance 'qd-real :value qdi:+qd-pi/2+) + "Quad-double value of pi/2") + +(defconstant +pi/4+ + (make-instance 'qd-real :value qdi:+qd-pi/4+) + "Quad-double value of pi/4") + +(defconstant +2pi+ + (make-instance 'qd-real :value qdi:+qd-2pi+) + "Quad-double value of 2*pi") + +(defconstant +log2+ + (make-instance 'qd-real :value qdi:+qd-log2+) + "Quad-double value of log(2), natural log of 2") #+cmu (defconstant +quad-double-float-positive-infinity+ @@ -200,9 +217,13 @@ (unary-divide number))) (macrolet ((frob (name &optional (type 'real)) - (let ((method-name (intern (concatenate 'string "Q" (symbol-name name)))) + (let ((method-name (intern (concatenate 'string + (string '#:q) + (symbol-name name)))) (cl-name (intern (symbol-name name) :cl)) - (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) + (qd-name (intern (concatenate 'string + (symbol-name name) + (string '#:-qd))))) `(progn (defmethod ,method-name ((x ,type)) (,cl-name x)) @@ -318,9 +339,11 @@ (macrolet ((frob (op) - (let ((method (intern (concatenate 'string "TWO-ARG-" (symbol-name op)))) + (let ((method (intern (concatenate 'string + (string '#:two-arg-) + (symbol-name op)))) (cl-fun (find-symbol (symbol-name op) :cl)) - (qd-fun (intern (concatenate 'string "QD-" (symbol-name op)) + (qd-fun (intern (concatenate 'string (string '#:qd-) (symbol-name op)) (find-package :qdi)))) `(progn (defmethod ,method ((a real) (b real)) @@ -352,9 +375,11 @@ (macrolet ((frob (name) (let ((method-name - (intern (concatenate 'string "Q" (symbol-name name)))) + (intern (concatenate 'string (string '#:q) + (symbol-name name)))) (cl-name (intern (symbol-name name) :cl)) - (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) + (qd-name (intern (concatenate 'string (symbol-name name) + (string '#:-qd))))) `(progn (defmethod ,name ((x number)) (,cl-name x)) @@ -828,7 +853,9 @@ ;; the corresponding two-arg- function. (macrolet ((frob (op) - (let ((method (intern (concatenate 'string "TWO-ARG-" (symbol-name op))))) + (let ((method (intern (concatenate 'string + (string '#:two-arg-) + (symbol-name op))))) `(define-compiler-macro ,op (number &rest more-numbers) (do* ((n number (car nlist)) (nlist more-numbers (cdr nlist)) --- /project/oct/cvsroot/oct/qd-package.lisp 2007/08/29 01:22:03 1.36 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/09/12 21:01:13 1.37 @@ -30,11 +30,9 @@ #:read-qd #:add-qd #:add-qd-d - #:cmu #:add-qd-dd #:add-d-qd #:sub-qd #:sub-qd-d - #:cmu #:sub-qd-dd #:sub-d-qd #:neg-qd #:mul-qd @@ -42,9 +40,7 @@ #:sqr-qd #:div-qd #:div-qd-d - #+cmu #:div-qd-dd #:make-qd-d - #+cmu #:make-qd-dd #:integer-decode-qd #:npow #:qd-0 @@ -55,6 +51,10 @@ #:+qd-one+ #:+qd-zero+ #:+qd-pi+ + #:+qd-pi/2+ + #:+qd-pi/4+ + #:+qd-2pi+ + #:+qd-log2+ ;; Functions #:hypot-qd #:abs-qd @@ -91,6 +91,11 @@ #:random-qd ) #+cmu + (:export #:add-qd-dd + #:sub-qd-dd + #:div-qd-dd + #:make-qd-dd) + #+cmu (:import-from #:c #:two-sum #:quick-two-sum @@ -164,6 +169,10 @@ #:decf #:float-digits ) + ;; Export types + (:export #:qd-real + #:qd-complex) + ;; Export functions (:export #:+ #:- #:* @@ -229,7 +238,11 @@ #:float-digits ) ;; Constants - (:export #:+pi+) + (:export #:+pi+ + #:+pi/2+ + #:+pi/4+ + #:+2pi+ + #:+log2+) ;; CMUCL supports infinities. #+cmu (:export #:+quad-double-float-positive-infinity+ From rtoy at common-lisp.net Thu Sep 13 01:06:02 2007 From: rtoy at common-lisp.net (rtoy) Date: Wed, 12 Sep 2007 21:06:02 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-dd.lisp Message-ID: <20070913010602.E22CE1903D@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv22721 Modified Files: qd-dd.lisp Log Message: Add declarations. Mostly to help Allegro generate much better code. --- /project/oct/cvsroot/oct/qd-dd.lisp 2007/08/25 17:08:48 1.4 +++ /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 01:06:02 1.5 @@ -34,19 +34,23 @@ (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)) + (declare (double-float a b) + (optimize (speed 3) (safety 0))) (let* ((s (+ a b)) (e (- b (- s a)))) + (declare (double-float s e)) (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)) + (declare (double-float a b) + (optimize (speed 3) (safety 0))) (let* ((s (+ a b)) (v (- s a)) (e (+ (- a (- s v)) (- b v)))) + (declare (double-float s v e)) (values s e))) (declaim (inline two-prod)) @@ -103,36 +107,46 @@ (as (* a (scale-float 1d0 -27))) (a-hi (* (- tmp (- tmp as)) (expt 2 27))) (a-lo (- a a-hi))) + (declare (double-float tmp as a-hi a-lo)) (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))) + (declare (double-float tmp a-hi a-lo)) (values a-hi a-lo)))) (defun two-prod (a b) "Compute fl(a*b) and err(a*b)" - (declare (double-float a b)) + (declare (double-float a b) + (optimize (speed 3) (safety 0))) (let ((p (* a b))) + (declare (double-float p)) (multiple-value-bind (a-hi a-lo) (split a) + (declare (double-float a-hi a-lo)) (multiple-value-bind (b-hi b-lo) (split b) + (declare (double-float b-hi b-lo)) (let ((e (+ (+ (- (* a-hi b-hi) p) (* a-hi b-lo) (* a-lo b-hi)) (* a-lo b-lo)))) + (declare (double-float e)) (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)) + (declare (double-float a) + (optimize (speed 3) (safety 0))) (let ((q (* a a))) + (declare (double-float q)) (multiple-value-bind (a-hi a-lo) (split a) + (declare (double-float a-hi a-lo)) (values q (+ (+ (- (* a-hi a-hi) q) (* 2 a-hi a-lo)) (* a-lo a-lo)))))) From rtoy at common-lisp.net Thu Sep 13 01:07:04 2007 From: rtoy at common-lisp.net (rtoy) Date: Wed, 12 Sep 2007 21:07:04 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct oct.asd Message-ID: <20070913010704.EEA071903E@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv22840 Added Files: oct.asd Log Message: Initial version. --- /project/oct/cvsroot/oct/oct.asd 2007/09/13 01:07:04 NONE +++ /project/oct/cvsroot/oct/oct.asd 2007/09/13 01:07:04 1.1 ;;;; -*- Mode: lisp -*- ;;;; ;;;; Copyright (c) 2007 Raymond Toy ;;;; ;;;; Permission is hereby granted, free of charge, to any person ;;;; obtaining a copy of this software and associated documentation ;;;; files (the "Software"), to deal in the Software without ;;;; restriction, including without limitation the rights to use, ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell ;;;; copies of the Software, and to permit persons to whom the ;;;; Software is furnished to do so, subject to the following ;;;; conditions: ;;;; ;;;; The above copyright notice and this permission notice shall be ;;;; included in all copies or substantial portions of the Software. ;;;; ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;;; OTHER DEALINGS IN THE SOFTWARE. ;;; This is the asdf definition for oct. I don't normally use this, ;;; so it might be out of date. Use at your own risk. ;; If you want all core functions to be inline (like the C++ code ;; does), add :qd-inline to *features* by enabling the following line. ;; This makes compilation much, much slower, but the resulting code ;; conses much less and is significantly faster. #+(not (and cmu x86)) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :qd-inline *features*)) ;; To be able to inline all the functions, we need to make ;; *inline-expansion-limit* much larger. ;; ;; Not sure we really want to inline everything, but the QD C++ code ;; inlines all of the functions so we do the same. This makes CMUCL ;; take a very long time to compile the code, and the resulting ;; functions are huge. (I think div-qd is 8 KB, and sqrt-qd is a ;; whopping 30 KB!) ;; #+(and cmu qd-inline) (eval-when (:load-toplevel :compile-toplevel :execute) (setf ext:*inline-expansion-limit* 1600)) (defpackage #:oct-system (:use #:cl)) (in-package #:oct-system) (asdf:defsystem oct :description "A portable implementation of quad-double arithmetic. See ." :author "Raymond Toy" :maintainer "See Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv4233 Modified Files: qd-dd.lisp Log Message: Some updates from Richard Fateman to make these routines run faster in Allegro. --- /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 01:06:02 1.5 +++ /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 16:45:42 1.6 @@ -35,7 +35,7 @@ (defun quick-two-sum (a b) "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" (declare (double-float a b) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0) (debug 0))) (let* ((s (+ a b)) (e (- b (- s a)))) (declare (double-float s e)) @@ -45,7 +45,7 @@ (defun two-sum (a b) "Computes fl(a+b) and err(a+b)" (declare (double-float a b) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0) (debug 0))) (let* ((s (+ a b)) (v (- s a)) (e (+ (- a (- s v)) @@ -120,7 +120,7 @@ (defun two-prod (a b) "Compute fl(a*b) and err(a*b)" (declare (double-float a b) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0) (debug 0))) (let ((p (* a b))) (declare (double-float p)) (multiple-value-bind (a-hi a-lo) @@ -141,7 +141,7 @@ "Compute fl(a*a) and err(a*b). This is a more efficient implementation of two-prod" (declare (double-float a) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0) (debug 0))) (let ((q (* a a))) (declare (double-float q)) (multiple-value-bind (a-hi a-lo) From rtoy at common-lisp.net Thu Sep 13 16:48:48 2007 From: rtoy at common-lisp.net (rtoy) Date: Thu, 13 Sep 2007 12:48:48 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-dd.lisp Message-ID: <20070913164848.D19565B069@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv4360 Modified Files: qd-dd.lisp Log Message: In SPLIT, compute the constants at compile time (#.) instead of run-time, in case the Lisp doesn't do it itself. --- /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 16:45:42 1.6 +++ /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 16:48:48 1.7 @@ -95,7 +95,7 @@ ;; 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))) + (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 @@ -103,14 +103,14 @@ ;; 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))) + (let* ((tmp (* a #.(+ 1 (scale-float 1d0 -27)))) + (as (* a #.(scale-float 1d0 -27))) + (a-hi (* (- tmp (- tmp as)) #.(scale-float 1d0 27))) (a-lo (- a a-hi))) (declare (double-float tmp as a-hi a-lo)) (values a-hi a-lo)) ;; Yozo's algorithm. - (let* ((tmp (* a (+ 1 (expt 2 27)))) + (let* ((tmp (* a #.(float (+ 1 (expt 2 27)) 1d0))) (a-hi (- tmp (- tmp a))) (a-lo (- a a-hi))) (declare (double-float tmp a-hi a-lo)) From rtoy at common-lisp.net Thu Sep 13 17:28:30 2007 From: rtoy at common-lisp.net (rtoy) Date: Thu, 13 Sep 2007 13:28:30 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-dd.lisp Message-ID: <20070913172830.9974F19000@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv10722 Modified Files: qd-dd.lisp Log Message: Add some comments on how split is supposed to work. Add a note that if you have a fused multiply-subtract instruction, you can replace two-prod with a much simpler and faster version. --- /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 16:48:48 1.7 +++ /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 17:28:30 1.8 @@ -82,6 +82,50 @@ (values a-hi a-lo))) +;; Here is my limited understanding of what SPLIT is really supposed +;; to do. +;; +;; Let A be a double-float number. We want to split the fraction bits +;; into 2 parts of 26 bits each. This is best explained by example. +;; Let use use A = 1d50. Use INTEGER-DECODE-FLOAT to display the bits +;; of A: +;; +;; (write (integer-decode-float 1d50) :base 2) -> +;; 10001000110110000111011000101011111100110010010011010 +;; +;; Break this into 2 parts with the lower part having 27 bits and the +;; upper having 26 (because of the extra "hidden" bit): +;; +;; 10001000110110000111011000 101011111100110010010011010 +;; +;; But this is not enough. Note that the bottom half has a leading 1. +;; We want to round up the upper part. Then we need to account for +;; this in the lower part: +;; +;; 10001000110110000111011001 -10100000011001101101100110 +;; +;; This is the answer we want. Convert these back to floats with the +;; appropriate exponents, and we get: +;; +;; 1.0000000087331024d50 and -8.733102285997912d41 +;; +;; While this example worked out nicely, we should note that the +;; rounding operation above should be done in an IEEE round-to-even +;; fashion. So if the lower part of the bits is exactly "half", we +;; round the upper part to even. Thus, +;; +;; (float #b10001000110110000111011000100000000000000000000000000 1d0) +;; should be split into two parts: +;; +;; 10001000110110000111011000 100000000000000000000000000 +;; +;; but +;; +;; (float #b10001000110110000111011001100000000000000000000000000 1d0) +;; is +;; +;; 10001000110110000111011010 -100000000000000000000000000 + (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 @@ -117,6 +161,21 @@ (values a-hi a-lo)))) +;; Note that if you have an architecture that has a fused +;; multiply-subtract instruction that computes a*b-c with exactly one +;; rounding operation, you can use that instead of the complicated +;; routine below. Power PC chips have such an instruction. +;; +;; Here is the code to do that, where (fused-multiply-subtract a b p) +;; computes a*b-p. +;; +;; (defun two-prod (a b) +;; "Compute fl(a*b) and err(a*b)" +;; (declare (double-float a b)) +;; (let* ((p (* a b)) +;; (err (fused-multiply-subtract a b p))) +;; (values p err))) + (defun two-prod (a b) "Compute fl(a*b) and err(a*b)" (declare (double-float a b) From rtoy at common-lisp.net Sun Sep 16 02:39:29 2007 From: rtoy at common-lisp.net (rtoy) Date: Sat, 15 Sep 2007 22:39:29 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-methods.lisp Message-ID: <20070916023929.AB70C49051@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv10199 Modified Files: qd-methods.lisp Log Message: T should be t (for Allegro case-sensitive modern-mode). --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/12 21:01:13 1.56 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/16 02:39:29 1.57 @@ -540,7 +540,7 @@ (declare (optimize (safety 2)) (dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist))) - ((atom nlist) T) + ((atom nlist) t) (declare (list nlist)) (if (not (two-arg-= (car nlist) number)) (return nil)))) @@ -554,7 +554,7 @@ ((atom nlist) t) (declare (list nlist)) (unless (do* ((nl nlist (cdr nl))) - ((atom nl) T) + ((atom nl) t) (declare (list nl)) (if (two-arg-= head (car nl)) (return nil))) From rtoy at common-lisp.net Sun Sep 16 02:46:25 2007 From: rtoy at common-lisp.net (rtoy) Date: Sat, 15 Sep 2007 22:46:25 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-dd.lisp qd-package.lisp qd.lisp Message-ID: <20070916024625.07182490A8@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv12645 Modified Files: qd-dd.lisp qd-package.lisp qd.lisp Log Message: To speed up Allegro (and other Lisp's that don't support inline functions), change QUICK-TWO-SUM from a function to a macro. Note that macro has different calling convention than the function. This is needed because Allegro apparently doesn't handle VALUES without boxing. All rt tests pass. qd-package.lisp: o For CMUCL, don't import C::QUICK-TWO-SUM into the QDI package anymore. qd-dd.lisp: o New QUICK-TWO-SUM macro. qd.lisp: o Add CMUCL version of QUICK-TWO-SUM macro, which just calls C::QUICK-TWO-SUM. o Update all users of QUICK-TWO-SUM appropriately. --- /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/13 17:28:30 1.8 +++ /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/16 02:46:24 1.9 @@ -31,6 +31,7 @@ ;;; ;;; These routines were taken directly from CMUCL. +#|| (declaim (inline quick-two-sum)) (defun quick-two-sum (a b) "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" @@ -40,6 +41,16 @@ (e (- b (- s a)))) (declare (double-float s e)) (values s e))) +||# + +(defmacro quick-two-sum (s e x y) + (let ((a (gensym)) + (b (gensym))) + `(let* ((,a ,x) + (,b ,y)) + (declare (double-float ,a ,b ,s ,e)) + (setf ,s (+ ,a ,b)) + (setf ,e (- ,b (- ,s ,a)))))) (declaim (inline two-sum)) (defun two-sum (a b) @@ -53,6 +64,21 @@ (declare (double-float s v e)) (values s e))) +#+nil +(defmacro two-sum (s e x y) + "Computes fl(a+b) and err(a+b)" + (let ((a (gensym)) + (b (gensym)) + (v (gensym)) + `(let ((,a ,x) + (,b ,y)) + (declare (double-float ,a ,b)) + (setf ,s (+ ,a ,b)) + (let ((,v (- ,s ,a))) + (declare (double-float v)) + (setf e (+ (- ,a (- ,s ,v)) + (- ,b ,v)))))))) + (declaim (inline two-prod)) (declaim (inline split)) ;; This algorithm is the version given by Yozo Hida. It has problems --- /project/oct/cvsroot/oct/qd-package.lisp 2007/09/12 21:01:13 1.37 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/09/16 02:46:24 1.38 @@ -98,7 +98,6 @@ #+cmu (:import-from #:c #:two-sum - #:quick-two-sum #:two-prod #:two-sqr)) --- /project/oct/cvsroot/oct/qd.lisp 2007/09/12 02:31:14 1.46 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/16 02:46:24 1.47 @@ -132,6 +132,16 @@ div-qd-d div-qd-dd)) +#+cmu +(defmacro quick-two-sum (s e x y) + `(multiple-value-setq (,s ,e) + (c::quick-two-sum ,x ,y))) + +#+(and nil cmu) +(defmacro two-sum (s e x y) + `(multiple-value-setq (s e) + (c::two-sum x y))) + #-(or qd-inline (not cmu)) (declaim (ext:start-block renorm-4 renorm-5 make-qd-d @@ -172,91 +182,67 @@ (defun renorm-4 (c0 c1 c2 c3) (declare (double-float c0 c1 c2 c3) - (optimize (speed 3) (safety 0))) - (let ((s2 0d0) + (optimize (speed 3) (safety 0) (debug 0))) + (let ((s0 0d0) + (s1 0d0) + (s2 0d0) (s3 0d0)) - (multiple-value-bind (s0 c3) - (quick-two-sum c2 c3) - (multiple-value-bind (s0 c2) - (quick-two-sum c1 s0) - (multiple-value-bind (c0 c1) - (quick-two-sum c0 s0) - (let ((s0 c0) - (s1 c1)) - (cond ((/= s1 0) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c2)) - (if (/= s2 0) - (multiple-value-setq (s2 s3) - (quick-two-sum s2 c3)) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c3)))) - (t - (multiple-value-setq (s0 s1) - (quick-two-sum s0 c2)) - (if (/= s1 0) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c3)) - (multiple-value-setq (s0 s1) - (quick-two-sum s0 c3))))) - (values s0 s1 s2 s3))))))) - + (declare (double-float s0 s1 s2 s3)) + (quick-two-sum s0 c3 c2 c3) + (quick-two-sum s0 c2 c1 s0) + (quick-two-sum c0 c1 c0 s0) + (setf s0 c0) + (setf s1 c1) + (cond ((/= s1 0) + (quick-two-sum s1 s2 s1 c2) + (if (/= s2 0) + (quick-two-sum s2 s3 s2 c3) + (quick-two-sum s1 s2 s1 c3))) + (t + (quick-two-sum s0 s1 s0 c2) + (if (/= s1 0) + (quick-two-sum s1 s2 s1 c3) + (quick-two-sum s0 s1 s0 c3)))) + (values s0 s1 s2 s3))) + (defun renorm-5 (c0 c1 c2 c3 c4) - (declare (double-float c0 c1 c2 c3) + (declare (double-float c0 c1 c2 c3 c4) (optimize (speed 3) (safety 0))) - (let ((s2 0d0) + (let ((s0 0d0) + (s1 0d0) + (s2 0d0) (s3 0d0)) - (declare (double-float s2 s3)) - (multiple-value-bind (s0 c4) - (quick-two-sum c3 c4) - (multiple-value-bind (s0 c3) - (quick-two-sum c2 s0) - (multiple-value-bind (s0 c2) - (quick-two-sum c1 s0) - (multiple-value-bind (c0 c1) - (quick-two-sum c0 s0) - (let ((s0 c0) - (s1 c1)) - (declare (double-float s0 s1)) - (multiple-value-setq (s0 s1) - (quick-two-sum c0 c1)) - (cond ((/= s1 0) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c2)) - (cond ((/= s2 0) - (multiple-value-setq (s2 s3) - (quick-two-sum s2 c3)) - (if (/= s3 0) - (incf s3 c4) - (incf s2 c4))) - (t - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c3)) - (if (/= s2 0) - (multiple-value-setq (s2 s3) - (quick-two-sum s2 c4)) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c4)))))) - (t - (multiple-value-setq (s0 s1) - (quick-two-sum s0 c2)) - (cond ((/= s1 0) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c3)) - (if (/= s2 0) - (multiple-value-setq (s2 s3) - (quick-two-sum s2 c4)) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c4)))) - (t - (multiple-value-setq (s0 s1) - (quick-two-sum s0 c3)) - (if (/= s1 0) - (multiple-value-setq (s1 s2) - (quick-two-sum s1 c4)) - (multiple-value-setq (s0 s1) - (quick-two-sum s0 c4))))))) - (values s0 s1 s2 s3)))))))) + (declare (double-float s0 s1 s2 s3)) + (quick-two-sum s0 c4 c3 c4) + (quick-two-sum s0 c3 c2 s0) + (quick-two-sum s0 c2 c1 s0) + (quick-two-sum c0 c1 c0 s0) + (quick-two-sum s0 s1 c0 c1) + (cond ((/= s1 0) + (quick-two-sum s1 s2 s1 c2) + (cond ((/= s2 0) + (quick-two-sum s2 s3 s2 c3) + (if (/= s3 0) + (incf s3 c4) + (incf s2 c4))) + (t + (quick-two-sum s1 s2 s1 c3) + (if (/= s2 0) + (quick-two-sum s2 s3 s2 c4) + (quick-two-sum s1 s2 s1 c4))))) + (t + (quick-two-sum s0 s1 s0 c2) + (cond ((/= s1 0) + (quick-two-sum s1 s2 s1 c3) + (if (/= s2 0) + (quick-two-sum s2 s3 s2 c4) + (quick-two-sum s1 s2 s1 c4))) + (t + (quick-two-sum s0 s1 s0 c3) + (if (/= s1 0) + (quick-two-sum s1 s2 s1 c4) + (quick-two-sum s0 s1 s0 c4)))))) + (values s0 s1 s2 s3))) (defun make-qd-d (a0 &optional (a1 0d0 a1-p) (a2 0d0) (a3 0d0)) "Create a %quad-double from four double-floats, appropriately @@ -786,17 +772,13 @@ (declare (double-float t0)) (multiple-value-bind (s1 t1) (two-sum q1 p3) - (declare (double-float t1)) + (declare (double-float s1 t1)) (multiple-value-setq (s1 t0) (two-sum s1 t0)) (incf t0 t1) - - (multiple-value-setq (s1 t0) - (quick-two-sum s1 t0)) - (multiple-value-setq (p2 t1) - (quick-two-sum s0 s1)) - (multiple-value-setq (p3 q0) - (quick-two-sum t1 t0)) + (quick-two-sum s1 t0 s1 t0) + (quick-two-sum p2 t1 s0 s1) + (quick-two-sum p3 q0 t1 t0) (let ((p4 (cl:* 2 (qd-0 a) (qd-3 a))) (p5 (cl:* 2 (qd-1 a) (qd-2 a)))) From rtoy at common-lisp.net Sun Sep 16 05:00:00 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 16 Sep 2007 01:00:00 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct oct.asd oct.system Message-ID: <20070916050000.468D3A183@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv5887 Modified Files: oct.asd oct.system Log Message: Update dependencies. --- /project/oct/cvsroot/oct/oct.asd 2007/09/13 01:07:04 1.1 +++ /project/oct/cvsroot/oct/oct.asd 2007/09/16 05:00:00 1.2 @@ -62,9 +62,9 @@ ((:file "qd-package") (:file "qd-rep" :depends-on ("qd-package")) #-cmu - (:file "qd-dd" :depends-on ("qd-package")) + (:file "qd-dd" :depends-on ("qd-package" "qd-rep")) (:file "qd" - :depends-on ("qd-rep")) + :depends-on ("qd-rep" #-cmu "qd-dd")) (:file "qd-io" :depends-on ("qd")) (:file "qd-const" --- /project/oct/cvsroot/oct/oct.system 2007/08/27 17:51:02 1.21 +++ /project/oct/cvsroot/oct/oct.system 2007/09/16 05:00:00 1.22 @@ -50,9 +50,9 @@ ((:file "qd-package") (:file "qd-rep" :depends-on ("qd-package")) #-cmu - (:file "qd-dd" :depends-on ("qd-package")) + (:file "qd-dd" :depends-on ("qd-package" "qd-rep")) (:file "qd" - :depends-on ("qd-rep")) + :depends-on ("qd-rep" #-cmu "qd-dd")) (:file "qd-io" :depends-on ("qd")) (:file "qd-const" From rtoy at common-lisp.net Sun Sep 16 05:01:16 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 16 Sep 2007 01:01:16 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-rep.lisp Message-ID: <20070916050116.18E57A186@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv7899 Modified Files: qd-rep.lisp Log Message: Make QD-0, QD-1, QD-2, and QD-3 macros to make sure access is fast for all Lisps. --- /project/oct/cvsroot/oct/qd-rep.lisp 2007/08/25 17:08:48 1.4 +++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/09/16 05:01:16 1.5 @@ -107,6 +107,7 @@ (deftype %quad-double () '(simple-array double-float (4))) +#|| (defun qd-0 (q) (declare (type %quad-double q) (optimize (speed 3))) @@ -127,6 +128,20 @@ (optimize (speed 3))) (aref q 3)) +||# + +(defmacro qd-0 (q) + `(aref ,q 0)) + +(defmacro qd-1 (q) + `(aref ,q 1)) + +(defmacro qd-2 (q) + `(aref ,q 2)) + +(defmacro qd-3 (q) + `(aref ,q 3)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defun %make-qd-d (a0 a1 a2 a3) "Make a %quad-double from 4 double-floats, exactly using the given @@ -144,6 +159,16 @@ a)) ) +#+nil +(defmacro %make-qd-d (a0 a1 a2 a3) + (let ((a (gensym))) + `(let ((,a (make-array 4 :element-type 'double-float))) + (setf (aref ,a 0) ,a0) + (setf (aref ,a 1) ,a1) + (setf (aref ,a 2) ,a2) + (setf (aref ,a 3) ,a3) + ,a))) + (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." From rtoy at common-lisp.net Sun Sep 16 05:04:05 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 16 Sep 2007 01:04:05 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-dd.lisp qd-package.lisp qd.lisp Message-ID: <20070916050405.CC04F13017@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv8050 Modified Files: qd-dd.lisp qd-package.lisp qd.lisp Log Message: Make TWO-SUM a macro, just like we did for QUICK-TWO-SUM. All RT tests pass on CMUCL and Allegro. qd-package.lisp: o Don't import C::TWO-SUM anymore. qd-dd.lisp: o Make TWO-SUM a macro. qd.lisp o Add TWO-SUM macro for CMUCL (which just calls C::TWO-SUM). o Update all uses of TWO-SUM to use the macro appropriately. --- /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/16 02:46:24 1.9 +++ /project/oct/cvsroot/oct/qd-dd.lisp 2007/09/16 05:04:04 1.10 @@ -52,6 +52,7 @@ (setf ,s (+ ,a ,b)) (setf ,e (- ,b (- ,s ,a)))))) +#|| (declaim (inline two-sum)) (defun two-sum (a b) "Computes fl(a+b) and err(a+b)" @@ -63,21 +64,21 @@ (- b v)))) (declare (double-float s v e)) (values s e))) +||# -#+nil (defmacro two-sum (s e x y) "Computes fl(a+b) and err(a+b)" (let ((a (gensym)) (b (gensym)) - (v (gensym)) + (v (gensym))) `(let ((,a ,x) (,b ,y)) (declare (double-float ,a ,b)) (setf ,s (+ ,a ,b)) (let ((,v (- ,s ,a))) - (declare (double-float v)) - (setf e (+ (- ,a (- ,s ,v)) - (- ,b ,v)))))))) + (declare (double-float ,v)) + (setf ,e (+ (- ,a (- ,s ,v)) + (- ,b ,v))))))) (declaim (inline two-prod)) (declaim (inline split)) --- /project/oct/cvsroot/oct/qd-package.lisp 2007/09/16 02:46:24 1.38 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/09/16 05:04:05 1.39 @@ -97,7 +97,6 @@ #:make-qd-dd) #+cmu (:import-from #:c - #:two-sum #:two-prod #:two-sqr)) --- /project/oct/cvsroot/oct/qd.lisp 2007/09/16 02:46:24 1.47 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/16 05:04:05 1.48 @@ -46,6 +46,14 @@ (declaim (inline three-sum three-sum2)) ;; Internal routines for implementing quad-double. + +#+cmu +(defmacro two-sum (s e x y) + `(multiple-value-setq (,s ,e) + (c::two-sum ,x ,y))) + + +#+nil (defun three-sum (a b c) (declare (double-float a b c) (optimize (speed 3))) @@ -57,6 +65,19 @@ (two-sum t2 t3) (values a b c))))) +(defun three-sum (a b c) + (declare (double-float a b c) + (optimize (speed 3))) + (let* ((t1 0d0) + (t2 t1) + (t3 t1)) + (declare (double-float t1 t2 t3)) + (two-sum t1 t2 a b) + (two-sum a t3 c t1) + (two-sum b c t2 t3) + (values a b c))) + +#+nil (defun three-sum2 (a b c) (declare (double-float a b c) (optimize (speed 3))) @@ -66,6 +87,17 @@ (two-sum c t1) (values a (cl:+ t2 t3) c)))) +(defun three-sum2 (a b c) + (declare (double-float a b c) + (optimize (speed 3))) + (let* ((t1 0d0) + (t2 t1) + (t3 t1)) + (two-sum t1 t2 a b) + (two-sum a t3 c t1) + (values a (cl:+ t2 t3) c))) + + ;; Not needed???? #+nil (declaim (inline quick-three-accum)) @@ -137,11 +169,6 @@ `(multiple-value-setq (,s ,e) (c::quick-two-sum ,x ,y))) -#+(and nil cmu) -(defmacro two-sum (s e x y) - `(multiple-value-setq (s e) - (c::two-sum x y))) - #-(or qd-inline (not cmu)) (declaim (ext:start-block renorm-4 renorm-5 make-qd-d @@ -267,22 +294,24 @@ (double-float b) (optimize (speed 3) (space 0))) - (multiple-value-bind (c0 e) - (two-sum (qd-0 a) b) + (let* ((c0 0d0) + (e c0) + (c1 c0) + (c2 c0) + (c3 c0)) + (declare (double-float e c0 c1 c2 c3)) + (two-sum c0 e (qd-0 a) b) #+cmu (when (float-infinity-p c0) (return-from add-qd-d (%make-qd-d c0 0d0 0d0 0d0))) - (multiple-value-bind (c1 e) - (two-sum (qd-1 a) e) - (multiple-value-bind (c2 e) - (two-sum (qd-2 a) e) - (multiple-value-bind (c3 e) - (two-sum (qd-3 a) e) - (multiple-value-bind (r0 r1 r2 r3) - (renorm-5 c0 c1 c2 c3 e) - (if (and (zerop (qd-0 a)) (zerop b)) - (%make-qd-d c0 0d0 0d0 0d0) - (%make-qd-d r0 r1 r2 r3)))))))) + (two-sum c1 e (qd-1 a) e) + (two-sum c2 e (qd-2 a) e) + (two-sum c3 e (qd-3 a) e) + (multiple-value-bind (r0 r1 r2 r3) + (renorm-5 c0 c1 c2 c3 e) + (if (and (zerop (qd-0 a)) (zerop b)) + (%make-qd-d c0 0d0 0d0 0d0) + (%make-qd-d r0 r1 r2 r3))))) (defun add-d-qd (a b) (declare (double-float a) @@ -297,19 +326,21 @@ (double-double-float b) (optimize (speed 3) (space 0))) - (multiple-value-bind (s0 t0) - (two-sum (qd-0 a) (kernel:double-double-hi b)) - (multiple-value-bind (s1 t1) - (two-sum (qd-1 a) (kernel:double-double-lo b)) - (multiple-value-bind (s1 t0) - (two-sum s1 t0) - (multiple-value-bind (s2 t0 t1) - (three-sum (qd-2 a) t0 t1) - (multiple-value-bind (s3 t0) - (two-sum t0 (qd-3 a)) - (let ((t0 (cl:+ t0 t1))) - (multiple-value-call #'%make-qd-d - (renorm-5 s0 s1 s2 s3 t0))))))))) + (let* ((s0 0d0) + (t0 s0) + (s1 s0) + (t1 s0) + (s3 s0)) + (declare (double-float s0 s1 s3 t0 t1)) + (two-sum s0 t1 (qd-0 a) (kernel:double-double-hi b)) + (two-sum s1 t1 (qd-1 a) (kernel:double-double-lo b)) + (two-sum s1 t0 s1 t0) + (multiple-value-bind (s2 t0 t1) + (three-sum (qd-2 a) t0 t1) + (two-sum s3 t0 t0 (qd-3 a)) + (let ((t0 (cl:+ t0 t1))) + (multiple-value-call #'%make-qd-d + (renorm-5 s0 s1 s2 s3 t0)))))) #+cmu (defun add-dd-qd (a b) @@ -386,20 +417,19 @@ (t1 (cl:+ w1 u1)) (t2 (cl:+ w2 u2)) (t3 (cl:+ w3 u3))) - (multiple-value-bind (s1 t0) - (two-sum s1 t0) - (multiple-value-bind (s2 t0 t1) - (three-sum s2 t0 t1) - (multiple-value-bind (s3 t0) - (three-sum2 s3 t0 t2) - (declare (double-float t0)) - (setf t0 (cl:+ t0 t1 t3)) - ;; Renormalize - (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)))))))))))))) + (two-sum s1 t0 s1 t0) + (multiple-value-bind (s2 t0 t1) + (three-sum s2 t0 t1) + (multiple-value-bind (s3 t0) + (three-sum2 s3 t0 t2) + (declare (double-float t0)) + (setf t0 (cl:+ t0 t1 t3)) + ;; Renormalize + (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))))))))))))) (defun neg-qd (a) (declare (type %quad-double a)) @@ -451,50 +481,23 @@ (two-prod (qd-1 a) b) (multiple-value-bind (p2 q2) (two-prod (qd-2 a) b) - (let ((p3 (cl:* (qd-3 a) b)) - (s0 p0)) - #+nil - (format t "q0 p1 = ~A ~A~%" q0 p1) - (multiple-value-bind (s1 s2) - (two-sum q0 p1) - #+nil - (format t "s1 s2 = ~A ~A~%" s1 s2) - #+nil - (format t "s2 q1 p2 = ~A ~A ~A~%" - s2 q1 p2) - (multiple-value-bind (s2 q1 p2) - (three-sum s2 q1 p2) - #+nil - (format t "s2,q1,p2 = ~A ~A ~A~%" - s2 q1 p2) - #+nil - (format t "q1 q2 p3 = ~A ~A ~A~%" - q1 q2 p3) - (multiple-value-bind (q1 q2) - (three-sum2 q1 q2 p3) - #+nil - (format t "q1 q2, p3 = ~A ~A ~A~%" q1 q2 p3) - (let ((s3 q1) - (s4 (cl:+ q2 p2))) - #+nil - (progn - (format t "~a~%" s0) - (format t "~a~%" s1) - (format t "~a~%" s2) - (format t "~a~%" s3) - (format t "~a~%" s4)) - (multiple-value-bind (s0 s1 s2 s3) - (renorm-5 s0 s1 s2 s3 s4) - #+nil - (progn - (format t "~a~%" s0) - (format t "~a~%" s1) - (format t "~a~%" s2) - (format t "~a~%" s3) - (format t "~a~%" s4)) - (if (zerop s0) - (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) - (%make-qd-d s0 s1 s2 s3)))))))))))) + (let* ((p3 (cl:* (qd-3 a) b)) + (s0 p0) + (s1 p0) + (s2 p0)) + (declare (double-float s0 s1 s2 p3)) + (two-sum s1 s2 q0 p1) + (multiple-value-bind (s2 q1 p2) + (three-sum s2 q1 p2) + (multiple-value-bind (q1 q2) + (three-sum2 q1 q2 p3) + (let ((s3 q1) + (s4 (cl:+ q2 p2))) + (multiple-value-bind (s0 s1 s2 s3) + (renorm-5 s0 s1 s2 s3 s4) + (if (zerop s0) + (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) + (%make-qd-d s0 s1 s2 s3))))))))))) ;; a0 * b0 0 ;; a0 * b1 1 @@ -617,34 +620,35 @@ (multiple-value-setq (p3 p4 p5) (three-sum p3 p4 p5)) ;; Compute (s0,s1,s2) = (p2,q1,q2) + (p3,p4,p5) - (multiple-value-bind (s0 t0) - (two-sum p2 p3) - (multiple-value-bind (s1 t1) - (two-sum q1 p4) - (let ((s2 (cl:+ q2 p5))) - (declare (double-float s2)) - (multiple-value-bind (s1 t0) - (two-sum s1 t0) - (declare (double-float s1)) - (incf s2 (cl:+ t0 t1)) - ;; O(eps^3) order terms. This is the sloppy - ;; multiplication version. Should we use - ;; the precise version? It's significantly - ;; more complex. + (let* ((s0 0d0) + (s1 s0) + (t0 s0) + (t1 s0)) + (declare (double-float s0 s1 t0 t1)) + (two-sum s0 t0 p2 p3) + (two-sum s1 t1 q1 p4) + (let ((s2 (cl:+ q2 p5))) + (declare (double-float s2)) + (two-sum s1 t0 s1 t0) + (incf s2 (cl:+ t0 t1)) + ;; O(eps^3) order terms. This is the sloppy + ;; multiplication version. Should we use + ;; the precise version? It's significantly + ;; more complex. - (incf s1 (cl:+ (cl:* a0 b3) - (cl:* a1 b2) - (cl:* a2 b1) - (cl:* a3 b0) - q0 q3 q4 q5)) - #+nil - (format t "p0,p1,s0,s1,s2 = ~a ~a ~a ~a ~a~%" - p0 p1 s0 s1 s2) - (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)))))))))))))))) + (incf s1 (cl:+ (cl:* a0 b3) + (cl:* a1 b2) + (cl:* a2 b1) + (cl:* a3 b0) + q0 q3 q4 q5)) + #+nil + (format t "p0,p1,s0,s1,s2 = ~a ~a ~a ~a ~a~%" + p0 p1 s0 s1 s2) + (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)))))))))))))) ;; This is the non-sloppy version. I think this works just fine, but ;; since qd defaults to the sloppy multiplication version, we do the @@ -760,45 +764,37 @@ (two-prod (cl:* 2 (qd-0 a)) (qd-2 a)) (multiple-value-bind (p3 q3) (two-sqr (qd-1 a)) - (multiple-value-setq (p1 q0) - (two-sum q0 p1)) - (multiple-value-setq (q0 q1) - (two-sum q0 q1)) - (multiple-value-setq (p2 p3) - (two-sum p2 p3)) - - (multiple-value-bind (s0 t0) - (two-sum q0 p2) - (declare (double-float t0)) - (multiple-value-bind (s1 t1) - (two-sum q1 p3) - (declare (double-float s1 t1)) - (multiple-value-setq (s1 t0) - (two-sum s1 t0)) - (incf t0 t1) - (quick-two-sum s1 t0 s1 t0) - (quick-two-sum p2 t1 s0 s1) - (quick-two-sum p3 q0 t1 t0) - - (let ((p4 (cl:* 2 (qd-0 a) (qd-3 a))) - (p5 (cl:* 2 (qd-1 a) (qd-2 a)))) - (declare (double-float p4)) - (multiple-value-setq (p4 p5) - (two-sum p4 p5)) - (multiple-value-setq (q2 q3) - (two-sum q2 q3)) - - (multiple-value-setq (t0 t1) - (two-sum p4 q2)) - - (incf t1 (cl:+ p5 q3)) - - (multiple-value-setq (p3 p4) - (two-sum p3 t0)) - (incf p4 (cl:+ q0 t1)) + (two-sum p1 q0 q0 p1) + (two-sum q0 q1 q0 q1) + (two-sum p2 p3 p2 p3) + + (let* ((s0 0d0) + (t0 s0) + (s1 s0) + (t1 s0)) + (declare (double-float s0 s1 t0 t1)) + (two-sum s0 t0 q0 p2) + (two-sum s1 t1 q1 p3) + (two-sum s1 t0 s1 t0) + (incf t0 t1) + (quick-two-sum s1 t0 s1 t0) + (quick-two-sum p2 t1 s0 s1) + (quick-two-sum p3 q0 t1 t0) + + (let ((p4 (cl:* 2 (qd-0 a) (qd-3 a))) + (p5 (cl:* 2 (qd-1 a) (qd-2 a)))) + (declare (double-float p4 p5)) + (two-sum p4 p5 p4 p5) + (two-sum q2 q3 q2 q3) + (two-sum t0 t1 p4 q2) + + (incf t1 (cl:+ p5 q3)) - (multiple-value-call #'%make-qd-d - (renorm-5 p0 p1 p2 p3 p4)))))))))) + (two-sum p3 p4 p3 t0) + (incf p4 (cl:+ q0 t1)) + + (multiple-value-call #'%make-qd-d + (renorm-5 p0 p1 p2 p3 p4))))))))) (defun div-qd (a b) From rtoy at common-lisp.net Sun Sep 16 14:23:25 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 16 Sep 2007 10:23:25 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd.lisp Message-ID: <20070916142325.0B1D01D113@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv2951 Modified Files: qd.lisp Log Message: o Remove old code. o Inline float-infinity-p. --- /project/oct/cvsroot/oct/qd.lisp 2007/09/16 05:04:05 1.48 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/16 14:23:24 1.49 @@ -53,18 +53,6 @@ (c::two-sum ,x ,y))) -#+nil -(defun three-sum (a b c) - (declare (double-float a b c) - (optimize (speed 3))) - (multiple-value-bind (t1 t2) - (two-sum a b) - (multiple-value-bind (a t3) - (two-sum c t1) - (multiple-value-bind (b c) - (two-sum t2 t3) - (values a b c))))) - (defun three-sum (a b c) (declare (double-float a b c) (optimize (speed 3))) @@ -77,16 +65,6 @@ (two-sum b c t2 t3) (values a b c))) -#+nil -(defun three-sum2 (a b c) - (declare (double-float a b c) - (optimize (speed 3))) - (multiple-value-bind (t1 t2) - (two-sum a b) - (multiple-value-bind (a t3) - (two-sum c t1) - (values a (cl:+ t2 t3) c)))) - (defun three-sum2 (a b c) (declare (double-float a b c) (optimize (speed 3))) @@ -293,7 +271,9 @@ (declare (type %quad-double a) (double-float b) (optimize (speed 3) - (space 0))) + (space 0)) + #+cmu + (inline ext:float-infinity-p)) (let* ((c0 0d0) (e c0) (c1 c0) @@ -393,7 +373,9 @@ (s1 (cl:+ a1 b1)) (s2 (cl:+ a2 b2)) (s3 (cl:+ a3 b3))) - (declare (double-float s0 s1 s2 s3)) + (declare (double-float s0 s1 s2 s3) + #+cmu + (inline ext:float-infinity-p)) #+cmu (when (float-infinity-p s0) (return-from add-qd (%make-qd-d s0 0d0 0d0 0d0))) @@ -471,7 +453,9 @@ (declare (type %quad-double a) (double-float b) (optimize (speed 3) - (space 0))) + (space 0)) + #+cmu + (inline ext:float-infinity-p)) (multiple-value-bind (p0 q0) (two-prod (qd-0 a) b) #+cmu @@ -590,7 +574,9 @@ (defun mul-qd (a b) (declare (type %quad-double a b) (optimize (speed 3) - (space 0))) + (space 0)) + #+cmu + (inline ext:float-infinity-p)) (multiple-value-bind (a0 a1 a2 a3) (qd-parts a) (multiple-value-bind (b0 b1 b2 b3) @@ -800,7 +786,9 @@ (defun div-qd (a b) (declare (type %quad-double a b) (optimize (speed 3) - (space 0))) + (space 0)) + #+cmu + (inline ext:float-infinity-p)) (let ((a0 (qd-0 a)) (b0 (qd-0 b))) (let* ((q0 (cl:/ a0 b0)) @@ -841,7 +829,9 @@ (declare (type %quad-double a) (double-float b) (optimize (speed 3) - (space 0))) + (space 0)) + #+cmu + (inline ext:float-infinity-p)) ;; Compute approximate quotient using high order doubles, then ;; correct it 3 times using the remainder. Analogous to long ;; division. @@ -877,7 +867,9 @@ (declare (type %quad-double a) (double-double-float b) (optimize (speed 3) - (space 0))) + (space 0)) + #+cmu + (inline ext:float-infinity-p)) (let* ((q0 (cl:/ (qd-0 a) (kernel:double-double-hi b))) (r (sub-qd-dd a (cl:* b q0)))) (when (float-infinity-p q0) From rtoy at common-lisp.net Mon Sep 17 03:07:27 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 16 Sep 2007 23:07:27 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-rep.lisp Message-ID: <20070917030727.4514D2E201@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv32766 Modified Files: qd-rep.lisp Log Message: Make %MAKE-QD-D a macro to make sure it's inlined. --- /project/oct/cvsroot/oct/qd-rep.lisp 2007/09/16 05:01:16 1.5 +++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/09/17 03:07:27 1.6 @@ -142,6 +142,7 @@ (defmacro qd-3 (q) `(aref ,q 3)) +#+(or) (eval-when (:compile-toplevel :load-toplevel :execute) (defun %make-qd-d (a0 a1 a2 a3) "Make a %quad-double from 4 double-floats, exactly using the given @@ -159,7 +160,6 @@ a)) ) -#+nil (defmacro %make-qd-d (a0 a1 a2 a3) (let ((a (gensym))) `(let ((,a (make-array 4 :element-type 'double-float))) From rtoy at common-lisp.net Mon Sep 17 03:08:25 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 16 Sep 2007 23:08:25 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd.lisp Message-ID: <20070917030825.4CDBC2E201@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv365 Modified Files: qd.lisp Log Message: o Replace THREE-SUM with a macro to make sure it's inlined everywhere. o Update code for new THREE-SUM macro. --- /project/oct/cvsroot/oct/qd.lisp 2007/09/16 14:23:24 1.49 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/17 03:08:25 1.50 @@ -53,17 +53,25 @@ (c::two-sum ,x ,y))) -(defun three-sum (a b c) - (declare (double-float a b c) - (optimize (speed 3))) - (let* ((t1 0d0) - (t2 t1) - (t3 t1)) - (declare (double-float t1 t2 t3)) - (two-sum t1 t2 a b) - (two-sum a t3 c t1) - (two-sum b c t2 t3) - (values a b c))) +(defmacro three-sum (s0 s1 s2 a b c) + (let ((aa (gensym)) + (bb (gensym)) + (cc (gensym)) + (t1 (gensym)) + (t2 (gensym)) + (t3 (gensym))) + `(let* ((,aa ,a) + (,bb ,b) + (,cc ,c) + (,t1 0d0) + (,t2 ,t1) + (,t3 ,t1)) + (declare (double-float ,t1 ,t2 ,t3)) + (two-sum ,t1 ,t2 ,aa ,bb) + (two-sum ,s0 ,t3 ,cc ,t1) + (two-sum ,s1 ,s2 ,t2 ,t3)))) + + (defun three-sum2 (a b c) (declare (double-float a b c) @@ -310,17 +318,20 @@ (t0 s0) (s1 s0) (t1 s0) + (s2 s0) (s3 s0)) - (declare (double-float s0 s1 s3 t0 t1)) + (declare (double-float s0 s1 s3 t0 t1 s2)) (two-sum s0 t1 (qd-0 a) (kernel:double-double-hi b)) (two-sum s1 t1 (qd-1 a) (kernel:double-double-lo b)) (two-sum s1 t0 s1 t0) - (multiple-value-bind (s2 t0 t1) - (three-sum (qd-2 a) t0 t1) - (two-sum s3 t0 t0 (qd-3 a)) - (let ((t0 (cl:+ t0 t1))) - (multiple-value-call #'%make-qd-d - (renorm-5 s0 s1 s2 s3 t0)))))) + (three-sum s2 t0 t1 t0 t0 (qd-3 a)) + (two-sum s3 t0 t0 (qd-3 a)) + (let ((t0 (cl:+ t0 t1))) + (declare (double-float t0)) + (multiple-value-bind (a0 a1 a2 a3) + (renorm-5 s0 s1 s2 s3 t0) + (declare (double-float a0 a1 a2 a3)) + (%make-qd-d a0 a1 a2 a3))))) #+cmu (defun add-dd-qd (a b) @@ -400,18 +411,17 @@ (t2 (cl:+ w2 u2)) (t3 (cl:+ w3 u3))) (two-sum s1 t0 s1 t0) - (multiple-value-bind (s2 t0 t1) - (three-sum s2 t0 t1) - (multiple-value-bind (s3 t0) - (three-sum2 s3 t0 t2) - (declare (double-float t0)) - (setf t0 (cl:+ t0 t1 t3)) - ;; Renormalize - (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))))))))))))) + (three-sum s2 t0 t1 s2 t0 t1) + (multiple-value-bind (s3 t0) + (three-sum2 s3 t0 t2) + (declare (double-float t0)) + (setf t0 (cl:+ t0 t1 t3)) + ;; Renormalize + (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)))))))))))) (defun neg-qd (a) (declare (type %quad-double a)) @@ -471,17 +481,16 @@ (s2 p0)) (declare (double-float s0 s1 s2 p3)) (two-sum s1 s2 q0 p1) - (multiple-value-bind (s2 q1 p2) - (three-sum s2 q1 p2) - (multiple-value-bind (q1 q2) - (three-sum2 q1 q2 p3) - (let ((s3 q1) - (s4 (cl:+ q2 p2))) - (multiple-value-bind (s0 s1 s2 s3) - (renorm-5 s0 s1 s2 s3 s4) - (if (zerop s0) - (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) - (%make-qd-d s0 s1 s2 s3))))))))))) + (three-sum s2 q1 p2 s2 q1 p2) + (multiple-value-bind (q1 q2) + (three-sum2 q1 q2 p3) + (let ((s3 q1) + (s4 (cl:+ q2 p2))) + (multiple-value-bind (s0 s1 s2 s3) + (renorm-5 s0 s1 s2 s3 s4) + (if (zerop s0) + (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) + (%make-qd-d s0 s1 s2 s3)))))))))) ;; a0 * b0 0 ;; a0 * b1 1 @@ -597,14 +606,11 @@ (multiple-value-bind (p5 q5) (two-prod a2 b0) ;; Start accumulation - (multiple-value-setq (p1 p2 q0) - (three-sum p1 p2 q0)) + (three-sum p1 p2 q0 p1 p2 q0) ;; six-three-sum of p2, q1, q2, p3, p4, p5 - (multiple-value-setq (p2 q1 q2) - (three-sum p2 q1 q2)) - (multiple-value-setq (p3 p4 p5) - (three-sum p3 p4 p5)) + (three-sum p2 q1 q2 p2 q1 q2) + (three-sum p3 p4 p5 p3 p4 p5) ;; Compute (s0,s1,s2) = (p2,q1,q2) + (p3,p4,p5) (let* ((s0 0d0) (s1 s0) @@ -779,8 +785,9 @@ (two-sum p3 p4 p3 t0) (incf p4 (cl:+ q0 t1)) - (multiple-value-call #'%make-qd-d - (renorm-5 p0 p1 p2 p3 p4))))))))) + (multiple-value-bind (a0 a1 a2 a3) + (renorm-5 p0 p1 p2 p3 p4) + (%make-qd-d a0 a1 a2 a3))))))))) (defun div-qd (a b) From rtoy at common-lisp.net Mon Sep 17 14:06:20 2007 From: rtoy at common-lisp.net (rtoy) Date: Mon, 17 Sep 2007 10:06:20 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd.lisp Message-ID: <20070917140620.C61DE4B026@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv21609 Modified Files: qd.lisp Log Message: o Fix typo in ADD-QD-DD that was introduced in the THREE-SUM macro conversion. o Slightly simplify ADD-QD-DD too. --- /project/oct/cvsroot/oct/qd.lisp 2007/09/17 03:08:25 1.50 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/17 14:06:20 1.51 @@ -43,7 +43,7 @@ (setf *inline-expansion-limit* 1600)) ;; All of the following functions should be inline. -(declaim (inline three-sum three-sum2)) +(declaim (inline three-sum2)) ;; Internal routines for implementing quad-double. @@ -324,14 +324,13 @@ (two-sum s0 t1 (qd-0 a) (kernel:double-double-hi b)) (two-sum s1 t1 (qd-1 a) (kernel:double-double-lo b)) (two-sum s1 t0 s1 t0) - (three-sum s2 t0 t1 t0 t0 (qd-3 a)) + (three-sum s2 t0 t1 (qd-2 a) t0 t1) (two-sum s3 t0 t0 (qd-3 a)) - (let ((t0 (cl:+ t0 t1))) - (declare (double-float t0)) - (multiple-value-bind (a0 a1 a2 a3) - (renorm-5 s0 s1 s2 s3 t0) - (declare (double-float a0 a1 a2 a3)) - (%make-qd-d a0 a1 a2 a3))))) + (incf t0 t1) + (multiple-value-bind (a0 a1 a2 a3) + (renorm-5 s0 s1 s2 s3 t0) + (declare (double-float a0 a1 a2 a3)) + (%make-qd-d a0 a1 a2 a3)))) #+cmu (defun add-dd-qd (a b) From rtoy at common-lisp.net Mon Sep 17 17:15:05 2007 From: rtoy at common-lisp.net (rtoy) Date: Mon, 17 Sep 2007 13:15:05 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd.lisp Message-ID: <20070917171505.217191D12E@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv21126 Modified Files: qd.lisp Log Message: o Convert THREE-SUM2 to a macro instead of a function (to speed things up for Allegro and other Lisps that don't inline). o Update code for the THREE-SUM2 macro. --- /project/oct/cvsroot/oct/qd.lisp 2007/09/17 14:06:20 1.51 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/17 17:15:04 1.52 @@ -43,7 +43,7 @@ (setf *inline-expansion-limit* 1600)) ;; All of the following functions should be inline. -(declaim (inline three-sum2)) +;;(declaim (inline three-sum2)) ;; Internal routines for implementing quad-double. @@ -73,6 +73,7 @@ +#+nil (defun three-sum2 (a b c) (declare (double-float a b c) (optimize (speed 3))) @@ -81,8 +82,25 @@ (t3 t1)) (two-sum t1 t2 a b) (two-sum a t3 c t1) - (values a (cl:+ t2 t3) c))) + (values a (cl:+ t2 t3)))) +(defmacro three-sum2 (s0 s1 a b c) + (let ((aa (gensym)) + (bb (gensym)) + (cc (gensym)) + (t1 (gensym)) + (t2 (gensym)) + (t3 (gensym))) + `(let* ((,aa ,a) + (,bb ,b) + (,cc ,c) + (,t1 0d0) + (,t2 ,t1) + (,t3 ,t1)) + (declare (double-float ,t1 ,t2 ,t3)) + (two-sum ,t1 ,t2 ,aa ,bb) + (two-sum ,s0 ,t3 ,cc ,t1) + (setf ,s1 (+ ,t2 ,t3))))) ;; Not needed???? #+nil @@ -409,18 +427,17 @@ (t1 (cl:+ w1 u1)) (t2 (cl:+ w2 u2)) (t3 (cl:+ w3 u3))) + (declare (double-float t0 t1 t2 t3)) (two-sum s1 t0 s1 t0) (three-sum s2 t0 t1 s2 t0 t1) - (multiple-value-bind (s3 t0) - (three-sum2 s3 t0 t2) - (declare (double-float t0)) - (setf t0 (cl:+ t0 t1 t3)) + (three-sum2 s3 t0 s3 t0 t2) + (setf t0 (cl:+ t0 t1 t3)) ;; Renormalize (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)))))))))))) + (%make-qd-d s0 s1 s2 s3))))))))))) (defun neg-qd (a) (declare (type %quad-double a)) @@ -472,8 +489,10 @@ (return-from mul-qd-d (%make-qd-d p0 0d0 0d0 0d0))) (multiple-value-bind (p1 q1) (two-prod (qd-1 a) b) + (declare (double-float p1 q1)) (multiple-value-bind (p2 q2) (two-prod (qd-2 a) b) + (declare (double-float p2 q2)) (let* ((p3 (cl:* (qd-3 a) b)) (s0 p0) (s1 p0) @@ -481,15 +500,14 @@ (declare (double-float s0 s1 s2 p3)) (two-sum s1 s2 q0 p1) (three-sum s2 q1 p2 s2 q1 p2) - (multiple-value-bind (q1 q2) - (three-sum2 q1 q2 p3) - (let ((s3 q1) - (s4 (cl:+ q2 p2))) - (multiple-value-bind (s0 s1 s2 s3) - (renorm-5 s0 s1 s2 s3 s4) - (if (zerop s0) - (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) - (%make-qd-d s0 s1 s2 s3)))))))))) + (three-sum2 q1 q2 q1 q2 p3) + (let ((s3 q1) + (s4 (cl:+ q2 p2))) + (multiple-value-bind (s0 s1 s2 s3) + (renorm-5 s0 s1 s2 s3 s4) + (if (zerop s0) + (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) + (%make-qd-d s0 s1 s2 s3))))))))) ;; a0 * b0 0 ;; a0 * b1 1 @@ -556,7 +574,7 @@ (cl:* (qd-3 a) (kernel:double-double-lo b)) q3 q4))) - (multiple-value-setq (p3 q0 s1) + (multiple-value-setq (p3 q0) (three-sum2 p3 q0 s1)) (let ((p4 (cl:+ q0 s2))) (multiple-value-call #'%make-qd-d From rtoy at common-lisp.net Mon Sep 17 19:04:23 2007 From: rtoy at common-lisp.net (rtoy) Date: Mon, 17 Sep 2007 15:04:23 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd.lisp Message-ID: <20070917190423.3A160450CB@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv8007 Modified Files: qd.lisp Log Message: New SCALE-FLOAT-QD implementation that shouldn't suffer from premature overflow/underflow. (Still issue if the exponent is very large or very small, though, but not if the exponent is < 2000 or so.) --- /project/oct/cvsroot/oct/qd.lisp 2007/09/17 17:15:04 1.52 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/17 19:04:23 1.53 @@ -1085,6 +1085,7 @@ q0-sign)))))) (declaim (inline scale-float-qd)) +#+(or) (defun scale-float-qd (qd k) (declare (type %quad-double qd) (type fixnum k) @@ -1112,6 +1113,29 @@ (cl:* (qd-2 qd) scale) (cl:* (qd-3 qd) scale)))) +(defun scale-float-qd (qd k) + (declare (type %quad-double qd) + (type (integer -2000 2000) k) + (optimize (speed 3) (space 0))) + ;; Split the exponent in half and do the scaling in two parts. + ;; Requires 2 multiplications, but should not prematurely return 0, + ;; and should be faster than the original version above. + (let* ((k1 (floor k 2)) + (k2 (- k k1)) + (s1 (scale-float 1d0 k1)) + (s2 (scale-float 1d0 k2))) + (multiple-value-bind (q0 q1 q2 q3) + (qd-parts qd) + (%make-qd-d (cl:* (cl:* q0 s1) s2) + (cl:* (cl:* q1 s1) s2) + (cl:* (cl:* q2 s1) s2) + (cl:* (cl:* q3 s1) s2))))) + + + + + + (defun decode-float-qd (q) (declare (type %quad-double q)) (multiple-value-bind (frac exp sign) From rtoy at common-lisp.net Tue Sep 18 03:05:56 2007 From: rtoy at common-lisp.net (rtoy) Date: Mon, 17 Sep 2007 23:05:56 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-test.lisp rt-tests.lisp Message-ID: <20070918030556.DBD2B4B027@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv24380 Modified Files: qd-test.lisp rt-tests.lisp Log Message: qd-test.lisp: o Add optional arg to enable/disable printing of results. Default is on. rt-tests.lisp: o Don't print results. --- /project/oct/cvsroot/oct/qd-test.lisp 2007/08/27 17:49:19 1.18 +++ /project/oct/cvsroot/oct/qd-test.lisp 2007/09/18 03:05:56 1.19 @@ -67,7 +67,7 @@ ;; pi = ;; 3.1415926535897932384626433832795028841971693993751058209749445923078L0 -(defun test2 () +(defun test2 (&optional (printp t)) ;; pi/4 = 4 * arctan(1/5) - arctan(1/239) ;; ;; Arctan is computed using the Taylor series @@ -100,11 +100,12 @@ (p (mul-qd-d (sub-qd (mul-qd-d s1 4d0) s2) 4d0))) - (format t "~2&pi via Machin's atan formula~%") - (print-result p +qd-pi+) + (when printp + (format t "~2&pi via Machin's atan formula~%") + (print-result p +qd-pi+)) p))) -(defun test3 () +(defun test3 (&optional (printp t)) (declare (optimize (speed 3))) ;; Salamin-Brent Quadratic formula for pi (let* ((a +qd-one+) @@ -127,11 +128,12 @@ (setf s s-new) (setf p (div-qd (mul-qd-d (sqr-qd a) 2d0) s)))) - (format t "~2&Salamin-Brent Quadratic formula for pi~%") - (print-result p +qd-pi+) + (when printp + (format t "~2&Salamin-Brent Quadratic formula for pi~%") + (print-result p +qd-pi+)) p)) -(defun test4 () +(defun test4 (&optional (printp t)) (declare (optimize (speed 3))) ;; Borwein Quartic formula for pi (let* ((a (sub-qd (make-qd-d 6d0) @@ -160,13 +162,14 @@ m))) (setf p (div-qd +qd-one+ a)))) - (format t "~2&Borwein's Quartic formula for pi~%") - (print-result p +qd-pi+) + (when printp + (format t "~2&Borwein's Quartic formula for pi~%") + (print-result p +qd-pi+)) p)) ;; e = ;; 2.718281828459045235360287471352662497757247093699959574966967627724L0 -(defun test5 () +(defun test5 (&optional (printp t)) ;; Taylor series for e (let ((s (make-qd-d 2d0)) (tmp +qd-one+) @@ -179,13 +182,14 @@ (setf tmp (div-qd tmp (make-qd-d (float n 1d0)))) (setf s (add-qd s tmp))) - (format t "~2&e via Taylor series~%") - (print-result s +qd-e+) + (when printp + (format t "~2&e via Taylor series~%") + (print-result s +qd-e+)) s)) ;; log(2) = ;; 0.6931471805599453094172321214581765680755001343602552541206800094934L0 -(defun test6 () +(defun test6 (&optional (printp t)) ;; Taylor series for log 2 ;; ;; -log(1-x) = x + x^2/2 + x^3/3 + x^4/4 + ... @@ -201,11 +205,12 @@ (setf tt (mul-qd-d tt .5d0)) (setf s (add-qd s (div-qd tt (make-qd-d (float n 1d0)))))) - (format t "~2&log(2) via Taylor series~%") - (print-result s +qd-log2+) + (when printp + (format t "~2&log(2) via Taylor series~%") + (print-result s +qd-log2+)) s)) -(defun test-atan (&optional (fun #'atan-qd)) +(defun test-atan (&optional (fun #'atan-qd) (printp t)) ;; Compute atan for known values (format t "~2&atan via ~S~%" fun) @@ -234,7 +239,7 @@ (format t "bits = ~,1f~%" (bit-accuracy y true)))) -(defun test-sin () +(defun test-sin (&optional (printp t)) (format t "~2&sin~%") (let* ((arg (div-qd +qd-pi+ (make-qd-d 6d0))) (y (sin-qd arg)) @@ -259,7 +264,7 @@ (bit-accuracy y true))) ) -(defun test-tan (&optional (f #'tan-qd)) +(defun test-tan (&optional (f #'tan-qd) (printp t)) (format t "~2&tan via ~S~%" f) (let* ((arg (div-qd +qd-pi+ (make-qd-d 6d0))) (y (funcall f arg)) @@ -284,7 +289,7 @@ (bit-accuracy y true))) ) -(defun test-asin () +(defun test-asin (&optional (printp t)) (format t "~2&asin~%") (let* ((arg (make-qd-d 0.5d0)) (y (asin-qd arg)) @@ -309,7 +314,7 @@ (bit-accuracy y true))) ) -(defun test-log (f) +(defun test-log (f &optional (printp t)) (format t "~2&Log via ~A~%" f) (let* ((arg (make-qd-d 2d0)) (y (funcall f arg)) @@ -334,7 +339,7 @@ (bit-accuracy y true))) ) -(defun test-log1p (f) +(defun test-log1p (f &optional (printp t)) (format t "~2&Log1p via ~A~%" f) (let* ((arg (make-qd-d 1d0)) (y (funcall f arg)) @@ -359,7 +364,7 @@ (bit-accuracy y true))) ) -(defun test-exp (f) +(defun test-exp (f &optional (printp t)) (format t "~2&Exp via ~A~%" f) (let* ((arg +qd-zero+) (y (funcall f arg)) @@ -385,6 +390,7 @@ (bit-accuracy y true))) ) + (defun all-tests () (test2) (test3) --- /project/oct/cvsroot/oct/rt-tests.lisp 2007/08/27 18:05:12 1.1 +++ /project/oct/cvsroot/oct/rt-tests.lisp 2007/09/18 03:05:56 1.2 @@ -50,7 +50,7 @@ ;; Pi via Machin's formula (rt:deftest oct.pi.machin (let* ((*standard-output* *null*) - (val (make-instance 'qd-real :value (qdi::test2))) + (val (make-instance 'qd-real :value (qdi::test2 nil))) (true qd:+pi+)) (check-accuracy 213 val true)) nil) @@ -58,7 +58,7 @@ ;; Pi via Salamin-Brent algorithm (rt:deftest oct.pi.salamin-brent (let* ((*standard-output* *null*) - (val (make-instance 'qd-real :value (qdi::test3))) + (val (make-instance 'qd-real :value (qdi::test3 nil))) (true qd:+pi+)) (check-accuracy 202 val true)) nil) @@ -66,7 +66,7 @@ ;; Pi via Borweign's Quartic formula (rt:deftest oct.pi.borweign (let* ((*standard-output* *null*) - (val (make-instance 'qd-real :value (qdi::test4))) + (val (make-instance 'qd-real :value (qdi::test4 nil))) (true qd:+pi+)) (check-accuracy 211 val true)) nil) @@ -74,7 +74,7 @@ ;; e via Taylor series (rt:deftest oct.e.taylor (let* ((*standard-output* *null*) - (val (make-instance 'qd-real :value (qdi::test5))) + (val (make-instance 'qd-real :value (qdi::test5 nil))) (true (make-instance 'qd-real :value qdi::+qd-e+))) (check-accuracy 212 val true)) nil) @@ -82,7 +82,7 @@ ;; log(2) via Taylor series (rt:deftest oct.log2.taylor (let* ((*standard-output* *null*) - (val (make-instance 'qd-real :value (qdi::test6))) + (val (make-instance 'qd-real :value (qdi::test6 nil))) (true (make-instance 'qd-real :value qdi::+qd-log2+))) (check-accuracy 212 val true)) nil) From rtoy at common-lisp.net Tue Sep 18 11:20:16 2007 From: rtoy at common-lisp.net (rtoy) Date: Tue, 18 Sep 2007 07:20:16 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-rep.lisp qd.lisp Message-ID: <20070918112016.D4EE92F050@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv19559 Modified Files: qd-rep.lisp qd.lisp Log Message: qd-rep.lisp: o Add macro WITH-QD-PARTS to extract the components of a quad-double. qd.lisp: o Use the macro as needed. --- /project/oct/cvsroot/oct/qd-rep.lisp 2007/09/17 03:07:27 1.6 +++ /project/oct/cvsroot/oct/qd-rep.lisp 2007/09/18 11:20:16 1.7 @@ -179,3 +179,13 @@ (aref qd 3))) ) ; end progn + +(defmacro with-qd-parts ((a0 a1 a2 a3) qd &body body) + (let ((q (gensym))) + `(let* ((,q ,qd) + (,a0 (qd-0 ,q)) + (,a1 (qd-1 ,q)) + (,a2 (qd-2 ,q)) + (,a3 (qd-3 ,q))) + , at body))) + --- /project/oct/cvsroot/oct/qd.lisp 2007/09/17 19:04:23 1.53 +++ /project/oct/cvsroot/oct/qd.lisp 2007/09/18 11:20:16 1.54 @@ -393,10 +393,12 @@ ;; version? It's quite a bit more complicated. ;; ;; In addition, this is reorganized to minimize data dependency. - (multiple-value-bind (a0 a1 a2 a3) - (qd-parts a) - (multiple-value-bind (b0 b1 b2 b3) - (qd-parts b) + (with-qd-parts (a0 a1 a2 a3) + a + (declare (double-float a0 a1 a2 a3)) + (with-qd-parts (b0 b1 b2 b3) + b + (declare (double-float b0 b1 b2 b3)) (let ((s0 (cl:+ a0 b0)) (s1 (cl:+ a1 b1)) (s2 (cl:+ a2 b2)) @@ -411,18 +413,22 @@ (v1 (cl:- s1 a1)) (v2 (cl:- s2 a2)) (v3 (cl:- s3 a3))) + (declare (double-float v0 v1 v2 v3)) (let ((u0 (cl:- s0 v0)) (u1 (cl:- s1 v1)) (u2 (cl:- s2 v2)) (u3 (cl:- s3 v3))) + (declare (double-float u0 u1 u2 u3)) (let ((w0 (cl:- a0 u0)) (w1 (cl:- a1 u1)) (w2 (cl:- a2 u2)) (w3 (cl:- a3 u3))) + (declare (double-float w0 w1 w2 w3)) (let ((u0 (cl:- b0 v0)) (u1 (cl:- b1 v1)) (u2 (cl:- b2 v2)) (u3 (cl:- b3 v3))) + (declare (double-float u0 u1 u2 u3)) (let ((t0 (cl:+ w0 u0)) (t1 (cl:+ w1 u1)) (t2 (cl:+ w2 u2)) @@ -432,17 +438,18 @@ (three-sum s2 t0 t1 s2 t0 t1) (three-sum2 s3 t0 s3 t0 t2) (setf t0 (cl:+ t0 t1 t3)) - ;; Renormalize - (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))))))))))) + ;; Renormalize + (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))))))))))) (defun neg-qd (a) (declare (type %quad-double a)) - (multiple-value-bind (a0 a1 a2 a3) - (qd-parts a) + (with-qd-parts (a0 a1 a2 a3) + a + (declare (double-float a0 a1 a2 a3)) (%make-qd-d (cl:- a0) (cl:- a1) (cl:- a2) (cl:- a3)))) (defun sub-qd (a b) @@ -603,10 +610,12 @@ (space 0)) #+cmu (inline ext:float-infinity-p)) - (multiple-value-bind (a0 a1 a2 a3) - (qd-parts a) - (multiple-value-bind (b0 b1 b2 b3) - (qd-parts b) + (with-qd-parts (a0 a1 a2 a3) + a + (declare (double-float a0 a1 a2 a3)) + (with-qd-parts (b0 b1 b2 b3) + b + (declare (double-float b0 b1 b2 b3)) (multiple-value-bind (p0 q0) (two-prod a0 b0) #+cmu @@ -1124,8 +1133,9 @@ (k2 (- k k1)) (s1 (scale-float 1d0 k1)) (s2 (scale-float 1d0 k2))) - (multiple-value-bind (q0 q1 q2 q3) - (qd-parts qd) + (with-qd-parts (q0 q1 q2 q3) + qd + (declare (double-float q0 q1 q2 q3)) (%make-qd-d (cl:* (cl:* q0 s1) s2) (cl:* (cl:* q1 s1) s2) (cl:* (cl:* q2 s1) s2) From rtoy at common-lisp.net Tue Sep 18 12:46:36 2007 From: rtoy at common-lisp.net (rtoy) Date: Tue, 18 Sep 2007 08:46:36 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-complex.lisp qd-methods.lisp qd-package.lisp Message-ID: <20070918124636.40E6E44060@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv7806 Modified Files: qd-complex.lisp qd-methods.lisp qd-package.lisp Log Message: Add method RATIONAL to convert a quad-double to a rational. qd-package.lisp: o Appropriately shadow and export RATIONAL. o Need to export WITH-QD-PARTS from QDI. qd-methods.lisp: o Define methods for RATIONAL for reals and qd-reals. qd-complex.lisp: o Use CL:RATIONAL as appropriate for the CL rational type. --- /project/oct/cvsroot/oct/qd-complex.lisp 2007/09/12 21:01:13 1.36 +++ /project/oct/cvsroot/oct/qd-complex.lisp 2007/09/18 12:46:36 1.37 @@ -35,27 +35,27 @@ :real (sub-qd-d (qd-value (realpart a)) 1d0) :imag (qd-value (imagpart a)))) -(defmethod two-arg-/ ((a qd-real) (b rational)) +(defmethod two-arg-/ ((a qd-real) (b cl:rational)) (make-instance 'qd-real :value (div-qd (qd-value a) (qd-value (float b #q0))))) -(defmethod two-arg-/ ((a rational) (b qd-real)) +(defmethod two-arg-/ ((a cl:rational) (b qd-real)) (make-instance 'qd-real :value (div-qd (qd-value (float a #q0)) (qd-value b)))) -(defmethod two-arg-* ((a qd-real) (b rational)) +(defmethod two-arg-* ((a qd-real) (b cl:rational)) (make-instance 'qd-real :value (mul-qd (qd-value a) (qd-value (float b #q0))))) -(defmethod two-arg-+ ((a qd-real) (b rational)) +(defmethod two-arg-+ ((a qd-real) (b cl:rational)) (make-instance 'qd-real :value (add-qd (qd-value a) (qd-value (float b #q0))))) -(defmethod two-arg-+ ((a rational) (b qd-real)) +(defmethod two-arg-+ ((a cl:rational) (b qd-real)) (make-instance 'qd-real :value (add-qd (qd-value b) (qd-value (float a #q0))))) -(defmethod two-arg-- ((a qd-real) (b rational)) +(defmethod two-arg-- ((a qd-real) (b cl:rational)) (make-instance 'qd-real :value (sub-qd (qd-value a) (qd-value (float b #q0))))) -(defmethod two-arg-- ((a rational) (b qd-real)) +(defmethod two-arg-- ((a cl:rational) (b qd-real)) (make-instance 'qd-real :value (sub-qd (qd-value (float a #q0)) (qd-value b)))) (defmethod unary-minus ((z qd-complex)) --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/16 02:39:29 1.57 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/18 12:46:36 1.58 @@ -814,6 +814,16 @@ (defmethod float-digits ((x qd-real)) (* 4 (float-digits 1d0))) +(defmethod rational ((x real)) + (cl:rational x)) + +(defmethod rational ((x qd-real)) + (with-qd-parts (x0 x1 x2 x3) + (qd-value x) + (+ (cl:rational x0) + (cl:rational x1) + (cl:rational x2) + (cl:rational x3)))) (define-compiler-macro + (&whole form &rest args) (if (null args) --- /project/oct/cvsroot/oct/qd-package.lisp 2007/09/16 05:04:05 1.39 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/09/18 12:46:36 1.40 @@ -89,6 +89,7 @@ #:scale-float-qd #:ffloor-qd #:random-qd + #:with-qd-parts ) #+cmu (:export #:add-qd-dd @@ -166,6 +167,7 @@ #:incf #:decf #:float-digits + #:rational ) ;; Export types (:export #:qd-real @@ -234,6 +236,7 @@ #:incf #:decf #:float-digits + #:rational ) ;; Constants (:export #:+pi+ From rtoy at common-lisp.net Wed Sep 19 17:30:05 2007 From: rtoy at common-lisp.net (rtoy) Date: Wed, 19 Sep 2007 13:30:05 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-class.lisp qd-methods.lisp Message-ID: <20070919173005.279E043218@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv18474 Modified Files: qd-class.lisp qd-methods.lisp Log Message: MAKE-QD should handle rationals better instead of converting them to doubles and then converting the qd-real. Convert the numerator and denominator to qd-real, and the divide. (This should be done better.) qd-class.lisp: o Change method to work on floats, instead of reals. qd-methods.lisp: o Add method to handle rationals. --- /project/oct/cvsroot/oct/qd-class.lisp 2007/09/06 02:58:38 1.25 +++ /project/oct/cvsroot/oct/qd-class.lisp 2007/09/19 17:30:04 1.26 @@ -60,7 +60,7 @@ (defmethod print-object ((qd qd-real) stream) (print-qd (qd-value qd) stream)) -(defmethod make-qd ((x real)) +(defmethod make-qd ((x cl:float)) (make-instance 'qd-real :value (make-qd-d (float x 1d0)))) (defmethod make-qd ((x qd-real)) --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/18 12:46:36 1.58 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/19 17:30:04 1.59 @@ -76,6 +76,16 @@ (defconstant +qd-real-one+ (make-instance 'qd-real :value (make-qd-d 1d0))) + +(defmethod make-qd ((x cl:rational)) + ;; We should do something better than this. + (let ((top (numerator x)) + (bot (denominator x))) + (make-instance 'qd-real + :value (div-qd (qdi::make-float (signum top) (abs top) 0 0 0) + (qdi::make-float (signum bot) (abs bot) 0 0 0))))) + + (defmethod add1 ((a number)) (cl::1+ a)) @@ -824,8 +834,10 @@ (cl:rational x1) (cl:rational x2) (cl:rational x3)))) + (define-compiler-macro + (&whole form &rest args) + (declare (ignore form)) (if (null args) 0 (do ((args (cdr args) (cdr args)) @@ -834,6 +846,7 @@ ((null args) res)))) (define-compiler-macro - (&whole form number &rest more-numbers) + (declare (ignore form)) (if more-numbers (do ((nlist more-numbers (cdr nlist)) (result number)) @@ -843,6 +856,7 @@ `(unary-minus ,number))) (define-compiler-macro * (&whole form &rest args) + (declare (ignore form)) (if (null args) 1 (do ((args (cdr args) (cdr args)) From rtoy at common-lisp.net Thu Sep 20 21:04:05 2007 From: rtoy at common-lisp.net (rtoy) Date: Thu, 20 Sep 2007 17:04:05 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-methods.lisp qd-package.lisp Message-ID: <20070920210405.00CE73001A@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv8223 Modified Files: qd-methods.lisp qd-package.lisp Log Message: Add RATIONALIZE methods. Algorithm graciously provided by Bruno Haible. qd-package.lisp: o Shadow RATIONALIZE qd-methods.lisp: o Add RATIONALIZE methods for CL:REAL's and QD-REAL's.. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/19 17:30:04 1.59 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/20 21:04:05 1.60 @@ -835,6 +835,102 @@ (cl:rational x2) (cl:rational x3)))) +(defmethod rationalize ((x cl:real)) + (cl:rationalize x)) + +;;; The algorithm here is the method described in CLISP. Bruno Haible has +;;; graciously given permission to use this algorithm. He says, "You can use +;;; it, if you present the following explanation of the algorithm." +;;; +;;; Algorithm (recursively presented): +;;; If x is a rational number, return x. +;;; If x = 0.0, return 0. +;;; If x < 0.0, return (- (rationalize (- x))). +;;; If x > 0.0: +;;; Call (integer-decode-float x). It returns a m,e,s=1 (mantissa, +;;; exponent, sign). +;;; If m = 0 or e >= 0: return x = m*2^e. +;;; Search a rational number between a = (m-1/2)*2^e and b = (m+1/2)*2^e +;;; with smallest possible numerator and denominator. +;;; Note 1: If m is a power of 2, we ought to take a = (m-1/4)*2^e. +;;; But in this case the result will be x itself anyway, regardless of +;;; the choice of a. Therefore we can simply ignore this case. +;;; Note 2: At first, we need to consider the closed interval [a,b]. +;;; but since a and b have the denominator 2^(|e|+1) whereas x itself +;;; has a denominator <= 2^|e|, we can restrict the seach to the open +;;; interval (a,b). +;;; So, for given a and b (0 < a < b) we are searching a rational number +;;; y with a <= y <= b. +;;; Recursive algorithm fraction_between(a,b): +;;; c := (ceiling a) +;;; if c < b +;;; then return c ; because a <= c < b, c integer +;;; else +;;; ; a is not integer (otherwise we would have had c = a < b) +;;; k := c-1 ; k = floor(a), k < a < b <= k+1 +;;; return y = k + 1/fraction_between(1/(b-k), 1/(a-k)) +;;; ; note 1 <= 1/(b-k) < 1/(a-k) +;;; +;;; You can see that we are actually computing a continued fraction expansion. +;;; +;;; Algorithm (iterative): +;;; If x is rational, return x. +;;; Call (integer-decode-float x). It returns a m,e,s (mantissa, +;;; exponent, sign). +;;; If m = 0 or e >= 0, return m*2^e*s. (This includes the case x = 0.0.) +;;; Create rational numbers a := (2*m-1)*2^(e-1) and b := (2*m+1)*2^(e-1) +;;; (positive and already in lowest terms because the denominator is a +;;; power of two and the numerator is odd). +;;; Start a continued fraction expansion +;;; p[-1] := 0, p[0] := 1, q[-1] := 1, q[0] := 0, i := 0. +;;; Loop +;;; c := (ceiling a) +;;; if c >= b +;;; then k := c-1, partial_quotient(k), (a,b) := (1/(b-k),1/(a-k)), +;;; goto Loop +;;; finally partial_quotient(c). +;;; Here partial_quotient(c) denotes the iteration +;;; i := i+1, p[i] := c*p[i-1]+p[i-2], q[i] := c*q[i-1]+q[i-2]. +;;; At the end, return s * (p[i]/q[i]). +;;; This rational number is already in lowest terms because +;;; p[i]*q[i-1]-p[i-1]*q[i] = (-1)^i. +;;; +(defmethod rationalize ((x qd-real)) + ;; This is a fairly straigtforward implementation of the iterative + ;; algorithm above. + (multiple-value-bind (frac expo sign) + (integer-decode-float x) + (cond ((or (zerop frac) (>= expo 0)) + (if (minusp sign) + (- (ash frac expo)) + (ash frac expo))) + (t + ;; expo < 0 and (2*m-1) and (2*m+1) are coprime to 2^(1-e), + ;; so build the fraction up immediately, without having to do + ;; a gcd. + (let ((a (/ (- (* 2 frac) 1) (ash 1 (- 1 expo)))) + (b (/ (+ (* 2 frac) 1) (ash 1 (- 1 expo)))) + (p0 0) + (q0 1) + (p1 1) + (q1 0)) + (do ((c (ceiling a) (ceiling a))) + ((< c b) + (let ((top (+ (* c p1) p0)) + (bot (+ (* c q1) q0))) + (/ (if (minusp sign) + (- top) + top) + bot))) + (let* ((k (- c 1)) + (p2 (+ (* k p1) p0)) + (q2 (+ (* k q1) q0))) + (psetf a (/ (- b k)) + b (/ (- a k))) + (setf p0 p1 + q0 q1 + p1 p2 + q1 q2)))))))) (define-compiler-macro + (&whole form &rest args) (declare (ignore form)) --- /project/oct/cvsroot/oct/qd-package.lisp 2007/09/18 12:46:36 1.40 +++ /project/oct/cvsroot/oct/qd-package.lisp 2007/09/20 21:04:05 1.41 @@ -168,6 +168,7 @@ #:decf #:float-digits #:rational + #:rationalize ) ;; Export types (:export #:qd-real @@ -237,6 +238,7 @@ #:decf #:float-digits #:rational + #:rationalize ) ;; Constants (:export #:+pi+ From rtoy at common-lisp.net Mon Sep 24 02:37:31 2007 From: rtoy at common-lisp.net (rtoy) Date: Sun, 23 Sep 2007 22:37:31 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-io.lisp Message-ID: <20070924023731.374605D006@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv23811 Modified Files: qd-io.lisp Log Message: Use more bits (265 instead of 212) when converting a rational to a quad-double. This fixes the issue that converting 10^100 to a quad-double isn't as accurate as it could be. --- /project/oct/cvsroot/oct/qd-io.lisp 2007/09/12 02:31:14 1.15 +++ /project/oct/cvsroot/oct/qd-io.lisp 2007/09/24 02:37:31 1.16 @@ -340,29 +340,25 @@ (neg-qd (mul-qd xx yy)) (mul-qd xx yy)))) (t - (let* #+nil - ((hi (ldb (byte 106 (cl:- len 106)) int)) - (lo (ldb (byte 106 (cl:- len 212)) int)) - (xx (make-qd-dd (cl:* sign (scale-float (float hi 1w0) - (cl:- len 106))) - (cl:* sign (scale-float (float lo 1w0) - (cl:- len 106 106))))) - (yy (npow (make-qd-d 10d0) - power))) - ((q0 (ldb (byte 53 (cl:- len 53)) int)) - (q1 (ldb (byte 53 (cl:- len (* 2 53))) int)) - (q2 (ldb (byte 53 (cl:- len (* 3 53))) int)) - (q3 (ldb (byte 53 (cl:- len (* 4 53))) int)) - (xx (make-qd-d (scale-float (float q0 1d0) - (cl:- len 53)) - (scale-float (float q1 1d0) - (cl:- len (* 2 53))) - (scale-float (float q2 1d0) - (cl:- len (* 3 53))) - (scale-float (float q3 1d0) - (cl:- len (* 4 53))))) - (yy (npow (make-qd-d 10d0) - power))) + (let* + ((q0 (ldb (byte 53 (cl:- len 53)) int)) + (q1 (ldb (byte 53 (cl:- len (* 2 53))) int)) + (q2 (ldb (byte 53 (cl:- len (* 3 53))) int)) + (q3 (ldb (byte 53 (cl:- len (* 4 53))) int)) + (q4 (ldb (byte 53 (cl:- len (* 5 53))) int)) + (xx (multiple-value-call #'%make-qd-d + (renorm-5 (scale-float (float q0 1d0) + (cl:- len 53)) + (scale-float (float q1 1d0) + (cl:- len (* 2 53))) + (scale-float (float q2 1d0) + (cl:- len (* 3 53))) + (scale-float (float q3 1d0) + (cl:- len (* 4 53))) + (scale-float (float q4 1d0) + (cl:- len (* 5 53)))))) + (yy (npow (make-qd-d 10d0) + power))) #+(or) (progn (format t "xx = ~A~%" xx) From rtoy at common-lisp.net Mon Sep 24 21:30:07 2007 From: rtoy at common-lisp.net (rtoy) Date: Mon, 24 Sep 2007 17:30:07 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-methods.lisp Message-ID: <20070924213007.ED80858331@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv16245 Modified Files: qd-methods.lisp Log Message: Minor optimization converting a rational to a qd-real. If the denominator is 1, skip the qd-real division. --- /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/20 21:04:05 1.60 +++ /project/oct/cvsroot/oct/qd-methods.lisp 2007/09/24 21:30:07 1.61 @@ -81,9 +81,11 @@ ;; We should do something better than this. (let ((top (numerator x)) (bot (denominator x))) - (make-instance 'qd-real - :value (div-qd (qdi::make-float (signum top) (abs top) 0 0 0) - (qdi::make-float (signum bot) (abs bot) 0 0 0))))) + (if (= bot 1) + (make-instance 'qd-real :value (qdi::make-float (signum top) (abs top) 0 0 0)) + (make-instance 'qd-real + :value (div-qd (qdi::make-float (signum top) (abs top) 0 0 0) + (qdi::make-float (signum bot) (abs bot) 0 0 0)))))) (defmethod add1 ((a number)) From rtoy at common-lisp.net Mon Sep 24 21:32:15 2007 From: rtoy at common-lisp.net (rtoy) Date: Mon, 24 Sep 2007 17:32:15 -0400 (EDT) Subject: [oct-cvs] Oct commit: oct qd-io.lisp Message-ID: <20070924213215.E261B58717@common-lisp.net> Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv16369 Modified Files: qd-io.lisp Log Message: A new version of MAKE-FLOAT that converts the number to rational before converting to a quad-double. This reduces round-off errors. This still needs work, I think. --- /project/oct/cvsroot/oct/qd-io.lisp 2007/09/24 02:37:31 1.16 +++ /project/oct/cvsroot/oct/qd-io.lisp 2007/09/24 21:32:15 1.17 @@ -305,11 +305,13 @@ (t (qd-output-aux arg stream)))) +;; This version has problems with roundoff. +#+nil (defun make-float (sign int-part frac-part scale exp) (declare (type (member -1 1) sign) (type unsigned-byte int-part frac-part) (fixnum scale exp)) - #+(or) + ;;#+(or) (progn (format t "sign = ~A~%" sign) (format t "int-part = ~A~%" int-part) @@ -319,7 +321,7 @@ (let ((int (cl:+ (cl:* int-part (expt 10 scale)) frac-part)) (power (cl:- exp scale))) - #+(or) + ;;#+(or) (format t "~A * ~A * 10^(~A)~%" sign int power) (let* ((len (integer-length int))) #+(or) @@ -379,6 +381,80 @@ (neg-qd (mul-qd xx yy)) (mul-qd xx yy)))))))) +(defun make-float (sign int-part frac-part scale exp) + (declare (type (member -1 1) sign) + (type unsigned-byte int-part frac-part) + (fixnum scale exp)) + (flet ((convert-int (int) + ;; Convert integer INT to a quad-double. + (let ((len (integer-length int))) + (cond ((<= len 53) + ;; The simple case that fits in a double-float + (let ((xx (make-qd-d (float int 1d0)))) + xx)) + (t + ;; The complicated case. We look at the top 5*53 + ;; bits and create doubles from them (properly + ;; scaled) and then combine into a quad-double. + ;; Looking at only 4*53 (212 bits) isn't accurate + ;; enough. In particulare 10^100 isn't converted + ;; as accurately as desired if only 212 bits are + ;; used. + ;; + ;; If the integer doesn't have 5*53 bits, left + ;; shift it until it does, and set the length to + ;; 5*53, so that the scaling is done properly. + (let* + ((new-int (if (< len (* 5 53)) + (progn + (setf len (* 5 53)) + (ash int (- (* 5 53) len))) + int)) + (q0 (ldb (byte 53 (cl:- len 53)) new-int)) + (q1 (ldb (byte 53 (cl:- len (* 2 53))) new-int)) + (q2 (ldb (byte 53 (cl:- len (* 3 53))) new-int)) + (q3 (ldb (byte 53 (cl:- len (* 4 53))) new-int)) + (q4 (ldb (byte 53 (cl:- len (* 5 53))) new-int)) + (xx (multiple-value-call #'%make-qd-d + (renorm-5 (scale-float (float q0 1d0) + (cl:- len 53)) + (scale-float (float q1 1d0) + (cl:- len (* 2 53))) + (scale-float (float q2 1d0) + (cl:- len (* 3 53))) + (scale-float (float q3 1d0) + (cl:- len (* 4 53))) + (scale-float (float q4 1d0) + (cl:- len (* 5 53))))))) + #+(or) + (progn + (format t "xx = ~A~%" xx) + #+(or) + (format t " = ~/qd::qd-format/~%" xx) + (format t "yy = ~A~%" yy) + #+(or) + (format t " = ~/qd::qd-format/~%" yy) + (format t "q0 = ~X (~A)~%" q0 + (scale-float (float q0 1d0) + (cl:- len 53))) + (format t "q1 = ~X (~A)~%" q1 + (scale-float (float q1 1d0) + (cl:- len (* 2 53)))) + #+(or) + (format t "~/qdi::qd-format/~%" (mul-qd xx yy))) + xx)))))) + (let* ((rat (* (cl:+ (cl:* int-part (expt 10 scale)) + frac-part) + (expt 10 (cl:- exp scale)))) + (top (numerator rat)) + (bot (denominator rat))) + (div-qd (let ((top-qd (convert-int top))) + (if (minusp sign) + (neg-qd top-qd) + top-qd)) + (convert-int bot))))) + + ;; This seems to work, but really needs to be rewritten! (defun read-qd (stream) (labels ((read-digits (s)