Commit 5b83139e by Raymond Toy

Use setexception to set inexact exception

Fix issue #12 by replacing the code with an explicit call to set the inexact exception when needed.
parents 0fc0061b fc1c9daa
#! /bin/bash
# Run the testsuite.
#
# By default, all the tests are run, but if additional args are given,
# then just those tests are run.
usage() {
echo "run-tests.sh [?] [-l lisp] [tests]"
echo " -l lisp Lisp to use for the tests; defaults to lisp"
echo " -? This help message"
echo ""
echo "Run the test suite"
echo ""
echo "Any remaining args are the names of the tests to run."
echo "These are basically the file names (without extension)"
echo "in the tests/ directory."
echo ""
echo "This script expects to be run from the top level of the"
echo "cmucl source tree. That is, is should be invoked as"
echo "bin/run-tests.sh"
exit 0;
}
LISP=lisp
while getopts "h?l:" arg
do
case $arg in
l) LISP=$OPTARG ;;
\?) usage ;;
esac
done
# Shift out the options
shift $[$OPTIND - 1]
if [ $# -eq 0 ]; then
# No args so run all the tests
$LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'
else
# Run selected files. Convert each file name to uppercase and append "-TESTS"
result=""
for f in $*
do
new=`echo $f | tr '[a-z]' '[A-Z]'`
result="$result "\"$new-TESTS\"
done
$LISP -noinit -load tests/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))"
fi
......@@ -1583,7 +1583,8 @@
"FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P"
"FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
"FLOAT-SIGNALING-NAN-P"
"WITH-FLOAT-TRAPS-MASKED")
"WITH-FLOAT-TRAPS-MASKED"
"WITH-FLOAT-TRAPS-ENABLED")
;; More float extensions
#+double-double
(:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"
......
......@@ -23,7 +23,8 @@
)
(in-package "EXTENSIONS")
(export '(set-floating-point-modes get-floating-point-modes
with-float-traps-masked))
with-float-traps-masked
with-float-traps-enabled))
(in-package "VM")
(eval-when (compile load eval)
......@@ -103,7 +104,7 @@
final-mode))
(defun (setf floating-point-modes) (new-mode)
(declare (type (unsigned-byte 24) new-mode))
(declare (type (unsigned-byte 32) new-mode))
;; Set the floating point modes for both X87 and SSE2. This
;; include the rounding control bits.
(let* ((rc (ldb float-rounding-mode new-mode))
......@@ -116,8 +117,8 @@
;; is ok and would be the correct setting if we
;; ever support long-floats.
(ash 3 8))))
(setf (vm::sse2-floating-point-modes) new-mode)
(setf (vm::x87-floating-point-modes) x87-modes))
(setf (vm::sse2-floating-point-modes) (ldb (byte 24 0) new-mode))
(setf (vm::x87-floating-point-modes) (ldb (byte 24 0) x87-modes)))
new-mode)
)
......@@ -364,45 +365,66 @@
(error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)"
code)))))))
;;; WITH-FLOAT-TRAPS-MASKED -- Public
;;;
(defmacro with-float-traps-masked (traps &body body)
"Execute BODY with the floating point exceptions listed in TRAPS
(macrolet
((with-float-traps (name logical-op docstring)
;; Define macros to enable or disable floating-point
;; exceptions. Masked exceptions and enabled exceptions only
;; differ whether we AND in the bits or OR them, respectively.
;; Logical-op is the operation to use.
(let ((macro-name (symbolicate "WITH-FLOAT-TRAPS-" name)))
`(progn
(defmacro ,macro-name (traps &body body)
,docstring
(let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
(trap-mask (dpb (lognot (float-trap-mask traps))
float-traps-byte #xffffffff))
(exception-mask (dpb (lognot (vm::float-trap-mask traps))
float-sticky-bits #xffffffff))
;; On ppc if we are masking the invalid trap, we need to make
;; sure we wipe out the various individual sticky bits
;; representing the invalid operation. Otherwise, if we
;; enable the invalid trap later, these sticky bits will cause
;; an exception.
#+ppc
(invalid-mask (if (member :invalid traps)
(dpb 0
(byte 1 31)
(dpb 0 vm::float-invalid-op-2-byte
(dpb 0 vm:float-invalid-op-1-byte #xffffffff)))
#xffffffff))
(orig-modes (gensym)))
`(let ((,orig-modes (floating-point-modes)))
(unwind-protect
(progn
(setf (floating-point-modes)
(ldb (byte 32 0)
(,',logical-op ,orig-modes ,(logand trap-mask exception-mask))))
,@body)
;; Restore the original traps and exceptions.
(setf (floating-point-modes)
(logior (logand ,orig-modes ,(logior traps exceptions))
(logand (floating-point-modes)
,(logand trap-mask exception-mask)
#+ppc
,invalid-mask
#+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))))))
;; WITH-FLOAT-TRAPS-MASKED -- Public
(with-float-traps masked logand
_N"Execute BODY with the floating point exceptions listed in TRAPS
masked (disabled). TRAPS should be a list of possible exceptions
which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
:DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
accrued exceptions are cleared at the start of the body to support
their testing within, and restored on exit."
(let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
(trap-mask (dpb (lognot (float-trap-mask traps))
float-traps-byte #xffffffff))
(exception-mask (dpb (lognot (vm::float-trap-mask traps))
float-sticky-bits #xffffffff))
;; On ppc if we are masking the invalid trap, we need to make
;; sure we wipe out the various individual sticky bits
;; representing the invalid operation. Otherwise, if we
;; enable the invalid trap later, these sticky bits will cause
;; an exception.
#+ppc
(invalid-mask (if (member :invalid traps)
(dpb 0
(byte 1 31)
(dpb 0 vm::float-invalid-op-2-byte
(dpb 0 vm:float-invalid-op-1-byte #xffffffff)))
#xffffffff))
(orig-modes (gensym)))
`(let ((,orig-modes (floating-point-modes)))
(unwind-protect
(progn
(setf (floating-point-modes)
(logand ,orig-modes ,(logand trap-mask exception-mask)))
,@body)
;; Restore the original traps and exceptions.
(setf (floating-point-modes)
(logior (logand ,orig-modes ,(logior traps exceptions))
(logand (floating-point-modes)
,(logand trap-mask exception-mask)
#+ppc
,invalid-mask
#+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
their testing within, and restored on exit.")
;; WITH-FLOAT-TRAPS-ENABLED -- Public
(with-float-traps enabled logorc2
_N"Execute BODY with the floating point exceptions listed in TRAPS
enabled. TRAPS should be a list of possible exceptions which
includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
:DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
accrued exceptions are cleared at the start of the body to support
their testing within, and restored on exit."))
......@@ -4797,6 +4797,16 @@ msgid ""
" their testing within, and restored on exit."
msgstr ""
#: src/code/float-trap.lisp
msgid ""
"Execute BODY with the floating point exceptions listed in TRAPS\n"
" enabled. TRAPS should be a list of possible exceptions which\n"
" includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and\n"
" :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective\n"
" accrued exceptions are cleared at the start of the body to support\n"
" their testing within, and restored on exit."
msgstr ""
#: src/code/float.lisp
msgid "Return true if the float X is denormalized."
msgstr ""
......
......@@ -50,7 +50,6 @@ static const double
static double
#endif
one = 1.00000000000000000000e+00, /* 0x3FF00000, 0x00000000 */
huge = 1.000e+300,
pio2_hi = 1.57079632679489655800e+00, /* 0x3FF921FB, 0x54442D18 */
pio2_lo = 6.12323399573676603587e-17, /* 0x3C91A626, 0x33145C07 */
pio4_hi = 7.85398163397448278999e-01, /* 0x3FE921FB, 0x54442D18 */
......@@ -89,7 +88,12 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */
return fdlibm_setexception(x, FDLIBM_INVALID);
} else if (ix<0x3fe00000) { /* |x|<0.5 */
if(ix<0x3e400000) { /* if |x| < 2**-27 */
if(huge+x>one) return x;/* return x with inexact if x!=0*/
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return x;
} else
t = x*x;
p = t*(pS0+t*(pS1+t*(pS2+t*(pS3+t*(pS4+t*pS5)))));
......
......@@ -35,7 +35,7 @@
#include "fdlibm.h"
#ifdef __STDC__
static const double one = 1.0, half=0.5, huge = 1.0e307;
static const double one = 1.0, half=0.5;
#else
static double one = 1.0, half=0.5, huge = 1.0e307;
#endif
......
......@@ -82,7 +82,6 @@ static double
#endif
one = 1.0,
halF[2] = {0.5,-0.5,},
huge = 1.0e+300,
twom1000= 9.33263618503218878990e-302, /* 2**-1000=0x01700000,0*/
o_threshold= 7.09782712893383973096e+02, /* 0x40862E42, 0xFEFA39EF */
u_threshold= -7.45133219101941108420e+02, /* 0xc0874910, 0xD52D3051 */
......@@ -161,7 +160,12 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */
x = hi - lo;
}
else if(hx < 0x3e300000) { /* when |x|<2**-28 */
if(huge+x>one) return one+x;/* trigger inexact */
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return one + x;
}
else k = 0;
......
......@@ -32,7 +32,7 @@
#include "fdlibm.h"
#ifdef __STDC__
static const double one = 1.0, shuge = 1.0e307;
static const double one = 1.0;
#else
static double one = 1.0, shuge = 1.0e307;
#endif
......@@ -67,8 +67,14 @@ static double one = 1.0, shuge = 1.0e307;
if (jx<0) h = -h;
/* |x| in [0,22], return sign(x)*0.5*(E+E/(E+1))) */
if (ix < 0x40360000) { /* |x|<22 */
if (ix<0x3e300000) /* |x|<2**-28 */
if(shuge+x>one) return x;/* sinh(tiny) = tiny with inexact */
if (ix<0x3e300000) { /* |x|<2**-28 */
/* sinh(tiny) = tiny with inexact */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return x;
}
t = fdlibm_expm1(fabs(x));
if(ix<0x3ff00000) return h*(2.0*t-t*t/(t+one));
return h*(t+t/(t+one));
......
......@@ -61,7 +61,8 @@ enum FDLIBM_EXCEPTION {
FDLIBM_DIVIDE_BY_ZERO,
FDLIBM_UNDERFLOW,
FDLIBM_OVERFLOW,
FDLIBM_INVALID
FDLIBM_INVALID,
FDLIBM_INEXACT
};
extern double fdlibm_setexception(double x, enum FDLIBM_EXCEPTION);
......
......@@ -75,7 +75,12 @@ C6 = -1.13596475577881948265e-11; /* 0xBDA8FAE9, 0xBE8838D4 */
ux.d = x;
ix = ux.i[HIWORD]&0x7fffffff; /* ix = |x|'s high word*/
if(ix<0x3e400000) { /* if x < 2**27 */
if(((int)x)==0) return one; /* generate inexact */
/* return 1 with inexact unless x == 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return one;
}
z = x*x;
r = z*(C1+z*(C2+z*(C3+z*(C4+z*(C5+z*C6)))));
......
......@@ -67,8 +67,14 @@ S6 = 1.58969099521155010221e-10; /* 0x3DE5D93A, 0x5ACFD57C */
ux.d = x;
ix = ux.i[HIWORD]&0x7fffffff; /* high word of x */
if(ix<0x3e400000) /* |x| < 2**-27 */
{if((int)x==0) return x;} /* generate inexact */
if(ix<0x3e400000) { /* |x| < 2**-27 */
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return x;
}
z = x*x;
v = z*x;
r = S2+z*(S3+z*(S4+z*(S5+z*S6)));
......
......@@ -78,31 +78,34 @@ __kernel_tan(double x, double y, int iy) {
hx = ux.i[HIWORD]; /* high word of x */
ix = hx & 0x7fffffff; /* high word of |x| */
if (ix < 0x3e300000) { /* x < 2**-28 */
if ((int) x == 0) { /* generate inexact */
if (((ix | ux.i[LOWORD]) | (iy + 1)) == 0)
return one / fabs(x);
else {
if (iy == 1)
return x;
else { /* compute -1 / (x+y) carefully */
double a, t;
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
z = w = x + y;
uz.d = z;
uz.i[LOWORD] = 0;
z = ux.d;
if (((ix | ux.i[LOWORD]) | (iy + 1)) == 0)
return one / fabs(x);
else {
if (iy == 1)
return x;
else { /* compute -1 / (x+y) carefully */
double a, t;
z = w = x + y;
uz.d = z;
uz.i[LOWORD] = 0;
z = ux.d;
v = y - (z - x);
t = a = -one / w;
uz.d = t;
uz.i[LOWORD] = 0;
t = uz.d;
v = y - (z - x);
t = a = -one / w;
uz.d = t;
uz.i[LOWORD] = 0;
t = uz.d;
s = one + t * z;
return t + a * (s + t * v);
}
}
s = one + t * z;
return t + a * (s + t * v);
}
}
}
if (ix >= 0x3FE59428) { /* |x| >= 0.6744 */
if (hx < 0) {
......
......@@ -32,8 +32,7 @@ static const double
static double
#endif
one = 1.00000000000000000000e+00, /* 0x3FF00000, 0x00000000 */
ln2 = 6.93147180559945286227e-01, /* 0x3FE62E42, 0xFEFA39EF */
huge= 1.00000000000000000000e+300;
ln2 = 6.93147180559945286227e-01; /* 0x3FE62E42, 0xFEFA39EF */
#ifdef __STDC__
double fdlibm_asinh(double x)
......@@ -59,7 +58,12 @@ huge= 1.00000000000000000000e+300;
}
if(ix< 0x3e300000) { /* |x|<2**-28 */
if(huge+x>one) return x; /* return x inexact except 0 */
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return x;
}
if(ix>0x41b00000) { /* |x| > 2**28 */
w = __ieee754_log(fabs(x))+ln2;
......
......@@ -79,8 +79,7 @@ static double aT[] = {
#else
static double
#endif
one = 1.0,
huge = 1.0e300;
one = 1.0;
#ifdef __STDC__
double fdlibm_atan(double x)
......@@ -104,7 +103,12 @@ huge = 1.0e300;
else return -atanhi[3]-atanlo[3];
} if (ix < 0x3fdc0000) { /* |x| < 0.4375 */
if (ix < 0x3e200000) { /* |x| < 2^-29 */
if(huge+x>one) return x; /* raise inexact */
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return x;
}
id = -1;
} else {
......
......@@ -160,8 +160,8 @@ Q5 = -2.01099218183624371326e-07; /* BE8AFDB7 6E09C32D */
}
if(xsb!=0) { /* x < -56*ln2, return -1.0 with inexact */
if(x+tiny<0.0) /* raise inexact */
return tiny-one; /* return -1 */
fdlibm_setexception(x, FDLIBM_INEXACT);
return tiny - one;
}
}
......
......@@ -85,7 +85,6 @@ static double
#endif
ln2_hi = 6.93147180369123816490e-01, /* 3fe62e42 fee00000 */
ln2_lo = 1.90821492927058770002e-10, /* 3dea39ef 35793c76 */
two54 = 1.80143985094819840000e+16, /* 43500000 00000000 */
Lp1 = 6.666666666666735130e-01, /* 3FE55555 55555593 */
Lp2 = 3.999999999940941908e-01, /* 3FD99999 9997FA04 */
Lp3 = 2.857142874366239149e-01, /* 3FD24924 94229359 */
......@@ -123,9 +122,14 @@ static double zero = 0.0;
}
}
if(ax<0x3e200000) { /* |x| < 2**-29 */
if(two54+x>zero /* raise inexact */
&&ax<0x3c900000) /* |x| < 2**-54 */
if (ax < 0x3c900000) { /* |x| < 2**-54 */
/* return x inexact except 0 */
if (x != 0) {
fdlibm_setexception(x, FDLIBM_INEXACT);
}
return x;
}
else
return x - x*x*0.5;
}
......
......@@ -26,9 +26,7 @@ static const double
static double
#endif
two54 = 1.80143985094819840000e+16, /* 0x43500000, 0x00000000 */
twom54 = 5.55111512312578270212e-17, /* 0x3C900000, 0x00000000 */
huge = 1.0e+300,
tiny = 1.0e-300;
twom54 = 5.55111512312578270212e-17; /* 0x3C900000, 0x00000000 */
#ifdef __STDC__
double fdlibm_scalbn (double x, int n)
......
......@@ -78,7 +78,9 @@ static double one=1.0, two=2.0, tiny = 1.0e-300;
}
/* |x| > 22, return +-1 */
} else {
z = one - tiny; /* raised inexact flag */
/* Always raise inexact flag */
fdlibm_setexception(x, FDLIBM_INEXACT);
z = one - tiny;
}
return (jx>=0)? z: -z;
}
......@@ -88,6 +88,10 @@ fdlibm_setexception(double x, enum FDLIBM_EXCEPTION type)
break;
}
case FDLIBM_INEXACT:
feraiseexcept(FE_INEXACT);
ret = x;
break;
default:
/* Shouldn't happen! */
ret = 0.0;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment