The GOOPS "unbound" value is a unique pair
[bpt/guile.git] / libguile / vm.c
index b0918b6..0e59835 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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
@@ -58,13 +58,14 @@ static SCM sym_keyword_argument_error;
 static SCM sym_regular;
 static SCM sym_debug;
 
+/* The page size.  */
+static size_t page_size;
+
 /* The VM has a number of internal assertions that shouldn't normally be
    necessary, but might be if you think you found a bug in the VM. */
-#define VM_ENABLE_ASSERTIONS
+/* #define VM_ENABLE_ASSERTIONS */
 
-/* #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 +75,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
@@ -108,17 +112,22 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
   scm_puts_unlocked (">", port);
 }
 
-/* In theory, a number of vm instances can be active in the call trace, and we
-   only want to reify the continuations of those in the current continuation
-   root. I don't see a nice way to do this -- ideally it would involve dynwinds,
-   and previous values of the *the-vm* fluid within the current continuation
-   root. But we don't have access to continuation roots in the dynwind stack.
-   So, just punt for now, we just capture the continuation for the current VM.
+int
+scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
+{
+  struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont);
 
-   While I'm on the topic, ideally we could avoid copying the C stack if the
-   continuation root is inside VM code, and call/cc was invoked within that same
-   call to vm_run; but that's currently not implemented.
- */
+  frame->stack_holder = data;
+  frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
+  frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
+  frame->ip = data->ra;
+
+  return 1;
+}
+
+/* Ideally we could avoid copying the C stack if the continuation root
+   is inside VM code, and call/cc was invoked within that same call to
+   vm_run.  That's currently not implemented.  */
 SCM
 scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
                         scm_t_dynstack *dynstack, scm_t_uint32 flags)
@@ -139,21 +148,21 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
   return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
 }
 
-static void
-vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
+struct return_to_continuation_data
 {
   struct scm_vm_cont *cp;
-  SCM *argv_copy;
-  scm_t_ptrdiff reloc;
-
-  argv_copy = alloca (n * sizeof(SCM));
-  memcpy (argv_copy, argv, n * sizeof(SCM));
-
-  cp = SCM_VM_CONT_DATA (cont);
+  struct scm_vm *vp;
+};
 
-  /* FIXME: Need to prevent GC while futzing with the stack; otherwise,
-     another thread causing GC may initiate a mark of a stack in an
-     inconsistent state.  */
+/* Called with the GC lock to prevent the stack marker from traversing a
+   stack in an inconsistent state.  */
+static void *
+vm_return_to_continuation_inner (void *data_ptr)
+{
+  struct return_to_continuation_data *data = data_ptr;
+  struct scm_vm *vp = data->vp;
+  struct scm_vm_cont *cp = data->cp;
+  scm_t_ptrdiff reloc;
 
   /* We know that there is enough space for the continuation, because we
      captured it in the past.  However there may have been an expansion
@@ -179,6 +188,25 @@ vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
         }
     }
 
+  return NULL;
+}
+
+static void
+vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
+{
+  struct scm_vm_cont *cp;
+  SCM *argv_copy;
+  struct return_to_continuation_data data;
+
+  argv_copy = alloca (n * sizeof(SCM));
+  memcpy (argv_copy, argv, n * sizeof(SCM));
+
+  cp = SCM_VM_CONT_DATA (cont);
+
+  data.cp = cp;
+  data.vp = vp;
+  GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data);
+
   /* Now we have the continuation properly copied over.  We just need to
      copy the arguments.  It is not guaranteed that there is actually
      space for the arguments, though, so we have to bump the SP first.  */
@@ -336,29 +364,26 @@ vm_abort (struct scm_vm *vp, SCM tag,
   for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
     argv[i] = scm_car (tail);
 
-  /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
   vp->sp = sp;
 
   scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers);
 }
 
-static void
-vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
-                                   size_t n, SCM *argv,
-                                   scm_t_dynstack *dynstack,
-                                   scm_i_jmp_buf *registers)
+struct vm_reinstate_partial_continuation_data
 {
+  struct scm_vm *vp;
   struct scm_vm_cont *cp;
-  SCM *argv_copy, *base;
   scm_t_ptrdiff reloc;
-  size_t i;
-
-  argv_copy = alloca (n * sizeof(SCM));
-  memcpy (argv_copy, argv, n * sizeof(SCM));
-
-  cp = SCM_VM_CONT_DATA (cont);
+};
 
-  vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1);
+static void *
+vm_reinstate_partial_continuation_inner (void *data_ptr)
+{
+  struct vm_reinstate_partial_continuation_data *data = data_ptr;
+  struct scm_vm *vp = data->vp;
+  struct scm_vm_cont *cp = data->cp;
+  SCM *base;
+  scm_t_ptrdiff reloc;
 
   base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
   reloc = cp->reloc + (base - cp->stack_base);
@@ -372,11 +397,40 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
   {
     SCM *fp;
     for (fp = vp->fp;
-         SCM_FRAME_LOWER_ADDRESS (fp) > base;
+         SCM_FRAME_LOWER_ADDRESS (fp) >= base;
          fp = SCM_FRAME_DYNAMIC_LINK (fp))
       SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc);
   }
 
+  data->reloc = reloc;
+
+  return NULL;
+}
+
+static void
+vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
+                                   size_t n, SCM *argv,
+                                   scm_t_dynstack *dynstack,
+                                   scm_i_jmp_buf *registers)
+{
+  struct vm_reinstate_partial_continuation_data data;
+  struct scm_vm_cont *cp;
+  SCM *argv_copy;
+  scm_t_ptrdiff reloc;
+  size_t i;
+
+  argv_copy = alloca (n * sizeof(SCM));
+  memcpy (argv_copy, argv, n * sizeof(SCM));
+
+  cp = SCM_VM_CONT_DATA (cont);
+
+  vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1);
+
+  data.vp = vp;
+  data.cp = cp;
+  GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data);
+  reloc = data.reloc;
+
   /* Push the arguments. */
   for (i = 0; i < n; i++)
     vp->sp[i + 1 - n] = argv_copy[i];
@@ -408,8 +462,8 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
 
 static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound_fluid (SCM fluid) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
@@ -423,6 +477,8 @@ static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
@@ -445,17 +501,17 @@ vm_error_bad_instruction (scm_t_uint32 inst)
 }
 
 static void
-vm_error_unbound (SCM proc, SCM sym)
+vm_error_unbound (SCM sym)
 {
-  scm_error_scm (scm_misc_error_key, proc,
+  scm_error_scm (scm_misc_error_key, SCM_BOOL_F,
                  scm_from_latin1_string ("Unbound variable: ~s"),
                  scm_list_1 (sym), SCM_BOOL_F);
 }
 
 static void
-vm_error_unbound_fluid (SCM proc, SCM fluid)
+vm_error_unbound_fluid (SCM fluid)
 {
-  scm_error_scm (scm_misc_error_key, proc,
+  scm_error_scm (scm_misc_error_key, SCM_BOOL_F,
                  scm_from_latin1_string ("Unbound fluid: ~s"),
                  scm_list_1 (fluid), SCM_BOOL_F);
 }
@@ -547,6 +603,19 @@ vm_error_not_a_struct (const char *subr, SCM x)
   scm_wrong_type_arg_msg (subr, 1, x, "struct");
 }
 
+static void
+vm_error_not_a_vector (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "vector");
+}
+
+static void
+vm_error_out_of_range (const char *subr, SCM k)
+{
+  scm_to_size_t (k);
+  scm_out_of_range (subr, k);
+}
+
 static void
 vm_error_no_values (void)
 {
@@ -698,24 +767,6 @@ scm_i_call_with_current_continuation (SCM proc)
  * VM
  */
 
-/* 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: 4 or 8 kB.  */
-static const size_t initial_stack_size = 1024;
-
-/* Default soft stack limit is 1M words (4 or 8 megabytes).  */
-static size_t default_max_stack_size = 1024 * 1024;
-
-static void
-initialize_default_stack_size (void)
-{
-  int size = scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size);
-  if (size >= initial_stack_size && (size_t) size < ((size_t) -1) / sizeof(SCM))
-    default_max_stack_size = size;
-}
-
 #define VM_NAME vm_regular_engine
 #define VM_USE_HOOKS 0
 #define FUNC_NAME "vm-regular-engine"
@@ -753,13 +804,17 @@ allocate_stack (size_t size)
   ret = mmap (NULL, size, PROT_READ | PROT_WRITE,
               MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
   if (ret == MAP_FAILED)
-    SCM_SYSERROR;
+    ret = NULL;
 #else
   ret = malloc (size);
-  if (!ret)
-    SCM_SYSERROR;
 #endif
 
+  if (!ret)
+    {
+      perror ("allocate_stack failed");
+      return NULL;
+    }
+
   return (SCM *) ret;
 }
 #undef FUNC_NAME
@@ -791,13 +846,16 @@ expand_stack (SCM *old_stack, size_t old_size, size_t new_size)
 
   new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE);
   if (new_stack == MAP_FAILED)
-    SCM_SYSERROR;
+    return NULL;
 
   return (SCM *) new_stack;
 #else
   SCM *new_stack;
 
   new_stack = allocate_stack (new_size);
+  if (!new_stack)
+    return NULL;
+
   memcpy (new_stack, old_stack, old_size * sizeof (SCM));
   free_stack (old_stack, old_size);
 
@@ -815,10 +873,15 @@ make_vm (void)
 
   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 
-  vp->stack_size = initial_stack_size;
+  vp->stack_size = page_size / sizeof (SCM);
   vp->stack_base = allocate_stack (vp->stack_size);
+  if (!vp->stack_base)
+    /* As in expand_stack, we don't have any way to throw an exception
+       if we can't allocate one measely page -- there's no stack to
+       handle it.  For now, abort.  */
+    abort ();
   vp->stack_limit = vp->stack_base + vp->stack_size;
-  vp->max_stack_size = default_max_stack_size;
+  vp->overflow_handler_stack = SCM_EOL;
   vp->ip         = NULL;
   vp->sp         = vp->stack_base - 1;
   vp->fp         = NULL;
@@ -831,8 +894,6 @@ make_vm (void)
 }
 #undef FUNC_NAME
 
-static size_t page_size;
-
 static void
 return_unused_stack_to_os (struct scm_vm *vp)
 {
@@ -849,7 +910,16 @@ return_unused_stack_to_os (struct scm_vm *vp)
   /* Return these pages to the OS.  The next time they are paged in,
      they will be zeroed.  */
   if (start < end)
-    madvise ((void *) start, end - start, MADV_DONTNEED);
+    {
+      int ret = 0;
+
+      do
+        ret = madvise ((void *) start, end - start, MADV_DONTNEED);
+      while (ret && errno == -EAGAIN);
+
+      if (ret)
+        perror ("madvise failed");
+    }
 
   vp->sp_max_since_gc = vp->sp;
 #endif
@@ -920,7 +990,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
                     {
                       /* This value may become dead as a result of GC,
                          so we can't just leave it on the stack.  */
-                      *sp = SCM_UNBOUND;
+                      *sp = SCM_UNSPECIFIED;
                       continue;
                     }
                 }
@@ -953,80 +1023,170 @@ scm_i_vm_free_stack (struct scm_vm *vp)
   vp->stack_size = 0;
 }
 
-static void
-vm_expand_stack (struct scm_vm *vp)
+struct vm_expand_stack_data
 {
-  scm_t_ptrdiff stack_size = vp->sp + 1 - vp->stack_base;
+  struct scm_vm *vp;
+  size_t stack_size;
+  SCM *new_sp;
+};
 
-  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 ();
-    }
+static void *
+vm_expand_stack_inner (void *data_ptr)
+{
+  struct vm_expand_stack_data *data = data_ptr;
 
-  /* FIXME: Prevent GC while we expand the stack, to ensure that a
-     stack marker can trace the stack.  */
-  if (stack_size > vp->stack_size)
+  struct scm_vm *vp = data->vp;
+  SCM *old_stack, *new_stack;
+  size_t new_size;
+  scm_t_ptrdiff reloc;
+
+  new_size = vp->stack_size;
+  while (new_size < data->stack_size)
+    new_size *= 2;
+  old_stack = vp->stack_base;
+
+  new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size);
+  if (!new_stack)
+    return NULL;
+
+  vp->stack_base = new_stack;
+  vp->stack_size = new_size;
+  vp->stack_limit = vp->stack_base + new_size;
+  reloc = vp->stack_base - old_stack;
+
+  if (reloc)
     {
-      SCM *old_stack;
-      size_t new_size;
-      scm_t_ptrdiff reloc;
-
-      new_size = vp->stack_size;
-      while (new_size < stack_size)
-        new_size *= 2;
-      old_stack = vp->stack_base;
-      vp->stack_base = expand_stack (old_stack, vp->stack_size, new_size);
-      vp->stack_size = new_size;
-      vp->stack_limit = vp->stack_base + new_size;
-      reloc = vp->stack_base - old_stack;
-
-      if (reloc)
+      SCM *fp;
+      if (vp->fp)
+        vp->fp += reloc;
+      data->new_sp += reloc;
+      fp = vp->fp;
+      while (fp)
         {
-          SCM *fp;
-          if (vp->fp)
-            vp->fp += reloc;
-          vp->sp += reloc;
-          vp->sp_max_since_gc += reloc;
-          fp = vp->fp;
-          while (fp)
+          SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
+          if (next_fp)
             {
-              SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
-              if (next_fp)
-                {
-                  next_fp += reloc;
-                  SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp);
-                }
-              fp = next_fp;
+              next_fp += reloc;
+              SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp);
             }
+          fp = next_fp;
         }
     }
 
-  if (stack_size >= vp->max_stack_size)
-    {
-      /* Expand the soft limit by 256K entries to give us space to
-         handle the error.  */
-      vp->max_stack_size += 256 * 1024;
+  return new_stack;
+}
+
+static scm_t_ptrdiff
+current_overflow_size (struct scm_vm *vp)
+{
+  if (scm_is_pair (vp->overflow_handler_stack))
+    return scm_to_ptrdiff_t (scm_caar (vp->overflow_handler_stack));
+  return -1;
+}
+
+static int
+should_handle_stack_overflow (struct scm_vm *vp, scm_t_ptrdiff stack_size)
+{
+  scm_t_ptrdiff overflow_size = current_overflow_size (vp);
+  return overflow_size >= 0 && stack_size >= overflow_size;
+}
+
+static void
+reset_stack_limit (struct scm_vm *vp)
+{
+  if (should_handle_stack_overflow (vp, vp->stack_size))
+    vp->stack_limit = vp->stack_base + current_overflow_size (vp);
+  else
+    vp->stack_limit = vp->stack_base + vp->stack_size;
+}
+
+struct overflow_handler_data
+{
+  struct scm_vm *vp;
+  SCM overflow_handler_stack;
+};
+
+static void
+wind_overflow_handler (void *ptr)
+{
+  struct overflow_handler_data *data = ptr;
+
+  data->vp->overflow_handler_stack = data->overflow_handler_stack;
+
+  reset_stack_limit (data->vp);
+}
+
+static void
+unwind_overflow_handler (void *ptr)
+{
+  struct overflow_handler_data *data = ptr;
+
+  data->vp->overflow_handler_stack = scm_cdr (data->overflow_handler_stack);
 
-      /* If it's still not big enough... it's quite improbable, but go
-         ahead and set to the full available stack size.  */
-      if (vp->max_stack_size < stack_size)
-        vp->max_stack_size = vp->stack_size;
+  reset_stack_limit (data->vp);
+}
+
+static void
+vm_expand_stack (struct scm_vm *vp, SCM *new_sp)
+{
+  scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base;
 
-      /* But don't exceed the hard maximum.  */
-      if (vp->max_stack_size > hard_max_stack_size)
-        vp->max_stack_size = hard_max_stack_size;
+  if (stack_size > vp->stack_size)
+    {
+      struct vm_expand_stack_data data;
 
-      /* Finally, reset the limit, to catch further overflows.  */
-      vp->stack_limit = vp->stack_base + vp->max_stack_size;
+      data.vp = vp;
+      data.stack_size = stack_size;
+      data.new_sp = new_sp;
+      
+      if (!GC_call_with_alloc_lock (vm_expand_stack_inner, &data))
+        /* Throw an unwind-only exception.  */
+        scm_report_stack_overflow ();
 
-      vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+      new_sp = data.new_sp;
     }
 
-  /* Otherwise continue, with the new enlarged stack.  */
+  vp->sp_max_since_gc = vp->sp = new_sp;
+
+  if (should_handle_stack_overflow (vp, stack_size))
+    {
+      SCM more_stack, new_limit;
+
+      struct overflow_handler_data data;
+      data.vp = vp;
+      data.overflow_handler_stack = vp->overflow_handler_stack;
+
+      scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+
+      scm_dynwind_rewind_handler (unwind_overflow_handler, &data,
+                                  SCM_F_WIND_EXPLICITLY);
+      scm_dynwind_unwind_handler (wind_overflow_handler, &data,
+                                  SCM_F_WIND_EXPLICITLY);
+
+      /* Call the overflow handler.  */
+      more_stack = scm_call_0 (scm_cdar (data.overflow_handler_stack));
+
+      /* If the overflow handler returns, its return value should be an
+         integral number of words from the outer stack limit to transfer
+         to the inner limit.  */
+      if (scm_to_ptrdiff_t (more_stack) <= 0)
+        scm_out_of_range (NULL, more_stack);
+      new_limit = scm_sum (scm_caar (data.overflow_handler_stack), more_stack);
+      if (scm_is_pair (scm_cdr (data.overflow_handler_stack)))
+        new_limit = scm_min (new_limit,
+                             scm_caadr (data.overflow_handler_stack));
+
+      /* Ensure the new limit is in range.  */
+      scm_to_ptrdiff_t (new_limit);
+
+      /* Increase the limit that we will restore.  */
+      scm_set_car_x (scm_car (data.overflow_handler_stack), new_limit);
+
+      scm_dynwind_end ();
+
+      /* Recurse  */
+      return vm_expand_stack (vp, new_sp);
+    }
 }
 
 static struct scm_vm *
@@ -1089,8 +1249,11 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
     int resume = SCM_I_SETJMP (registers);
       
     if (SCM_UNLIKELY (resume))
-      /* Non-local return.  */
-      vm_dispatch_abort_hook (vp);
+      {
+        scm_gc_after_nonlocal_exit ();
+        /* Non-local return.  */
+        vm_dispatch_abort_hook (vp);
+      }
 
     return vm_engines[vp->engine](thread, vp, &registers, resume);
   }
@@ -1268,6 +1431,61 @@ SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_call_with_stack_overflow_handler,
+            "call-with-stack-overflow-handler", 3, 0, 0,
+           (SCM limit, SCM thunk, SCM handler),
+           "Call @var{thunk} in an environment in which the stack limit has\n"
+            "been reduced to @var{limit} additional words.  If the limit is\n"
+            "reached, @var{handler} (a thunk) will be invoked in the dynamic\n"
+            "environment of the error.  For the extent of the call to\n"
+            "@var{handler}, the stack limit and handler are restored to the\n"
+            "values that were in place when\n"
+            "@code{call-with-stack-overflow-handler} was called.")
+#define FUNC_NAME s_scm_call_with_stack_overflow_handler
+{
+  struct scm_vm *vp;
+  scm_t_ptrdiff c_limit, stack_size;
+  struct overflow_handler_data data;
+  SCM new_limit, ret;
+
+  vp = scm_the_vm ();
+  stack_size = vp->sp - vp->stack_base;
+
+  c_limit = scm_to_ptrdiff_t (limit);
+  if (c_limit <= 0)
+    scm_out_of_range (FUNC_NAME, limit);
+
+  new_limit = scm_sum (scm_from_ptrdiff_t (stack_size), limit);
+  if (scm_is_pair (vp->overflow_handler_stack))
+    new_limit = scm_min (new_limit, scm_caar (vp->overflow_handler_stack));
+
+  /* Hacky check that the current stack depth plus the limit is within
+     the range of a ptrdiff_t.  */
+  scm_to_ptrdiff_t (new_limit);
+
+  data.vp = vp;
+  data.overflow_handler_stack =
+    scm_acons (limit, handler, vp->overflow_handler_stack);
+
+  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+
+  scm_dynwind_rewind_handler (wind_overflow_handler, &data,
+                              SCM_F_WIND_EXPLICITLY);
+  scm_dynwind_unwind_handler (unwind_overflow_handler, &data,
+                              SCM_F_WIND_EXPLICITLY);
+
+  /* Reset vp->sp_max_since_gc so that the VM checks actually
+     trigger.  */
+  return_unused_stack_to_os (vp);
+
+  ret = scm_call_0 (thunk);
+
+  scm_dynwind_end ();
+
+  return ret;
+}
+#undef FUNC_NAME
+
 \f
 /*
  * Initialize
@@ -1318,8 +1536,6 @@ scm_bootstrap_vm (void)
   if (page_size & (page_size - 1))
     abort ();
 
-  initialize_default_stack_size ();
-
   sym_vm_run = scm_from_latin1_symbol ("vm-run");
   sym_vm_error = scm_from_latin1_symbol ("vm-error");
   sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");