Repositories / ecl.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 9d1b7c8)
ecl_cs_overflow() and SIGSEGV handler now share the same strategy: jump to the outerm...
authorJuan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Mon, 8 Feb 2010 11:46:13 +0000 (12:46 +0100)
committerJuan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Mon, 8 Feb 2010 11:46:13 +0000 (12:46 +0100)
src/CHANGELOG patch | blob | blame | history
src/c/error.d patch | blob | blame | history
src/c/stacks.d patch | blob | blame | history
src/c/unixint.d patch | blob | blame | history
src/h/external.h patch | blob | blame | history

diff --git a/src/CHANGELOG b/src/CHANGELOG
index 87e09f5..c67e01a 100755 (executable)
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -39,6 +39,10 @@ ECL 10.2.1:
 
  - ECL accepts FTYPE proclamations for SETF-functions.
 
+ - On platforms where a stack overflow does not cause a SIGSEGV, ECL was unable
+   to recover from it. Now it jumps to the outermost protection frame
+   (typically the toplevel).
+
 * Visible changes:
 
  - Significant speedup in access to hash tables of up to 30% by writing
diff --git a/src/c/error.d b/src/c/error.d
index 99e7362..0339946 100644 (file)
--- a/src/c/error.d
+++ b/src/c/error.d
@@ -41,6 +41,37 @@ ecl_internal_error(const char *s)
        abort();
 }
 
+
+void
+ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
+{
+       /*
+        * Right now we have no means of specifying a jump point
+        * for really bad events. We just jump to the outermost
+        * frame, which is equivalent to quitting, and wait for
+        * someone to intercept this jump.
+        */
+        ecl_frame_ptr destination;
+        cl_object tag;
+
+        /*
+         * We output the error message with very low level routines
+         * because we can not risk another stack overflow.
+         */
+        writestr_stream(message, cl_core.error_output);
+
+        tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*');
+        the_env->nvalues = 0;
+        if (tag) {
+                destination = frs_sch(tag);
+                if (destination) {
+                        ecl_unwind(the_env, destination);
+                }
+        }
+        destination = ecl_process_env()->frs_org;
+       ecl_unwind(the_env, destination);
+}
+
 /*****************************************************************************/
 /*             Support for Lisp Error Handler                               */
 /*****************************************************************************/
diff --git a/src/c/stacks.d b/src/c/stacks.d
index 97d631d..ae94757 100644 (file)
--- a/src/c/stacks.d
+++ b/src/c/stacks.d
@@ -53,6 +53,10 @@ cs_set_size(cl_env_ptr env, cl_index new_size)
 void
 ecl_cs_overflow(void)
 {
+        static const char *stack_overflow_msg =
+                "\n;;;\n;;; Stack overflow.\n"
+                ";;; Jumping to the outermost toplevel prompt\n"
+                ";;;\n\n";
        cl_env_ptr env = ecl_process_env();
        cl_index safety_area = ecl_get_option(ECL_OPT_C_STACK_SAFETY_AREA);
        cl_index size = env->cs_size;
@@ -64,7 +68,7 @@ ecl_cs_overflow(void)
                env->cs_limit += safety_area;
 #endif
        else
-               ecl_internal_error("Cannot grow stack size.");
+                ecl_unrecoverable_error(env, stack_overflow_msg);
        cl_cerror(6, make_constant_base_string("Extend stack size"),
                  @'ext::stack-overflow', @':size', MAKE_FIXNUM(size),
                  @':type', @'ext::c-stack');
diff --git a/src/c/unixint.d b/src/c/unixint.d
index 2e2d827..872f671 100644 (file)
--- a/src/c/unixint.d
+++ b/src/c/unixint.d
@@ -245,36 +245,6 @@ interrupts_disabled_by_lisp(cl_env_ptr the_env)
                ecl_symbol_value(@'si::*interrupts-enabled*') == Cnil);
 }
 
-static void
-jump_to_sigsegv_handler(cl_env_ptr the_env, const char *message)
-{
-       /*
-        * Right now we have no means of specifying a jump point
-        * for really bad events. We just jump to the outermost
-        * frame, which is equivalent to quitting, and wait for
-        * someone to intercept this jump.
-        */
-        ecl_frame_ptr destination;
-        cl_object tag;
-
-        /*
-         * We output the error message with very low level routines
-         * because we can not risk another stack overflow.
-         */
-        writestr_stream(message, cl_core.error_output);
-
-        tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*');
-        the_env->nvalues = 0;
-        if (tag) {
-                destination = frs_sch(tag);
-                if (destination) {
-                        ecl_unwind(the_env, destination);
-                }
-        }
-        destination = ecl_process_env()->frs_org;
-       ecl_unwind(the_env, destination);
-}
-
 static cl_object pop_signal(cl_env_ptr env);
 
 static cl_object
@@ -600,14 +570,14 @@ handler_fn_protype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
        if ((char*)info->si_addr > the_env->cs_barrier &&
            (char*)info->si_addr <= the_env->cs_org) {
                 unblock_signal(SIGSEGV);
-               jump_to_sigsegv_handler(the_env, stack_overflow_msg);
+               ecl_unrecoverable_error(the_env, stack_overflow_msg);
                 return;
        }
 # else
        if ((char*)info->si_addr < the_env->cs_barrier &&
            (char*)info->si_addr >= the_env->cs_org) {
                 unblock_signal(SIGSEGV);
-               jump_to_sigsegv_handler(the_env, stack_overflow_msg);
+               ecl_unrecoverable_error(the_env, stack_overflow_msg);
                 return;
        }
 # endif
@@ -617,7 +587,7 @@ handler_fn_protype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
          * up to the outermost toplevel.
         */
         unblock_signal(SIGSEGV);
-       jump_to_sigsegv_handler(the_env, segv_msg);
+       ecl_unrecoverable_error(the_env, segv_msg);
 # else
         handle_or_queue(@'ext::segmentation-violation', SIGSEGV);
 # endif
@@ -628,7 +598,7 @@ handler_fn_protype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
         * the outermost handler.
         */
         unblock_signal(SIGSEGV);
-       jump_to_sigsegv_handler(the_env, segv_msg);
+       ecl_unrecoverable_error(the_env, segv_msg);
 #endif
 }
 
diff --git a/src/h/external.h b/src/h/external.h
index 7dabd32..7e1be2e 100755 (executable)
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -538,7 +538,8 @@ extern ECL_API cl_object si_bc_split(cl_object v);
 extern ECL_API cl_object cl_error _ARGS((cl_narg narg, cl_object eformat, ...)) ecl_attr_noreturn;
 extern ECL_API cl_object cl_cerror _ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...));
 
-extern ECL_API void ecl_internal_error(const char *s) /*ecl_attr_noreturn*/;
+extern ECL_API void ecl_internal_error(const char *s) ecl_attr_noreturn;
+extern ECL_API void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_attr_noreturn;
 extern ECL_API void ecl_cs_overflow(void) /*ecl_attr_noreturn*/;
 extern ECL_API void FEprogram_error(const char *s, int narg, ...) ecl_attr_noreturn;
 extern ECL_API void FEprogram_error_noreturn(const char *s, int narg, ...) ecl_attr_noreturn;
Embeddable Common Lisp (Official: https://gitlab.com/embeddable-common-lisp/ecl)