guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-760-g24af549


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-760-g24af549
Date: Thu, 20 Feb 2014 09:23:54 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=24af549ac15110e6cdac326def3987a3aa4a0d2d

The branch, master has been updated
       via  24af549ac15110e6cdac326def3987a3aa4a0d2d (commit)
       via  c2ae85beabfbbdee19b128e90f0be0f32c6e3c60 (commit)
       via  7e2fd4e7f53c281307efd12b80df46346002a33d (commit)
       via  5d20fd49fe53c2520e36e8bf983c7b7214b0ad2a (commit)
      from  0f0b6f2d868b36560ea04f50cdc7b7e1a0e565ea (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 24af549ac15110e6cdac326def3987a3aa4a0d2d
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 20 10:21:51 2014 +0100

    Remove the hard stack size limit
    
    * libguile/vm.c (vm_expand_stack): Remove the hard stack size limit.

commit c2ae85beabfbbdee19b128e90f0be0f32c6e3c60
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 20 10:17:51 2014 +0100

    VM never extends vp->sp beyond mapped region of stack
    
    * libguile/vm-engine.c (ALLOC_FRAME): Fold CHECK_OVERFLOW into this
      routine, and rework to not extend vp->sp until the stack has been
      expanded.
    
    * libguile/vm.c (vm_increase_sp): Likewise, don't extend vp->sp until
      the stack has expanded.
      (vm_expand_stack): Rework to take the new stack pointer as an
      argument, and also to update vp->sp_max_since_gc and vp->sp.

commit 7e2fd4e7f53c281307efd12b80df46346002a33d
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 20 09:45:01 2014 +0100

    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.

commit 5d20fd49fe53c2520e36e8bf983c7b7214b0ad2a
Author: Andy Wingo <address@hidden>
Date:   Wed Feb 19 21:56:48 2014 +0100

    %exception-handler fluid refactor
    
    * libguile/throw.c (scm_init_throw): Define %exception-handler here.
    * module/ice-9/boot-9.scm (%eh): Use the incoming %exception-handler,
      and then delete it.  This way we should be able to do unwind-only
      exceptions from C.

-----------------------------------------------------------------------

Summary of changes:
 libguile/stackchk.c     |   24 +----
 libguile/stackchk.h     |    3 +-
 libguile/throw.c        |  288 +++++++++++++++++++++++++++-------------------
 libguile/throw.h        |    6 +-
 libguile/vm-engine.c    |   54 +++------
 libguile/vm.c           |   50 +++------
 module/ice-9/boot-9.scm |   28 +++--
 7 files changed, 228 insertions(+), 225 deletions(-)

diff --git a/libguile/stackchk.c b/libguile/stackchk.c
index 208ba97..7e2441b 100644
--- a/libguile/stackchk.c
+++ b/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)
 {
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
index 1ed170f..23dbdba 100644
--- a/libguile/stackchk.h
+++ b/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);
diff --git a/libguile/throw.c b/libguile/throw.c
index e10695a..98149a1 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 
2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 
2010, 2011, 2012, 2013, 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
@@ -45,9 +45,18 @@
 #include "libguile/private-options.h"
 
 
-/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
-   prompt, abort, and the %exception-handler fluid. This file just provides
-   shims so that it's easy to have catch functionality from C.
+/* Pleasantly enough, the guts of catch are defined in Scheme, in terms
+   of prompt, abort, and the %exception-handler fluid.  Check boot-9 for
+   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,41 +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 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"));
+  return catch (key, thunk, handler, pre_unwind_handler);
 }
 
 SCM
 scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
 {
-  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
-  scm_i_pthread_once (&once, init_with_throw_handler_var);
-
-  return scm_call_3 (scm_variable_ref (with_throw_handler_var),
-                     key, thunk, handler);
+  return catch (key, thunk, SCM_UNDEFINED, handler);
 }
 
 SCM
@@ -441,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,
-   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");
-
-static SCM
-pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
-{
-  struct scm_vm *vp;
-  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 */
-  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
-     nonlocal return to the setjmp.  */
-  vp = scm_the_vm ();
-  v_handler = handler;
-
-  /* Push the prompt onto the dynamic stack. */
-  scm_dynstack_push_prompt (dynstack,
-                            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;
-}
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
 
-static int
-find_pre_init_catch (void)
+void
+scm_report_stack_overflow (void)
 {
-  if (scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack,
-                                sym_pre_init_catch_tag,
-                                NULL, NULL, NULL, NULL, NULL))
-    return 1;
+  /* Arguments as if from:
 
-  return 0;
-}
+       scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
 
-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);
-        }
+     We build the arguments manually because we throw without running
+     pre-unwind handlers.  (Pre-unwind handlers could rewind the
+     stack.)  */
+  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);
 
-      fprintf (stderr, "Aborting.\n");
-      abort ();
-      return SCM_BOOL_F; /* not reached */
-    }
+  /* Not reached.  */
+  abort ();
 }
 
 void
@@ -546,10 +592,14 @@ scm_init_throw ()
   tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
   scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
 
-  catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
-                                                       pre_init_catch));
+  exception_handler_fluid = scm_make_fluid_with_default (SCM_BOOL_F);
+  /* This binding is later removed when the Scheme definitions of catch,
+     throw, and with-throw-handler are created in boot-9.scm.  */
+  scm_c_define ("%exception-handler", exception_handler_fluid);
+
+  scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, 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"
 }
diff --git a/libguile/throw.h b/libguile/throw.h
index 62592d2..531aadd 100644
--- a/libguile/throw.h
+++ b/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);
 
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e95aad5..87e94ff 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -132,19 +132,7 @@
 
 /* Virtual Machine
 
-   This is Guile's new virtual machine.  When I say "new", I mean
-   relative to the current virtual machine.  At some point it will
-   become "the" virtual machine, and we'll delete this paragraph.  As
-   such, the rest of the comments speak as if there's only one VM.
-   In difference from the old VM, local 0 is the procedure, and the
-   first argument is local 1.  At some point in the future we should
-   change the fp to point to the procedure and not to local 1.
-
-   <more overview here>
- */
-
-
-/* The VM has three state bits: the instruction pointer (IP), the frame
+   The VM has three state bits: the instruction pointer (IP), the frame
    pointer (FP), and the top-of-stack pointer (SP).  We cache the first
    two of these in machine registers, local to the VM, because they are
    used extensively by the VM.  As the SP is used more by code outside
@@ -173,33 +161,30 @@
   } while (0)
 
 
-
-/* After advancing vp->sp, but before writing any stack slots, check
-   that it is actually in bounds.  If it is not in bounds, currently we
-   signal an error.  In the future we may expand the stack instead,
-   possibly by moving it elsewhere, therefore no pointer into the stack
-   besides FP is valid across a CHECK_OVERFLOW call.  Be careful!  */
-#define CHECK_OVERFLOW()                                            \
-  do {                                                              \
-    if (SCM_UNLIKELY (vp->sp >= vp->stack_limit))                   \
-      {                                                             \
-        SYNC_IP ();                                                 \
-        vm_expand_stack (vp);                                       \
-        CACHE_FP ();                                                \
-      }                                                             \
-  } while (0)
-
 /* Reserve stack space for a frame.  Will check that there is sufficient
    stack space for N locals, including the procedure.  Invoke after
-   preparing the new frame and setting the fp and ip.  */
+   preparing the new frame and setting the fp and ip.
+
+   If there is not enough space for this frame, we try to expand the
+   stack, possibly relocating it somewhere else in the address space.
+   Because of the possible relocation, no pointer into the stack besides
+   FP is valid across an ALLOC_FRAME call.  Be careful!  */
 #define ALLOC_FRAME(n)                                              \
   do {                                                              \
-    vp->sp = LOCAL_ADDRESS (n - 1);                                 \
-    if (vp->sp > vp->sp_max_since_gc)                               \
+    SCM *new_sp = LOCAL_ADDRESS (n - 1);                            \
+    if (new_sp > vp->sp_max_since_gc)                               \
       {                                                             \
-        vp->sp_max_since_gc = vp->sp;                               \
-        CHECK_OVERFLOW ();                                          \
+        if (SCM_UNLIKELY (new_sp >= vp->stack_limit))               \
+          {                                                         \
+            SYNC_IP ();                                             \
+            vm_expand_stack (vp, new_sp);                           \
+            CACHE_FP ();                                            \
+          }                                                         \
+        else                                                        \
+          vp->sp_max_since_gc = vp->sp = new_sp;                    \
       }                                                             \
+    else                                                            \
+      vp->sp = new_sp;                                              \
   } while (0)
 
 /* Reset the current frame to hold N locals.  Used when we know that no
@@ -3235,7 +3220,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 #undef BV_INT_REF
 #undef BV_INT_SET
 #undef CACHE_REGISTER
-#undef CHECK_OVERFLOW
 #undef END_DISPATCH_SWITCH
 #undef FREE_VARIABLE_REF
 #undef INIT
diff --git a/libguile/vm.c b/libguile/vm.c
index b071a54..10d800f 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -64,7 +64,7 @@ static SCM sym_debug;
 
 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
 
-static void vm_expand_stack (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE;
 
 /* RESTORE is for the case where we know we have done a PUSH of equal or
    greater stack size in the past.  Otherwise PUSH is the thing, which
@@ -74,13 +74,16 @@ enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE };
 static inline void
 vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind)
 {
-  vp->sp = new_sp;
-  if (new_sp > vp->sp_max_since_gc)
+  if (new_sp <= vp->sp_max_since_gc)
     {
-      vp->sp_max_since_gc = new_sp;
-      if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit)
-        vm_expand_stack (vp);
+      vp->sp = new_sp;
+      return;
     }
+
+  if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit)
+    vm_expand_stack (vp, new_sp);
+  else
+    vp->sp_max_since_gc = vp->sp = new_sp;
 }
 
 static inline void
@@ -708,10 +711,6 @@ scm_i_call_with_current_continuation (SCM proc)
 /* The page size.  */
 static size_t page_size;
 
-/* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
-   64-bit machines.  */
-static const size_t hard_max_stack_size = 512 * 1024 * 1024;
-
 /* Initial stack size.  Defaults to one page.  */
 static size_t initial_stack_size;
 
@@ -989,18 +988,9 @@ scm_i_vm_free_stack (struct scm_vm *vp)
 }
 
 static void
-vm_expand_stack (struct scm_vm *vp)
+vm_expand_stack (struct scm_vm *vp, SCM *new_sp)
 {
-  scm_t_ptrdiff stack_size = vp->sp + 1 - vp->stack_base;
-
-  if (stack_size > hard_max_stack_size)
-    {
-      /* We have expanded the soft limit to the point that we reached a
-         hard limit.  There is nothing sensible to do.  */
-      fprintf (stderr, "Hard stack size limit (%zu words) reached; 
aborting.\n",
-               hard_max_stack_size);
-      abort ();
-    }
+  scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base;
 
   /* FIXME: Prevent GC while we expand the stack, to ensure that a
      stack marker can trace the stack.  */
@@ -1016,13 +1006,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
-           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 ();
+        scm_report_stack_overflow ();
 
       vp->stack_base = new_stack;
       vp->stack_size = new_size;
@@ -1034,7 +1018,6 @@ vm_expand_stack (struct scm_vm *vp)
           SCM *fp;
           if (vp->fp)
             vp->fp += reloc;
-          vp->sp += reloc;
           vp->sp_max_since_gc += reloc;
           fp = vp->fp;
           while (fp)
@@ -1048,6 +1031,8 @@ vm_expand_stack (struct scm_vm *vp)
               fp = next_fp;
             }
         }
+
+      new_sp += reloc;
     }
 
   if (stack_size >= vp->max_stack_size)
@@ -1061,17 +1046,16 @@ vm_expand_stack (struct scm_vm *vp)
       if (vp->max_stack_size < stack_size)
         vp->max_stack_size = vp->stack_size;
 
-      /* But don't exceed the hard maximum.  */
-      if (vp->max_stack_size > hard_max_stack_size)
-        vp->max_stack_size = hard_max_stack_size;
-
       /* 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);
     }
 
   /* Otherwise continue, with the new enlarged stack.  */
+  vp->sp_max_since_gc = vp->sp = new_sp;
 }
 
 static struct scm_vm *
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 23f2d5b..fd92445 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -706,10 +706,9 @@ information is unavailable."
 ;; shared fluid. Hide the helpers in a lexical contour.
 
 (define with-throw-handler #f)
-(let ()
-  (define %exception-handler (make-fluid #f))
+(let ((%eh (module-ref (current-module) '%exception-handler)))
   (define (make-exception-handler catch-key prompt-tag pre-unwind)
-    (vector (fluid-ref %exception-handler) catch-key prompt-tag pre-unwind))
+    (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind))
   (define (exception-handler-prev handler) (vector-ref handler 0))
   (define (exception-handler-catch-key handler) (vector-ref handler 1))
   (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
@@ -762,7 +761,7 @@ If there is no handler at all, Guile prints an error and 
then exits."
     (unless (symbol? key)
       (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
              (list 1 key) (list key)))
-    (dispatch-exception (fluid-ref %exception-handler) key args))
+    (dispatch-exception (fluid-ref %eh) key args))
 
   (define* (catch k thunk handler #:optional pre-unwind-handler)
     "Invoke @var{thunk} in the dynamic context of @var{handler} for
@@ -798,16 +797,21 @@ 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)))
-        (scm-error 'wrong-type-arg "catch"
-                   "Wrong type argument in position ~a: ~a"
-                   (list 1 k) (list k)))
+    (define (wrong-type-arg n val)
+      (scm-error 'wrong-type-arg "catch"
+                 "Wrong type argument in position ~a: ~a"
+                 (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
        (lambda ()
-         (with-fluid* %exception-handler
-             (make-exception-handler k tag pre-unwind-handler)
+         (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
            thunk))
        (lambda (cont k . args)
          (apply handler k args)))))
@@ -819,10 +823,10 @@ for key @var{k}, then invoke @var{thunk}."
         (scm-error 'wrong-type-arg "with-throw-handler"
                    "Wrong type argument in position ~a: ~a"
                    (list 1 k) (list k)))
-    (with-fluid* %exception-handler
-        (make-exception-handler k #f pre-unwind-handler)
+    (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
       thunk))
 
+  (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
   (define! 'catch catch)
   (define! 'with-throw-handler with-throw-handler)
   (define! 'throw throw))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]