diff --git a/src/CHANGELOG b/src/CHANGELOG index 3d38685ec..96449f53f 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -44,8 +44,6 @@ ECL 0.9h true bignums then, just long long int if possible; doesn't work with native compilation because compiler needs true bignums). -* System design: - - ECL's own conservative garbage collector works again. - It is possible now to execute lisp code from threads that have been created @@ -53,7 +51,16 @@ ECL 0.9h ecl_import_current_thread(cl_object name, cl_object bindings) should be called to register the current thread with the lisp world, while ecl_release_current_thread() - should be invoked before the current thread exits. + should be invoked before the current thread exits. However, in order to + ensure that the garbage collector can handle these threads, these + applications must be compiled and linked against ECL so that the + appropiate replacements for pthread_create()/CreateThread() are used. + + - On systems with GNU libc, we are able to signal and trap floating point + exceptions of the following kinds: overflow, underflow and division by zero. + Trapping of these exceptions can be disabled with (SI::TRAP-FPE NIL). In + practice this means overflows in routines like EXP, EXPT, etc, are now + detected. * Visible changes: diff --git a/src/c/cinit.d b/src/c/cinit.d index 0dd59bcd4..2f195a6a1 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -66,6 +66,9 @@ main(int argc, char **args) /* This should be always the first call */ cl_boot(argc, args); + /* We are computing unnormalized numbers at some point */ + si_trap_fpe(Ct, Cnil); + #ifdef ECL_CMU_FORMAT SYM_VAL(@'*load-verbose*') = Cnil; #endif diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 6bf58606b..b91e7e1f3 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1563,6 +1563,8 @@ cl_symbols[] = { {KEY_ "CDECL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "STDCALL", KEYWORD, NULL, -1, OBJNULL}, +{SYS_ "TRAP-FPE", SI_ORDINARY, si_trap_fpe, 2, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 84b152e39..db56b2a0e 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1563,6 +1563,8 @@ cl_symbols[] = { {KEY_ "CDECL",NULL}, {KEY_ "STDCALL",NULL}, +{SYS_ "TRAP-FPE","si_trap_fpe"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/c/unixint.d b/src/c/unixint.d index 8d1b90ccf..7bd679786 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -14,6 +14,26 @@ See file '../Copyright' for full details. */ +#include +#ifdef HAVE_FENV_H +# define _GNU_SOURCE +# include +# ifndef FE_UNDERFLOW +# define FE_UNDERFLOW 0 +# endif +# ifndef FE_OVERFLOW +# define FE_OVERFLOW 0 +# endif +# ifndef FE_INVALID +# define FE_INVALID 0 +# endif +# ifndef FE_DIVBYZERO +# define FE_DIVBYZERO 0 +# endif +# ifndef FE_INEXACT +# define FE_INEXACT 0 +# endif +#endif #include "ecl.h" #include "internal.h" #include @@ -28,8 +48,27 @@ bool ecl_interrupt_enable; +#ifdef HAVE_SIGPROCMASK static void +mysignal(int code, void *handler) +{ + struct sigaction new_action, old_action; + + new_action.sa_sigaction = handler; + sigemptyset(&new_action.sa_mask); + new_action.sa_flags = SA_SIGINFO; + sigaction(code, &new_action, &old_action); +} +#else +#define mysignal(x,y) signal(x,y) +#endif + +static void +#ifdef SA_SIGINFO +handle_signal(int sig, siginfo_t *info, void *aux) +#else handle_signal(int sig) +#endif { switch (sig) { #if defined(ECL_THREADS) && !defined(_MSC_VER) && !defined(mingw32) @@ -40,9 +79,35 @@ handle_signal(int sig) case SIGINT: funcall(2, @'si::terminal-interrupt', Ct); break; - case SIGFPE: - FEerror("Floating-point exception.", 0); + case SIGFPE: { + cl_object condition = @'arithmetic-error'; +#if defined(HAVE_FENV_H) + int bits = fetestexcept(FE_ALL_EXCEPT); + if (bits & FE_DIVBYZERO) + condition = @'division-by-zero'; + if (bits & FE_OVERFLOW) + condition = @'floating-point-overflow'; + if (bits & FE_UNDERFLOW) + condition = @'floating-point-underflow'; + if (bits & FE_INEXACT) + condition = @'floating-point-inexact'; + if (bits & FE_INVALID) + condition = @'floating-point-invalid-operation'; +#endif +#ifdef SA_SIGINFO + if (info) { + if (info->si_code == FPE_INTDIV || info->si_code == FPE_FLTDIV) + condition = @'division-by-zero'; + if (info->si_code == FPE_FLTOVF) + condition = @'floating-point-overflow'; + if (info->si_code == FPE_FLTUND) + condition = @'floating-point-underflow'; + } +#endif + si_trap_fpe(@'last', Ct); + cl_error(1, condition); break; + } case SIGSEGV: FEerror("Segmentation violation.", 0); break; @@ -56,7 +121,11 @@ handle_signal(int sig) * handle stack overflows gracefully. */ static void +#ifdef SA_SIGINFO +signal_catcher(int sig, siginfo_t *siginfo, void *data) +#else signal_catcher(int sig) +#endif { if (!ecl_interrupt_enable || symbol_value(@'si::*interrupt-enable*') == Cnil) { @@ -64,10 +133,10 @@ signal_catcher(int sig) cl_env.interrupt_pending = sig; return; } - signal(sig, signal_catcher); + mysignal(sig, signal_catcher); #ifdef HAVE_SIGPROCMASK CL_UNWIND_PROTECT_BEGIN { - handle_signal(sig); + handle_signal(sig, siginfo, data); } CL_UNWIND_PROTECT_EXIT { sigset_t block_mask; sigemptyset(&block_mask); @@ -88,26 +157,26 @@ si_check_pending_interrupts(void) { int what = cl_env.interrupt_pending; cl_env.interrupt_pending = 0; - handle_signal(what); + handle_signal(what, 0, 0); @(return) } cl_object si_catch_bad_signals() { - signal(SIGILL, signal_catcher); + mysignal(SIGILL, signal_catcher); #ifndef GBC_BOEHM - signal(SIGBUS, signal_catcher); + mysignal(SIGBUS, signal_catcher); #endif - signal(SIGSEGV, signal_catcher); + mysignal(SIGSEGV, signal_catcher); #ifdef SIGIOT - signal(SIGIOT, signal_catcher); + mysignal(SIGIOT, signal_catcher); #endif #ifdef SIGEMT - signal(SIGEMT, signal_catcher); + mysignal(SIGEMT, signal_catcher); #endif #ifdef SIGSYS - signal(SIGSYS, signal_catcher); + mysignal(SIGSYS, signal_catcher); #endif @(return Ct) } @@ -115,19 +184,19 @@ si_catch_bad_signals() cl_object si_uncatch_bad_signals() { - signal(SIGILL, SIG_DFL); + mysignal(SIGILL, SIG_DFL); #ifndef GBC_BOEHM - signal(SIGBUS, SIG_DFL); + mysignal(SIGBUS, SIG_DFL); #endif - signal(SIGSEGV, SIG_DFL); + mysignal(SIGSEGV, SIG_DFL); #ifdef SIGIOT - signal(SIGIOT, SIG_DFL); + mysignal(SIGIOT, SIG_DFL); #endif #ifdef SIGEMT - signal(SIGEMT, SIG_DFL); + mysignal(SIGEMT, SIG_DFL); #endif #ifdef SIGSYS - signal(SIGSYS, SIG_DFL); + mysignal(SIGSYS, SIG_DFL); #endif @(return Ct) } @@ -182,13 +251,43 @@ BOOL WINAPI W32_console_ctrl_handler(DWORD type) } #endif +cl_object +si_trap_fpe(cl_object condition, cl_object flag) +{ +#if defined(HAVE_FENV_H) && defined(HAVE_FEENABLEEXCEPT) + static int last_bits = 0; + int bits = 0; + if (condition == @'division-by-zero') + bits = FE_DIVBYZERO; + else if (condition == @'floating-point-overflow') + bits = FE_OVERFLOW; + else if (condition == @'floating-point-underflow') + bits = FE_UNDERFLOW; + else if (condition == Ct) + bits = FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW; + else if (condition == @'last') + bits = last_bits; + if (bits) { + if (flag == Cnil) { + fedisableexcept(bits); + last_bits &= ~bits; + } else { + feenableexcept(bits); + last_bits |= bits; + } + } +#endif + @(return flag) +} + void init_unixint(void) { - signal(SIGFPE, signal_catcher); - signal(SIGINT, signal_catcher); + mysignal(SIGFPE, signal_catcher); + si_trap_fpe(Ct, Ct); + mysignal(SIGINT, signal_catcher); #if defined(ECL_THREADS) && !defined(_MSC_VER) && !defined(mingw32) - signal(SIGUSR1, signal_catcher); + mysignal(SIGUSR1, signal_catcher); #endif #ifdef _MSC_VER SetUnhandledExceptionFilter(W32_exception_filter); diff --git a/src/configure b/src/configure index ea5bc6456..582268566 100755 --- a/src/configure +++ b/src/configure @@ -5485,9 +5485,10 @@ fi + for ac_header in fcntl.h inttypes.h limits.h netdb.h netinet/in.h \ stddef.h stdlib.h string.h sys/param.h \ - sys/socket.h sys/time.h unistd.h + sys/socket.h sys/time.h unistd.h fenv.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then @@ -9560,8 +9561,9 @@ done + for ac_func in nanosleep alarm times isnanf select setenv putenv \ - lstat mkstemp sigprocmask isatty + lstat mkstemp sigprocmask isatty feenableexcept do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 diff --git a/src/configure.in b/src/configure.in index cbef8e716..d2820ba5c 100644 --- a/src/configure.in +++ b/src/configure.in @@ -299,7 +299,7 @@ AC_HEADER_STDC AC_HEADER_TIME AC_CHECK_HEADERS( [fcntl.h inttypes.h limits.h netdb.h netinet/in.h] \ [stddef.h stdlib.h string.h sys/param.h] \ - [sys/socket.h sys/time.h unistd.h] ) + [sys/socket.h sys/time.h unistd.h fenv.h] ) dnl !!! end autoscan AC_CHECK_HEADERS( [sys/resource.h sys/utsname.h float.h pwd.h dlfcn.h link.h] \ @@ -369,7 +369,7 @@ AC_CHECK_FUNCS( [floor getcwd gethostbyaddr gethostbyname getpagesize] \ dnl !!! end autoscan AC_CHECK_FUNCS( [nanosleep alarm times isnanf select setenv putenv] \ - [lstat mkstemp sigprocmask isatty] ) + [lstat mkstemp sigprocmask isatty feenableexcept] ) dnl ===================================================================== dnl Checks for system services diff --git a/src/h/config.h.in b/src/h/config.h.in index 7cff003b6..93547dc01 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -203,6 +203,10 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey; #undef HAVE_ISATTY /* compiler understands long long */ #undef HAVE_LONG_LONG +/* can manipulate floating point environment */ +#undef HAVE_FENV_H +/* can activate individual traps in floating point environment */ +#undef HAVE_FEENABLEEXCEPT /* what characters are used to mark beginning of new line */ #undef ECL_NEWLINE_IS_CRLF diff --git a/src/h/ecl.h b/src/h/ecl.h index 4aa38dbb7..c25280278 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -33,7 +33,9 @@ typedef unsigned char uint8_t; typedef unsigned short uint16_t; #endif +#ifndef FIXNUM_BITS #include +#endif #ifdef ECL_THREADS # if defined(_MSC_VER) || defined(mingw32) diff --git a/src/h/external.h b/src/h/external.h index 6e86aa74c..40715c858 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -1463,6 +1463,7 @@ extern cl_object homedir_pathname(cl_object user); extern cl_object si_catch_bad_signals(void); extern cl_object si_uncatch_bad_signals(void); extern cl_object si_check_pending_interrupts(void); +extern cl_object si_trap_fpe(cl_object condition, cl_object flag); /* unixsys.c */