From dc223395fd0eba296e1d014f0817bc0a9e10238e Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Sat, 1 Dec 2018 22:41:56 +0000 Subject: [PATCH] Teach Scheme about the floating-point subnormal-operand exception. --- src/microcode/floenv.c | 9 +++++++++ src/runtime/floenv.scm | 5 ++++- src/runtime/runtime.pkg | 1 + tests/runtime/test-floenv.scm | 15 +++++++++++++++ 4 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/microcode/floenv.c b/src/microcode/floenv.c index 4a8543314..8d29ad106 100644 --- a/src/microcode/floenv.c +++ b/src/microcode/floenv.c @@ -392,6 +392,15 @@ DEFINE_PRIMITIVE ("FLOAT-INEXACT-RESULT-EXCEPTION", Prim_float_inexact_result_ex #else UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () #endif + +/* The subnormal operand exception is nonstandard but appears on x86. */ + +DEFINE_PRIMITIVE ("FLOAT-SUBNORMAL-OPERAND-EXCEPTION", Prim_float_subnormal_operand_exception, 0, 0, 0) +#ifdef FE_DENORMAL + FLOAT_EXCEPTIONS_PRIMITIVE (FE_DENORMAL) +#else + UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () +#endif DEFINE_PRIMITIVE ("FLOAT-EXCEPTIONS", Prim_float_exceptions, 0, 0, 0) FLOAT_EXCEPTIONS_PRIMITIVE (FE_ALL_EXCEPT) diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm index 6c7bb0feb..f3985562d 100644 --- a/src/runtime/floenv.scm +++ b/src/runtime/floenv.scm @@ -239,6 +239,7 @@ USA. (flo:exception:underflow float-underflow-exception 0) (flo:exception:overflow float-overflow-exception 0) (flo:exception:inexact-result float-inexact-result-exception 0) + (flo:exception:subnormal-operand float-subnormal-operand-exception 0) (flo:test-exceptions test-float-exceptions 1) (flo:save-exception-flags save-float-exception-flags 1) (flo:test-exception-flags test-float-exception-flags 2) @@ -301,7 +302,8 @@ USA. (n 'invalid-operation (flo:exception:invalid-operation) (n 'overflow (flo:exception:overflow) (n 'underflow (flo:exception:underflow) - '())))))) + (n 'subnormal-operand (flo:exception:subnormal-operand) + '()))))))) (define (flo:names->exceptions names) (define (name->exceptions name) @@ -311,6 +313,7 @@ USA. ((invalid-operation) (flo:exception:invalid-operation)) ((overflow) (flo:exception:overflow)) ((underflow) (flo:exception:underflow)) + ((subnormal-operand) (flo:exception:subnormal-operand)) (else (error:bad-range-argument names 'flo:names->exceptions)))) (guarantee list-of-unique-symbols? names 'flo:names->exceptions) (reduce fix:or 0 (map name->exceptions names))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e0cdfa61b..934c6fe6d 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -425,6 +425,7 @@ USA. flo:exception:inexact-result flo:exception:invalid-operation flo:exception:overflow + flo:exception:subnormal-operand flo:exception:underflow flo:exceptions->names flo:have-environment? diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm index 9fc9cc0f8..68e179dc9 100644 --- a/tests/runtime/test-floenv.scm +++ b/tests/runtime/test-floenv.scm @@ -292,6 +292,21 @@ USA. ;; (Note that if underflow is trapped, then the machine traps ;; whether or not the result is exact. Go figure.) (flo:* (no-op .5000001) (flo:shift (no-op 1.) -1022))))) + +(if (not (zero? (flo:exception:subnormal-operand))) + (begin + (define-fpe-descriptor 'SUBNORMAL-OPERAND #t + flo:exception:subnormal-operand + ;; XXX Should have its own condition type, but this requires OS + ;; support for the siginfo code. + condition-type:inexact-floating-point-result) + (define-fpe-elicitor 'SUBNORMAL-OPERAND 'RAISE + (lambda () + (flo:raise-exceptions! (flo:exception:subnormal-operand)))) + (define-fpe-elicitor 'SUBNORMAL-OPERAND 'USE-A-SUBNORMAL-OPERAND + (let ((x (no-op flo:smallest-positive-subnormal))) + (lambda () + (flo:+ x flo:smallest-positive-subnormal)))))) (define (for-each-trappable-exception receiver) (for-each-exception -- 2.25.1