Merge pull request #1619 from clasp-developers/fpe

Enable Floating Point Exceptions
clasp-developers · Aug 22, 2024 · dc008b5 · dc008b5
2 parents f7ac1ea + 2fd69f1
commit dc008b5
Show file tree

Hide file tree

Showing 32 changed files with 478 additions and 442 deletions.
diff --git 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

diff --git 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).

diff --git 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
@@ -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 <typename Float> struct float_convert {
+  static constexpr uint16_t significand_width = std::numeric_limits<Float>::digits;
+  static constexpr uint16_t exponent_width = std::bit_width((unsigned int)std::numeric_limits<Float>::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<Float>::max_exponent + significand_width - 2;
+  using uint_t =
+      std::conditional_t<storage_width <= 8, uint8_t,
+                         std::conditional_t<storage_width <= 16, uint16_t,
+                                            std::conditional_t<storage_width <= 32, uint32_t,
+                                                               std::conditional_t<storage_width <= 64, uint64_t, __uint128_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 <typename Char> struct fmt::formatter<core::T_sp, Char> : fmt::formatter<fmt::basic_string_view<Char>> {

diff --git a/include/clasp/core/fp_env.h b/include/clasp/core/fp_env.h
diff --git 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<uint> _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
@@ -30,6 +30,7 @@
 #include <cmath>
 #include <math.h>
 #include <limits.h>
+#include <cfenv>
 #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<DoubleFloat_O>::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
@@ -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<float>::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<float>::to_bits(value));
     return;
   } else if (obj.characterp()) {
     hg.addValue(obj.unsafe_character());

diff --git 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 <typename Protf, typename Cleanupf> 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 <typename Protf, typename Cleanupf> T_mv funwind_protect(Protf&& protec
 template <typename Blockf> 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 <typename Tagbodyf> 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 <typename Tagbodyf> void call_with_tagbody(Tagbodyf&& tagbody) {
 
 template <typename Catchf> 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/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"