From 982f8d09a7b2500f55369af12491056e8fb1d77d Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Mon, 1 Nov 2010 04:37:31 +0000 Subject: [PATCH] Implement support for a floating-point environment. --- src/microcode/cmpauxmd/i386.m4 | 76 +++- src/microcode/cmpauxmd/x86-64.m4 | 46 ++- src/microcode/cmpintmd/i386.c | 8 + src/microcode/cmpintmd/i386.h | 34 +- src/microcode/cmpintmd/x86-64.c | 6 + src/microcode/cmpintmd/x86-64.h | 35 +- src/microcode/cmpintmd/x86-fenv.c | 264 ++++++++++++++ src/microcode/cmpintmd/x86-fenv.h | 124 +++++++ src/microcode/floenv.c | 518 +++++++++++++++++++++++++++ src/microcode/floenv.h | 125 +++++++ src/microcode/interp.c | 4 +- src/microcode/makegen/files-core.scm | 1 + src/microcode/sysprim.c | 156 -------- src/microcode/uxsig.c | 2 - src/runtime/error.scm | 32 +- src/runtime/fixart.scm | 55 +-- src/runtime/floenv.scm | 202 +++++++++++ src/runtime/make.scm | 5 + src/runtime/runtime.pkg | 52 ++- src/runtime/thread.scm | 59 ++- src/runtime/uerror.scm | 98 +++-- tests/runtime/test-floenv.scm | 457 +++++++++++++++++++++++ tests/unit-testing.scm | 4 + 23 files changed, 2010 insertions(+), 353 deletions(-) create mode 100644 src/microcode/cmpintmd/x86-fenv.c create mode 100644 src/microcode/cmpintmd/x86-fenv.h create mode 100644 src/microcode/floenv.c create mode 100644 src/microcode/floenv.h create mode 100644 src/runtime/floenv.scm create mode 100644 tests/runtime/test-floenv.scm diff --git a/src/microcode/cmpauxmd/i386.m4 b/src/microcode/cmpauxmd/i386.m4 index 8ce02c6d2..1cb34099e 100644 --- a/src/microcode/cmpauxmd/i386.m4 +++ b/src/microcode/cmpauxmd/i386.m4 @@ -113,8 +113,12 @@ ### what you're doing. ### DISABLE_387 ### If defined, do not generate 387 floating-point instructions. +### DISABLE_SSE +### If defined, do not generate SSE media instructions. ### VALGRIND_MODE ### If defined, modify code to make it work with valgrind. + +define(DISABLE_SSE,1) #### Utility macros and definitions @@ -130,6 +134,14 @@ ifdef(`DISABLE_387', `define(IFN387,`$1')', `define(IFN387,`')') +ifdef(`DISABLE_SSE', + `define(IFSSE,`')', + `define(IFSSE,`$1')') + +ifdef(`DISABLE_SSE', + `define(IFNSSE,`$1')', + `define(IFNSSE,`')') + IF_WIN32(`define(DASM,1)') ifdef(`WCC386R',`define(WCC386,1)') @@ -358,6 +370,9 @@ allocate_space(Registers,eval(REGBLOCK_SIZE_IN_OBJECTS*4)) define_data(i387_presence) allocate_longword(i387_presence) +define_data(sse_presence) +allocate_longword(sse_presence) + define_data(C_Stack_Pointer) allocate_longword(C_Stack_Pointer) @@ -401,6 +416,13 @@ i386_initialize_no_fp: ') OP(mov,l) TW(REG(eax),ABS(EVR(i387_presence))) +# FIXME: Some IA-32 systems have SSE support, and since the microcode +# might use SSE instructions, we need to determine, using CPUID, +# whether the CPU supports SSE instructions, so that we can save and +# restore the SSE MXCSR in the floating-point environment. + + OP(mov,l) TW(IMM(0),ABS(EVR(sse_presence))) + # Do a bunch of hair to determine if we need to do cache synchronization. # See if the CPUID instruction is supported. @@ -1207,28 +1229,54 @@ asm_fixnum_rsh_overflow_negative: OP(mov,l) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(eax)) ret -define_c_label(i387_read_fp_control_word) -IF387(` OP(cmp,l) TW(IMM(0),ABS(EVR(i387_presence))) - je i387_read_fp_control_word_lose - enter IMM(4),IMM(0) +define_c_label(sse_read_mxcsr) +IFSSE(` enter IMM(4),IMM(0) + stmxcsr IND(REG(esp)) + OP(mov,l) TW(IND(REG(esp)),REG(eax)) + leave') + ret + +define_c_label(sse_write_mxcsr) +IFSSE(` ldmxcsr LOF(4,REG(esp))') + ret + +define_c_label(x87_clear_exceptions) +IF387(` fnclex') + ret + +define_c_label(x87_trap_exceptions) +IF387(` fwait') + ret + +define_c_label(x87_read_control_word) +IF387(` enter IMM(4),IMM(0) fnstcw IND(REG(esp)) OP(mov,w) TW(IND(REG(esp)),REG(ax)) - leave + leave') ret -') -i387_read_fp_control_word_lose: - OP(xor,l) TW(REG(eax),REG(eax)) +define_c_label(x87_write_control_word) +IF387(` fldcw LOF(4,REG(esp))') ret -define_c_label(i387_write_fp_control_word) -IF387(` OP(cmp,l) TW(IMM(0),ABS(EVR(i387_presence))) - je i387_write_fp_control_word_lose - fldcw LOF(4,REG(esp)) +define_c_label(x87_read_status_word) +IF387(` enter IMM(4),IMM(0) + fnstsw IND(REG(esp)) + OP(mov,w) TW(IND(REG(esp)),REG(ax)) + leave') + ret + +define_c_label(x87_read_environment) +IF387(` OP(mov,l) TW(LOF(4,REG(esp)),REG(eax)) + fnstenv IND(REG(eax)) + # fnstenv masks all exceptions (go figure), so we must load + # the control word back in order to undo that. + fldcw IND(REG(eax))') ret -') -i387_write_fp_control_word_lose: +define_c_label(x87_write_environment) +IF387(` OP(mov,l) TW(LOF(4,REG(esp)),REG(eax)) + fldenv IND(REG(eax))') ret IFDASM(`end') diff --git a/src/microcode/cmpauxmd/x86-64.m4 b/src/microcode/cmpauxmd/x86-64.m4 index b70f0c6d5..2a1ffa884 100644 --- a/src/microcode/cmpauxmd/x86-64.m4 +++ b/src/microcode/cmpauxmd/x86-64.m4 @@ -966,19 +966,59 @@ asm_fixnum_rsh_overflow_negative: OP(mov,q) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(rax)) ret -define_c_label(x86_64_read_mxcsr) +define_c_label(sse_read_mxcsr) enter IMM(8),IMM(0) stmxcsr IND(REG(rsp)) OP(mov,l) TW(IND(REG(rsp)),REG(eax)) leave ret -define_c_label(x86_64_write_mxcsr) +define_c_label(sse_write_mxcsr) enter IMM(8),IMM(0) - OP(mov,l) TW(REG(eax),IND(REG(rsp))) + OP(mov,l) TW(REG(edi),IND(REG(rsp))) ldmxcsr IND(REG(rsp)) leave ret + +define_c_label(x87_clear_exceptions) + fnclex + ret + +define_c_label(x87_trap_exceptions) + fwait + ret + +define_c_label(x87_read_control_word) + enter IMM(4),IMM(0) + fnstcw IND(REG(esp)) + OP(mov,w) TW(IND(REG(esp)),REG(ax)) + leave + ret + +define_c_label(x87_write_control_word) + enter IMM(4),IMM(0) + OP(mov,w) TW(REG(di),IND(REG(rsp)) + fldcw IND(REG(esp)) + leave + ret + +define_c_label(x87_read_status_word) + enter IMM(4),IMM(0) + fnstsw IND(REG(esp)) + OP(mov,w) TW(IND(REG(esp)),REG(ax)) + leave + ret + +define_c_label(x87_read_environment) + fnstenv IND(REG(rdi)) + # fnstenv masks all exceptions (go figure), so we must load + # the control word back in order to undo that. + fldcw IND(REG(eax)) + ret + +define_c_label(x87_write_environment) + fldenv IND(REG(rdi)) + ret IFDASM(`end') diff --git a/src/microcode/cmpintmd/i386.c b/src/microcode/cmpintmd/i386.c index d9fc5680f..892d1d62e 100644 --- a/src/microcode/cmpintmd/i386.c +++ b/src/microcode/cmpintmd/i386.c @@ -389,3 +389,11 @@ i386_reset_hook (void) } #endif /* _MACH_UNIX */ } + +#ifndef HAVE_FENV_H +extern int i387_presence; +extern int sse_presence; +# define x87_p i387_presence +# define sse_p sse_presence +# include "cmpintmd/x86-fenv.c" +#endif diff --git a/src/microcode/cmpintmd/i386.h b/src/microcode/cmpintmd/i386.h index e39dbc8a7..f7ab66826 100644 --- a/src/microcode/cmpintmd/i386.h +++ b/src/microcode/cmpintmd/i386.h @@ -332,40 +332,12 @@ extern insn_t * read_compiled_closure_target (insn_t *, reloc_ref_t *); extern void start_operator_relocation (SCHEME_OBJECT *, reloc_ref_t *); extern insn_t * read_uuo_target (SCHEME_OBJECT *, reloc_ref_t *); extern void i386_reset_hook (void); -extern int i387_read_fp_control_word (void); -extern void i387_write_fp_control_word (int); extern int ia32_cpuid_needed; #ifndef HAVE_FENV_H - -# define FE_TONEAREST 0 -# define FE_DOWNWARD 1 -# define FE_UPWARD 2 -# define FE_TOWARDZERO 3 - -# define HAVE_FEGETROUND -# define HAVE_FESETROUND - -static inline int -fegetround (void) -{ - return (3 & ((i387_read_fp_control_word ()) >> 10)); -} - -static inline int -fesetround (int mode) -{ - switch (mode) - { - case 0: case 1: case 2: case 3: break; - default: return (1); - } - i387_write_fp_control_word - ((mode << 10) | (0xf3ff & (i387_read_fp_control_word ()))); - return (0); -} - -#endif /* HAVE_FENV_H */ +# define CMPINTMD_EMULATES_FENV +# include "cmpintmd/x86-fenv.h" +#endif #endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/src/microcode/cmpintmd/x86-64.c b/src/microcode/cmpintmd/x86-64.c index 86144a79a..8d5c3967a 100644 --- a/src/microcode/cmpintmd/x86-64.c +++ b/src/microcode/cmpintmd/x86-64.c @@ -330,3 +330,9 @@ x86_64_reset_hook (void) } #endif /* _MACH_UNIX */ } + +#ifndef HAVE_FENV_H +# define x87_p 1 +# define sse_p 1 +# include "cmpintmd/x86-fenv.c" +#endif diff --git a/src/microcode/cmpintmd/x86-64.h b/src/microcode/cmpintmd/x86-64.h index d2e3bc55b..91c815f5a 100644 --- a/src/microcode/cmpintmd/x86-64.h +++ b/src/microcode/cmpintmd/x86-64.h @@ -239,37 +239,12 @@ extern void asm_trampoline_to_interface (void); extern insn_t * read_compiled_closure_target (insn_t *); extern insn_t * read_uuo_target (SCHEME_OBJECT *); extern void x86_64_reset_hook (void); -extern int x86_64_read_mxcsr (void); -extern void x86_64_write_mxcsr (int); #ifndef HAVE_FENV_H - -# define FE_TONEAREST 0 -# define FE_DOWNWARD 1 -# define FE_UPWARD 2 -# define FE_TOWARDZERO 3 - -# define HAVE_FEGETROUND -# define HAVE_FESETROUND - -static inline int -fegetround (void) -{ - return (3 & ((x86_64_read_mxcsr ()) >> 13)); -} - -static inline void -fesetround (int mode) -{ - switch (mode) - { - case 0: case 1: case 2: case 3: break; - default: return (1); - } - x86_64_write_mxcsr ((mode << 13) | (0xffff9fff & (x86_64_read_mxcsr ()))); - return (0); -} - -#endif /* HAVE_FENV_H */ +# define CMPINTMD_EMULATES_FENV +# define x87_p 1 +# define sse_p 1 +# include "cmpintmd/x86-fenv.h" +#endif #endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/src/microcode/cmpintmd/x86-fenv.c b/src/microcode/cmpintmd/x86-fenv.c new file mode 100644 index 000000000..7a4734a4c --- /dev/null +++ b/src/microcode/cmpintmd/x86-fenv.c @@ -0,0 +1,264 @@ +/* -*-C-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* C99 emulation for x86 (shared between i386 and amd64) */ + +extern unsigned int sse_read_mxcsr (void); +extern void sse_write_mxcsr (unsigned int); +extern void x87_clear_exceptions (void); +extern void x87_trap_exceptions (void); +extern unsigned short x87_read_control_word (void); +extern void x87_write_control_word (unsigned short); +extern unsigned short x87_read_status_word (void); +/* extern void x87_write_status_word (unsigned short); No f(n)stsw. */ +extern void x87_read_environment (unsigned char *); +extern void x87_write_environment (const unsigned char *); + +#ifndef x87_p +# ifdef HAVE_X87 +static const bool x87_p = true; +# else +static const bool x87_p = false; +# endif +#endif + +#ifndef sse_p +# ifdef HAVE_SSE +static const bool sse_p = true; +# else +static const bool sse_p = false; +# endif +#endif + +int +fegetround (void) +{ + int sse_mode = (sse_p ? (3 & ((sse_read_mxcsr ()) >> 13)) : 0); + int x87_mode = (x87_p ? (3 & ((x87_read_control_word ()) >> 10)) : 0); + if (x87_p && sse_p) + return ((sse_mode == x87_mode) ? sse_mode : (-1)); + else + return (x87_p? x87_mode : sse_p? sse_mode : (-1)); +} + +int +fesetround (int mode) +{ + switch (mode) + { + case 0: case 1: case 2: case 3: break; + default: return (1); + } + if (sse_p) + sse_write_mxcsr ((mode << 13) | (0xffff9fff & (sse_read_mxcsr ()))); + if (x87_p) + x87_write_control_word + ((mode << 10) | (0xf3ff & (x87_read_control_word ()))); + return (! (sse_p || x87_p)); +} + +int +fetestexcept (int excepts) +{ + excepts &= FE_ALL_EXCEPT; + return + ((sse_p ? ((sse_read_mxcsr ()) & excepts) : 0) + | (x87_p ? ((x87_read_status_word ()) & excepts) : 0)); +} + +int +feclearexcept (int excepts) +{ + if (excepts &~ FE_ALL_EXCEPT) + return (-1); + if (sse_p) + sse_write_mxcsr ((sse_read_mxcsr ()) &~ excepts); + if (x87_p) + { + if (excepts == FE_ALL_EXCEPT) + /* This is supposed to be much faster than fetching and storing + the environment. */ + x87_clear_exceptions (); + else + { + x87_fenv_t fenv; + x87_read_environment (fenv.environment_bytes); + (fenv.environment.x87_status_word) &=~ excepts; + x87_write_environment (fenv.environment_bytes); + } + } + return (! (sse_p || x87_p)); +} + +int +feraiseexcept (int excepts) +{ + if (excepts &~ FE_ALL_EXCEPT) + return (-1); + if (sse_p) + sse_write_mxcsr ((sse_read_mxcsr ()) | excepts); + if (x87_p) + { + x87_fenv_t fenv; + x87_read_environment (fenv.environment_bytes); + (fenv.environment.x87_status_word) |= excepts; + x87_write_environment (fenv.environment_bytes); + x87_trap_exceptions (); + } + /* There seems to be no good way to request a trap in SSE. + Fortunately, I don't think there are any systems with SSE but not + x87. + if (sse_p && (!x87_p) && (fetestexcept (excepts))) + raise (SIGFPE); */ + return (! (sse_p || x87_p)); +} + +int +fegetexceptflag (fexcept_t *flagp, int excepts) +{ + if (excepts &~ FE_ALL_EXCEPT) + return (-1); + (*flagp) = (fetestexcept (excepts)); + return (! (sse_p || x87_p)); +} + +int +fesetexceptflag (const fexcept_t *flagp, int excepts) +{ + if (((*flagp) | excepts) &~ FE_ALL_EXCEPT) + return (-1); + if (sse_p) + sse_write_mxcsr ((sse_read_mxcsr ()) | ((*flagp) & excepts)); + if (x87_p) + { + x87_fenv_t fenv; + x87_read_environment (fenv.environment_bytes); + (fenv.environment.x87_status_word) |= ((*flagp) & excepts); + x87_write_environment (fenv.environment_bytes); + } + return (! (sse_p || x87_p)); +} + +/* The following are glibc extensions. */ + +int +fegetexcept (void) +{ + int sse_mask = (sse_p ? ((sse_read_mxcsr ()) >> 7) : (~0)); + int x87_mask = (x87_p ? (x87_read_control_word ()) : (~0)); + return (FE_ALL_EXCEPT &~ (sse_mask & x87_mask)); +} + +int +feenableexcept (int excepts) +{ + int old_excepts = 0; + if (excepts &~ FE_ALL_EXCEPT) + return (-1); + if (sse_p) + { + unsigned int mxcsr = (sse_read_mxcsr ()); + old_excepts |= (FE_ALL_EXCEPT &~ (mxcsr >> 7)); + sse_write_mxcsr (mxcsr &~ (excepts << 7)); + } + if (x87_p) + { + unsigned short control_word = (x87_read_control_word ()); + old_excepts |= (FE_ALL_EXCEPT &~ control_word); + x87_write_control_word (control_word &~ excepts); + } + return ((sse_p || x87_p) ? old_excepts : (-1)); +} + +int +fedisableexcept (int excepts) +{ + int old_excepts = 0; + if (excepts &~ FE_ALL_EXCEPT) + return (-1); + if (sse_p) + { + unsigned int mxcsr = (sse_read_mxcsr ()); + old_excepts |= (FE_ALL_EXCEPT &~ (mxcsr >> 7)); + sse_write_mxcsr (mxcsr | (excepts << 7)); + } + if (x87_p) + { + unsigned short control_word = (x87_read_control_word ()); + old_excepts |= (FE_ALL_EXCEPT &~ control_word); + x87_write_control_word (control_word | excepts); + } + return ((sse_p || x87_p) ? old_excepts : (-1)); +} + +int +fegetenv (fenv_t *envp) +{ + if (sse_p) + (envp->fenv_sse.sse_mxcsr) = (sse_read_mxcsr ()); + if (x87_p) + x87_read_environment (envp->fenv_x87.environment_bytes); + return (! (sse_p || x87_p)); +} + +int +fesetenv (const fenv_t *envp) +{ + if (sse_p) + sse_write_mxcsr (envp->fenv_sse.sse_mxcsr); + if (x87_p) + x87_write_environment (envp->fenv_x87.environment_bytes); + return (! (sse_p || x87_p)); +} + +int +feholdexcept (fenv_t *envp) +{ + int status = (fegetenv (envp)); + if (status != 0) + return (status); + if (sse_p) + sse_write_mxcsr + (((envp->fenv_sse.sse_mxcsr) + | (FE_ALL_EXCEPT << 7)) /* Set all mask bits. */ + &~ FE_ALL_EXCEPT); /* Clear all flag bits. */ + if (x87_p) + { + x87_clear_exceptions (); + x87_write_control_word + ((envp->fenv_x87.environment.x87_control_word) | FE_ALL_EXCEPT); + } + return (0); +} + +int +feupdateenv (const fenv_t *envp) +{ + int excepts = (fetestexcept (FE_ALL_EXCEPT)); + int status = (fesetenv (envp)); + if (status != 0) + return (status); + return (feraiseexcept (excepts)); +} diff --git a/src/microcode/cmpintmd/x86-fenv.h b/src/microcode/cmpintmd/x86-fenv.h new file mode 100644 index 000000000..5e01fb563 --- /dev/null +++ b/src/microcode/cmpintmd/x86-fenv.h @@ -0,0 +1,124 @@ +/* -*-C-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* C99 emulation for x86 (shared between i386 and amd64) */ + +#define HAVE_FENV_T +#define HAVE_FEXCEPT_T + +typedef int fexcept_t; + +typedef struct +{ + int sse_mxcsr; +} sse_fenv_t; + +/* FIXME: This structure needs to be packed. */ + +struct x87_environment +{ + unsigned short x87_control_word; + unsigned short x87_unused1; + unsigned short x87_status_word; + unsigned short x87_unused2; + unsigned short x87_tag_word; + unsigned short x87_unused3; + unsigned int x87_instruction_offset; + unsigned short x87_instruction_cs_selector; + unsigned short x87_instruction_opcode : 11; + unsigned short x87_unused4 : 5; + unsigned int x87_data_offset; + unsigned short x87_data_ds_selector; + unsigned short x87_unused5; +}; + +typedef union +{ + struct x87_environment environment; + unsigned char environment_bytes [sizeof (struct x87_environment)]; +} x87_fenv_t; + +typedef struct +{ + sse_fenv_t fenv_sse; + x87_fenv_t fenv_x87; +} fenv_t; + +#define FE_TONEAREST 0 +#define FE_DOWNWARD 1 +#define FE_UPWARD 2 +#define FE_TOWARDZERO 3 + +#define HAVE_FEGETROUND +#define HAVE_FESETROUND + +extern int fegetround (void); +extern int fesetround (int); + +#define FE_INVALID (1 << 0) +#define FE_DENORMAL (1 << 1) /* Non-standard */ +#define FE_DIVBYZERO (1 << 2) +#define FE_OVERFLOW (1 << 3) +#define FE_UNDERFLOW (1 << 4) +#define FE_INEXACT (1 << 5) + +#define FE_ALL_EXCEPT \ + (FE_DENORMAL|FE_DIVBYZERO|FE_INEXACT|FE_INVALID|FE_OVERFLOW|FE_UNDERFLOW) + +#if FE_ALL_EXCEPT != 0x3f +# error Floating-point exception set is wrong. +#endif + +#define HAVE_FECLEAREXCEPT +#define HAVE_FEGETEXCEPTFLAG +#define HAVE_FERAISEEXCEPT +#define HAVE_FESETEXCEPTFLAG +#define HAVE_FETESTEXCEPT + +extern int fetestexcept (int); +extern int feclearexcept (int); +extern int feraiseexcept (int); +extern int fegetexceptflag (fexcept_t *, int); +extern int fesetexceptflag (const fexcept_t *, int); + +/* The next three are glibc extensions. */ + +#define HAVE_FEDISABLEEXCEPT +#define HAVE_FEENABLEEXCEPT +#define HAVE_FEGETEXCEPT + +extern int fegetexcept (void); +extern int feenableexcept (int); +extern int fedisableexcept (int); + +#define HAVE_FEGETENV +#define HAVE_FESETENV +#define HAVE_FEHOLDEXCEPT +#define HAVE_FEUPDATEENV + +extern int fegetenv (fenv_t *); +extern int fesetenv (const fenv_t *); +extern int feholdexcept (fenv_t *); +extern int feupdateenv (const fenv_t *); diff --git a/src/microcode/floenv.c b/src/microcode/floenv.c new file mode 100644 index 000000000..143c9ac00 --- /dev/null +++ b/src/microcode/floenv.c @@ -0,0 +1,518 @@ +/* -*-C-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Floating Point Environment */ + +#include "scheme.h" +#include "osscheme.h" +#include "prims.h" + +#include "floenv.h" + +#ifndef __GNUC__ +# pragma STDC FENV_ACCESS ON +#endif + +#define VECTOR_8B_LENGTH STRING_LENGTH +#define VECTOR_8B_P STRING_P +#define VECTOR_8B_POINTER STRING_POINTER +#define allocate_vector_8b allocate_string + +static SCHEME_OBJECT +arg_vector_8b (int n) +{ + CHECK_ARG (n, VECTOR_8B_P); + return (ARG_REF (n)); +} + +#ifndef HAVE_FENV_T +typedef char fenv_t; +#endif + +#ifndef HAVE_FEXCEPT_T +typedef char fexcept_t; +#endif + +static bool scheme_fenv_p = false; +static fenv_t scheme_fenv; + +static void +cache_float_environment (void) +{ +#ifdef HAVE_FEGETENV + if (0 != (fegetenv (&scheme_fenv))) + error_external_return (); + scheme_fenv_p = true; +#endif +} + +void +fixup_float_environment (void) +{ +#ifdef HAVE_FESETENV + if (scheme_fenv_p) + (void) fesetenv (&scheme_fenv); +#endif +} + +/* FIXME: Alignment? */ + +static SCHEME_OBJECT +allocate_fenv (fenv_t **envp_loc) +{ + SCHEME_OBJECT environment = (allocate_vector_8b (sizeof (fenv_t))); + (*envp_loc) = ((fenv_t *) (VECTOR_8B_POINTER (environment))); + return (environment); +} + +static fenv_t * +arg_fenv (int n) +{ + SCHEME_OBJECT environment = (arg_vector_8b (n)); + if ((sizeof (fenv_t)) != (VECTOR_8B_LENGTH (environment))) + error_bad_range_arg (n); + return ((fenv_t *) (VECTOR_8B_POINTER (environment))); +} + +static SCHEME_OBJECT +allocate_fexcept (fexcept_t **flagp_loc) +{ + SCHEME_OBJECT flags = (allocate_vector_8b (sizeof (fexcept_t))); + (*flagp_loc) = ((fexcept_t *) (VECTOR_8B_POINTER (flags))); + return (flags); +} + +static fexcept_t * +arg_fexcept (int n) +{ + SCHEME_OBJECT flags = (arg_vector_8b (n)); + if ((sizeof (fexcept_t)) != (VECTOR_8B_LENGTH (flags))) + error_bad_range_arg (n); + return ((fexcept_t *) (VECTOR_8B_POINTER (flags))); +} + +DEFINE_PRIMITIVE ("FLOAT-ENVIRONMENT", Prim_float_environment, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); +#ifdef HAVE_FEGETENV + { + fenv_t *envp; + SCHEME_OBJECT environment = (allocate_fenv (&envp)); + if (0 != (fegetenv (envp))) + error_external_return (); + PRIMITIVE_RETURN (environment); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("SET-FLOAT-ENVIRONMENT", Prim_set_float_environment, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FESETENV + if (0 != (fesetenv (arg_fenv (1)))) + error_external_return (); + cache_float_environment (); +#else + error_unimplemented_primitive (); +#endif + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("DEFER-FLOAT-EXCEPTIONS", Prim_defer_float_exceptions, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); +#ifdef HAVE_FEHOLDEXCEPT + { + fenv_t *envp; + SCHEME_OBJECT environment = (allocate_fenv (&envp)); + if (0 != (feholdexcept (envp))) + error_external_return (); + cache_float_environment (); + PRIMITIVE_RETURN (environment); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("UPDATE-FLOAT-ENVIRONMENT", Prim_restore_float_environment, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FEUPDATEENV + if (0 != (feupdateenv (arg_fenv (1)))) + error_external_return (); + cache_float_environment (); +#else + error_unimplemented_primitive (); +#endif + PRIMITIVE_RETURN (UNSPECIFIC); +} + +enum { FRMODE_NEAREST, FRMODE_TOWARD_ZERO, FRMODE_DOWNWARD, FRMODE_UPWARD }; + +DEFINE_PRIMITIVE ("FLOAT-ROUNDING-MODES", Prim_float_rounding_modes, 0, 0, 0) +{ + unsigned int modes = 0; + PRIMITIVE_HEADER (0); +#ifdef HAVE_FEGETROUND +# ifdef FE_TONEAREST + modes |= (1 << FRMODE_NEAREST); +# endif +# ifdef FE_TOWARDZERO + modes |= (1 << FRMODE_TOWARD_ZERO); +# endif +# ifdef FE_DOWNWARD + modes |= (1 << FRMODE_DOWNWARD); +# endif +# ifdef FE_UPWARD + modes |= (1 << FRMODE_UPWARD); +# endif +#endif + PRIMITIVE_RETURN (ulong_to_integer (modes)); +} + +DEFINE_PRIMITIVE ("GET-FLOAT-ROUNDING-MODE", Prim_get_float_rounding_mode, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); +#ifdef HAVE_FEGETROUND + { + int mode = (fegetround ()); + if (mode < 0) + error_external_return (); + switch (mode) + { +#ifdef FE_TONEAREST + case FE_TONEAREST: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_NEAREST)); +#endif +#ifdef FE_TOWARDZERO + case FE_TOWARDZERO: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_TOWARD_ZERO)); +#endif +#ifdef FE_DOWNWARD + case FE_DOWNWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_DOWNWARD)); +#endif +#ifdef FE_UPWARD + case FE_UPWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_UPWARD)); +#endif + default: PRIMITIVE_RETURN (SHARP_F); + } + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("SET-FLOAT-ROUNDING-MODE", Prim_set_float_rounding_mode, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FESETROUND + { + int mode = (-1); + switch (arg_ulong_integer (1)) + { +#ifdef FE_TONEAREST + case FRMODE_NEAREST: mode = FE_TONEAREST; break; +#endif +#ifdef FE_TOWARDZERO + case FRMODE_TOWARD_ZERO: mode = FE_TOWARDZERO; break; +#endif +#ifdef FE_DOWNWARD + case FRMODE_DOWNWARD: mode = FE_DOWNWARD; break; +#endif +#ifdef FE_UPWARD + case FRMODE_UPWARD: mode = FE_UPWARD; break; +#endif + default: error_bad_range_arg (1); break; + } + if ((fesetround (mode)) != 0) + error_external_return (); + cache_float_environment (); + } +#else + error_unimplemented_primitive (); +#endif + PRIMITIVE_RETURN (UNSPECIFIC); +} + +/* The following two definitions could be replaced by a more complex + mapping between the system's representation of exception sets and a + system-independent representation of them for Scheme, like the + rounding modes above. While OS-independent representations are + generally good, (a) machine-dependent representations don't matter + much, (b) the system-dependent representations are likely to be + machine-dependent but OS-independent, and (c) it would be nice to + open-code all the floating-point environment hackery. */ + +#define FLOAT_EXCEPTIONS_RESULT(EXCEPTIONS) \ + PRIMITIVE_RETURN (ULONG_TO_FIXNUM (EXCEPTIONS)) + +static int +arg_float_exceptions (int n) +{ + CHECK_ARG (n, UNSIGNED_FIXNUM_P); + { + unsigned long scheme_exceptions = (FIXNUM_TO_ULONG (ARG_REF (n))); + if (scheme_exceptions &~ FE_ALL_EXCEPT) + error_bad_range_arg (n); + return (scheme_exceptions); + } +} + +/* It is not safe to run Scheme with the inexact result exception + unmasked, but the exception can sometimes be useful to test. + Consequently, we go to some trouble to make sure that it is masked, + and signal an error if anyone ever tries to unmask it. */ + +static const int always_masked_exceptions = 0 +#ifdef FE_INEXACT + | FE_INEXACT +#endif + ; + +static int +arg_maskable_float_exceptions (int n) +{ + return (always_masked_exceptions | (arg_float_exceptions (n))); +} + +static int +arg_unmaskable_float_exceptions (int n) +{ + int exceptions = (arg_float_exceptions (n)); + if (exceptions & always_masked_exceptions) + error_bad_range_arg (n); + return (exceptions); +} + +static int +arg_float_exception_mask (int n) +{ + int exceptions = (arg_float_exceptions (n)); + if (! (exceptions & always_masked_exceptions)) + error_bad_range_arg (n); + return (exceptions); +} + +#define FLOAT_EXCEPTIONS_PRIMITIVE(E) \ +{ \ + PRIMITIVE_HEADER (0); \ + FLOAT_EXCEPTIONS_RESULT (E); \ +} + +#define UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE() \ +{ \ + PRIMITIVE_HEADER (0); \ + /* error_unimplemented_primitive (); */ \ + FLOAT_EXCEPTIONS_RESULT (0); \ +} + +DEFINE_PRIMITIVE ("FLOAT-INVALID-OPERATION-EXCEPTION", Prim_float_invalid_operation_exception, 0, 0, 0) +#ifdef FE_INVALID + FLOAT_EXCEPTIONS_PRIMITIVE (FE_INVALID) +#else + UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () +#endif + +DEFINE_PRIMITIVE ("FLOAT-DIVIDE-BY-ZERO-EXCEPTION", Prim_float_divide_by_zero_exception, 0, 0, 0) +#ifdef FE_DIVBYZERO + FLOAT_EXCEPTIONS_PRIMITIVE (FE_DIVBYZERO) +#else + UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () +#endif + +DEFINE_PRIMITIVE ("FLOAT-OVERFLOW-EXCEPTION", Prim_float_overflow_exception, 0, 0, 0) +#ifdef FE_OVERFLOW + FLOAT_EXCEPTIONS_PRIMITIVE (FE_OVERFLOW) +#else + UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () +#endif + +DEFINE_PRIMITIVE ("FLOAT-UNDERFLOW-EXCEPTION", Prim_float_underflow_exception, 0, 0, 0) +#ifdef FE_UNDERFLOW + FLOAT_EXCEPTIONS_PRIMITIVE (FE_UNDERFLOW) +#else + UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () +#endif + +DEFINE_PRIMITIVE ("FLOAT-INEXACT-RESULT-EXCEPTION", Prim_float_inexact_result_exception, 0, 0, 0) +#ifdef FE_INEXACT + FLOAT_EXCEPTIONS_PRIMITIVE (FE_INEXACT) +#else + UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE () +#endif + +DEFINE_PRIMITIVE ("FLOAT-EXCEPTIONS", Prim_float_exceptions, 0, 0, 0) + FLOAT_EXCEPTIONS_PRIMITIVE (FE_ALL_EXCEPT) + +DEFINE_PRIMITIVE ("UNMASKABLE-FLOAT-EXCEPTIONS", Prim_unmaskable_float_exceptions, 0, 0, 0) + FLOAT_EXCEPTIONS_PRIMITIVE (FE_ALL_EXCEPT &~ always_masked_exceptions) + +DEFINE_PRIMITIVE ("TEST-FLOAT-EXCEPTIONS", Prim_test_float_exceptions, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FETESTEXCEPT + FLOAT_EXCEPTIONS_RESULT (fetestexcept (arg_float_exceptions (1))); +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("CLEAR-FLOAT-EXCEPTIONS", Prim_clear_float_exceptions, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FECLEAREXCEPT + if (0 != (feclearexcept (arg_float_exceptions (1)))) + error_external_return (); + cache_float_environment (); +#else + error_unimplemented_primitive (); +#endif + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("RAISE-FLOAT-EXCEPTIONS", Prim_raise_float_exceptions, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FERAISEEXCEPT + if (0 != (feraiseexcept (arg_float_exceptions (1)))) + error_external_return (); + /* cache_float_environment (); */ +#else + error_unimplemented_primitive (); +#endif + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("SAVE-FLOAT-EXCEPTION-FLAGS", Prim_save_float_exception_flags, 1, 1, 0) +{ + PRIMITIVE_HEADER (0); +#ifdef HAVE_FEGETEXCEPTFLAG + { + fexcept_t *flagp; + SCHEME_OBJECT flags = (allocate_fexcept (&flagp)); + if (0 != (fegetexceptflag (flagp, (arg_float_exceptions (1))))) + error_external_return (); + PRIMITIVE_RETURN (flags); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("TEST-FLOAT-EXCEPTION-FLAGS", Prim_test_float_exception_flags, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + /* Oops! IEEE 754-2008 requests this operation, but C99 doesn't + provide it. */ + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("RESTORE-FLOAT-EXCEPTION-FLAGS", Prim_restore_float_exception_flags, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); +#ifdef HAVE_FESETEXCEPTFLAG + if (0 > (fesetexceptflag ((arg_fexcept (1)), (arg_float_exceptions (2))))) + error_external_return (); + cache_float_environment (); +#else + error_unimplemented_primitive (); +#endif + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("MASKED-FLOAT-EXCEPTIONS", Prim_masked_float_exceptions, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); +#ifdef HAVE_FEGETEXCEPT + { + int exceptions = (fegetexcept ()); + if (exceptions < 0) error_external_return (); + FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ exceptions); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("SET-MASKED-FLOAT-EXCEPTIONS", Prim_set_masked_float_exceptions, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#if ((defined (HAVE_FEENABLEEXCEPT)) && (defined (HAVE_FEDISABLEEXCEPT))) + { + int masked_exceptions = (arg_float_exception_mask (1)); + int previous_exceptions = (fedisableexcept (masked_exceptions)); + if ((0 > previous_exceptions) + || (0 > (feenableexcept (FE_ALL_EXCEPT &~ masked_exceptions)))) + error_external_return (); + cache_float_environment (); + FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ previous_exceptions); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("MASK-FLOAT-EXCEPTIONS", Prim_mask_float_exceptions, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FEDISABLEEXCEPT + { + int exceptions = (arg_maskable_float_exceptions (1)); + int previous_exceptions = (fedisableexcept (exceptions)); + if (previous_exceptions < 0) error_external_return (); + cache_float_environment (); + FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ previous_exceptions); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} + +DEFINE_PRIMITIVE ("UNMASK-FLOAT-EXCEPTIONS", Prim_unmask_float_exceptions, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); +#ifdef HAVE_FEENABLEEXCEPT + { + int exceptions = (arg_unmaskable_float_exceptions (1)); + int previous_exceptions = (feenableexcept (exceptions)); + if (previous_exceptions < 0) error_external_return (); + cache_float_environment (); + FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ previous_exceptions); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} diff --git a/src/microcode/floenv.h b/src/microcode/floenv.h new file mode 100644 index 000000000..46ad48886 --- /dev/null +++ b/src/microcode/floenv.h @@ -0,0 +1,125 @@ +/* -*-C-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Floating Point Environment */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "cmpintmd.h" + +#if (defined (HAVE_FENV_H)) +# include +#elif ((!defined (CMPINTMD_EMULATES_FENV)) && (defined (HAVE_IEEEFP_H))) + +/* Assumption: If we have , then we don't need to test for + individual definitions in it. If you come across a different + from what one finds on BSD systems, you'll have to fix + this code. */ + +# include + +# define FE_TONEAREST FP_RN +# define FE_DOWNWARD FP_RM +# define FE_UPWARD FP_RP +# define FE_TOWARDZERO FP_RZ + +# define fegetround fpgetround +# define fesetround(rm) ((fpsetround (rm)), 0) + +# define FE_INVALID FP_X_INV +# define FE_DIVBYZERO FP_X_DZ +# define FE_OVERFLOW FP_X_OFL +# define FE_UNDERFLOW FP_X_UFL +# define FE_INEXACT FP_X_IMP +/* FP_X_IOV? */ + +# define fexcept_t fp_except + +# define fetestexcepts(excepts) ((excepts) & (fpgetsticky ())) +# define fecleareexcept(excepts) \ + (fpsetsticky ((fpgetsticky ()) &~ (FE_ALL_EXCEPT & (excepts)))) + +/* This isn't right -- it doesn't necessarily actually raise the + exception until some floating-point operation is performed. */ +# define feraiseexcept(excepts) \ + (fpsetsticky ((fpgetsticky ()) || (FE_ALL_EXCEPT & (excepts))) + +# define fegetexceptflag(flagp, excepts) \ + (((* ((0 ? ((int *) 0) : flagp))) = ((excepts) & (fpgetsticky ()))), 0) +# define fesetexceptflag(flagp, excepts) \ + (fpsetsticky \ + (FE_ALL_EXCEPT & (excepts) & (* ((0 ? ((const int *) 0) : flagp))))) + +# define fegetexcept fpgetmask +# define feenableexcept(excepts) \ + (fpsetmask ((fpgetmask ()) || (FE_ALL_EXCEPT & (excepts)))) +# define fedisableexcept(excepts) \ + (fpsetmask ((fpgetmask ()) &~ (FE_ALL_EXCEPT & (excepts)))) + +typedef struct +{ + fp_except fe_enabled_exceptions; + fp_except fe_sticky_exceptions; + fp_rnd fe_rounding_mode; +} fenv_t; + +static inline int +fegetenv (fenv_t *fe) +{ + (fe->fe_enabled_exceptions) = (fpgetmask ()); + (fe->fe_sticky_exceptions) = (fpgetsticky ()); + (fe->fe_rounding_mode) = (fpgetround ()); + return (0); +} + +static inline int +fesetenv (const fenv_t *fe) +{ + (void) fpsetmask (fe->fe_enabled_exceptions); + (void) fpsetsticky (fe->fe_sticky_exceptions); + (void) fpsetround (fe->fe_rounding_mode); + return (0); +} + +static inline int +feholdexcept (fenv_t *fe) +{ + (void) fegetenv (fe); + fpsetmask (0); + return (0); +} + +static inline int +feupdateenv (const fenv_t *fe) +{ + fp_except exceptions = (fpgetsticky ()); + (void) fesetenv (fe); + /* Unfortunately, this doesn't actually do anything, because of the + useless definition of feraiseexcept above. */ + (void) feraiseexcept (exceptions); +} +#endif diff --git a/src/microcode/interp.c b/src/microcode/interp.c index 8d3d7bda9..cca842a32 100644 --- a/src/microcode/interp.c +++ b/src/microcode/interp.c @@ -33,7 +33,7 @@ USA. extern void * obstack_chunk_alloc (size_t); #define obstack_chunk_free free extern void preserve_signal_mask (void); -extern void fixup_float_rounding_mode (void); +extern void fixup_float_environment (void); /* In order to make the interpreter tail recursive (i.e. * to avoid calling procedures and thus saving unnecessary @@ -268,7 +268,7 @@ Interpret (int pop_return_p) bind_interpreter_state (&new_state); dispatch_code = (setjmp (interpreter_catch_env)); preserve_signal_mask (); - fixup_float_rounding_mode (); + fixup_float_environment (); switch (dispatch_code) { diff --git a/src/microcode/makegen/files-core.scm b/src/microcode/makegen/files-core.scm index f5c19847b..8cec66232 100644 --- a/src/microcode/makegen/files-core.scm +++ b/src/microcode/makegen/files-core.scm @@ -42,6 +42,7 @@ USA. "fasl" "fasload" "fixnum" +"floenv" "flonum" "gcloop" "generic" diff --git a/src/microcode/sysprim.c b/src/microcode/sysprim.c index 7654116bf..db828568d 100644 --- a/src/microcode/sysprim.c +++ b/src/microcode/sysprim.c @@ -32,10 +32,6 @@ USA. #include "ostty.h" #include "ostop.h" -#ifdef HAVE_FENV_H -# include -#endif - extern long OS_set_trap_state (long); extern double arg_flonum (int); @@ -204,155 +200,3 @@ DEFINE_PRIMITIVE ("CC-BLOCK-LINKAGE-INFO", Prim_cc_block_linkage_info, 1, 1, 0) CHECK_ARG (1, CC_BLOCK_P); PRIMITIVE_RETURN (cc_block_linkage_info (ARG_REF (1))); } - -/* Emulate with BSD's . */ - -#if !defined(HAVE_FENV_H) && defined(HAVE_IEEEFP_H) -# include -#endif - -#if !defined(HAVE_FEGETROUND) && defined(HAVE_FPGETROUND) -# define fegetround fpgetround -# define HAVE_FEGETROUND -#endif - -#if !defined(HAVE_FESETROUND) && defined(HAVE_FPSETROUND) - -static inline int -fesetround (int mode) -{ - /* fpsetround never fails; instead, it returns the old rounding mode, - which has only a one-in-four chance in general of being 0 as the - SET-FLOAT-ROUNDING-MODE primitive wants. */ - (void) fpsetround (mode); - return (0); -} - -# define HAVE_FESETROUND -#endif - -#if !defined(FE_TONEAREST) && defined(FP_RN) -# define FE_TONEAREST FP_RN -#endif - -#if !defined(FE_TOWARDZERO) && defined(FP_RZ) -# define FE_TOWARDZERO FP_RZ -#endif - -#if !defined(FE_DOWNWARD) && defined(FP_RM) -# define FE_DOWNWARD FP_RM -#endif - -#if !defined(FE_UPWARD) && defined(FP_RP) -# define FE_UPWARD FP_RP -#endif - -#ifndef __GNUC__ -# pragma STDC FENV_ACCESS ON -#endif - -enum { FRMODE_NEAREST, FRMODE_TOWARD_ZERO, FRMODE_DOWNWARD, FRMODE_UPWARD }; - -DEFINE_PRIMITIVE ("FLOAT-ROUNDING-MODES", Prim_float_rounding_modes, 0, 0, 0) -{ - unsigned int modes = 0; - PRIMITIVE_HEADER (0); -#ifdef HAVE_FEGETROUND -# ifdef FE_TONEAREST - modes |= (1 << FRMODE_NEAREST); -# endif -# ifdef FE_TOWARDZERO - modes |= (1 << FRMODE_TOWARD_ZERO); -# endif -# ifdef FE_DOWNWARD - modes |= (1 << FRMODE_DOWNWARD); -# endif -# ifdef FE_UPWARD - modes |= (1 << FRMODE_UPWARD); -# endif -#endif - PRIMITIVE_RETURN (ulong_to_integer (modes)); -} - -DEFINE_PRIMITIVE ("GET-FLOAT-ROUNDING-MODE", Prim_get_float_rounding_mode, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); -#ifdef HAVE_FEGETROUND - { - int mode = (fegetround ()); - if (mode < 0) - error_external_return (); - switch (mode) - { -#ifdef FE_TONEAREST - case FE_TONEAREST: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_NEAREST)); -#endif -#ifdef FE_TOWARDZERO - case FE_TOWARDZERO: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_TOWARD_ZERO)); -#endif -#ifdef FE_DOWNWARD - case FE_DOWNWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_DOWNWARD)); -#endif -#ifdef FE_UPWARD - case FE_UPWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_UPWARD)); -#endif - default: PRIMITIVE_RETURN (SHARP_F); - } - } -#else - error_unimplemented_primitive (); - PRIMITIVE_RETURN (UNSPECIFIC); -#endif -} - -#ifdef HAVE_FESETROUND -static int float_rounding_mode = (-1); -#endif - -DEFINE_PRIMITIVE ("SET-FLOAT-ROUNDING-MODE", Prim_set_float_rounding_mode, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); -#ifdef HAVE_FESETROUND - { - int mode = (-1); - switch (arg_ulong_integer (1)) - { -#ifdef FE_TONEAREST - case FRMODE_NEAREST: mode = FE_TONEAREST; break; -#endif -#ifdef FE_TOWARDZERO - case FRMODE_TOWARD_ZERO: mode = FE_TOWARDZERO; break; -#endif -#ifdef FE_DOWNWARD - case FRMODE_DOWNWARD: mode = FE_DOWNWARD; break; -#endif -#ifdef FE_UPWARD - case FRMODE_UPWARD: mode = FE_UPWARD; break; -#endif - default: error_bad_range_arg (1); break; - } - if ((fesetround (mode)) != 0) - { - float_rounding_mode = (-1); - error_bad_range_arg (1); - } - else - float_rounding_mode = mode; - } -#else - error_unimplemented_primitive (); -#endif - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* This kludge is to work around the fact that setjmp saves the - floating-point rounding mode and longjmp restores it. */ - -void -fixup_float_rounding_mode (void) -{ -#ifdef HAVE_FESETROUND - if (float_rounding_mode >= 0) - fesetround (float_rounding_mode); -#endif -} diff --git a/src/microcode/uxsig.c b/src/microcode/uxsig.c index eb011b627..743d2f765 100644 --- a/src/microcode/uxsig.c +++ b/src/microcode/uxsig.c @@ -550,8 +550,6 @@ static DEFUN_STD_HANDLER (sighnd_fpe, { FPE_RESET_TRAPS (); - if (executing_scheme_primitive_p ()) - error_floating_point_exception (); trap_handler ("floating-point exception", signo, info, scp); }) #endif diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 08dede1fc..6770828d8 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -697,10 +697,14 @@ USA. (define condition-type:error) (define condition-type:file-error) (define condition-type:file-operation-error) +(define condition-type:floating-point-divide-by-zero) (define condition-type:floating-point-overflow) (define condition-type:floating-point-underflow) (define condition-type:illegal-datum) (define condition-type:illegal-pathname-component) +(define condition-type:inexact-floating-point-result) +(define condition-type:integer-divide-by-zero) +(define condition-type:invalid-floating-point-operation) (define condition-type:macro-binding) (define condition-type:no-such-restart) (define condition-type:not-8-bit-char) @@ -1064,7 +1068,7 @@ USA. " the same " (get-noun condition) " again."))))) - + (set! condition-type:variable-error (make-condition-type 'VARIABLE-ERROR condition-type:cell-error '(ENVIRONMENT) @@ -1092,7 +1096,7 @@ USA. (lambda (condition port) (write-string "Variable reference to a syntactic keyword: " port) (write (access-condition condition 'LOCATION) port)))) - + (let ((arithmetic-error-report (lambda (description) (lambda (condition port) @@ -1111,6 +1115,26 @@ USA. (make-condition-type 'DIVIDE-BY-ZERO condition-type:arithmetic-error '() (arithmetic-error-report "Division by zero"))) + (set! condition-type:integer-divide-by-zero + (make-condition-type 'INTEGER-DIVIDE-BY-ZERO + condition-type:divide-by-zero + '() + (arithmetic-error-report "Integer division by zero"))) + (set! condition-type:floating-point-divide-by-zero + (make-condition-type 'FLOATING-POINT-DIVIDE-BY-ZERO + condition-type:divide-by-zero + '() + (arithmetic-error-report "Floating-point division by zero"))) + (set! condition-type:inexact-floating-point-result + (make-condition-type 'INEXACT-FLOATING-POINT-RESULT + condition-type:arithmetic-error + '() + (arithmetic-error-report "Inexact floating-point result"))) + (set! condition-type:invalid-floating-point-operation + (make-condition-type 'INVALID-FLOATING-POINT-OPERATION + condition-type:arithmetic-error + '() + (arithmetic-error-report "Invalid floating-point operation"))) (set! condition-type:floating-point-overflow (make-condition-type 'FLOATING-POINT-OVERFLOW condition-type:arithmetic-error @@ -1121,14 +1145,14 @@ USA. condition-type:arithmetic-error '() (arithmetic-error-report "Floating-point underflow")))) - + (set! condition-type:not-8-bit-char (make-condition-type 'NOT-8-BIT-CHAR condition-type:error '(CHAR) (lambda (condition port) (write-string "Character too large for 8-bit string: " port) (write (access-condition condition 'CHAR) port) (newline port)))) - + (set! make-simple-error (condition-constructor condition-type:simple-error '(MESSAGE IRRITANTS))) diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm index 0674952ce..e2f9fc9bc 100644 --- a/src/runtime/fixart.scm +++ b/src/runtime/fixart.scm @@ -175,57 +175,4 @@ USA. (define (->flonum x) (guarantee-real x '->FLONUM) - (exact->inexact (real-part x))) - -(define-primitives - (float-rounding-modes 0) - (get-float-rounding-mode 0) - (set-float-rounding-mode 1)) - -(define float-rounding-mode-names - '#(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD)) - -(define (flo:rounding-modes) - (let ((n (vector-length float-rounding-mode-names)) - (m (float-rounding-modes))) - (let loop ((i 0) (names '())) - (if (fix:< i n) - (loop (fix:+ i 1) - (if (fix:= (fix:and (fix:lsh 1 i) m) 0) - names - (cons (vector-ref float-rounding-mode-names i) names))) - names)))) - -(define (flo:rounding-mode) - (let ((m (get-float-rounding-mode))) - (if (not (fix:< m (vector-length float-rounding-mode-names))) - (error "Unknown float rounding mode:" m)) - (vector-ref float-rounding-mode-names m))) - -(define (flo:set-rounding-mode! mode) - (set-float-rounding-mode (%mode-name->number mode 'FLO:SET-ROUNDING-MODE!))) - -(define (flo:with-rounding-mode mode thunk) - (let ((inside-mode (%mode-name->number mode 'FLO:WITH-ROUNDING-MODE)) - (outside-mode)) - (shallow-fluid-bind (lambda () - (set! outside-mode (get-float-rounding-mode)) - (set-float-rounding-mode inside-mode) - (set! inside-mode) - unspecific) - thunk - (lambda () - (set! inside-mode (get-float-rounding-mode)) - (set-float-rounding-mode outside-mode) - (set! outside-mode) - unspecific)))) - -(define (%mode-name->number mode caller) - (guarantee-interned-symbol mode caller) - (let ((n (vector-length float-rounding-mode-names))) - (let loop ((i 0)) - (if (not (fix:< i n)) - (error:bad-range-argument mode caller)) - (if (eq? mode (vector-ref float-rounding-mode-names i)) - i - (loop (fix:+ i 1)))))) \ No newline at end of file + (exact->inexact (real-part x))) \ No newline at end of file diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm new file mode 100644 index 000000000..7a38f063d --- /dev/null +++ b/src/runtime/floenv.scm @@ -0,0 +1,202 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Floating-Point Environment +;;; package: (runtime floating-point-environment) + +(declare (usual-integrations)) + +;;;; Floating-Point Environment + +(define-primitives + (flo:environment float-environment 0) + (flo:set-environment! set-float-environment 1) + (flo:defer-exceptions! defer-float-exceptions 0) + (flo:update-environment! update-float-environment 1)) + +(define (flo:deferring-exceptions procedure) + (flo:preserving-environment + (lambda () + (let ((environment (flo:defer-exceptions!))) + (let ((result (procedure))) + (flo:update-environment! environment) + result))))) + +(define (flo:ignoring-exceptions procedure) + (flo:preserving-environment + (lambda () + (flo:defer-exceptions!) + (procedure)))) + +(define (flo:preserving-environment procedure) + (let ((environment (flo:environment))) + (define (swap) + (let ((temporary environment)) + (set! environment (flo:environment)) + (flo:set-environment! temporary))) + (dynamic-wind swap procedure swap))) + +(define (flo:with-default-environment procedure) + (flo:preserving-environment + (lambda () + (flo:set-environment! (flo:default-environment)) + (procedure)))) + +(define default-environment) + +(define (flo:default-environment) + default-environment) + +(define (initialize-package!) + (set! default-environment + (let ((environment (flo:environment))) + (flo:set-rounding-mode! (flo:default-rounding-mode)) + (flo:clear-exceptions! (flo:supported-exceptions)) + (flo:set-masked-exceptions! (flo:default-exception-mask)) + (let ((environment* (flo:environment))) + (flo:set-environment! environment) + environment*))) + unspecific) + +(define-primitives + (float-rounding-modes 0) + (get-float-rounding-mode 0) + (set-float-rounding-mode 1)) + +(define float-rounding-mode-names + '#(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD)) + +(define (flo:rounding-modes) + (let ((n (vector-length float-rounding-mode-names)) + (m (float-rounding-modes))) + (let loop ((i 0) (names '())) + (if (fix:< i n) + (loop (fix:+ i 1) + (if (fix:= (fix:and (fix:lsh 1 i) m) 0) + names + (cons (vector-ref float-rounding-mode-names i) names))) + names)))) + +(define (flo:default-rounding-mode) + 'TO-NEAREST) + +(define (flo:rounding-mode) + (let ((m (get-float-rounding-mode))) + (if (not (fix:< m (vector-length float-rounding-mode-names))) + (error "Unknown float rounding mode:" m)) + (vector-ref float-rounding-mode-names m))) + +(define (flo:set-rounding-mode! mode) + (set-float-rounding-mode (%mode-name->number mode 'FLO:SET-ROUNDING-MODE!))) + +(define (flo:with-rounding-mode mode thunk) + (let ((mode (%mode-name->number mode 'FLO:WITH-ROUNDING-MODE))) + (flo:preserving-environment + (lambda () + (set-float-rounding-mode mode) + (thunk))))) + +(define (%mode-name->number mode caller) + (guarantee-interned-symbol mode caller) + (let ((n (vector-length float-rounding-mode-names))) + (let loop ((i 0)) + (if (not (fix:< i n)) + (error:bad-range-argument mode caller)) + (if (eq? mode (vector-ref float-rounding-mode-names i)) + i + (loop (fix:+ i 1)))))) + +(define-primitives + (flo:supported-exceptions float-exceptions 0) + (flo:exception:divide-by-zero float-divide-by-zero-exception 0) + (flo:exception:invalid-operation float-invalid-operation-exception 0) + (flo:exception:underflow float-underflow-exception 0) + (flo:exception:overflow float-overflow-exception 0) + (flo:exception:inexact-result float-inexact-result-exception 0) + (flo:test-exceptions test-float-exceptions 1) + (flo:clear-exceptions! clear-float-exceptions 1) + (flo:raise-exceptions! raise-float-exceptions 1) + (flo:save-exception-flags save-float-exception-flags 1) + (flo:test-exception-flags test-float-exception-flags 2) + (flo:restore-exception-flags! restore-float-exception-flags 2) + (flo:masked-exceptions masked-float-exceptions 0) + (flo:set-masked-exceptions! set-masked-float-exceptions 1) + (flo:mask-exceptions! mask-float-exceptions 1) + (flo:unmask-exceptions! unmask-float-exceptions 1) + (flo:unmaskable-exceptions unmaskable-float-exceptions 0)) + +(define (flo:default-exception-mask) + ;; By default, we unmask the standard IEEE 754 exceptions that Scheme + ;; can safely run with, in order to report errors as soon as they + ;; happen. Scheme cannot safely run with the inexact result + ;; exception (which you almost never want *trapping* anyway), and + ;; there are some non-standard exceptions which we will mask in order + ;; to keep behaviour consistent between host systems. + (fix:andc (flo:supported-exceptions) + (fix:or (fix:or (flo:exception:divide-by-zero) + (flo:exception:invalid-operation)) + (fix:or (flo:exception:overflow) + (flo:exception:underflow))))) + +(define (flo:with-exception-mask exceptions procedure) + (flo:preserving-environment + (lambda () + (flo:set-masked-exceptions! exceptions) + (procedure)))) + +(define (flo:with-exceptions-masked exceptions procedure) + (flo:preserving-environment + (lambda () + (flo:mask-exceptions! exceptions) + (procedure)))) + +;++ Include machine-dependent bits, by number rather than by name. + +(define (flo:exceptions->names exceptions) + (define (n name bits tail) + (if (fix:zero? (fix:and bits exceptions)) + tail + (cons name tail))) + (guarantee-index-fixnum exceptions 'FLO:EXCEPTIONS->NAMES) + (if (not (fix:zero? (fix:andc exceptions (flo:supported-exceptions)))) + (error:bad-range-argument exceptions 'FLO:EXCEPTIONS->NAMES)) + (n 'DIVIDE-BY-ZERO (flo:exception:divide-by-zero) + (n 'INEXACT-RESULT (flo:exception:inexact-result) + (n 'INVALID-OPERATION (flo:exception:invalid-operation) + (n 'OVERFLOW (flo:exception:overflow) + (n 'UNDERFLOW (flo:exception:underflow) + '())))))) + +(define (flo:names->exceptions names) + (define (name->exceptions name) + (case name + ((DIVIDE-BY-ZERO) (flo:exception:divide-by-zero)) + ((INEXACT-RESULT) (flo:exception:inexact-result)) + ((INVALID-OPERATION) (flo:exception:invalid-operation)) + ((OVERFLOW) (flo:exception:overflow)) + ((UNDERFLOW) (flo:exception:underflow)) + (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))) \ No newline at end of file diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 823a555e2..0c782b335 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -476,6 +476,8 @@ USA. ((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!) ;; System dependent stuff ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!) + ;; Floating-point environment -- needed by threads. + (RUNTIME FLOATING-POINT-ENVIRONMENT) ;; Threads (RUNTIME THREAD) ;; I/O @@ -582,5 +584,8 @@ USA. ) (package/add-child! system-global-package 'USER user-initial-environment) +;; Might be better to do this sooner, to trap on floating-point +;; mistakes earlier in the cold load. +(flo:set-environment! (flo:default-environment)) (start-thread-timer) (initial-top-level-repl) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 15edbc165..a5c64c8a4 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -242,9 +242,6 @@ USA. flo:positive? flo:round flo:round->exact - flo:rounding-mode - flo:rounding-modes - flo:set-rounding-mode! flo:sin flo:sqrt flo:tan @@ -254,7 +251,6 @@ USA. flo:vector-length flo:vector-ref flo:vector-set! - flo:with-rounding-mode flo:zero? guarantee-fixnum guarantee-index-fixnum @@ -288,6 +284,48 @@ USA. non-positive-fixnum? positive-fixnum?)) +(define-package (runtime floating-point-environment) + (files "floenv") + (parent (runtime)) + (export () + flo:clear-exceptions! + flo:default-environment + flo:default-exception-mask + flo:default-rounding-mode + flo:defer-exceptions! + flo:deferring-exceptions + flo:environment + flo:exception:divide-by-zero + flo:exception:inexact-result + flo:exception:invalid-operation + flo:exception:overflow + flo:exception:underflow + flo:exceptions->names + flo:ignoring-exceptions + flo:mask-exceptions! + flo:masked-exceptions + flo:names->exceptions + flo:preserving-environment + flo:raise-exceptions! + flo:restore-exception-flags! + flo:rounding-mode + flo:rounding-modes + flo:save-exception-flags + flo:set-environment! + flo:set-masked-exceptions! + flo:set-rounding-mode! + flo:supported-exceptions + flo:test-exception-flags + flo:test-exceptions + flo:unmask-exceptions! + flo:unmaskable-exceptions + flo:update-environment! + flo:with-default-environment + flo:with-exception-mask + flo:with-exceptions-masked + flo:with-rounding-mode) + (initialization (initialize-package!))) + (define-package (runtime integer-bits) (files "integer-bits") (parent (runtime)) @@ -1304,6 +1342,7 @@ USA. continuation/block-thread-events? continuation/control-point continuation/dynamic-state + continuation/floating-point-environment continuation? error:not-continuation guarantee-continuation @@ -1335,6 +1374,7 @@ USA. stack-frame/compiled-code? stack-frame/dynamic-state stack-frame/elements + stack-frame/floating-point-environment stack-frame/interrupt-mask stack-frame/length stack-frame/next @@ -1680,10 +1720,14 @@ USA. condition-type:error condition-type:file-error condition-type:file-operation-error + condition-type:floating-point-divide-by-zero condition-type:floating-point-overflow condition-type:floating-point-underflow condition-type:illegal-datum condition-type:illegal-pathname-component + condition-type:inexact-floating-point-result + condition-type:integer-divide-by-zero + condition-type:invalid-floating-point-operation condition-type:macro-binding condition-type:no-such-restart condition-type:not-8-bit-char diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 40d52be22..7eb801a12 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -68,6 +68,9 @@ USA. ;; Root state-point of the local state space of the thread. Used to ;; unwind the thread's state space when it is exited. + (floating-point-environment #f) + ;; Thread-local floating-point environment. + (mutexes '()) ;; List of mutexes that this thread owns or is waiting to own. Used ;; to disassociate the thread from those mutexes when it is exited. @@ -106,6 +109,7 @@ USA. (define (make-thread continuation) (let ((thread (%make-thread))) (set-thread/continuation! thread continuation) + (set-thread/floating-point-environment! thread (flo:default-environment)) (set-thread/root-state-point! thread (current-state-point state-space:local)) (add-to-population!/unsafe thread-population thread) @@ -218,10 +222,13 @@ USA. (wait-for-io)))) (define (run-thread thread) - (let ((continuation (thread/continuation thread))) + (let ((continuation (thread/continuation thread)) + (fp-env (thread/floating-point-environment thread))) (set-thread/continuation! thread #f) + (set-thread/floating-point-environment! thread #f) (%within-continuation continuation #t (lambda () + (flo:set-environment! fp-env) (%resume-current-thread thread))))) (define (%resume-current-thread thread) @@ -237,7 +244,8 @@ USA. (define (%suspend-current-thread) (call-with-current-thread #f (lambda (thread) - (let ((block-events? (thread/block-events? thread))) + (let ((fp-env (flo:environment)) + (block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #f) (maybe-signal-io-thread-events) (let ((any-events? (handle-thread-events thread))) @@ -247,6 +255,7 @@ USA. (call-with-current-continuation (lambda (continuation) (set-thread/continuation! thread continuation) + (set-thread/floating-point-environment! thread fp-env) (set-thread/block-events?! thread #f) (thread-not-running thread 'WAITING))))))))) @@ -258,6 +267,7 @@ USA. (call-with-current-continuation (lambda (continuation) (set-thread/continuation! thread continuation) + (set-thread/floating-point-environment! thread (flo:environment)) (thread-not-running thread 'STOPPED)))))))) (define (restart-thread thread discard-events? event) @@ -282,20 +292,26 @@ USA. (set-thread/execution-state! (current-thread) 'RUNNING)) (define (thread-timer-interrupt-handler) - (set! next-scheduled-timeout #f) - (set-interrupt-enables! interrupt-mask/gc-ok) - (deliver-timer-events) - (maybe-signal-io-thread-events) - (let ((thread first-running-thread)) - (cond ((not thread) - (%maybe-toggle-thread-timer)) - ((thread/continuation thread) - (run-thread thread)) - ((not (eq? 'RUNNING-WITHOUT-PREEMPTION - (thread/execution-state thread))) - (yield-thread thread)) - (else - (%resume-current-thread thread))))) + ;; Preserve the floating-point environment here to guarantee that the + ;; thread timer won't raise or clear exceptions (particularly the + ;; inexact result exception) that the interrupted thread cares about. + (let ((fp-env (flo:environment))) + (flo:set-environment! (flo:default-environment)) + (set! next-scheduled-timeout #f) + (set-interrupt-enables! interrupt-mask/gc-ok) + (deliver-timer-events) + (maybe-signal-io-thread-events) + (let ((thread first-running-thread)) + (cond ((not thread) + (%maybe-toggle-thread-timer)) + ((thread/continuation thread) + (run-thread thread)) + ((not (eq? 'RUNNING-WITHOUT-PREEMPTION + (thread/execution-state thread))) + (yield-thread thread fp-env)) + (else + (flo:set-environment! fp-env) + (%resume-current-thread thread)))))) (define (yield-current-thread) (without-interrupts @@ -307,13 +323,20 @@ USA. (set-thread/execution-state! thread 'RUNNING) (yield-thread thread)))))) -(define (yield-thread thread) +(define (yield-thread thread #!optional fp-env) (let ((next (thread/next thread))) (if (not next) - (%resume-current-thread thread) + (begin + (if (not (default-object? fp-env)) + (flo:set-environment! fp-env)) + (%resume-current-thread thread)) (call-with-current-continuation (lambda (continuation) (set-thread/continuation! thread continuation) + (set-thread/floating-point-environment! thread + (if (default-object? fp-env) + (flo:environment) + fp-env)) (set-thread/next! thread #f) (set-thread/next! last-running-thread thread) (set! last-running-thread thread) diff --git a/src/runtime/uerror.scm b/src/runtime/uerror.scm index f00908136..556b9a905 100644 --- a/src/runtime/uerror.scm +++ b/src/runtime/uerror.scm @@ -319,26 +319,32 @@ USA. (string-replace (symbol-name error-type) #\- #\space) (string-append "error " (write-to-string error-type))))) +;++ Whattakludge! + (define (normalize-trap-code-name name) - (let loop ((prefixes '("floating-point " "integer "))) - (if (not (null? prefixes)) - (if (string-prefix-ci? (car prefixes) name) - (set! name (string-tail name (string-length (car prefixes)))) - (loop (cdr prefixes))))) - (let loop ((suffixes '(" trap" " fault"))) - (if (not (null? suffixes)) - (if (string-suffix-ci? (car suffixes) name) - (set! name - (string-head name - (- (string-length name) - (string-length (car suffixes))))) - (loop (cdr suffixes))))) - (cond ((string-ci=? "underflow" name) 'UNDERFLOW) - ((string-ci=? "overflow" name) 'OVERFLOW) - ((or (string-ci=? "divide by 0" name) - (string-ci=? "divide by zero" name)) + (cond ((or (string-prefix-ci? "integer divide by 0" name) + (string-prefix-ci? "integer divide by zero" name)) + 'INTEGER-DIVIDE-BY-ZERO) + ((or (string-prefix-ci? "floating-point divide by 0" name) + (string-prefix-ci? "floating-point divide by zero" name)) + 'FLOATING-POINT-DIVIDE-BY-ZERO) + ((or (string-prefix-ci? "divide by 0" name) + (string-prefix-ci? "divide by zero" name)) 'DIVIDE-BY-ZERO) - (else false))) + ((or (string-prefix-ci? "inexact result" name) + (string-prefix-ci? "inexact operation" name) + (string-prefix-ci? "floating-point inexact result" name)) + 'INEXACT-RESULT) + ((or (string-prefix-ci? "invalid operation" name) + (string-prefix-ci? "invalid floating-point operation" name)) + 'INVALID-OPERATION) + ((or (string-prefix-ci? "overflow" name) + (string-prefix-ci? "floating-point overflow" name)) + 'OVERFLOW) + ((or (string-prefix-ci? "underflow" name) + (string-prefix-ci? "floating-point underflow" name)) + 'UNDERFLOW) + (else #f))) (define (file-primitive-description primitive) (cond ((or (eq? primitive (ucode-primitive file-exists? 1)) @@ -985,22 +991,35 @@ USA. "User microcode reset")) (set! hook/hardware-trap - (let ((signal-user-microcode-reset - (condition-signaller condition-type:user-microcode-reset '())) + (let ((signal-arithmetic-error + (condition-signaller condition-type:arithmetic-error + '(OPERATOR OPERANDS))) (signal-divide-by-zero (condition-signaller condition-type:divide-by-zero '(OPERATOR OPERANDS))) + (signal-floating-point-divide-by-zero + (condition-signaller condition-type:floating-point-divide-by-zero + '(OPERATOR OPERANDS))) (signal-floating-point-overflow (condition-signaller condition-type:floating-point-overflow '(OPERATOR OPERANDS))) (signal-floating-point-underflow (condition-signaller condition-type:floating-point-underflow '(OPERATOR OPERANDS))) - (signal-arithmetic-error - (condition-signaller condition-type:arithmetic-error - '(OPERATOR OPERANDS))) (signal-hardware-trap - (condition-signaller condition-type:hardware-trap '(NAME CODE)))) + (condition-signaller condition-type:hardware-trap '(NAME CODE))) + (signal-inexact-floating-point-result + (condition-signaller condition-type:inexact-floating-point-result + '(OPERATOR OPERANDS))) + (signal-integer-divide-by-zero + (condition-signaller condition-type:integer-divide-by-zero + '(OPERATOR OPERANDS))) + (signal-invalid-floating-point-operation + (condition-signaller + condition-type:invalid-floating-point-operation + '(OPERATOR OPERANDS))) + (signal-user-microcode-reset + (condition-signaller condition-type:user-microcode-reset '()))) (lambda (name) (call-with-current-continuation (lambda (k) @@ -1013,12 +1032,15 @@ USA. ((or (string=? "XCPT_FLOAT_OVERFLOW" name) (string=? "XCPT_INTEGER_OVERFLOW" name)) (signal-floating-point-overflow k #f '())) - ((or (string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name) - (string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name)) - (signal-divide-by-zero k #f '())) + ((string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name) + (signal-floating-point-divide-by-zero k #f '())) + ((string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name) + (signal-integer-divide-by-zero k #f '())) + ((string=? "XCPT_FLOAT_INEXACT_RESULT" name) + (signal-inexact-floating-point-result k #f '())) + ((string=? "XCPT_FLOAT_INVALID_OPERATION" name) + (signal-invalid-floating-point-operation k #f '())) ((or (string=? "XCPT_FLOAT_DENORMAL_OPERAND" name) - (string=? "XCPT_FLOAT_INEXACT_RESULT" name) - (string=? "XCPT_FLOAT_INVALID_OPERATION" name) (string=? "XCPT_FLOAT_STACK_CHECK" name) (string=? "XCPT_B1NPX_ERRATA_02" name)) (signal-arithmetic-error k #f '())) @@ -1032,14 +1054,20 @@ USA. (if (string=? "SIGFPE" name) ((case (and (string? code) (normalize-trap-code-name code)) - ((UNDERFLOW) signal-floating-point-underflow) - ((OVERFLOW) signal-floating-point-overflow) ((DIVIDE-BY-ZERO) signal-divide-by-zero) + ((FLOATING-POINT-DIVIDE-BY-ZERO) + signal-floating-point-divide-by-zero) + ((INEXACT-RESULT) + signal-inexact-floating-point-result) + ((INTEGER-DIVIDE-BY-ZERO) + signal-integer-divide-by-zero) + ((INVALID-OPERATION) + signal-invalid-floating-point-operation) + ((OVERFLOW) signal-floating-point-overflow) + ((UNDERFLOW) signal-floating-point-underflow) (else signal-arithmetic-error)) - k false '()) - (signal-hardware-trap k - name - code))))))))))) + k #f '()) + (signal-hardware-trap k name code))))))))))) ;;; end INITIALIZE-PACKAGE!. ) \ No newline at end of file diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm new file mode 100644 index 000000000..21045ca04 --- /dev/null +++ b/tests/runtime/test-floenv.scm @@ -0,0 +1,457 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests of the floating-point environment + +(declare (usual-integrations)) + +(define-test 'FLO:DEFAULT-ROUNDING-MODE + (lambda () + (assert-eqv (flo:default-rounding-mode) 'TO-NEAREST))) + +(define-test 'FLO:ROUNDING-MODES + (lambda () + (assert-eqv + (lset-difference eq? + (flo:rounding-modes) + '(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD)) + '()))) + +(define-test 'FLO:ROUNDING-MODE + (lambda () + (assert-memv (flo:rounding-mode) (flo:rounding-modes)))) + +(define (for-each-rounding-mode receiver) + (for-each receiver '(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD))) + +(for-each-rounding-mode + (lambda (mode) + (define-test (symbol-append 'FLO:SET-ROUNDING-MODE ': mode) + (lambda () + (let ((mode* (flo:rounding-mode))) + (dynamic-wind (lambda () (flo:set-rounding-mode! mode)) + (lambda () (assert-eqv (flo:rounding-mode) mode)) + (lambda () (flo:set-rounding-mode! mode*))) + (assert-eqv (flo:rounding-mode) mode*)))))) + +(for-each-rounding-mode + (lambda (mode) + (define-test (symbol-append 'FLO:WITH-ROUNDING-MODE ': mode) + (lambda () + (let ((mode* (flo:rounding-mode))) + (flo:with-rounding-mode mode + (lambda () + (assert-eqv (flo:rounding-mode) mode))) + (assert-eqv (flo:rounding-mode) mode*)))))) + +(for-each-rounding-mode + (lambda (mode) + (define inputs '(-2.0 -1.5 -1.0 -0.5 -0.0 0.0 0.5 1.0 1.5 2.0)) + (define (define-rounding-test name operator outputs) + (define-test (symbol-append 'ROUNDING-MODE-INDEPENDENT ': mode '/ name) + (lambda () + (do ((inputs inputs (cdr inputs)) + (outputs outputs (cdr outputs)) + (i 0 (+ i 1))) + ((not (and (pair? inputs) (pair? outputs)))) + (let ((input (car inputs)) (output (car outputs))) + (run-sub-test + (lambda () + (assert-eqv + (flo:with-rounding-mode mode (lambda () (operator input))) + output)))))))) + (define-rounding-test 'CEILING ceiling + '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 1.0 1.0 2.0 2.0)) + (define-rounding-test 'FLOOR floor + '(-2.0 -2.0 -1.0 -1.0 -0.0 0.0 0.0 1.0 1.0 2.0)) + (define-rounding-test 'ROUND round + '(-2.0 -2.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 2.0 2.0)) + (define-rounding-test 'TRUNCATE truncate + '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 1.0 2.0)))) + +;++ Add tests for rounding-mode-dependent operations... + +(define floating-point-exception-descriptors '()) + +(define (no-op x) x) ;Do not integrate! + +(define (define-fpe-descriptor name unmaskable? exception condition-type) + (let ((descriptor (list name exception condition-type unmaskable? '()))) + (cond ((assq name floating-point-exception-descriptors) + => (lambda (descriptor*) + (set-cdr! descriptor* (cdr descriptor)))) + (else + (set! floating-point-exception-descriptors + (cons descriptor floating-point-exception-descriptors)) + unspecific)))) + +(define (define-fpe-elicitor name elicitor-name procedure) + (cond ((assq name floating-point-exception-descriptors) + => (lambda (descriptor) + (let ((elicitors (list-ref descriptor 4))) + (cond ((assq elicitor-name elicitors) + => (lambda (pair) (set-cdr! pair procedure))) + (else + (set-car! (list-tail descriptor 4) + (cons (cons elicitor-name procedure) + elicitors))))))) + (else + (error:bad-range-argument name 'DEFINE-FPE-ELICITOR)))) + +(define (for-each-exception receiver) + (for-each (lambda (descriptor) + (apply receiver descriptor)) + floating-point-exception-descriptors)) + +(define (for-each-unmaskable-exception receiver) + (for-each-exception + (lambda (name exception condition-type unmaskable? elicitors) + (if unmaskable? + (receiver name exception condition-type elicitors))))) + +(define (for-each-exception-elicitor receiver) + (for-each-exception + (lambda (name exception condition-type unmaskable? elicitors) + (for-each (lambda (name.elicitor) + (receiver name exception condition-type unmaskable? + (car name.elicitor) + (cdr name.elicitor))) + elicitors)))) + +(define (for-each-unmaskable-exception-elicitor receiver) + (for-each-unmaskable-exception + (lambda (name exception condition-type elicitors) + (for-each (lambda (name.elicitor) + (receiver name exception condition-type + (car name.elicitor) + (cdr name.elicitor))) + elicitors)))) + +(define-fpe-descriptor 'DIVIDE-BY-ZERO #t flo:exception:divide-by-zero + condition-type:floating-point-divide-by-zero) + +(define-fpe-elicitor 'DIVIDE-BY-ZERO 'RAISE + (lambda () (flo:raise-exceptions! (flo:exception:divide-by-zero)))) + +(define-fpe-elicitor 'DIVIDE-BY-ZERO 'POSITIVE-ONE-OVER-ZERO + (lambda () (flo:/ (no-op +1.) (no-op 0.)))) + +(define-fpe-elicitor 'DIVIDE-BY-ZERO 'NEGATIVE-ONE-OVER-ZERO + (lambda () (flo:/ (no-op -1.) (no-op 0.)))) + +(define-fpe-elicitor 'DIVIDE-BY-ZERO 'LOG-ZERO + (lambda () (flo:log (no-op 0.)))) + +(define-fpe-descriptor 'INEXACT-RESULT #f flo:exception:inexact-result + condition-type:inexact-floating-point-result) + +(define-fpe-elicitor 'INEXACT-RESULT 'RAISE + (lambda () (flo:raise-exceptions! (flo:exception:inexact-result)))) + +(define-fpe-elicitor 'INEXACT-RESULT 'ONE-PLUS-EPSILON-OVER-TWO + (lambda () + (flo:+ (no-op 1.) (flo:* (no-op .5) microcode-id/floating-epsilon)))) + +(define-fpe-descriptor 'INVALID-OPERATION #t flo:exception:invalid-operation + condition-type:invalid-floating-point-operation) + +(define-fpe-elicitor 'INVALID-OPERATION 'RAISE + (lambda () (flo:raise-exceptions! (flo:exception:invalid-operation)))) + +(define-fpe-elicitor 'INVALID-OPERATION 'ZERO-OVER-ZERO + (lambda () + (flo:/ (no-op 0.) (no-op 0.)))) + +(define-fpe-descriptor 'OVERFLOW #t flo:exception:overflow + condition-type:floating-point-overflow) + +(define-fpe-elicitor 'OVERFLOW 'RAISE + (lambda () (flo:raise-exceptions! (flo:exception:overflow)))) + +;++ The maximum and minimum exponents should not be hard-coded here. + +(define-fpe-elicitor 'OVERFLOW 'MOST-POSITIVE-NUMBER-TIMES-TWO + (let ((flo:shift (make-primitive-procedure 'FLONUM-DENORMALIZE 2))) + (lambda () + (flo:* (no-op 2.) (flo:shift (no-op 1.) 1023))))) + +(define-fpe-descriptor 'UNDERFLOW #t flo:exception:underflow + condition-type:floating-point-underflow) + +(define-fpe-elicitor 'UNDERFLOW 'RAISE + (lambda () (flo:raise-exceptions! (flo:exception:underflow)))) + +(define-fpe-elicitor 'UNDERFLOW 'LEAST-POSITIVE-NUMBER-OVER-TWO + (let ((flo:shift (make-primitive-procedure 'FLONUM-DENORMALIZE 2))) + (lambda () + ;; Problem: On every machine I tested (several different models + ;; of each of x87, amd64, and sparc), if this doesn't trap, it + ;; doesn't set the underflow exception flag either. So all tests + ;; relying on the exception flag will fail. + (flo:* (no-op .5) (flo:shift (no-op 1.) -1022))))) + +(define (for-each-unmaskable-exception receiver) + (for-each-exception + (lambda (name exception condition-type unmaskable? elicitors) + (if unmaskable? (receiver name exception condition-type elicitors))))) + +(for-each-exception + (lambda (name exception condition-type unmaskable? elicitors) + condition-type unmaskable? elicitors ;ignore + (define-test (symbol-append 'FLO:EXCEPTIONS->NAMES ': name) + (lambda () + (assert-equal (flo:exceptions->names (exception)) (list name)))) + (define-test (symbol-append 'FLO:NAMES->EXCEPTIONS ': name) + (lambda () + (assert-equal (flo:names->exceptions (list name)) (exception)))))) + +(define-test 'FLO:EXCEPTIONS->NAMES + (lambda () + (let ((descriptors floating-point-exception-descriptors)) + (assert-equal + (lset-difference + eq? + (flo:exceptions->names + (reduce fix:or 0 (map (lambda (f) (f)) (map cadr descriptors)))) + (map car descriptors)) + '())))) + +(define-test 'FLO:NAMES->EXCEPTIONS + (lambda () + (let ((descriptors floating-point-exception-descriptors)) + (assert-eqv + (flo:names->exceptions (map car descriptors)) + (reduce fix:or 0 (map (lambda (f) (f)) (map cadr descriptors))))))) + +(define-test 'FLO:SUPPORTED-EXCEPTIONS + (lambda () + (flo:supported-exceptions))) + +(define-test 'FLO:SUPPORTED-EXCEPTION-NAMES + (lambda () + (assert-eqv + (lset-difference eq? + (flo:exceptions->names (flo:supported-exceptions)) + (map car floating-point-exception-descriptors)) + '()))) + +(define-test 'FLO:MASKED-EXCEPTIONS + (lambda () + (flo:masked-exceptions))) + +(define (define-set-masked-exceptions-test name to-mask) + (define-test (symbol-append 'FLO:SET-MASKED-EXCEPTIONS! ': name) + (lambda () + (let ((exceptions (fix:andc (flo:supported-exceptions) (to-mask))) + (mask (flo:masked-exceptions))) + (dynamic-wind + (lambda () unspecific) + (lambda () + (assert-eqv (flo:set-masked-exceptions! exceptions) mask) + (assert-eqv (flo:masked-exceptions) exceptions)) + (lambda () (flo:set-masked-exceptions! mask))))))) + +(define (define-with-exception-mask-test name to-mask) + (define-test (symbol-append 'FLO:WITH-EXCEPTION-MASK ': name) + (lambda () + (let ((exceptions (fix:andc (flo:supported-exceptions) (to-mask)))) + (flo:with-exception-mask exceptions + (lambda () + (assert-eqv (flo:masked-exceptions) exceptions))))))) + +(define-set-masked-exceptions-test 'ALL (lambda () 0)) +(define-set-masked-exceptions-test 'NONE flo:unmaskable-exceptions) + +(define-with-exception-mask-test 'ALL (lambda () 0)) +(define-with-exception-mask-test 'NONE flo:unmaskable-exceptions) + +(for-each-unmaskable-exception + (lambda (name exception condition-type elicitors) + elicitors ;ignore + (define-test (symbol-append 'FLO:WITH-EXCEPTION-MASK ': name) + (lambda () + (let ((mask (fix:andc (flo:supported-exceptions) (exception)))) + (flo:with-exception-mask mask + (lambda () + (assert-eqv (flo:masked-exceptions) mask)))))))) + +(for-each-unmaskable-exception + (lambda (name exception condition-type elicitors) + elicitors ;ignore + (define-test (symbol-append 'FLO:MASK-EXCEPTIONS! ': name) + (lambda () + (let ((mask + (fix:andc (flo:supported-exceptions) + (flo:unmaskable-exceptions)))) + (flo:with-exception-mask mask + (lambda () + (assert-eqv (flo:mask-exceptions! (exception)) mask) + (assert-eqv (flo:masked-exceptions) + (fix:or mask (exception)))))))))) + +(for-each-unmaskable-exception + (lambda (name exception condition-type elicitors) + elicitors ;ignore + (define-test (symbol-append 'FLO:UNMASK-EXCEPTIONS! ': name) + (lambda () + (flo:with-exception-mask (flo:supported-exceptions) + (lambda () + (assert-eqv (flo:unmask-exceptions! (exception)) + (flo:supported-exceptions)) + (assert-eqv (flo:masked-exceptions) + (fix:andc (flo:supported-exceptions) (exception))))))))) + +(for-each-unmaskable-exception + (lambda (name exception condition-type elicitors) + elicitors ;ignore + (define-test (symbol-append 'FLO:SET-MASKED-EXCEPTIONS! ': name ': 'ENABLE) + (lambda () + (let ((mask + (fix:andc (flo:supported-exceptions) + (flo:unmaskable-exceptions)))) + (flo:with-exception-mask (fix:or mask (exception)) + (lambda () + (assert-eqv (flo:set-masked-exceptions! mask) + (fix:or mask (exception))) + (assert-eqv (flo:masked-exceptions) mask)))))))) + +(for-each-unmaskable-exception + (lambda (name exception condition-type elicitors) + elicitors ;ignore + (define-test (symbol-append 'FLO:SET-MASKED-EXCEPTIONS! ': name ': 'DISABLE) + (lambda () + (let ((mask (fix:andc (flo:supported-exceptions) (exception)))) + (flo:with-exception-mask (flo:supported-exceptions) + (lambda () + (assert-eqv (flo:set-masked-exceptions! mask) + (flo:supported-exceptions)) + (assert-eqv (flo:masked-exceptions) mask)))))))) + +(for-each-unmaskable-exception-elicitor + (lambda (name exception condition-type elicitor-name elicitor) + (define-test (symbol-append 'ELICIT ': name ': elicitor-name) + (lambda () + (assert-error (lambda () + (flo:with-exception-mask + (fix:andc (flo:supported-exceptions) (exception)) + elicitor)) + (list condition-type)))))) + +(for-each-unmaskable-exception-elicitor + (lambda (name exception condition-type elicitor-name elicitor) + (define-test (symbol-append 'ELICIT-DEFERRED ': name ': elicitor-name) + (lambda () + (assert-error + (lambda () + (flo:with-exception-mask + (fix:andc (flo:supported-exceptions) (flo:unmaskable-exceptions)) + (lambda () + (flo:deferring-exceptions + (lambda () + (let ((flag #f)) + (dynamic-wind (lambda () unspecific) + (lambda () (elicitor) (set! flag #t)) + (lambda () (assert-true flag))))))))) + (list condition-type)))))) + +(for-each-exception-elicitor + (lambda (name exception condition-type unmaskable? elicitor-name elicitor) + unmaskable? ;ignore + (define-test (symbol-append 'ELICIT-IGNORED ': name ': elicitor-name) + (lambda () + (flo:ignoring-exceptions elicitor))))) + +(for-each-exception-elicitor + (lambda (name exception condition-type unmaskable? elicitor-name elicitor) + unmaskable? ;ignore + (define-test (symbol-append 'ELICIT-AND-TEST ': name ': elicitor-name) + (lambda () + (assert-eqv (flo:ignoring-exceptions + (lambda () + (elicitor) + (flo:test-exceptions (exception)))) + (exception)))))) + +(for-each-exception-elicitor + (lambda (name exception condition-type unmaskable? elicitor-name elicitor) + unmaskable? ;ignore + (define-test (symbol-append 'ELICIT-CLEAR-TEST ': name ': elicitor-name) + (lambda () + (assert-eqv (flo:ignoring-exceptions + (lambda () + (elicitor) + (flo:clear-exceptions! (exception)) + (flo:test-exceptions (exception)))) + 0))))) + +(define-test 'FLO:ENVIRONMENT + (lambda () + (flo:environment))) + +(define-test 'FLO:SET-ENVIRONMENT + (lambda () + (flo:set-environment! (flo:environment)))) + +(define-test 'FLO:DEFAULT-ENVIRONMENT + (lambda () + (flo:default-environment))) + +(define-test 'FLO:SET-DEFAULT-ENVIRONMENT + (lambda () + (let ((environment (flo:environment))) + (dynamic-wind + (lambda () unspecific) + (lambda () (flo:set-environment! (flo:default-environment))) + (lambda () (flo:set-environment! environment)))))) + +(define-test 'FLO:WITH-DEFAULT-ENVIRONMENT + (lambda () + (flo:with-default-environment (lambda () 0)))) + +(define (define-default-environment-test name procedure) + (define-test (symbol-append 'FLO:DEFAULT-ENVIRONMENT ': name) + (lambda () + (flo:preserving-environment + (lambda () + ;; Futz with the floating-point environment first, + ;; guaranteeing that it is not the default one. + (flo:set-rounding-mode! + (if (eq? 'UPWARD (flo:default-rounding-mode)) + 'TO-NEAREST + 'UPWARD)) + (flo:set-masked-exceptions! + (if (= (flo:supported-exceptions) (flo:default-exception-mask)) + (fix:andc (flo:supported-exceptions) + (flo:unmaskable-exceptions)) + (flo:supported-exceptions))) + (flo:with-default-environment procedure)))))) + +(define-default-environment-test 'ROUNDING-MODE + (lambda () + (assert-eqv (flo:rounding-mode) (flo:default-rounding-mode)))) + +(define-default-environment-test 'MASKED-EXCEPTIONS + (lambda () + (assert-eqv (flo:masked-exceptions) (flo:default-exception-mask)))) diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index f7b01a200..2851fe89a 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -381,6 +381,10 @@ USA. (define-for-tests assert-boolean-!= (binary-assertion (lambda (x y) (not (boolean=? x y))))) +(define-for-tests assert-memv + (binary-assertion (lambda (actual-value expected-list) + (and (memv actual-value expected-list) #t)))) + (define-for-tests (assert-error thunk condition-types . properties) (call-with-current-continuation (lambda (k) -- 2.25.1