Unwind-only stack overflow exceptions

* module/ice-9/boot-9.scm (catch): Signal an early error if the handler
  or pre-unwind handler types aren't right.  This is more important than
  it was, given that we dispatch on type now when finding matching catch
  clauses.

* libguile/vm.c (vm_expand_stack): Use the standard
  scm_report_stack_overflow to signal stack overflow.  This will avoid
  running pre-unwind handlers.

* libguile/throw.h: Move scm_report_stack_overflow here.

* libguile/throw.c (catch): Define a version of catch in C.
  (throw_without_pre_unwind): New helper.  Besides serving as the
  pre-boot "throw" binding, it allows stack overflow to throw without
  running pre-unwind handlers.
  (scm_catch, scm_catch_with_pre_unwind_handler)
  (scm_with_throw_handler): Use the new catch in C.
  (scm_report_stack_overflow): Moved from stackchk.c; throws an
  unwind-only exception.

* libguile/stackchk.h:
* libguile/stackchk.c: Remove the scm_report_stack_overflow bits.

libguile/stackchk.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
+/*	Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010, 2011, 2014 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -36,34 +36,12 @@
 
 int scm_stack_checking_enabled_p;
 
-SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
-
 static void
 reset_scm_stack_checking_enabled_p (void *arg)
 {
   scm_stack_checking_enabled_p = (int)(scm_t_bits)arg;
 }
 
-void
-scm_report_stack_overflow ()
-{
-  scm_dynwind_begin (0); /* non-rewindable frame */
-  scm_dynwind_unwind_handler (reset_scm_stack_checking_enabled_p,
-                              (void*)(scm_t_bits)scm_stack_checking_enabled_p,
-                              SCM_F_WIND_EXPLICITLY);
-  
-  scm_stack_checking_enabled_p = 0;
-
-  scm_error (scm_stack_overflow_key,
-	     NULL,
-	     "Stack overflow",
-	     SCM_BOOL_F,
-	     SCM_BOOL_F);
-
-  /* not reached */
-  scm_dynwind_end ();
-}
-
 long
 scm_stack_size (SCM_STACKITEM *start)
 {

libguile/stackchk.h

@@ -3,7 +3,7 @@
 #ifndef SCM_STACKCHK_H
 #define SCM_STACKCHK_H
 
-/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -57,7 +57,6 @@ SCM_API int scm_stack_checking_enabled_p;
 
 
 
-SCM_API void scm_report_stack_overflow (void);
 SCM_API long scm_stack_size (SCM_STACKITEM *start);
 SCM_API void scm_stack_report (void);
 SCM_API SCM scm_sys_get_stack_size (void);

libguile/throw.c

@@ -45,9 +45,18 @@
 #include "libguile/private-options.h"
 
 
-/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
+/* Pleasantly enough, the guts of catch are defined in Scheme, in terms
-   prompt, abort, and the %exception-handler fluid. This file just provides
+   of prompt, abort, and the %exception-handler fluid.  Check boot-9 for
-   shims so that it's easy to have catch functionality from C.
+   the definitions.
+
+   Still, it's useful to be able to throw unwind-only exceptions from C,
+   for example so that we can recover from stack overflow.  We also need
+   to have an implementation of catch and throw handy before boot time.
+   For that reason we have a parallel implementation of "catch" that
+   uses the same fluids here.  Throws from C still call out to Scheme
+   though, so that pre-unwind handlers can be run.  Getting the dynamic
+   environment right for pre-unwind handlers is tricky, and it's
+   important to have all of the implementation in one place.
 
    All of these function names and prototypes carry a fair bit of historical
    baggage. */
@@ -55,43 +64,155 @@
 
 
 
-static SCM catch_var, throw_var, with_throw_handler_var;
+static SCM throw_var;
 
 static SCM exception_handler_fluid;
 
+static SCM
+catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
+{
+  struct scm_vm *vp;
+  SCM eh, prompt_tag;
+  SCM res;
+  scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+  SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
+  scm_i_jmp_buf registers;
+  scm_t_ptrdiff saved_stack_depth;
+
+  if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag))
+    scm_wrong_type_arg ("catch", 1, tag);
+
+  if (SCM_UNBNDP (handler))
+    handler = SCM_BOOL_F;
+  else if (!scm_is_true (scm_procedure_p (handler)))
+    scm_wrong_type_arg ("catch", 3, handler);
+
+  if (SCM_UNBNDP (pre_unwind_handler))
+    pre_unwind_handler = SCM_BOOL_F;
+  else if (!scm_is_true (scm_procedure_p (pre_unwind_handler)))
+    scm_wrong_type_arg ("catch", 4, pre_unwind_handler);
+
+  prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
+
+  eh = scm_c_make_vector (4, SCM_BOOL_F);
+  scm_c_vector_set_x (eh, 0, scm_fluid_ref (exception_handler_fluid));
+  scm_c_vector_set_x (eh, 1, tag);
+  scm_c_vector_set_x (eh, 2, prompt_tag);
+  scm_c_vector_set_x (eh, 3, pre_unwind_handler);
+
+  vp = scm_the_vm ();
+  saved_stack_depth = vp->sp - vp->stack_base;
+
+  /* Push the prompt and exception handler onto the dynamic stack. */
+  scm_dynstack_push_prompt (dynstack,
+                            SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+                            | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+                            prompt_tag,
+                            vp->fp - vp->stack_base,
+                            saved_stack_depth,
+                            vp->ip,
+                            &registers);
+  scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
+                           dynamic_state);
+
+  if (SCM_I_SETJMP (registers))
+    {
+      /* A non-local return.  */
+
+      /* FIXME: We know where the args will be on the stack; we could
+         avoid consing them.  */
+      SCM args = scm_i_prompt_pop_abort_args_x (vp);
+
+      /* Cdr past the continuation. */
+      args = scm_cdr (args);
+
+      return scm_apply_0 (handler, args);
+    }
+
+  res = scm_call_0 (thunk);
+
+  scm_dynstack_unwind_fluid (dynstack, dynamic_state);
+  scm_dynstack_pop (dynstack);
+
+  return res;
+}
+
+static void
+default_exception_handler (SCM k, SCM args)
+{
+  static int error_printing_error = 0;
+  static int error_printing_fallback = 0;
+
+  if (error_printing_fallback)
+    fprintf (stderr, "\nFailed to print exception.\n");
+  else if (error_printing_error)
+    {
+      fprintf (stderr, "\nError while printing exception:\n");
+      error_printing_fallback = 1;
+      fprintf (stderr, "Key: ");
+      scm_write (k, scm_current_error_port ());
+      fprintf (stderr, ", args: ");
+      scm_write (args, scm_current_error_port ());
+      scm_newline (scm_current_error_port ());
+   }
+  else
+    {
+      fprintf (stderr, "Uncaught exception:\n");
+      error_printing_error = 1;
+      scm_handle_by_message (NULL, k, args);
+    }
+
+  /* Normally we don't get here, because scm_handle_by_message will
+     exit.  */
+  fprintf (stderr, "Aborting.\n");
+  abort ();
+}
+
+static SCM
+throw_without_pre_unwind (SCM tag, SCM args)
+{
+  SCM eh;
+
+  for (eh = scm_fluid_ref (exception_handler_fluid);
+       scm_is_true (eh);
+       eh = scm_c_vector_ref (eh, 0))
+    {
+      SCM catch_key, prompt_tag;
+
+      catch_key = scm_c_vector_ref (eh, 1);
+      if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag))
+        continue;
+
+      if (scm_is_true (scm_c_vector_ref (eh, 3)))
+        fprintf (stderr, "\nWarning: unwind-only exception, perhaps due to "
+                 "stack overflow; not running pre-unwind handlers.");
+
+      prompt_tag = scm_c_vector_ref (eh, 2);
+      if (scm_is_true (prompt_tag))
+        scm_abort_to_prompt_star (prompt_tag, scm_cons (tag, args));
+    }
+
+  default_exception_handler (tag, args);
+  return SCM_UNSPECIFIED;
+}
+
 SCM
 scm_catch (SCM key, SCM thunk, SCM handler)
 {
-  return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
+  return catch (key, thunk, handler, SCM_UNDEFINED);
 }
 
 SCM
 scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
                                    SCM pre_unwind_handler)
 {
-  if (SCM_UNBNDP (pre_unwind_handler))
+  return catch (key, thunk, handler, pre_unwind_handler);
-    return scm_catch (key, thunk, handler);
-  else
-    return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
-                       pre_unwind_handler);
-}
-
-static void
-init_with_throw_handler_var (void)
-{
-  with_throw_handler_var
-    = scm_module_variable (scm_the_root_module (),
-                           scm_from_latin1_symbol ("with-throw-handler"));
 }
 
 SCM
 scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
 {
-  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  return catch (key, thunk, SCM_UNDEFINED, handler);
-  scm_i_pthread_once (&once, init_with_throw_handler_var);
-
-  return scm_call_3 (scm_variable_ref (with_throw_handler_var),
-                     key, thunk, handler);
 }
 
 SCM
@@ -443,103 +564,26 @@ scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
   return scm_throw (key, args);
 }
 
-/* Unfortunately we have to support catch and throw before boot-9 has, um,
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
-   booted. So here are lame versions, which will get replaced with their scheme
-   equivalents. */
 
-SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
+void
-
+scm_report_stack_overflow (void)
-static SCM
-pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
 {
-  struct scm_vm *vp;
+  /* Arguments as if from:
-  volatile SCM v_handler;
-  SCM res;
-  scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
-  scm_i_jmp_buf registers;
 
-  /* Only handle catch-alls without pre-unwind handlers */
+       scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
-  if (!SCM_UNBNDP (pre_unwind_handler))
-    abort ();
-  if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
-    abort ();
 
-  /* These two are volatile, so we know we can access them after a
+     We build the arguments manually because we throw without running
-     nonlocal return to the setjmp.  */
+     pre-unwind handlers.  (Pre-unwind handlers could rewind the
-  vp = scm_the_vm ();
+     stack.)  */
-  v_handler = handler;
+  SCM args = scm_list_4 (SCM_BOOL_F,
+                         scm_from_latin1_string ("Stack overflow"),
+                         SCM_BOOL_F,
+                         SCM_BOOL_F);
+  throw_without_pre_unwind (scm_stack_overflow_key, args);
 
-  /* Push the prompt onto the dynamic stack. */
+  /* Not reached.  */
-  scm_dynstack_push_prompt (dynstack,
+  abort ();
-                            SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
-                            | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
-                            sym_pre_init_catch_tag,
-                            vp->fp - vp->stack_base,
-                            vp->sp - vp->stack_base,
-                            vp->ip,
-                            &registers);
-
-  if (SCM_I_SETJMP (registers))
-    {
-      /* nonlocal exit */
-      SCM args;
-      /* vp is not volatile */
-      vp = scm_the_vm ();
-      args = scm_i_prompt_pop_abort_args_x (vp);
-      /* cdr past the continuation */
-      return scm_apply_0 (v_handler, scm_cdr (args));
-    }
-
-  res = scm_call_0 (thunk);
-  scm_dynstack_pop (dynstack);
-
-  return res;
-}
-
-static int
-find_pre_init_catch (void)
-{
-  if (scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack,
-                                sym_pre_init_catch_tag,
-                                NULL, NULL, NULL, NULL, NULL))
-    return 1;
-
-  return 0;
-}
-
-static SCM
-pre_init_throw (SCM k, SCM args)
-{
-  if (find_pre_init_catch ())
-    return scm_abort_to_prompt_star (sym_pre_init_catch_tag, scm_cons (k, args));
-  else
-    { 
-      static int error_printing_error = 0;
-      static int error_printing_fallback = 0;
-      
-      if (error_printing_fallback)
-        fprintf (stderr, "\nFailed to print exception.\n");
-      else if (error_printing_error)
-        {
-          fprintf (stderr, "\nError while printing exception:\n");
-          error_printing_fallback = 1;
-          fprintf (stderr, "Key: ");
-          scm_write (k, scm_current_error_port ());
-          fprintf (stderr, ", args: ");
-          scm_write (args, scm_current_error_port ());
-          scm_newline (scm_current_error_port ());
-        }
-      else
-        {
-          fprintf (stderr, "Throw without catch before boot:\n");
-          error_printing_error = 1;
-          scm_handle_by_message_noexit (NULL, k, args);
-        }
-
-      fprintf (stderr, "Aborting.\n");
-      abort ();
-      return SCM_BOOL_F; /* not reached */
-    }
 }
 
 void
@@ -553,10 +597,9 @@ scm_init_throw ()
      throw, and with-throw-handler are created in boot-9.scm.  */
   scm_c_define ("%exception-handler", exception_handler_fluid);
 
-  catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
+  scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, catch));
-                                                       pre_init_catch));
   throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
-                                                       pre_init_throw));
+                                                       throw_without_pre_unwind));
 
 #include "libguile/throw.x"
 }

libguile/throw.h

@@ -3,7 +3,7 @@
 #ifndef SCM_THROW_H
 #define SCM_THROW_H
 
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010, 2014 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -81,6 +81,10 @@ SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return);
 
+/* This throws to the `stack-overflow' key, without running pre-unwind
+   handlers.  */
+SCM_API void scm_report_stack_overflow (void);
+
 SCM_API SCM scm_throw (SCM key, SCM args);
 SCM_INTERNAL void scm_init_throw (void);
 

libguile/vm.c

@@ -1016,13 +1016,7 @@ vm_expand_stack (struct scm_vm *vp)
       old_stack = vp->stack_base;
       new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size);
       if (!new_stack)
-        /* It would be nice to throw an exception here, but that is
+        scm_report_stack_overflow ();
-           extraordinarily hard.  Exceptionally hard, you might say!
-           "throw" is implemented in Scheme, and there may be arbitrary
-           pre-unwind handlers that push on more frames.  We will
-           endeavor to do so in the future, but for now we just
-           abort.  */
-        abort ();
 
       vp->stack_base = new_stack;
       vp->stack_size = new_size;
@@ -1068,6 +1062,8 @@ vm_expand_stack (struct scm_vm *vp)
       /* Finally, reset the limit, to catch further overflows.  */
       vp->stack_limit = vp->stack_base + vp->max_stack_size;
 
+      /* FIXME: Use scm_report_stack_overflow, but in a mode that allows
+         pre-unwind handlers to run.  */
       vm_error ("VM: Stack overflow", SCM_UNDEFINED);
     }
 

module/ice-9/boot-9.scm

@@ -797,10 +797,16 @@ A @var{pre-unwind-handler} can exit either normally or non-locally.
 If it exits normally, Guile unwinds the stack and dynamic context
 and then calls the normal (third argument) handler.  If it exits
 non-locally, that exit determines the continuation."
-    (if (not (or (symbol? k) (eqv? k #t)))
+    (define (wrong-type-arg n val)
-        (scm-error 'wrong-type-arg "catch"
+      (scm-error 'wrong-type-arg "catch"
-                   "Wrong type argument in position ~a: ~a"
+                 "Wrong type argument in position ~a: ~a"
-                   (list 1 k) (list k)))
+                 (list n val) (list val)))
+    (unless (or (symbol? k) (eqv? k #t))
+      (wrong-type-arg 1 k))
+    (unless (procedure? handler)
+      (wrong-type-arg 3 handler))
+    (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
+      (wrong-type-arg 4 pre-unwind-handler))
     (let ((tag (make-prompt-tag "catch")))
       (call-with-prompt
        tag