diff --git a/code/irrat.lisp b/code/irrat.lisp index dc96e73ad77acc592866401bd7d664ddb97ca587..63a80ec86cf03944da9f72249963785920df203f 100644 --- a/code/irrat.lisp +++ b/code/irrat.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.53 2007/08/03 14:28:22 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.54 2008/01/28 18:21:03 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -182,15 +182,26 @@ #+(or ppc x86) (progn -(declaim (inline %ieee754-rem-pi/2)) +(declaim (inline %%ieee754-rem-pi/2)) ;; Basic argument reduction routine. It returns two values: n and y ;; such that (n + 8*k)*pi/2+y = x where |y|<pi/4 and n indicates in ;; which octant the arg lies. Y is actually computed in two parts, ;; y[0] and y[1] such that the sum is y, for accuracy. -(alien:def-alien-routine ("__ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int +(alien:def-alien-routine ("__ieee754_rem_pio2" %%ieee754-rem-pi/2) c-call:int (x double-float) (y (* double-float))) + +;; Same as above, but instead of needing to pass an array in, the +;; output array is broken up into two output values instead. This is +;; easier for the user, and we don't have to wrap calls with +;; without-gcing. +(declaim (inline %ieee754-rem-pi/2)) +(alien:def-alien-routine ("ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int + (x double-float) + (y0 double-float :out) + (y1 double-float :out)) + ) #+ppc @@ -207,7 +218,7 @@ #+(or ppc x86) (macrolet ((frob (sin cos tan) - `(let ((y (make-array 2 :element-type 'double-float))) + `(progn ;; The array y holds the result for %ieee754-rem-pi/2 ;; ;; In all of the routines below, we just compute the sum of @@ -222,35 +233,38 @@ (if (< (abs x) (/ pi 4)) (,sin x) ;; Argument reduction needed - (let* ((n (%ieee754-rem-pi/2 x (vector-sap y))) - (reduced (+ (aref y 0) (aref y 1)))) - (case (logand n 3) - (0 (,sin reduced)) - (1 (,cos reduced)) - (2 (- (,sin reduced))) - (3 (- (,cos reduced))))))) + (multiple-value-bind (n y0 y1) + (%ieee754-rem-pi/2 x) + (let ((reduced (+ y0 y1))) + (case (logand n 3) + (0 (,sin reduced)) + (1 (,cos reduced)) + (2 (- (,sin reduced))) + (3 (- (,cos reduced)))))))) (defun %cos (x) (declare (double-float x)) (if (< (abs x) (/ pi 4)) (,cos x) ;; Argument reduction needed - (let* ((n (%ieee754-rem-pi/2 x (vector-sap y))) - (reduced (+ (aref y 0) (aref y 1)))) - (case (logand n 3) - (0 (,cos reduced)) - (1 (- (,sin reduced))) - (2 (- (,cos reduced))) - (3 (,sin reduced)))))) + (multiple-value-bind (n y0 y1) + (%ieee754-rem-pi/2 x) + (let ((reduced (+ y0 y1))) + (case (logand n 3) + (0 (,cos reduced)) + (1 (- (,sin reduced))) + (2 (- (,cos reduced))) + (3 (,sin reduced))))))) (defun %tan (x) (declare (double-float x)) (if (< (abs x) (/ pi 4)) (,tan x) ;; Argument reduction needed - (let* ((n (%ieee754-rem-pi/2 x (vector-sap y))) - (reduced (+ (aref y 0) (aref y 1)))) - (if (evenp n) - (,tan reduced) - (- (/ (,tan reduced)))))))))) + (multiple-value-bind (n y0 y1) + (%ieee754-rem-pi/2 x) + (let ((reduced (+ y0 y1))) + (if (evenp n) + (,tan reduced) + (- (/ (,tan reduced))))))))))) #+x86 (frob %sin-quick %cos-quick %tan-quick) #+ppc diff --git a/lisp/Config.linux_gencgc b/lisp/Config.linux_gencgc index 108a2f454e3a843414a9963875510783a6ad2f30..94c91e5e19e583c99201d4702e3dec316a095ab5 100644 --- a/lisp/Config.linux_gencgc +++ b/lisp/Config.linux_gencgc @@ -41,7 +41,7 @@ OS_LIBS = -ldl # since we can't tell what compiler version we're using. e_rem_pio2.o : e_rem_pio2.c - $(CC) -c $(CFLAGS) -O1 $< + $(CC) -c $(CFLAGS) -O1 -ffloat-store $< k_rem_pio2.o : k_rem_pio2.c - $(CC) -c $(CFLAGS) -O1 $< + $(CC) -c $(CFLAGS) -O1 -ffloat-store $< diff --git a/lisp/ppc-arch.c b/lisp/ppc-arch.c index 90b3b7e3a1fe5946046b0ab93b81c03508e03f2e..c18e1f228ee5e725f3d24a433c3f787292134610 100644 --- a/lisp/ppc-arch.c +++ b/lisp/ppc-arch.c @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/ppc-arch.c,v 1.11 2007/11/16 05:04:09 cshapiro Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/ppc-arch.c,v 1.12 2008/01/28 18:21:04 rtoy Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -723,3 +723,17 @@ arch_linkage_entry(unsigned long retaddr) / LinkageEntrySize; } #endif + +int ieee754_rem_pio2(double x, double *y0, double *y1) +{ + extern int __ieee754_rem_pio2(double x, double *y); + + double y[2]; + int n; + + n = __ieee754_rem_pio2(x, y); + *y0 = y[0]; + *y1 = y[1]; + + return n; +} diff --git a/lisp/x86-arch.c b/lisp/x86-arch.c index 0ec7ea66c0d3510248459b82da65d536a473561d..88f5fb91079d7c42ee5481903cc43d18cbbfa4bb 100644 --- a/lisp/x86-arch.c +++ b/lisp/x86-arch.c @@ -1,6 +1,6 @@ /* x86-arch.c -*- Mode: C; comment-column: 40 -*- * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-arch.c,v 1.34 2007/12/15 15:26:29 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-arch.c,v 1.35 2008/01/28 18:21:04 rtoy Exp $ * */ @@ -424,3 +424,19 @@ arch_linkage_entry(unsigned long retaddr) return ((retaddr - 5) - FOREIGN_LINKAGE_SPACE_START) / LinkageEntrySize; } #endif /* LINKAGE_TABLE */ + +int ieee754_rem_pio2(double x, double *y0, double *y1) +{ + extern int __ieee754_rem_pio2(double x, double *y); + + double y[2]; + int n; + + n = __ieee754_rem_pio2(x, y); + *y0 = y[0]; + *y1 = y[1]; + + return n; +} + +