From cf2bce7f9ef8c31a13f030dc675db30c71135fcf Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Wed, 21 Aug 2024 15:35:30 -0400 Subject: [PATCH 1/7] Use _setjmp/_longjmp everywhere so Mac doesn't get confused --- include/clasp/core/unwind.h | 8 ++++---- src/core/bytecode.cc | 4 ++-- src/core/unwind.cc | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/include/clasp/core/unwind.h b/include/clasp/core/unwind.h index 285aa30213..41e3817e6c 100644 --- a/include/clasp/core/unwind.h +++ b/include/clasp/core/unwind.h @@ -211,7 +211,7 @@ DynEnv_O::SearchStatus sjlj_unwind_search(DestDynEnv_sp dest); template T_mv funwind_protect(Protf&& protected_thunk, Cleanupf&& cleanup_thunk) { jmp_buf target; T_mv result; - if (setjmp(target)) { + if (_setjmp(target)) { // We have longjmped here. Clean up. // Remember to save return values, in case the cleanup thunk // messes with them. @@ -260,7 +260,7 @@ template T_mv funwind_protect(Protf&& protec template T_mv call_with_escape(Blockf&& block) { jmp_buf target; void* frame = __builtin_frame_address(0); - if (setjmp(target)) { + if (_setjmp(target)) { core::MultipleValues& mv = core::lisp_multipleValues(); T_mv result = mv.readFromMultipleValue0(mv.getSize()); return result; @@ -297,7 +297,7 @@ template void call_with_tagbody(Tagbodyf&& tagbody) { /* Per the standard, we can't store the result of setjmp in a variable or * anything. So we kind of fake it via the dest index we set ourselves. */ size_t index = 0; - if (setjmp(target)) + if (_setjmp(target)) index = my_thread->_UnwindDestIndex; again: try { @@ -316,7 +316,7 @@ template void call_with_tagbody(Tagbodyf&& tagbody) { template T_mv call_with_catch(T_sp tag, Catchf&& cf) { jmp_buf target; - if (setjmp(target)) { + if (_setjmp(target)) { core::MultipleValues& mv = core::lisp_multipleValues(); T_mv result = mv.readFromMultipleValue0(mv.getSize()); return result; diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index 38a44719f0..2b02cf719d 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -720,7 +720,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure vm.setreg(fp, n, env.raw_()); gctools::StackAllocate sa_ec(env, my_thread->dynEnvStackGet()); DynEnvPusher dep(my_thread, sa_ec.asSmartPtr()); - setjmp(target); + _setjmp(target); again: try { bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); @@ -1268,7 +1268,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi vm.setreg(fp, n, env.raw_()); gctools::StackAllocate sa_ec(env, my_thread->dynEnvStackGet()); DynEnvPusher dep(my_thread, sa_ec.asSmartPtr()); - setjmp(target); + _setjmp(target); again: try { bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); diff --git a/src/core/unwind.cc b/src/core/unwind.cc index 21a1cb1649..38f7dffc55 100644 --- a/src/core/unwind.cc +++ b/src/core/unwind.cc @@ -89,7 +89,7 @@ void sjlj_unwind_invalidate(DestDynEnv_sp dest) { thread->dynEnvStackSet(CONS_CDR(iter)); else thread->dynEnvStackSet(iter); - longjmp(*(dest->target), index); + _longjmp(*(dest->target), index); } else { thread->dynEnvStackSet(iter); diter->proceed(); @@ -99,7 +99,7 @@ void sjlj_unwind_invalidate(DestDynEnv_sp dest) { [[noreturn]] void UnwindProtectDynEnv_O::proceed() { my_thread->dynEnvStackSet(CONS_CDR(my_thread->dynEnvStackGet())); - longjmp(*(this->target), 1); // 1 irrelevant + _longjmp(*(this->target), 1); // 1 irrelevant } void BindingDynEnv_O::proceed() { this->cell->unbind(this->old); } From ec57d8bb7a4473db013c27022b4768cf8a85eaa8 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sun, 11 Aug 2024 10:53:19 -0400 Subject: [PATCH 2/7] Enable floating point exceptions --- include/clasp/core/exceptions.h | 3 - include/clasp/core/foundation.h | 35 +++++ include/clasp/core/fp_env.h | 85 ------------ include/clasp/core/lisp.h | 5 +- include/clasp/core/numbers.h | 70 +++++++++- include/clasp/core/object.h | 6 +- src/analysis/clasp_gc.sif | 2 + src/analysis/clasp_gc_cando.sif | 2 + src/core/bignum.cc | 4 +- src/core/corePackage.cc | 11 ++ src/core/cscript.lisp | 1 - src/core/fp_env.cc | 43 ------ src/core/hashTable.cc | 18 ++- src/core/lisp.cc | 4 +- src/core/num_co.cc | 10 +- src/core/numbers.cc | 75 +++++------ src/core/random.cc | 8 +- src/gctools/interrupt.cc | 126 ++++++++---------- src/lisp/kernel/lsp/claspmacros.lisp | 32 ++--- src/lisp/regression-tests/float-features.lisp | 19 +-- src/lisp/regression-tests/numbers.lisp | 48 ++++--- src/lisp/regression-tests/read01.lisp | 59 ++++---- .../ansi-test-expected-failures.sexp | 17 --- 23 files changed, 320 insertions(+), 363 deletions(-) delete mode 100644 include/clasp/core/fp_env.h delete mode 100644 src/core/fp_env.cc diff --git a/include/clasp/core/exceptions.h b/include/clasp/core/exceptions.h index 9469ceb34c..7f72012416 100644 --- a/include/clasp/core/exceptions.h +++ b/include/clasp/core/exceptions.h @@ -463,7 +463,6 @@ void assert_failure_bounds_error_lt(const char* file, size_t line, const char* f if (!(x)) \ ::core::assert_failure(__FILE__, __LINE__, __FUNCTION__, #x) #define ASSERT(x) lisp_ASSERT(x) -#define ENSURE_NOT_NAN(x) unlikely_if(std::isnan(x)) core::lisp_floating_point_invalid_operation(); #define ASSERT_DO(x) \ do { \ x; \ @@ -526,8 +525,6 @@ void assert_failure_bounds_error_lt(const char* file, size_t line, const char* f {} #define ASSERT(x) \ {} -#define ENSURE_NOT_NAN(x) \ - {} #define lisp_ASSERTP(l, x, e) \ {} #define ASSERTP(x, e) \ diff --git a/include/clasp/core/foundation.h b/include/clasp/core/foundation.h index 9d72a36f5b..dd48065d62 100644 --- a/include/clasp/core/foundation.h +++ b/include/clasp/core/foundation.h @@ -56,6 +56,41 @@ namespace core { [[noreturn]] void lisp_error_simple(const char* functionName, const char* fileName, int lineNumber, const std::string& str); void lisp_debugLogWrite(const char* fileName, const char* funcName, uint lineNumber, uint column, const std::string& message, uint debugFlags = DEBUG_CPP_FUNCTION); + +template struct float_convert { + static constexpr uint16_t significand_width = std::numeric_limits::digits; + static constexpr uint16_t exponent_width = std::bit_width((unsigned int)std::numeric_limits::max_exponent); + static constexpr uint16_t sign_width = 1; + static constexpr bool has_hidden_bit = ((sign_width + exponent_width + significand_width) % 8) != 0; + static constexpr uint16_t storage_width = sign_width + exponent_width + significand_width + ((has_hidden_bit) ? -1 : 0); + static constexpr int32_t exponent_bias = std::numeric_limits::max_exponent + significand_width - 2; + using uint_t = + std::conditional_t>>>; + static constexpr uint16_t exponent_shift = storage_width - sign_width - exponent_width; + static constexpr uint16_t sign_shift = storage_width - sign_width; + static constexpr uint_t significand_mask = (uint_t{1} << (significand_width + ((has_hidden_bit) ? -1 : 0))) - uint_t{1}; + static constexpr uint_t exponent_mask = ((uint_t{1} << exponent_width) - uint_t{1}) << exponent_shift; + static constexpr uint_t sign_mask = ((uint_t{1} << sign_width) - uint_t{1}) << sign_shift; + + typedef union { + Float f; + uint_t b; + } convert_t; + + static inline uint_t to_bits(Float f) { + convert_t convert = {.f = f}; + return convert.b; + } + + static inline Float from_bits(uint_t b) { + convert_t convert = {.b = b}; + return convert.f; + } +}; + }; // namespace core template struct fmt::formatter : fmt::formatter> { diff --git a/include/clasp/core/fp_env.h b/include/clasp/core/fp_env.h deleted file mode 100644 index ad0f21bf31..0000000000 --- a/include/clasp/core/fp_env.h +++ /dev/null @@ -1,85 +0,0 @@ -#pragma once -/* -Utilities for dealing with the FPU environment. -In Lisp we want floating point problems (overflow, etc) to be indicated -by conditions being signaled. -On some (many?) systems, including x86-64 POSIX (our only one right now), -we have an FPU that can be configured to trigger a hardware interrupt in -these situations, and an OS that receives the hardware interrupt and -in turn triggers a software interrupt to Lisp - e.g., SIGFPE. -Unfortunately, C and POSIX do not standardize any of this trap behavior, -so it's a bit of a mess. -TODO: Rounding mode stuff should go here too. -*/ - -// NOTE: IMPORTANT NOTE: None of this works at the moment. -// Some day. - -/** // support is nonexistent at the moment - -#include // needed for _TARGET, indirectly -#include -#ifdef _TARGET_OS_DARWIN -#include -#endif - -*/ - -/* Our model for traps is as follows: - * The FPU has a bit flags register. - * Each kind of exception has some flag, and we can bitwise OR - * flags together. - * If a flag is set in the register, that exception is "masked"- - * the FPU does NOT interrupt execution if it's run into, and - * instead just returns a NaN or whatever. - * clasp_feenableexcept UNmasks the given exceptions; exceptions - * it doesn't flag are masked. - */ - -/** // still commenting stuff out - -// FIXME: Add arch-specific flags (mostly denormals I think) - -// These are the flags for FPU traps. -// CLASP_FPT_SUPPORT indicates we can deal with traps at all. -#ifdef _TARGET_OS_LINUX -#define CLASP_FPT_SUPPORT -// FE_etc. are all required to exist by C++11. -#define CLASP_FPT_DIVBYZERO FE_DIVBYZERO -#define CLASP_FPT_INEXACT FE_INEXACT -#define CLASP_FPT_INVALID FE_INVALID -#define CLASP_FPT_OVERFLOW FE_OVERFLOW -#define CLASP_FPT_UNDERFLOW FE_UNDERFLOW -#define clasp_feenablexcept(flags) feenableexcept(flags) -#define clasp_fegetexcept() fegetexcept() -#elif defined(_TARGET_OS_DARWIN) // FIXME: indicate x86-64 only -#define CLASP_FPT_SUPPORT -// On Darwin all floating point operations use SSE, -// so we use those flags. -// Semantics are that if a mask bit is 1, the default, -// the exception is masked. -#define CLASP_FPT_DIVBYZERO _MM_MASK_DIV_ZERO -#define CLASP_FPT_INEXACT _MM_MASK_INEXACT -#define CLASP_FPT_INVALID _MM_MASK_INVALID -#define CLASP_FPT_OVERFLOW _MM_MASK_OVERFLOW -#define CLASP_FPT_UNDERFLOW _MM_MASK_UNDERFLOW -// NOTE: As documented by Intel, the _MM_MASK_MASK& shouldn't -// be necessary, but it seems to be - without it we can touch -// bits we're not allowed to, triggering a segfault. -#define clasp_feenableexcept(flags)\ - _MM_SET_EXCEPTION_MASK(_MM_MASK_MASK & ~(flags)) -#define clasp_fegetexcept() _MM_GET_EXCEPTION_MASK() -#endif // no support - -#ifdef CLASP_FPT_SUPPORT -// This is the initial disposition we want for Lisp. -#define CLASP_FPT_INIT_EXCEPT \ - (CLASP_FPT_DIVBYZERO | CLASP_FPT_INVALID \ - | CLASP_FPT_OVERFLOW | CLASP_FPT_UNDERFLOW) -#endif - -**/ // everything commented out - -// Function called from image initialization to set the flags to -// CLASP_FPT_INIT_EXCEPT -void init_float_traps(void); diff --git a/include/clasp/core/lisp.h b/include/clasp/core/lisp.h index 61dc1fecbc..af1d07c9a6 100644 --- a/include/clasp/core/lisp.h +++ b/include/clasp/core/lisp.h @@ -379,6 +379,7 @@ class Lisp { bool _MpiEnabled; int _MpiRank; int _MpiSize; + int _TrapFpeBits; // Current FPE traps needed for restoration in SIGFPE for amd64. /*! Keep track of every new environment that is created */ std::atomic _EnvironmentId; @@ -451,8 +452,8 @@ class Lisp { void setFileScope(const string& fileName, FileScope_sp fileInfo); public: - /*! Takes the place of ECL trap_fpe_bits - for now trap everything */ - int trapFpeBits() { return ~0; }; + int getTrapFpeBits() { return _TrapFpeBits; }; + void setTrapFpeBits(int bits) { _TrapFpeBits = bits; } public: #if 0 diff --git a/include/clasp/core/numbers.h b/include/clasp/core/numbers.h index 1ef6314b59..963d8e4e77 100644 --- a/include/clasp/core/numbers.h +++ b/include/clasp/core/numbers.h @@ -30,6 +30,7 @@ #include #include #include +#include #pragma GCC diagnostic push // #pragma GCC diagnostic ignored "-Wunused-local-typedef" #pragma GCC diagnostic pop @@ -59,6 +60,73 @@ #define CLASP_PI2_D 1.57079632679489661923132169163975144 #define CLASP_PI2_L 1.57079632679489661923132169163975144l +#ifdef _TARGET_OS_DARWIN + +#if defined(__aarch64__) +#define __FE_EXCEPT_SHIFT 8 +#elif defined(__amd64__) +#define __FE_EXCEPT_SHIFT 7 +#else +#error "Don't know how to provide FPE for this platform." +#endif + +#define __FE_ALL_EXCEPT FE_ALL_EXCEPT + +inline int feenableexcept(int excepts) { + static fenv_t fenv; + unsigned int new_excepts = excepts & __FE_ALL_EXCEPT; + unsigned int old_excepts = 0; + + if (fegetenv(&fenv)) { + return -1; + } + +#ifdef __aarch64__ + old_excepts = (fenv.__fpcr >> __FE_EXCEPT_SHIFT) & __FE_ALL_EXCEPT; + fenv.__fpcr |= new_excepts << __FE_EXCEPT_SHIFT; +#else + old_excepts = ~fenv.__control & __FE_ALL_EXCEPT; + fenv.__control &= ~new_excepts; + fenv.__mxcsr &= ~(new_excepts << __FE_EXCEPT_SHIFT); +#endif + + return fesetenv(&fenv) ? -1 : old_excepts; +} + +inline int fedisableexcept(int excepts) { + static fenv_t fenv; + unsigned int new_excepts = excepts & __FE_ALL_EXCEPT; + unsigned int old_excepts = 0; + + if (fegetenv(&fenv)) { + return -1; + } + +#ifdef __aarch64__ + old_excepts = (fenv.__fpcr >> __FE_EXCEPT_SHIFT) & __FE_ALL_EXCEPT; + fenv.__fpcr &= ~(new_excepts << __FE_EXCEPT_SHIFT); +#else + old_excepts = ~fenv.__control & __FE_ALL_EXCEPT; + fenv.__control |= new_excepts; + fenv.__mxcsr |= new_excepts << __FE_EXCEPT_SHIFT; +#endif + + return fesetenv(&fenv) ? -1 : old_excepts; +} + +inline int fegetexcept() { + static fenv_t fenv; + if (fegetenv(&fenv)) + return -1; +#ifdef __aarch64__ + return (fenv.__fpcr >> __FE_EXCEPT_SHIFT) & __FE_ALL_EXCEPT; +#else + return ~fenv.__control & __FE_ALL_EXCEPT; +#endif +} + +#endif + namespace cl { extern core::Symbol_sp& _sym_Integer_O; // CL:INTEGER extern core::Symbol_sp& _sym_Real_O; // CL:INTEGER @@ -400,7 +468,6 @@ class DoubleFloat_O : public Float_O { public: static DoubleFloat_sp create(double nm) { - ENSURE_NOT_NAN(nm); auto v = gctools::GC::allocate_with_default_constructor(); v->set(nm); return v; @@ -417,7 +484,6 @@ class DoubleFloat_O : public Float_O { double get() const { return this->_Value; }; Number_sp signum_() const override; Number_sp abs_() const override { - ENSURE_NOT_NAN(this->_Value); return DoubleFloat_O::create(fabs(this->_Value)); }; bool isnan_() const override { return std::isnan(this->_Value); }; // NaN is supposed to be the only value that != itself!!!! diff --git a/include/clasp/core/object.h b/include/clasp/core/object.h index 22a70e1d9e..dcb4abd9b6 100644 --- a/include/clasp/core/object.h +++ b/include/clasp/core/object.h @@ -577,7 +577,8 @@ inline void clasp_sxhash(T_sp obj, HashGenerator& hg) { hg.addValue(obj.unsafe_fixnum()); return; } else if (obj.single_floatp()) { - hg.addValue((gc::Fixnum)::std::abs((int)::floor(obj.unsafe_single_float()))); + float value = obj.unsafe_single_float(); + hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::to_bits(value)); return; } else if (obj.characterp()) { hg.addValue(obj.unsafe_character()); @@ -598,7 +599,8 @@ inline void clasp_sxhash(T_sp obj, Hash1Generator& hg) { hg.addValue(obj.unsafe_fixnum()); return; } else if (obj.single_floatp()) { - hg.addValue((gc::Fixnum)::std::abs((int)::floor(obj.unsafe_single_float()))); + float value = obj.unsafe_single_float(); + hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::to_bits(value)); return; } else if (obj.characterp()) { hg.addValue(obj.unsafe_character()); diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index 61840f7aff..e58eca049e 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -5830,6 +5830,8 @@ :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_MpiRank")} {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_MpiSize")} +{fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" + :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_TrapFpeBits")} {fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET_unsigned_int" :offset-ctype "unsigned int" :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_EnvironmentId")} diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index bce32bdb59..a3b6fb778d 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -12370,6 +12370,8 @@ :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_MpiRank")} {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_MpiSize")} +{fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" + :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_TrapFpeBits")} {fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET_unsigned_int" :offset-ctype "unsigned int" :offset-base-ctype "core::Lisp" :layout-offset-field-names ("_EnvironmentId")} diff --git a/src/core/bignum.cc b/src/core/bignum.cc index 0f5e46a2ce..393e40ab13 100644 --- a/src/core/bignum.cc +++ b/src/core/bignum.cc @@ -823,9 +823,9 @@ double next_to_double(mp_size_t len, const mp_limb_t* limbs) { return std::ldexp(((len < 0) ? -soon : soon), 64 * (size - 2)); } -float Bignum_O::as_float_() const { return static_cast(next_to_double(this->length(), this->limbs())); } +float Bignum_O::as_float_() const { return static_cast(mpz_get_d(this->mpz().get_mpz_t())); } -double Bignum_O::as_double_() const { return next_to_double(this->length(), this->limbs()); } +double Bignum_O::as_double_() const { return mpz_get_d(this->mpz().get_mpz_t()); } LongFloat Bignum_O::as_long_float_() const { return static_cast(next_to_double(this->length(), this->limbs())); } diff --git a/src/core/corePackage.cc b/src/core/corePackage.cc index a83482aa7d..46a0f42f85 100644 --- a/src/core/corePackage.cc +++ b/src/core/corePackage.cc @@ -29,6 +29,7 @@ THE SOFTWARE. #include #include #include +#include #include #include #include @@ -203,6 +204,11 @@ SYMBOL_EXPORT_SC_(CorePkg, _PLUS_run_all_function_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_standardReadtable_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_type_header_value_map_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_variant_name_PLUS_); +SYMBOL_EXPORT_SC_(CorePkg, _PLUS_fe_divbyzero_PLUS_); +SYMBOL_EXPORT_SC_(CorePkg, _PLUS_fe_inexact_PLUS_); +SYMBOL_EXPORT_SC_(CorePkg, _PLUS_fe_invalid_PLUS_); +SYMBOL_EXPORT_SC_(CorePkg, _PLUS_fe_underflow_PLUS_); +SYMBOL_EXPORT_SC_(CorePkg, _PLUS_fe_overflow_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, arguments); SYMBOL_EXPORT_SC_(CorePkg, array_out_of_bounds); SYMBOL_EXPORT_SC_(CorePkg, breakstep); @@ -565,6 +571,11 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { _sym__PLUS_bitcode_name_PLUS_->defconstant(SimpleBaseString_O::make(BITCODE_NAME)); _sym__PLUS_executable_name_PLUS_->defconstant(SimpleBaseString_O::make(EXECUTABLE_NAME)); _sym__PLUS_application_name_PLUS_->defconstant(SimpleBaseString_O::make(APP_NAME)); + _sym__PLUS_fe_divbyzero_PLUS_->defconstant(clasp_make_fixnum(FE_DIVBYZERO)); + _sym__PLUS_fe_inexact_PLUS_->defconstant(clasp_make_fixnum(FE_INEXACT)); + _sym__PLUS_fe_invalid_PLUS_->defconstant(clasp_make_fixnum(FE_INVALID)); + _sym__PLUS_fe_underflow_PLUS_->defconstant(clasp_make_fixnum(FE_UNDERFLOW)); + _sym__PLUS_fe_overflow_PLUS_->defconstant(clasp_make_fixnum(FE_OVERFLOW)); _sym_STARbuild_libSTAR->defconstant(SimpleBaseString_O::make(BUILD_LIB)); _sym_STARbuild_stlibSTAR->defconstant(SimpleBaseString_O::make(BUILD_STLIB)); _sym_STARbuild_linkflagsSTAR->defconstant(SimpleBaseString_O::make(BUILD_LINKFLAGS)); diff --git a/src/core/cscript.lisp b/src/core/cscript.lisp index ad277e4fac..0532203c0f 100644 --- a/src/core/cscript.lisp +++ b/src/core/cscript.lisp @@ -37,7 +37,6 @@ #~"num_arith.cc" #~"numberToString.cc" #~"num_co.cc" - #~"fp_env.cc" #~"load.cc" #~"bignum.cc" #~"write_object.cc" diff --git a/src/core/fp_env.cc b/src/core/fp_env.cc deleted file mode 100644 index 13aba1691f..0000000000 --- a/src/core/fp_env.cc +++ /dev/null @@ -1,43 +0,0 @@ -// Dealing with the FPU environment. Check the header for more info. - -#include -#include -#include - -void init_float_traps(void) { -#ifdef CLASP_FPT_SUPPORT - clasp_feenableexcept(CLASP_FPT_INIT_EXCEPT); -#endif -} - -namespace core { - -SYMBOL_EXPORT_SC_(CorePkg, floatTrapsSupportedP); - -CL_LAMBDA(); -CL_DECLARE(); -CL_DOCSTRING(R"dx(Are float traps supported?)dx"); -DOCGROUP(clasp); -CL_DEFUN bool core__float_traps_supported_p() { -#ifdef CLASP_FPT_SUPPORT - return 1; -#else - return 0; -#endif -} - -SYMBOL_EXPORT_SC_(CorePkg, getFloatTraps); - -CL_LAMBDA(); -CL_DECLARE(); -CL_DOCSTRING(R"dx(Get current floating point traps state.)dx"); -DOCGROUP(clasp); -CL_DEFUN int core__get_float_traps() { -#ifdef CLASP_FPT_SUPPORT - return clasp_fegetexcept(); -#else - return 0; // FIXME: warn -#endif -} - -} // namespace core diff --git a/src/core/hashTable.cc b/src/core/hashTable.cc index b16f0b8f1a..1872bfae42 100644 --- a/src/core/hashTable.cc +++ b/src/core/hashTable.cc @@ -515,7 +515,7 @@ void HashTable_O::sxhash_eql(HashGenerator& hg, T_sp obj) { return; } case gctools::single_float_tag: { - hg.addValue0(std::abs(::floor(obj.unsafe_single_float()))); + hg.addValue0(float_convert::to_bits(obj.unsafe_single_float())); return; } case gctools::character_tag: { @@ -546,8 +546,9 @@ void HashTable_O::sxhash_eql(Hash1Generator& hg, T_sp obj) { hg.addValue(obj.unsafe_fixnum()); return; } else if (obj.single_floatp()) { - if (hg.isFilling()) - hg.addValue(std::abs(::floor(obj.unsafe_single_float()))); + if (hg.isFilling()) { + hg.addValue(float_convert::to_bits(obj.unsafe_single_float())); + } return; } else if (obj.characterp()) { if (hg.isFilling()) @@ -573,8 +574,9 @@ void HashTable_O::sxhash_equal(HashGenerator& hg, T_sp obj) { hg.addValue(obj.unsafe_fixnum()); return; } else if (obj.single_floatp()) { - if (hg.isFilling()) - hg.addValue(std::abs(::floor(obj.unsafe_single_float()))); + if (hg.isFilling()) { + hg.addValue(float_convert::to_bits(obj.unsafe_single_float())); + } return; } else if (obj.characterp()) { if (hg.isFilling()) @@ -613,8 +615,10 @@ void HashTable_O::sxhash_equalp(HashGenerator& hg, T_sp obj) { hg.addValue(obj.unsafe_fixnum()); return; } else if (obj.single_floatp()) { - if (hg.isFilling()) - hg.addValue(std::abs(::floor(obj.unsafe_single_float()))); + if (hg.isFilling()) { + float value = obj.unsafe_single_float(); + hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::to_bits(value)); + } return; } else if (obj.characterp()) { if (hg.isFilling()) diff --git a/src/core/lisp.cc b/src/core/lisp.cc index c18a6d5c36..decccb26bb 100644 --- a/src/core/lisp.cc +++ b/src/core/lisp.cc @@ -202,7 +202,7 @@ Lisp::GCRoots::GCRoots() this->_SingleDispatchGenericFunctions.store(nil()); }; -Lisp::Lisp() : _Booted(false), _MpiEnabled(false), _MpiRank(0), _MpiSize(1), _BootClassTableIsValid(true) { +Lisp::Lisp() : _Booted(false), _MpiEnabled(false), _MpiRank(0), _MpiSize(1), _BootClassTableIsValid(true), _TrapFpeBits(FE_DIVBYZERO | FE_INVALID | FE_OVERFLOW) { // this->_Roots._Bindings.reserve(1024); // moved to Lisp::initialize() } @@ -564,6 +564,8 @@ void Lisp::startupLispEnvironment() { this->_Roots._PrintSymbolsProperly = true; mpip::Mpi_O::initializeGlobals(_lisp); + feenableexcept(_TrapFpeBits); + fedisableexcept(~_TrapFpeBits); _lisp->_Roots._Started = true; // diff --git a/src/core/num_co.cc b/src/core/num_co.cc index 65e2e7c06f..89536215a7 100644 --- a/src/core/num_co.cc +++ b/src/core/num_co.cc @@ -108,7 +108,7 @@ CL_DEFUN Float_sp cl__float(Real_sp x, T_sp y) { case number_Ratio: switch (ty) { case number_SingleFloat: - return clasp_make_single_float(clasp_to_double(x)); + return clasp_make_single_float(clasp_to_float(x)); case number_DoubleFloat: return clasp_make_double_float(clasp_to_double(x)); #ifdef CLASP_LONG_FLOAT @@ -317,7 +317,7 @@ static void clasp_truncate(Real_sp dividend, Real_sp divisor, Integer_sp& quotie case_SingleFloat_v_Bignum: case_SingleFloat_v_SingleFloat: case_SingleFloat_v_Ratio : { - float n = clasp_to_double(divisor); + float n = clasp_to_float(divisor); float p = dividend.unsafe_single_float() / n; float q = std::trunc(p); quotient = _clasp_float_to_integer(q); @@ -788,14 +788,14 @@ CL_DEFUN Number_sp cl__scale_float(Number_sp x, Number_sp y) { } switch (clasp_t_of(x)) { case number_SingleFloat: - x = clasp_make_single_float(ldexpf(x.unsafe_single_float(), k)); + x = clasp_make_single_float(std::ldexp(x.unsafe_single_float(), k)); break; case number_DoubleFloat: - x = clasp_make_double_float(ldexp(gc::As_unsafe(x)->get(), k)); + x = clasp_make_double_float(std::ldexp(gc::As_unsafe(x)->get(), k)); break; #ifdef CLASP_LONG_FLOAT case number_LongFloat: - x = clasp_make_long_float(ldexpl(clasp_long_float(x), k)); + x = clasp_make_long_float(std::ldexp(clasp_long_float(x), k)); break; #endif default: diff --git a/src/core/numbers.cc b/src/core/numbers.cc index b60d6c4ff3..fe1c2470f7 100644 --- a/src/core/numbers.cc +++ b/src/core/numbers.cc @@ -1531,7 +1531,9 @@ CL_DEFMETHOD Integer_sp ShortFloat_O::castToInteger() const { Number_sp ShortFloat_O::abs_() const { return ShortFloat_O::create(fabs(this->_Value)); } -void ShortFloat_O::sxhash_(HashGenerator& hg) const { hg.addValue(std::abs(::floor(this->_Value))); } +void ShortFloat_O::sxhash_(HashGenerator& hg) const { + hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::to_bits(this->_Value)); +} bool ShortFloat_O::eql_(T_sp obj) const { if (this->eq(obj)) @@ -1573,7 +1575,9 @@ CL_DEFMETHOD Integer_sp DoubleFloat_O::castToInteger() const { Number_sp DoubleFloat_O::signum_() const { return DoubleFloat_O::create(this->_Value > 0.0 ? 1 : (this->_Value < 0.0 ? -1 : 0)); } -void DoubleFloat_O::sxhash_(HashGenerator& hg) const { hg.addValue(std::abs(::floor(this->_Value))); } +void DoubleFloat_O::sxhash_(HashGenerator& hg) const { + hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::to_bits(this->_Value)); +} bool DoubleFloat_O::eql_(T_sp obj) const { if (this->eq(obj)) @@ -1630,7 +1634,9 @@ string LongFloat_O::valueAsString() const { Number_sp LongFloat_O::abs() const { return LongFloat_O::create(fabs(this->_Value)); } -void LongFloat_O::sxhash(HashGenerator& hg) const { hg.addValue(std::abs(::floor(this->_Value))); } +void LongFloat_O::sxhash(HashGenerator& hg) const { + hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::to_bits(this->_Value)); +} bool LongFloat_O::eql(T_sp obj) const { if (this->eq(obj)) @@ -1665,11 +1671,6 @@ string LongFloat_O::__repr__() const { // -------------------------------------------------------------------------------- -float Ratio_O::as_float_() const { - double d = this->as_double_(); - return d; -} - // translated from https://gitlab.com/embeddable-common-lisp/ecl/blob/develop/src/c/number.d#L663 static Integer_sp mantissa_and_exponent_from_ratio(Integer_sp num, Integer_sp den, int digits, gc::Fixnum* exponent) { /* We have to cook our own routine because GMP does not round. The @@ -1712,8 +1713,20 @@ static Integer_sp mantissa_and_exponent_from_ratio(Integer_sp num, Integer_sp de return quotient; } +float Ratio_O::as_float_() const { + gc::Fixnum exponent; + Integer_sp mantissa = + mantissa_and_exponent_from_ratio(this->_numerator, this->_denominator, std::numeric_limits::digits, &exponent); + return std::ldexp(mantissa.fixnump() ? static_cast(mantissa.unsafe_fixnum()) : mantissa->as_float_(), exponent); +} + double Ratio_O::as_double_() const { - if ((this->_numerator).fixnump() && (this->_denominator).fixnump()) { + gc::Fixnum exponent; + Integer_sp mantissa = + mantissa_and_exponent_from_ratio(this->_numerator, this->_denominator, std::numeric_limits::digits, &exponent); + return std::ldexp(mantissa.fixnump() ? static_cast(mantissa.unsafe_fixnum()) : mantissa->as_double_(), exponent); + + /*if ((this->_numerator).fixnump() && (this->_denominator).fixnump()) { double d = clasp_to_double(this->_numerator); d /= clasp_to_double(this->_denominator); return d; @@ -1725,13 +1738,15 @@ double Ratio_O::as_double_() const { output = mantissa.unsafe_fixnum(); else output = mantissa->as_double_(); - return ldexp(output, exponent); - } + return std::ldexp(output, exponent); + }*/ } LongFloat Ratio_O::as_long_float_() const { - double d = this->as_double_(); - return d; + gc::Fixnum exponent; + Integer_sp mantissa = + mantissa_and_exponent_from_ratio(this->_numerator, this->_denominator, std::numeric_limits::digits, &exponent); + return std::ldexp(mantissa.fixnump() ? static_cast(mantissa.unsafe_fixnum()) : mantissa->as_long_float_(), exponent); } string Ratio_O::__repr__() const { @@ -2924,16 +2939,7 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Return the IEEE754 binary32 (single) representation of a single float, as an integer.)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp ext__single_float_to_bits(SingleFloat_sp singleFloat) { - // NOTE: This and the later ones are probably undefined behavior, - // though Clang seems to support them fine. - // I don't know a conforming way to do this other than converting to - // bytes, but that's a pretty annoying way to go about this. - union { - float f; - uint32_t i; - } converter; - converter.f = unbox_single_float(singleFloat); - return Integer_O::create(converter.i); + return Integer_O::create(float_convert::to_bits(unbox_single_float(singleFloat))); } CL_LAMBDA(bit-representation); @@ -2941,13 +2947,8 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Convert an IEEE754 binary32 (single) representation, an integer, to a single float.)dx"); DOCGROUP(clasp); -CL_DEFUN SingleFloat_sp ext__bits_to_single_float(Fixnum_sp fixnum) { - union { - float f; - uint32_t i; - } converter; - converter.i = unbox_fixnum(fixnum); - return make_single_float(converter.f); +CL_DEFUN SingleFloat_sp ext__bits_to_single_float(Integer_sp integer) { + return make_single_float(float_convert::from_bits(clasp_to_uint32_t(integer))); }; CL_LAMBDA(doubleFloat); @@ -2956,12 +2957,7 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Return the IEEE754 binary64 (double) bit representation of a double float as an integer.)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp ext__double_float_to_bits(DoubleFloat_sp doubleFloat) { - union { - double d; - uint64_t i; - } converter; - converter.d = doubleFloat->get(); - return Integer_O::create(converter.i); + return Integer_O::create(float_convert::to_bits(doubleFloat->get())); } CL_LAMBDA(bit-representation); @@ -2970,12 +2966,7 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Convert an IEEE754 binary64 (double) representation, an integer, to a double float.)dx"); DOCGROUP(clasp); CL_DEFUN DoubleFloat_sp ext__bits_to_double_float(Integer_sp integer) { - union { - double d; - uint64_t i; - } converter; - converter.i = clasp_to_uint64_t(integer); - return clasp_make_double_float(converter.d); + return clasp_make_double_float(float_convert::from_bits(clasp_to_uint64_t(integer))); } }; // namespace core diff --git a/src/core/random.cc b/src/core/random.cc index d9708de44c..6051dce8da 100644 --- a/src/core/random.cc +++ b/src/core/random.cc @@ -95,14 +95,18 @@ CL_DEFUN T_sp cl__random(Number_sp olimit, RandomState_sp random_state) { BIGNUM_NORMALIZE(len, res); return cl__mod(bignum_result(len, res), gbn); } else if (DoubleFloat_sp df = olimit.asOrNull()) { - if (df->get() > 0.0) { + if (df->get() == DBL_TRUE_MIN) { + return DoubleFloat_O::create(0.0); + } else if (df->get() > 0.0) { std::uniform_real_distribution<> range(0.0, df->get()); return DoubleFloat_O::create(range(random_state->_Producer._value)); } else TYPE_ERROR_cl_random(olimit); } else if (olimit.single_floatp()) { float flimit = olimit.unsafe_single_float(); - if (flimit > 0.0f) { + if (flimit == FLT_TRUE_MIN) { + return clasp_make_single_float(0.0f); + } else if (flimit > 0.0f) { std::uniform_real_distribution<> range(0.0, flimit); return clasp_make_single_float(range(random_state->_Producer._value)); } else diff --git a/src/gctools/interrupt.cc b/src/gctools/interrupt.cc index 6a1a9cb8e6..4aafbc9c4e 100644 --- a/src/gctools/interrupt.cc +++ b/src/gctools/interrupt.cc @@ -3,10 +3,6 @@ #if defined(__i386__) || defined(__x86_64__) #include #endif -#ifdef __aarch64__ -#include -#include -#endif #include #include #include @@ -19,8 +15,8 @@ #include #include #include -#include #include +#include SYMBOL_EXPORT_SC_(CorePkg, terminal_interrupt); SYMBOL_EXPORT_SC_(ExtPkg, illegal_instruction); @@ -296,85 +292,44 @@ int global_signalTrap = 0; int global_pollTicksGC = INITIAL_GLOBAL_POLL_TICKS_PER_CLEANUP; DOCGROUP(clasp); -CL_DEFUN void core__disable_all_fpe_masks() { -#if defined(__i386__) || defined(__x86_64__) - _MM_SET_EXCEPTION_MASK(_MM_MASK_MASK); -#elif defined(__aarch64__) - std::fenv_t env; - std::feholdexcept(&env); -#else - printf("%s:%d:%s Add support for FPE masks for this architecture\n", __FILE__, __LINE__, __FUNCTION__); -#endif +CL_DEFUN int core__fe_enable_except(int ex) { + feclearexcept(FE_ALL_EXCEPT); + int prev = feenableexcept(ex); + _lisp->setTrapFpeBits(fegetexcept()); + return prev; } -CL_LAMBDA(&key underflow overflow inexact invalid divide-by-zero denormalized-operand); -CL_DECLARE(); -CL_DOCSTRING(R"dx(core::enable-fpe-masks)dx"); DOCGROUP(clasp); -CL_DEFUN void core__enable_fpe_masks(core::T_sp underflow, core::T_sp overflow, core::T_sp inexact, core::T_sp invalid, - core::T_sp divide_by_zero, core::T_sp denormalized_operand) { - // See https://doc.rust-lang.org/stable/core/arch/x86_64/fn._mm_setcsr.html - // mask all -> no fpe-exceptions -#if defined(__i386__) || defined(__x86_64__) - _MM_SET_EXCEPTION_MASK(_MM_MASK_MASK); - if (underflow.notnilp()) - _mm_setcsr(_mm_getcsr() & (~_MM_MASK_UNDERFLOW)); - if (overflow.notnilp()) - _mm_setcsr(_mm_getcsr() & (~_MM_MASK_OVERFLOW)); - if (inexact.notnilp()) - _mm_setcsr(_mm_getcsr() & (~_MM_MASK_INEXACT)); - if (invalid.notnilp()) - _mm_setcsr(_mm_getcsr() & (~_MM_MASK_INVALID)); - if (divide_by_zero.notnilp()) - _mm_setcsr(_mm_getcsr() & (~_MM_MASK_DIV_ZERO)); - if (denormalized_operand.notnilp()) - _mm_setcsr(_mm_getcsr() & (~_MM_MASK_DENORM)); -#elif defined(CLASP_APPLE_SILICON) - std::fenv_t env; - std::fegetenv(&env); - env.__fpcr = (underflow.notnilp() ? __fpcr_trap_underflow : 0) | (overflow.notnilp() ? __fpcr_trap_overflow : 0) | - (inexact.notnilp() ? __fpcr_trap_inexact : 0) | (invalid.notnilp() ? __fpcr_trap_invalid : 0) | - (divide_by_zero.notnilp() ? __fpcr_trap_divbyzero : 0) | (denormalized_operand.notnilp() ? __fpcr_trap_denormal : 0); - std::fesetenv(&env); -#else - printf("%s:%d:%s Add support for FPE masks for this architecture\n", __FILE__, __LINE__, __FUNCTION__); -#endif +CL_DEFUN int core__fe_disable_except(int ex) { + feclearexcept(FE_ALL_EXCEPT); + int prev = fedisableexcept(ex); + _lisp->setTrapFpeBits(fegetexcept()); + return prev; } DOCGROUP(clasp); -CL_DEFUN core::Fixnum_sp core__get_current_fpe_mask() { -#if defined(__i386__) || defined(__x86_64__) - unsigned int before = _MM_GET_EXCEPTION_MASK(); - return core::clasp_make_fixnum(before); -#elif defined(__aarch64__) - std::fenv_t env; - std::fegetenv(&env); - return core::clasp_make_fixnum(env.__fpcr); -#else - printf("%s:%d:%s Add support for FPE masks for this architecture\n", __FILE__, __LINE__, __FUNCTION__); - abort(); -#endif +CL_DEFUN int core__fe_get_except() { + return fegetexcept(); } DOCGROUP(clasp); -CL_DEFUN void core__set_current_fpe_mask(core::Fixnum_sp mask) { - Fixnum value = core::unbox_fixnum(mask); -#if defined(__i386__) || defined(__x86_64__) - _MM_SET_EXCEPTION_MASK(value); -#elif defined(__aarch64__) - std::fenv_t env; - std::fegetenv(&env); - env.__fpcr = value; - std::fesetenv(&env); -#else - printf("%s:%d:%s Add support for FPE masks for this architecture\n", __FILE__, __LINE__, __FUNCTION__); -#endif +CL_DEFUN int core__fe_restore_except(int ex) { + feclearexcept(FE_ALL_EXCEPT); + int prev = feenableexcept(ex); + fedisableexcept(~ex); + _lisp->setTrapFpeBits(fegetexcept()); + return prev; } void handle_fpe(int signo, siginfo_t* info, void* context) { (void)context; // unused - // printf("Enter handle_fpe Signo: %d Errno:%d Code:%d\n", (info->si_signo), (info->si_errno), (info->si_code)); - // init_float_traps(); // WHY + if (_lisp) { + // If _lisp has started then restore the traps that existed before the SIGFPE. This is needed on at least amd64 because the + // masked traps are reset before SIGFPE is raised. + feenableexcept(_lisp->getTrapFpeBits()); + fedisableexcept(~_lisp->getTrapFpeBits()); + } + // TODO: Get operation and operands when possible. // Probably off the call stack. switch (info->si_code) { @@ -404,6 +359,27 @@ void handle_fpe(int signo, siginfo_t* info, void* context) { } } +#ifdef CLASP_APPLE_SILICON +void handle_ill(int signo, siginfo_t* info, void* context) { + int esr; + if (info->si_code == ILL_ILLTRP && ((esr = static_cast(context)->uc_mcontext->__es.__esr) >> 26 & 0x3f) == 0x2C) { + if (esr & FE_INEXACT) { + NO_INITIALIZERS_ERROR(cl::_sym_floatingPointInexact); + } else if (esr & FE_UNDERFLOW) { + NO_INITIALIZERS_ERROR(cl::_sym_floatingPointUnderflow); + } else if (esr & FE_OVERFLOW) { + NO_INITIALIZERS_ERROR(cl::_sym_floatingPointOverflow); + } else if (esr & FE_DIVBYZERO) { + NO_INITIALIZERS_ERROR(cl::_sym_divisionByZero); + } else if (esr & FE_INVALID) { + NO_INITIALIZERS_ERROR(cl::_sym_floatingPointInvalidOperation); + } + } + + handle_signal_now(signo); +} +#endif + void handle_segv(int signo, siginfo_t* info, void* context) { (void)context; // unused core::eval::funcall(ext::_sym_segmentation_violation, core::Integer_O::create((uintptr_t)(info->si_addr))); @@ -467,8 +443,12 @@ void initialize_signals(int clasp_signal) { INIT_SIGNALI(SIGBUS, (SA_NODEFER | SA_RESTART), handle_bus); } INIT_SIGNALI(SIGFPE, (SA_NODEFER | SA_RESTART), handle_fpe); - // Handle all signals that would terminate clasp (and can be caught) +#ifdef CLASP_APPLE_SILICON + INIT_SIGNALI(SIGILL, (SA_NODEFER | SA_RESTART), handle_ill); +#else INIT_SIGNAL(SIGILL, (SA_NODEFER | SA_RESTART), handle_signal_now); +#endif + // Handle all signals that would terminate clasp (and can be caught) INIT_SIGNAL(SIGPIPE, (SA_NODEFER | SA_RESTART), handle_signal_now); INIT_SIGNAL(SIGALRM, (SA_NODEFER | SA_RESTART), handle_signal_now); INIT_SIGNAL(SIGTTIN, (SA_NODEFER | SA_RESTART), handle_signal_now); @@ -486,8 +466,6 @@ void initialize_signals(int clasp_signal) { #endif INIT_SIGNAL(SIGXFSZ, (SA_NODEFER | SA_RESTART), handle_signal_now); - // FIXME: Move? - init_float_traps(); llvm::install_fatal_error_handler(fatal_error_handler, NULL); } diff --git a/src/lisp/kernel/lsp/claspmacros.lisp b/src/lisp/kernel/lsp/claspmacros.lisp index 168cc1b367..077bc85180 100644 --- a/src/lisp/kernel/lsp/claspmacros.lisp +++ b/src/lisp/kernel/lsp/claspmacros.lisp @@ -5,27 +5,23 @@ (defmacro ext::lexical-var (name depth index) `(ext::lexical-var ,name ,depth ,index)) -;;; to work with fpe-exceptions -(defun ext::get-fpe-parameters (traps all-traps) - (ext:with-current-source-form (traps) - (let ((result nil)) - (dolist (trap all-traps) - (push trap result) - (push (if (find trap traps) nil t) result)) - (reverse result)))) - (defmacro ext:with-float-traps-masked (traps &body body) (let ((previous (gensym "PREVIOUS")) - (all-traps '(:underflow :overflow :inexact :invalid :divide-by-zero :denormalized-operand))) - (unless (subsetp traps all-traps) - (warn "Unknown float traps ~a ignored" (set-difference traps all-traps))) - `(let ((,previous (core::get-current-fpe-mask))) + (mask (reduce (lambda (bits trap) + (logior bits + (ecase trap + (:underflow core:+fe-underflow+) + (:overflow core:+fe-overflow+) + (:invalid core:+fe-invalid+) + (:inexact core:+fe-inexact+) + (:divide-by-zero core:+fe-divbyzero+) + (:denormalized-operand 0)))) + traps + :initial-value 0))) + `(let ((,previous (core:fe-disable-except ,mask))) (unwind-protect - (progn - (core::enable-fpe-masks - ,@(ext::get-fpe-parameters traps all-traps)) - ,@body) - (core::set-current-fpe-mask ,previous))))) + (progn ,@body) + (core:fe-restore-except ,previous))))) ;; ;; Some helper macros for working with iterators diff --git a/src/lisp/regression-tests/float-features.lisp b/src/lisp/regression-tests/float-features.lisp index a9cf539193..25993159cc 100644 --- a/src/lisp/regression-tests/float-features.lisp +++ b/src/lisp/regression-tests/float-features.lisp @@ -7,13 +7,10 @@ (ext:with-float-traps-masked (:divide-by-zero) (/ (bar) (foo)))))) -;;; Floating point signals are problematic right now. See #961. -#+(or) (test-expect-error float-features-1b (flet ((foo () (if (> 10 (random 20)) 0.0 0.0)) (bar () (if (> 10 (random 20)) 23 24))) - (ext:with-float-traps-masked () - (/ (bar) (foo)))) + (/ (bar) (foo))) :type division-by-zero) (defun foo-ext-1 (n) @@ -28,11 +25,9 @@ (let ((n (random 100))) (+ (foo-ext-1 n) (bar-ext-1 n)))))) -#+(or) (test-expect-error float-features-4 (let ((n (random 100))) - (ext:with-float-traps-masked () - (+ (foo-ext-1 n) (bar-ext-1 n)))) + (+ (foo-ext-1 n) (bar-ext-1 n))) :type floating-point-overflow) (defun foo-ext-2 (n) @@ -47,11 +42,9 @@ (let ((n (random 100))) (+ (foo-ext-2 n) (bar-ext-2 n)))))) -#+(or) (test-expect-error float-features-6 (let ((n (random 100))) - (ext:with-float-traps-masked () - (+ (foo-ext-2 n) (bar-ext-2 n)))) + (+ (foo-ext-2 n) (bar-ext-2 n))) :type (or floating-point-inexact floating-point-overflow)) (defun foo-ext-3 (n) @@ -66,10 +59,8 @@ (let ((n (random 100))) (/ (foo-ext-3 n) (bar-ext-3 n)))))) -#+(or) (test-expect-error float-features-8 - (ext:with-float-traps-masked () - (let ((n (random 100))) - (/ (foo-ext-3 n) (bar-ext-3 n)))) + (let ((n (random 100))) + (/ (foo-ext-3 n) (bar-ext-3 n))) :type (or floating-point-inexact floating-point-invalid-operation)) diff --git a/src/lisp/regression-tests/numbers.lisp b/src/lisp/regression-tests/numbers.lisp index 1402ab9723..271ef869f3 100644 --- a/src/lisp/regression-tests/numbers.lisp +++ b/src/lisp/regression-tests/numbers.lisp @@ -334,13 +334,19 @@ (test-true infinity-6 (ext:float-infinity-p ext:double-float-negative-infinity)) (test-true infinity-7 (ext:float-infinity-p ext:long-float-positive-infinity)) (test-true infinity-8 (ext:float-infinity-p ext:long-float-negative-infinity)) -(test-true infinity-9 (ext:float-infinity-p (+ most-positive-long-float most-positive-long-float))) +(test-true infinity-9 (ext:with-float-traps-masked (:overflow) + (ext:float-infinity-p (+ most-positive-long-float + most-positive-long-float)))) ;;; nan -(test-true nan-1 (ext:float-nan-p (/ 0s0 0s0))) -(test-true nan-2 (ext:float-nan-p (/ 0.0 0.0))) -(test-true nan-3 (ext:float-nan-p (/ 0d0 0d0))) -(test-true nan-4 (ext:float-nan-p (/ 0l0 0l0))) +(test-true nan-1 (ext:with-float-traps-masked (:invalid) + (ext:float-nan-p (/ 0s0 0s0)))) +(test-true nan-2 (ext:with-float-traps-masked (:invalid) + (ext:float-nan-p (/ 0.0 0.0)))) +(test-true nan-3 (ext:with-float-traps-masked (:invalid) + (ext:float-nan-p (/ 0d0 0d0)))) +(test-true nan-4 (ext:with-float-traps-masked (:invalid) + (ext:float-nan-p (/ 0l0 0l0)))) (test signum-1 (signum most-negative-fixnum) (-1)) @@ -350,24 +356,32 @@ (test signum-3 (SIGNUM (COMPLEX 3/5 4/5)) (#c(0.6 0.8))) (test-true sqrt-big-ratio-1 - (let ((result - (SQRT 28022395738783732117648967388274923619871355234097921/122167958641777737216225939000892255646232346624))) - (and (typep result 'float)(not (ext:float-nan-p result))))) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((result + (SQRT 28022395738783732117648967388274923619871355234097921/122167958641777737216225939000892255646232346624))) + (and (typep result 'float)(not (ext:float-nan-p result)))))) (test-true sqrt-bignum-should-fit-in-single-float-1 - (let ((result - (sqrt 28022395738783732117648967388274923619871355234097921))) - (and (typep result 'float)(not (ext:float-nan-p result))(not (ext:float-infinity-p result))))) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((result + (sqrt 28022395738783732117648967388274923619871355234097921))) + (and (typep result 'float) + (not (ext:float-nan-p result)) + (not (ext:float-infinity-p result)))))) (test-true sqrt-bignum-does-not-fit-in-single-float-overflow-1 - (let ((result - (sqrt 2802239573878373211764896738827492361987135523409792123423423468273647283642783467283643456837465347653487563847658346587346523847687324678236487234687234627834687234678236478237687623423426862843627834623846782346234239479283472934798237498273423467823642342342837468723467283462348762378462342347862344998))) - (and (typep result 'float)(ext:float-infinity-p result)))) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((result + (sqrt 2802239573878373211764896738827492361987135523409792123423423468273647283642783467283643456837465347653487563847658346587346523847687324678236487234687234627834687234678236478237687623423426862843627834623846782346234239479283472934798237498273423467823642342342837468723467283462348762378462342347862344998))) + (and (typep result 'float) + (ext:float-infinity-p result))))) (test-true sqrt-bignum-should-fit-in-single-float-overflow-2 - (let ((result - (sqrt 280223957387837321176489673882749236198713552340979212342342346827364728364278346728364345683746534765348756384765834658734652384768732467823648723468723462783468723467823647823768762342342686284362783462384678234623423947928347293479823749827342346782364234234283746872346728346234876237846234234786234499889))) - (and (typep result 'float)(ext:float-infinity-p result)))) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((result + (sqrt 280223957387837321176489673882749236198713552340979212342342346827364728364278346728364345683746534765348756384765834658734652384768732467823648723468723462783468723467823647823768762342342686284362783462384678234623423947928347293479823749827342346782364234234283746872346728346234876237846234234786234499889))) + (and (typep result 'float) + (ext:float-infinity-p result))))) ;;; the following all have &rest numbers+ in the definition, so need at least 1 argument (test-expect-error number-compare-1 (=) :type program-error) diff --git a/src/lisp/regression-tests/read01.lisp b/src/lisp/regression-tests/read01.lisp index a9b2cd02d6..345296ef04 100644 --- a/src/lisp/regression-tests/read01.lisp +++ b/src/lisp/regression-tests/read01.lisp @@ -13,21 +13,23 @@ ((1.111 1.111 1.111d0 1.111d0))) (test read-2 - (with-output-to-string (*standard-output*) - (let ((*read-default-float-format* 'single-float) - (*print-readably* nil)) - (print (read-from-string (format nil "12~40,2f" most-positive-single-float))))) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (with-output-to-string (*standard-output*) + (let ((*read-default-float-format* 'single-float) + (*print-readably* nil)) + (print (read-from-string (format nil "12~40,2f" most-positive-single-float)))))) (" #.ext:single-float-positive-infinity ")) (test-true read-3 - (string-equal - (concatenate 'string (string #\Newline) - "#.ext:double-float-positive-infinity ") - (with-output-to-string (*standard-output*) - (let ((*read-default-float-format* 'double-float) - (*print-readably* nil)) - (print (read-from-string (format nil "12~308,2f" most-positive-double-float))))))) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (string-equal + (concatenate 'string (string #\Newline) + "#.ext:double-float-positive-infinity ") + (with-output-to-string (*standard-output*) + (let ((*read-default-float-format* 'double-float) + (*print-readably* nil)) + (print (read-from-string (format nil "12~308,2f" most-positive-double-float)))))))) ;;; Reader-errors @@ -379,9 +381,10 @@ float) (test-type PRINT.SHORT-FLOAT.RANDOM.simplyfied - (let ((*read-base* 7)) - (read-from-string "2.8821837e-39")) - float) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((*read-base* 7)) + (read-from-string "2.8821837e-39"))) + float) #+kpoeck (test @@ -396,24 +399,28 @@ (write-to-string -59990859179/64657108615)))))) (test-type PRINT.SINGLE-FLOAT.RANDOM.simplyfied.1 - (let ((*READ-DEFAULT-FLOAT-FORMAT* 'SINGLE-FLOAT)) - (read-from-string "1.8218674e-39")) - single-float) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((*READ-DEFAULT-FLOAT-FORMAT* 'SINGLE-FLOAT)) + (read-from-string "1.8218674e-39"))) + single-float) (test-type PRINT.SINGLE-FLOAT.RANDOM.simplyfied.2 - (let ((*READ-DEFAULT-FLOAT-FORMAT* 'DOUBLE-FLOAT)) - (read-from-string "1.8218674e-39")) - double-float) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((*READ-DEFAULT-FLOAT-FORMAT* 'DOUBLE-FLOAT)) + (read-from-string "1.8218674e-39"))) + double-float) (test-type PRINT.SINGLE-FLOAT.RANDOM.simplyfied.3 - (let ((*READ-DEFAULT-FLOAT-FORMAT* 'short-float)) - (read-from-string "1.8218674e-39")) - short-float) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((*READ-DEFAULT-FLOAT-FORMAT* 'short-float)) + (read-from-string "1.8218674e-39"))) + short-float) (test-type PRINT.SINGLE-FLOAT.RANDOM.simplyfied.4 - (let ((*READ-DEFAULT-FLOAT-FORMAT* 'LONG-FLOAT)) - (read-from-string "1.8218674e-39")) - LONG-FLOAT) + (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) + (let ((*READ-DEFAULT-FLOAT-FORMAT* 'LONG-FLOAT)) + (read-from-string "1.8218674e-39"))) + LONG-FLOAT) (test-type PRINT.RATIOS.RANDOM.simplyfied.2 (let ((num 16/13) diff --git a/tools-for-build/ansi-test-expected-failures.sexp b/tools-for-build/ansi-test-expected-failures.sexp index 16e0827703..306d8e0368 100644 --- a/tools-for-build/ansi-test-expected-failures.sexp +++ b/tools-for-build/ansi-test-expected-failures.sexp @@ -31,23 +31,6 @@ FORMATTER.C.2A ;;; ansi-test assumes that SYNONYM-STREAM doesn't act like FILE-STREAM FILE-LENGTH.ERROR.3 -;;; these no longer crash, but fail -EXP.ERROR.4 -EXP.ERROR.5 -EXP.ERROR.6 -EXP.ERROR.7 -EXP.ERROR.8 -EXP.ERROR.9 -EXP.ERROR.10 -EXP.ERROR.11 -EXPT.ERROR.6 -EXPT.ERROR.4 -EXPT.ERROR.5 -EXPT.ERROR.7 -EXPT.ERROR.8 -EXPT.ERROR.9 -EXPT.ERROR.10 -EXPT.ERROR.11 ;;; FIND-ALL-SYMBOLS.1 FUNCALL.ERROR.3 ATAN.IEEE.2 From 41fce619c654026c01aeefc039df3624bd0271a1 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sat, 17 Aug 2024 09:52:13 -0400 Subject: [PATCH 3/7] Add macos-14 to test --- .github/workflows/test.yml | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f4a7e35ade..478156102c 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -22,6 +22,7 @@ jobs: - cando os: - macos-13 + - macos-14 - ubuntu-latest mode: - faso @@ -46,6 +47,12 @@ jobs: - os: macos-13 mode: bytecode auto: no + - os: macos-14 + mode: faso + - os: macos-14 + mode: bytecode-faso + - os: macos-14 + auto: yes runs-on: ${{ matrix.os }} @@ -55,9 +62,9 @@ jobs: run: | sudo apt-get update sudo apt install -y binutils-gold clang-15 libclang-15-dev libclang-cpp15-dev llvm-15 llvm-15-dev libelf-dev libgmp-dev libunwind-dev ninja-build sbcl libnetcdf-dev libexpat1-dev libfmt-dev libboost-all-dev - + - name: Install MacOS dependencies - if: matrix.os == 'macos-13' + if: matrix.os == 'macos-13' || matrix.os == 'macos-14' run: | brew update brew upgrade @@ -81,14 +88,22 @@ jobs: if: ${{ matrix.os == 'ubuntu-latest' && matrix.build == 'cando' }} run: | ./koga --build-mode=${{ matrix.mode }} --extensions=cando,seqan-clasp - - name: Clasp koga @ MacOS + - name: Clasp koga @ MacOS=13 if: ${{ matrix.os == 'macos-13' && matrix.build == 'clasp' }} run: | ./koga --build-mode=${{ matrix.mode }} - - name: Cando koga @ MacOS + - name: Clasp koga @ MacOS-14 + if: ${{ matrix.os == 'macos-14' && matrix.build == 'clasp' }} + run: | + ./koga --build-mode=${{ matrix.mode }} --cflags=-I/opt/homebrew/include --cppflags=-I/opt/homebrew/include --cxxflags=-I/opt/homebrew/include + - name: Cando koga @ MacOS-13 if: ${{ matrix.os == 'macos-13' && matrix.build == 'cando' }} run: | ./koga --build-mode=${{ matrix.mode }} --extensions=cando,seqan-clasp + - name: Cando koga @ MacOS-14 + if: ${{ matrix.os == 'macos-14' && matrix.build == 'cando' }} + run: | + ./koga --build-mode=${{ matrix.mode }} --extensions=cando,seqan-clasp --cflags=-I/opt/homebrew/include --cppflags=-I/opt/homebrew/include --cxxflags=-I/opt/homebrew/include - name: Build run: | ninja -C build From 27b32956195f7f1dce52202c13320cc62d87ebce Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sat, 17 Aug 2024 14:03:28 -0400 Subject: [PATCH 4/7] Improve regression testing selection --- src/lisp/regression-tests/framework.lisp | 44 ++++++--- src/lisp/regression-tests/run-all.lisp | 111 ++++++++++++----------- 2 files changed, 89 insertions(+), 66 deletions(-) diff --git a/src/lisp/regression-tests/framework.lisp b/src/lisp/regression-tests/framework.lisp index 085637f503..25176a523e 100644 --- a/src/lisp/regression-tests/framework.lisp +++ b/src/lisp/regression-tests/framework.lisp @@ -13,6 +13,22 @@ (defparameter *test-marker-table* (make-hash-table)) (defparameter *duplicate-tests* nil) +(defun message (level control-string &rest args) + "Display a message using ANSI highlighting if possible. LEVEL should be NIL, :ERR, +:WARN or :EMPH." + (fresh-line *standard-output*) + (when (interactive-stream-p *standard-output*) + (format t "~c[~dm" #\escape + (case level + (:err 31) + (:warn 33) + (:emph 32) + (otherwise 0)))) + (apply #'format t control-string args) + (when (interactive-stream-p *standard-output*) + (format t "~c[0m" #\escape)) + (terpri *standard-output*)) + (defun reset-clasp-tests () (setq *expected-failed-tests* nil *unexpected-failed-tests* nil @@ -32,18 +48,18 @@ (push file&error *files-failed-to-compile*)) (defun show-test-summary () - (format t "~@[~%Failures:~% ~/pprint-fill/~%~]~ + (message :emph "~@[~%Failures:~% ~/pprint-fill/~%~]~ ~@[~%Unexpected Successes:~% ~/pprint-fill/~%~]~ ~@[~%Expected Failures:~% ~/pprint-fill/~%~] -Successes: ~d~%" +Successes: ~d" (reverse *unexpected-failed-tests*) (reverse *unexpected-passed-tests*) (reverse *expected-failed-tests*) (length *expected-passed-tests*)) (when *files-failed-to-compile* (dolist (file&error *files-failed-to-compile*) - (format t "Compilation error for file ~a with error ~a~%" (first file&error)(second file&error)))) + (message :err "Compilation error for file ~a with error ~a" (first file&error)(second file&error)))) (when *duplicate-tests* (dolist (test *duplicate-tests*) - (format t "Duplicate test ~a~%" test))) + (message :warn "Duplicate test ~a" test))) (not *unexpected-failed-tests*)) (defvar *all-runtime-errors* nil) @@ -54,24 +70,26 @@ Successes: ~d~%" (if (member name *expected-failures*) (push name *expected-failed-tests*) (push name *unexpected-failed-tests*)) - (format t "~&Failed ~s~%Unexpected error~%~t~a~%while evaluating~%~t~a~%" - name error form) - (when description (format t "~s~%" description))) + (message :err "Failed ~s" name) + (message :warn "Unexpected error~%~t~a~%while evaluating~%~t~a" + error form) + (when description (message :info "~s" description))) (defun %fail-test (name form expected actual description test) (if (member name *expected-failures*) (push name *expected-failed-tests*) (push name *unexpected-failed-tests*)) - (format t "~&Failed ~s~%Wanted values ~s to~%~{~t~a~%~}but got~%~{~t~a~%~}" - name test expected actual) - (format t "while evaluating~%~t~a~%" form) - (when description (format t "~s~%" description))) + (message :err "Failed ~s" name) + (message :warn "Wanted values ~s to~%~{~t~a~%~}but got~%~{~t~a~%~}" + test expected actual) + (message :warn "while evaluating~%~t~a~%" form) + (when description (message :info "~s" description))) (defun %succeed-test (name) (if (member name *expected-failures*) (push name *unexpected-passed-tests*) (push name *expected-passed-tests*)) - (format t "~&Passed ~s~%" name)) + (message :info "Passed ~s" name)) (defun %test (name form thunk expected &key description (test 'equalp)) (note-test name) @@ -120,7 +138,7 @@ Successes: ~d~%" (load fasl))) (error (e) (note-compile-error (list file e)) - (format t "Regression: compile-file of ~a failed with ~a~%" file e)))) + (message :err "Regression: compile-file of ~a failed with ~a" file e)))) (defun no-handler-case-load-if-compiled-correctly (file) (multiple-value-bind diff --git a/src/lisp/regression-tests/run-all.lisp b/src/lisp/regression-tests/run-all.lisp index 347f2f0cc0..6b94cc257f 100644 --- a/src/lisp/regression-tests/run-all.lisp +++ b/src/lisp/regression-tests/run-all.lisp @@ -15,57 +15,62 @@ ;;; ------------------------------------------------------------ ;;; Run tests (reset-clasp-tests) -(load-if-compiled-correctly "sys:src;lisp;regression-tests;defcallback-native.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;lowlevel.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;fastgf.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;array0.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;tests01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;finalizers.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;strings01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;cons01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;sequences01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;clos.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;mop.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;update-instance-abort.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;numbers.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;ehkiller.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;package.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;structures.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;symbol0.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;string-comparison0.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;bit-array0.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;bit-array1.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;character0.lisp") -#+unicode -(load-if-compiled-correctly "sys:src;lisp;regression-tests;unicode.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;hash-tables0.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;misc.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;read01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;printer01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;streams01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;environment01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;types01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;control01.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;iteration.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;loop.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;numbers-core.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;unwind.lisp") -#+unicode -(load-if-compiled-correctly "sys:src;lisp;regression-tests;encodings.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;environment.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;conditions.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;float-features.lisp") -#+(or)(progn - (load-if-compiled-correctly "sys:src;lisp;regression-tests;system-construction.lisp") - (no-handler-case-load-if-compiled-correctly "sys:src;lisp;regression-tests;debug.lisp") - ) -#+(and)(load-if-compiled-correctly "sys:src;lisp;regression-tests;debug.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;mp.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;posix.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;btb.lisp") + +(defvar *suites* + '("defcallback-native" + "lowlevel" + "fastgf" + "array0" + "tests01" + "finalizers" + "strings01" + "cons01" + "sequences01" + "clos" + "mop" + "update-instance-abort" + "numbers" + "ehkiller" + "package" + "structures" + "symbol0" + "string-comparison0" + "bit-array0" + "bit-array1" + "character0" + #+unicode "unicode" + "hash-tables0" + "misc" + "read01" + "printer01" + "streams01" + "environment01" + "types01" + "control01" + "iteration" + "loop" + "numbers-core" + "unwind" + #+unicode "encodings" + "environment" + "conditions" + "float-features" + "debug" + "mp" + "posix" + "btb" ;;; When we have system construction before debug.lisp, debug.lisp will fail -(load-if-compiled-correctly "sys:src;lisp;regression-tests;system-construction.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;extensions.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;run-program.lisp") -(load-if-compiled-correctly "sys:src;lisp;regression-tests;snapshot.lisp") -(sys:quit (if (show-test-summary) 0 1)) + "system-construction" + "extensions" + "run-program" + "snapshot")) + +(loop with requested-suites = (core:split (or (ext:getenv "TEST_SUITES") "") ",") + for suite in *suites* + finally (sys:quit (if (show-test-summary) 0 1)) + when (or (null requested-suites) + (member suite requested-suites :test #'equal)) + do (message :emph "~%Running ~a suite..." suite) + (load-if-compiled-correctly (merge-pathnames #P"sys:src;lisp;regression-tests;" + (make-pathname :name suite + :type "lisp")))) From 9f55ab60409c2746bb32867eab0f307f93d2cb94 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 21 Aug 2024 13:39:30 -0400 Subject: [PATCH 5/7] Define function to get the current signal mask --- src/core/unixfsys.cc | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/src/core/unixfsys.cc b/src/core/unixfsys.cc index cfa38f17b0..624c632c84 100644 --- a/src/core/unixfsys.cc +++ b/src/core/unixfsys.cc @@ -383,6 +383,43 @@ SYMBOL_EXPORT_SC_(KeywordPkg, sig_block); SYMBOL_EXPORT_SC_(KeywordPkg, sig_unblock); SYMBOL_EXPORT_SC_(KeywordPkg, sig_setmask); +// Get this thread's current signal mask. +CL_DEFUN List_sp core__get_sigmask() { + ql::list sigs; + sigset_t mask; + pthread_sigmask(SIG_UNBLOCK, NULL, &mask); + // Maybe some macro magic would make this part less dumb. + if (sigismember(&mask, SIGABRT)) sigs << core::_sym_signal_SIGABRT; + if (sigismember(&mask, SIGALRM)) sigs << core::_sym_signal_SIGALRM; + if (sigismember(&mask, SIGBUS)) sigs << core::_sym_signal_SIGBUS; + if (sigismember(&mask, SIGCHLD)) sigs << core::_sym_signal_SIGCHLD; + if (sigismember(&mask, SIGCONT)) sigs << core::_sym_signal_SIGCONT; + if (sigismember(&mask, SIGFPE)) sigs << core::_sym_signal_SIGFPE; + if (sigismember(&mask, SIGHUP)) sigs << core::_sym_signal_SIGHUP; + if (sigismember(&mask, SIGILL)) sigs << core::_sym_signal_SIGILL; + if (sigismember(&mask, SIGINT)) sigs << core::_sym_signal_SIGINT; + if (sigismember(&mask, SIGKILL)) sigs << core::_sym_signal_SIGKILL; + if (sigismember(&mask, SIGPIPE)) sigs << core::_sym_signal_SIGPIPE; + if (sigismember(&mask, SIGQUIT)) sigs << core::_sym_signal_SIGQUIT; + if (sigismember(&mask, SIGSEGV)) sigs << core::_sym_signal_SIGSEGV; + if (sigismember(&mask, SIGSTOP)) sigs << core::_sym_signal_SIGSTOP; + if (sigismember(&mask, SIGTERM)) sigs << core::_sym_signal_SIGTERM; + if (sigismember(&mask, SIGTSTP)) sigs << core::_sym_signal_SIGTSTP; + if (sigismember(&mask, SIGTTIN)) sigs << core::_sym_signal_SIGTTIN; + if (sigismember(&mask, SIGTTOU)) sigs << core::_sym_signal_SIGTTOU; + if (sigismember(&mask, SIGUSR1)) sigs << core::_sym_signal_SIGUSR1; + if (sigismember(&mask, SIGUSR2)) sigs << core::_sym_signal_SIGUSR2; + if (sigismember(&mask, SIGPROF)) sigs << core::_sym_signal_SIGPROF; + if (sigismember(&mask, SIGSYS)) sigs << core::_sym_signal_SIGSYS; + if (sigismember(&mask, SIGTRAP)) sigs << core::_sym_signal_SIGTRAP; + if (sigismember(&mask, SIGURG)) sigs << core::_sym_signal_SIGURG; + if (sigismember(&mask, SIGVTALRM)) sigs << core::_sym_signal_SIGVTALRM; + if (sigismember(&mask, SIGXCPU)) sigs << core::_sym_signal_SIGXCPU; + if (sigismember(&mask, SIGXFSZ)) sigs << core::_sym_signal_SIGXFSZ; + // done + return sigs.cons(); +} + CL_DOCSTRING(R"(Like the unix function sigthreadmask. The **how** argument can be one of :sig-setmask, :sig-block, :sig-unblock. The **old-set** can be a core:sigset or nil (NULL). From 65b5099a36c370124a6254e4ea7703ae6b48668c Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Thu, 15 Aug 2024 11:35:06 -0400 Subject: [PATCH 6/7] Update cando branch reference --- repos.sexp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/repos.sexp b/repos.sexp index 90fb03d453..3bca8546cb 100644 --- a/repos.sexp +++ b/repos.sexp @@ -219,7 +219,7 @@ (:name :cando :repository "https://github.com/cando-developers/cando.git" :directory "extensions/cando/" - :branch "main" + :branch "fpe" :extension :cando) (:name :seqan-clasp :repository "https://github.com/clasp-developers/seqan-clasp.git" From 2fd69f19648213459e605f9eb41f24a61d78d60b Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Thu, 22 Aug 2024 06:32:20 -0400 Subject: [PATCH 7/7] Update release notes --- RELEASE_NOTES.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index 9df8cfea54..c538d8fd28 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -4,6 +4,10 @@ * Package lock support, based on SBCL's. Currently ignores local bindings. Thanks @bumblingbats. +## Changed +* Floating point exceptions FE_INVALID, FE_OVERFLOW and FE_DIVBYZERO + now signal the corresponding lisp errors by default. + ## Fixed * Pathnames and filesystem operations support Unicode (#1595). * Package names support Unicode (#1596).