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

Add the trig argument reduction routines from Sun's fdlibm so we can

accurately reduce the arg and therefore compute the value of trig
functions accurately.

lisp/Config.linux_gencgc:
o Compile e_rem_pio2.c and k_rem_pio2.c

code/irrat.lisp:
o Disable %sin, %cos, %tan functions.
o Implement %sin, %cos, and %tan to call the fdlibm routine
  __ieee754_rem_pio2 to do argument reduction before calling the sin,
  cos, tan vops.

compiler/x86/float.lisp:
o Disable the vops for %sin, %cos, and %tan, so the Lisp code in
  irrat.lisp is used.
parent 58589c23
No related branches found
No related tags found
No related merge requests found
......@@ -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.46 2006/06/30 18:41:22 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.47 2006/07/19 02:54:30 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -84,6 +84,7 @@
#+x86 ;; These are needed for use by byte-compiled files.
(progn
#+nil
(defun %sin (x)
(declare (double-float x)
(values double-float))
......@@ -92,6 +93,7 @@
(declare (double-float x)
(values double-float))
(%sin-quick x))
#+nil
(defun %cos (x)
(declare (double-float x)
(values double-float))
......@@ -100,6 +102,7 @@
(declare (double-float x)
(values double-float))
(%cos-quick x))
#+nil
(defun %tan (x)
(declare (double-float x)
(values double-float))
......@@ -168,6 +171,49 @@
(%sqrt x))
)
#+x86
(progn
(alien:def-alien-routine ("__ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int
(x double-float)
(y (* double-float)))
(let ((y (make-array 2 :element-type 'double-float)))
(defun %sin (x)
(declare (double-float x))
(if (< (abs x) (/ pi 4))
(%sin-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 (%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))))))))
)
;;;; Power functions.
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.43 2006/07/01 13:52:48 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.44 2006/07/19 02:54:31 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -2511,6 +2511,7 @@
;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
;;; the argument is out of range 2^63 and would thus be hopelessly
;;; inaccurate.
#+nil
(macrolet ((frob (func trans op)
`(define-vop (,func)
(:translate ,trans)
......@@ -2546,6 +2547,7 @@
(frob fsin %sin fsin)
(frob fcos %cos fcos))
#+nil
(define-vop (ftan)
(:translate %tan)
(:args (x :scs (double-reg) :target fr0))
......@@ -3656,6 +3658,7 @@
;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
;;; the argument is out of range 2^63 and would thus be hopelessly
;;; inaccurate.
#+nil
(macrolet ((frob (func trans op)
`(define-vop (,func)
(:translate ,trans)
......
......@@ -27,7 +27,7 @@ NM = $(PATH1)/linux-nm
UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
ASSEM_SRC = x86-assem.S linux-stubs.S
ARCH_SRC = x86-arch.c
OS_SRC = Linux-os.c os-common.c elf.c
OS_SRC = Linux-os.c os-common.c elf.c e_rem_pio2.c k_rem_pio2.c
OS_LINK_FLAGS = -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker foo
OS_LIBS = -ldl
#GC_SRC = gencgc.c
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