Skip to content
Snippets Groups Projects
Commit a1ccc294 authored by rtoy's avatar rtoy
Browse files

Add better trig arg reduction via Sun's fdlibm.

lisp/Config.ppc_darwin
o Compile e_rem_pio2.c and k_rem_pio2.c

code/irrat.lisp:
o Update the arg reduction code to support ppc.  We call out to the C
  sin, cos, and tan functions, after the argument has been accurately
  reduced.
parent c63d920e
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.47 2006/07/19 02:54:30 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.48 2006/07/19 03:52:38 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -171,49 +171,69 @@ ...@@ -171,49 +171,69 @@
(%sqrt x)) (%sqrt x))
) )
#+x86 #+(or ppc x86)
(progn (progn
(declaim (inline %ieee754-rem-pi/2))
(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) (x double-float)
(y (* double-float))) (y (* double-float)))
)
(let ((y (make-array 2 :element-type 'double-float))) #+ppc
(defun %sin (x) (progn
(declare (double-float x)) (declaim (inline %%sin %%cos %%tan))
(if (< (abs x) (/ pi 4)) (macrolet ((frob (alien-name lisp-name)
(%sin-quick x) `(alien:def-alien-routine (,alien-name ,lisp-name) double-float
;; Argument reduction needed (x double-float))))
(let* ((n (%ieee754-rem-pi/2 x (vector-sap y))) (frob "sin" %%sin)
(reduced (+ (aref y 0) (aref y 1)))) (frob "cos" %%cos)
(case (logand n 3) (frob "tan" %%tan))
(0 (%sin-quick reduced))
(1 (%cos-quick reduced))
(2 (- (%sin-quick reduced)))
(3 (- (%cos-quick reduced)))))))
(defun %cos (x)
(declare (double-float x))
(if (< (abs x) (/ pi 4))
(%cos-quick 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-quick reduced))
(1 (- (%sin-quick reduced)))
(2 (- (%cos-quick reduced)))
(3 (%sin-quick reduced))))))
(defun %tan (x)
(declare (double-float x))
(if (< (abs x) (/ pi 4))
(%tan-quick 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-quick reduced)
(- (/ (%tan-quick reduced))))))))
) )
#+(or ppc x86)
(macrolet
((frob (sin cos tan)
`(let ((y (make-array 2 :element-type 'double-float)))
(defun %sin (x)
(declare (double-float x))
(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)))))))
(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))))))
(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))))))))))
#+x86
(frob %sin-quick %cos-quick %tan-quick)
#+ppc
(frob %%sin %%cos %%tan))
;;;; Power functions. ;;;; Power functions.
......
...@@ -29,7 +29,7 @@ ASFLAGS = -traditional -g -O3 -no-cpp-precomp -DDARWIN -Dppc $(LINKAGE) $(GENCGC ...@@ -29,7 +29,7 @@ ASFLAGS = -traditional -g -O3 -no-cpp-precomp -DDARWIN -Dppc $(LINKAGE) $(GENCGC
UNDEFSYMPATTERN = -Xlinker -u -Xlinker & UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
ASSEM_SRC = ppc-assem.S linux-stubs.S ASSEM_SRC = ppc-assem.S linux-stubs.S
ARCH_SRC = ppc-arch.c ARCH_SRC = ppc-arch.c
OS_SRC = ppc-darwin-dlshim.c os-common.c Darwin-os.c OS_SRC = ppc-darwin-dlshim.c os-common.c Darwin-os.c e_rem_pio2.c k_rem_pio2.c
# I (rtoy) am not exactly sure what these values are, but it seems # I (rtoy) am not exactly sure what these values are, but it seems
# that the segaddr for CMUCLRO should be the READ_ONLY_SPACE_START. # that the segaddr for CMUCLRO should be the READ_ONLY_SPACE_START.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment