December 2015 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][rtoy-setexception-inexact] Fix compiler warnings by removing unused vars.
by Raymond Toy 28 Dec '15

28 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 80d7ca4e by Raymond Toy at 2015-12-28T10:26:27Z Fix compiler warnings by removing unused vars. - - - - - 8 changed files: - src/lisp/e_asin.c - src/lisp/e_cosh.c - src/lisp/e_exp.c - src/lisp/e_sinh.c - src/lisp/s_asinh.c - src/lisp/s_atan.c - src/lisp/s_log1p.c - src/lisp/s_scalbn.c Changes: ===================================== src/lisp/e_asin.c ===================================== --- a/src/lisp/e_asin.c +++ b/src/lisp/e_asin.c @@ -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 */ ===================================== src/lisp/e_cosh.c ===================================== --- a/src/lisp/e_cosh.c +++ b/src/lisp/e_cosh.c @@ -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 ===================================== src/lisp/e_exp.c ===================================== --- a/src/lisp/e_exp.c +++ b/src/lisp/e_exp.c @@ -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 */ ===================================== src/lisp/e_sinh.c ===================================== --- a/src/lisp/e_sinh.c +++ b/src/lisp/e_sinh.c @@ -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 ===================================== src/lisp/s_asinh.c ===================================== --- a/src/lisp/s_asinh.c +++ b/src/lisp/s_asinh.c @@ -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) ===================================== src/lisp/s_atan.c ===================================== --- a/src/lisp/s_atan.c +++ b/src/lisp/s_atan.c @@ -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) ===================================== src/lisp/s_log1p.c ===================================== --- a/src/lisp/s_log1p.c +++ b/src/lisp/s_log1p.c @@ -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 */ ===================================== src/lisp/s_scalbn.c ===================================== --- a/src/lisp/s_scalbn.c +++ b/src/lisp/s_scalbn.c @@ -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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/80d7ca4e8c9aae3154c38fe17…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] Clean up with-float-traps macro.
by Raymond Toy 28 Dec '15

28 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 90b9651b by Raymond Toy at 2015-12-27T21:02:14Z Clean up with-float-traps macro. * Add some comments. * Change x86 (setf floating-point-modes) to accept (unsigned-byte 32). * Remove unneeded x86 conditionalization on the byte size. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -104,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)) @@ -117,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) ) @@ -365,12 +365,12 @@ (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" code))))))) -;;; WITH-FLOAT-TRAPS-MASKED -- Public -;;; WITH-FLOAT-TRAPS-ENABLED -- Public - - (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) @@ -398,9 +398,7 @@ (unwind-protect (progn (setf (floating-point-modes) - (ldb (byte #+x86 24 - #-x86 32 - 0) + (ldb (byte 32 0) (,',logical-op ,orig-modes ,(logand trap-mask exception-mask)))) ,@body) ;; Restore the original traps and exceptions. @@ -411,8 +409,8 @@ #+ppc ,invalid-mask #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))))))) - ;; Masked and Enabled only differ whether we AND in the bits or OR - ;; them. + + ;; 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 @@ -421,6 +419,7 @@ accrued exceptions are cleared at the start of the body to support 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 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/90b9651bf60a59800f76a6e7f…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] 2 commits: Disable FP traps when printing arithmetic-error messages
by Raymond Toy 27 Dec '15

27 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 0fc0061b by Raymond Toy at 2015-12-27T10:16:45Z Disable FP traps when printing arithmetic-error messages Printing of FP numbers can signal some traps like overflow, underflow, inexact, or denormalized-operand, so we need to disable these traps when printing out the error message for arithmetic errors. - - - - - 62acaf64 by Raymond Toy at 2015-12-27T10:36:59Z Merge branch 'master' into rtoy-setexception-inexact - - - - - 1 changed file: - src/code/error.lisp Changes: ===================================== src/code/error.lisp ===================================== --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -1138,9 +1138,14 @@ (format stream (intl:gettext "Arithmetic error ~S signalled.") (type-of condition)) (when (arithmetic-error-operation condition) - (format stream (intl:gettext "~%Operation was ~S, operands ~S.") - (arithmetic-error-operation condition) - (arithmetic-error-operands condition)))))) + ;; Printing the operands can signal these FP traps, so + ;; disable them while we're printing out the error + ;; message. + (with-float-traps-masked (:overflow :underflow :inexact + #+x86 :denormalized-operand) + (format stream (intl:gettext "~%Operation was ~S, operands ~S.") + (arithmetic-error-operation condition) + (arithmetic-error-operands condition))))))) (define-condition division-by-zero (arithmetic-error) ()) (define-condition floating-point-overflow (arithmetic-error) ()) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/55b541e5fdac9794eae14859…

1 0

[Git][cmucl/cmucl][master] Disable FP traps when printing arithmetic-error messages
by Raymond Toy 27 Dec '15

27 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 0fc0061b by Raymond Toy at 2015-12-27T10:16:45Z Disable FP traps when printing arithmetic-error messages Printing of FP numbers can signal some traps like overflow, underflow, inexact, or denormalized-operand, so we need to disable these traps when printing out the error message for arithmetic errors. - - - - - 1 changed file: - src/code/error.lisp Changes: ===================================== src/code/error.lisp ===================================== --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -1138,9 +1138,14 @@ (format stream (intl:gettext "Arithmetic error ~S signalled.") (type-of condition)) (when (arithmetic-error-operation condition) - (format stream (intl:gettext "~%Operation was ~S, operands ~S.") - (arithmetic-error-operation condition) - (arithmetic-error-operands condition)))))) + ;; Printing the operands can signal these FP traps, so + ;; disable them while we're printing out the error + ;; message. + (with-float-traps-masked (:overflow :underflow :inexact + #+x86 :denormalized-operand) + (format stream (intl:gettext "~%Operation was ~S, operands ~S.") + (arithmetic-error-operation condition) + (arithmetic-error-operands condition))))))) (define-condition division-by-zero (arithmetic-error) ()) (define-condition floating-point-overflow (arithmetic-error) ()) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/0fc0061b5302f516f051a5996…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] Add shell script to run the test suite.
by Raymond Toy 26 Dec '15

26 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 55b541e5 by Raymond Toy at 2015-12-26T09:49:25Z Add shell script to run the test suite. This makes it quite a bit easier to run the test suite instead of trying to remember exactly how to invoke it from the command line. - - - - - 1 changed file: - + bin/run-tests.sh Changes: ===================================== bin/run-tests.sh ===================================== --- /dev/null +++ b/bin/run-tests.sh @@ -0,0 +1,50 @@ +#! /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 + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/55b541e5fdac9794eae148597…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] Regenerated du to float-traps.lisp changes.
by Raymond Toy 26 Dec '15

26 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 6cc16b9b by Raymond Toy at 2015-12-26T09:11:40Z Regenerated du to float-traps.lisp changes. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -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 "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/6cc16b9bcc660a2899a6205b6…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] Fix bug on sparc and clean up.
by Raymond Toy 26 Dec '15

26 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 38e8ce5c by Raymond Toy at 2015-12-26T09:09:56Z Fix bug on sparc and clean up. On sparc and ppc (setf vm:floating-point-modes) takes an (unsigned-byte 32) arg, so adjust the ldb byte appopriately. Clean up code by putting the docstring into the macro. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -374,6 +374,7 @@ (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)) @@ -397,7 +398,9 @@ (unwind-protect (progn (setf (floating-point-modes) - (ldb (byte 24 0) + (ldb (byte #+x86 24 + #-x86 32 + 0) (,',logical-op ,orig-modes ,(logand trap-mask exception-mask)))) ,@body) ;; Restore the original traps and exceptions. @@ -407,25 +410,22 @@ ,(logand trap-mask exception-mask) #+ppc ,invalid-mask - #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))) - ;; Set the docstring appropriately - (setf (c::info function documentation ',macro-name) - ,docstring))))) + #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))))))) ;; Masked and Enabled only differ whether we AND in the bits or OR ;; them. (with-float-traps masked logand - "Execute BODY with the floating point exceptions listed in TRAPS - disabled. TRAPS should be a list of possible exceptions which - includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and + _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.") + (with-float-traps enabled logorc2 - "Execute BODY with the floating point exceptions listed in TRAPS + _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.")) -;; Set up the appropriate documentation for these macros View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/38e8ce5c1084e1c55f9002882…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] 3 commits: ADD docstrings for WITH-FLOAT-TRAPS-MASKED and
by Raymond Toy 25 Dec '15

25 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: d2a8d5c7 by Raymond Toy at 2015-12-24T22:25:13Z ADD docstrings for WITH-FLOAT-TRAPS-MASKED and WITH-FLOAT-TRAPS-ENABLED. - - - - - 519d5133 by Raymond Toy at 2015-12-24T22:47:24Z (setf floating-point-modes) wants (unsigned-byte 24) When enabling traps, need to take just the low 24 bits of the arg because (setf floating-point-modes) wants an (unsigned-byte 24) argument. The logorc2 makes the result negative when enabling traps. - - - - - 46e43aed by Raymond Toy at 2015-12-24T22:48:49Z Use correct package (EXT) for WITH-FLOAT-TRAPS-MASKED. Also replae WITH-INXACT-EXCEPTION-ENABLED with WITH-FLOAT-TRAPS-ENABLED. All tests still pass, as expected. - - - - - 2 changed files: - src/code/float-trap.lisp - tests/fdlibm.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -370,48 +370,62 @@ (macrolet - ((with-float-traps (name logical-op) - `(defmacro ,(symbolicate "WITH-FLOAT-TRAPS-" name) (traps &body body) - "Execute BODY with the floating point exceptions listed in TRAPS + ((with-float-traps (name logical-op docstring) + (let ((macro-name (symbolicate "WITH-FLOAT-TRAPS-" name))) + `(progn + (defmacro ,macro-name (traps &body body) + (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 24 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)))))))) + ;; Set the docstring appropriately + (setf (c::info function documentation ',macro-name) + ,docstring))))) + ;; Masked and Enabled only differ whether we AND in the bits or OR + ;; them. + (with-float-traps masked logand + "Execute BODY with the floating point exceptions listed in TRAPS + 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.") + (with-float-traps enabled logorc2 + "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." - (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) - (,',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)))))))))) - ;; Masked and Enabled only differ whether we AND in the bits or OR - ;; them. - (with-float-traps masked logand) - (with-float-traps enabled logorc2)) + their testing within, and restored on exit.")) +;; Set up the appropriate documentation for these macros + ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -6,7 +6,7 @@ (in-package "FDLIBM-TESTS") (defparameter *qnan* - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (* 0 ext:double-float-positive-infinity)) "Some randon quiet MaN value") @@ -15,13 +15,9 @@ "A randon signaling MaN value") (defmacro with-inexact-exception-enabled (&body body) - (let ((old-modes (gensym "OLD-MODES-"))) - `(let ((,old-modes (ext:get-floating-point-modes))) - (unwind-protect - (progn - (ext:set-floating-point-modes :traps '(:inexact)) - ,@body) - (apply 'ext:set-floating-point-modes ,old-modes))))) + `(ext:with-float-traps-enabled (:inexact) + ,@body)) + (define-test %cosh.exceptions (:tag :fdlibm) @@ -34,7 +30,7 @@ (assert-true (ext:float-nan-p (kernel:%cosh *qnan*))) ;; Same, but with overflow's masked - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%cosh 1000d0)) (assert-equal ext:double-float-positive-infinity @@ -44,7 +40,7 @@ (assert-equal ext:double-float-positive-infinity (kernel:%cosh ext:double-float-negative-infinity))) ;; Test NaN - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%cosh *snan*))))) (define-test %sinh.exceptions @@ -57,7 +53,7 @@ (kernel:%sinh *snan*)) (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))) ;; Same, but with overflow's masked - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%sinh 1000d0)) (assert-equal ext:double-float-negative-infinity @@ -67,7 +63,7 @@ (assert-equal ext:double-float-negative-infinity (kernel:%sinh ext:double-float-negative-infinity))) ;; Test NaN - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%sinh *qnan*)))) ;; sinh(x) = x for |x| < 2^-28. Should signal inexact unless x = 0. (let ((x (scale-float 1d0 -29)) @@ -87,7 +83,7 @@ (assert-true (ext:float-nan-p (kernel:%tanh *qnan*))) (assert-error 'floating-point-invalid-operation (kernel:%tanh *snan*)) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%tanh *snan*)))) ;; tanh(x) = +/- 1 for |x| > 22, raising inexact, always. (let ((x 22.1d0)) @@ -103,10 +99,10 @@ (kernel:%acosh ext:double-float-positive-infinity)) (assert-error 'floating-point-invalid-operation (kernel:%acosh 0d0)) - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%acosh ext:double-float-positive-infinity))) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%acosh 0d0))))) (define-test %asinh.exceptions @@ -118,12 +114,12 @@ (assert-error 'floating-point-overflow (kernel:%asinh ext:double-float-negative-infinity)) (assert-true (ext:float-nan-p (kernel:%asinh *qnan*))) - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%asinh ext:double-float-positive-infinity)) (assert-error ext:double-float-negative-infinity (kernel:%asinh ext:double-float-negative-infinity))) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%asinh *snan*)))) (let ((x (scale-float 1d0 -29)) (x0 0d0)) @@ -147,10 +143,10 @@ (kernel:%atanh 1d0)) (assert-error 'division-by-zero (kernel:%atanh -1d0)) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%atanh 2d0))) (assert-true (ext:float-nan-p (kernel:%atanh -2d0)))) - (kernel::with-float-traps-masked (:divide-by-zero) + (ext:with-float-traps-masked (:divide-by-zero) (assert-equal ext:double-float-positive-infinity (kernel:%atanh 1d0)) (assert-equal ext:double-float-negative-infinity @@ -165,11 +161,11 @@ (assert-error 'floating-point-invalid-operation (kernel:%expm1 *snan*)) (assert-true (ext:float-nan-p (kernel:%expm1 *qnan*))) - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%expm1 709.8d0)) ) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext::float-nan-p (kernel:%expm1 *snan*)))) ;; expm1(x) = -1 for x < -56*log(2), signaling inexact (let ((x (* -57 (log 2d0)))) @@ -184,10 +180,10 @@ (assert-error 'floating-point-overflow (kernel:%log1p -1d0)) (assert-true (ext:float-nan-p (kernel:%log1p *qnan*))) - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-negative-infinity (kernel:%log1p -1d0))) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%log1p *snan*)))) ;; log1p(x) = x for |x| < 2^-54, signaling inexact except for x = 0. (let ((x (scale-float 1d0 -55)) @@ -213,7 +209,7 @@ (kernel:%exp ext:double-float-positive-infinity)) (assert-equal 0d0 (kernel:%exp -1000d0)) - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%exp 710d0))) (let ((modes (ext:get-floating-point-modes))) @@ -247,12 +243,12 @@ (assert-error 'floating-point-invalid-operation (kernel:%log *snan*)) (assert-true (ext:float-nan-p (kernel:%log *qnan*))) - (kernel::with-float-traps-masked (:divide-by-zero) + (ext:with-float-traps-masked (:divide-by-zero) (assert-equal ext:double-float-negative-infinity (kernel:%log 0d0)) (assert-equal ext:double-float-negative-infinity (kernel:%log -0d0))) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%log -1d0))) (assert-true (ext:float-nan-p (kernel:%log *snan*))))) @@ -262,7 +258,7 @@ (kernel:%acos 2d0)) (assert-error 'floating-point-invalid-operation (kernel:%acos -2d0)) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%acos 2d0))) (assert-true (ext:float-nan-p (kernel:%acos -2d0))))) @@ -272,7 +268,7 @@ (kernel:%asin 2d0)) (assert-error 'floating-point-invalid-operation (kernel:%asin -2d0)) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%asin 2d0))) (assert-true (ext:float-nan-p (kernel:%asin -2d0))))) @@ -281,7 +277,7 @@ (assert-error 'floating-point-invalid-operation (kernel:%atan *snan*)) (assert-true (ext:float-nan-p (kernel:%atan *qnan*))) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%atan *snan*)))) ;; atan(x) = x for |x| < 2^-29, signaling inexact. (let ((x (scale-float 1d0 -30)) @@ -309,12 +305,12 @@ (assert-true (ext:float-nan-p (kernel:%log10 *qnan*))) (assert-equal ext:double-float-positive-infinity (kernel:%log10 ext:double-float-positive-infinity)) - (kernel::with-float-traps-masked (:divide-by-zero) + (ext:with-float-traps-masked (:divide-by-zero) (assert-equal ext:double-float-negative-infinity (kernel:%log10 0d0)) (assert-equal ext:double-float-negative-infinity (kernel:%log10 -0d0))) - (kernel::with-float-traps-masked (:invalid) + (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%log10 -1d0))))) (define-test %scalbn.exceptions @@ -338,7 +334,7 @@ (kernel:%scalbn most-positive-double-float 2)) (assert-error 'floating-point-overflow (kernel:%scalbn most-negative-double-float 2)) - (kernel::with-float-traps-masked (:overflow) + (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%scalbn ext:double-float-positive-infinity 1)) (assert-equal ext:double-float-positive-infinity View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5721ddd2c71849c61c25bad6…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] Simplify WITH-FLOAT-TRAPS-MASKED and WITH-FLOAT-TRAPS-ENABLED.
by Raymond Toy 24 Dec '15

24 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 5721ddd2 by Raymond Toy at 2015-12-24T11:46:36Z Simplify WITH-FLOAT-TRAPS-MASKED and WITH-FLOAT-TRAPS-ENABLED. Merge the body of both macros into one since they only differ in how the bits are merged with the actual mode bits. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -366,85 +366,52 @@ code))))))) ;;; WITH-FLOAT-TRAPS-MASKED -- Public -;;; -(defmacro with-float-traps-masked (traps &body body) - "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)))))))) - -(defmacro with-float-traps-enabled (traps &body body) - "Execute BODY with the floating point exceptions listed in TRAPS +;;; WITH-FLOAT-TRAPS-ENABLED -- Public + + +(macrolet + ((with-float-traps (name logical-op) + `(defmacro ,(symbolicate "WITH-FLOAT-TRAPS-" name) (traps &body body) + "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." - (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) - (logorc2 ,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)))))))) + (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) + (,',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)))))))))) + ;; Masked and Enabled only differ whether we AND in the bits or OR + ;; them. + (with-float-traps masked logand) + (with-float-traps enabled logorc2)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5721ddd2c71849c61c25bad61…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] Add WITH-FLOAT-TRAPS-ENABLED to enable specific traps.
by Raymond Toy 24 Dec '15

24 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 97bd0eaa by Raymond Toy at 2015-12-24T10:37:57Z Add WITH-FLOAT-TRAPS-ENABLED to enable specific traps. This works like WITH-FLOAT-TRAPS-MASKED, except that the specified traps are enabled. Use this in fdlibm to enable the inexact trap. - - - - - 2 changed files: - src/code/exports.lisp - src/code/float-trap.lisp Changes: ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -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" ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -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) @@ -406,3 +407,44 @@ #+ppc ,invalid-mask #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))) + +(defmacro with-float-traps-enabled (traps &body body) + "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." + (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) + (logorc2 ,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)))))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/97bd0eaa99f355568b4d58886…

1 0