Default stack size is one page.

[bpt/guile.git] / libguile / vm.c

diff --git a/libguile/vm.c b/libguile/vm.c
index b0918b6..93a3720 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -423,6 +423,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;
@@ -547,6 +549,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,12 +713,15 @@ scm_i_call_with_current_continuation (SCM proc)
  * VM
  */
 
+/* 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: 4 or 8 kB.  */
-static const size_t initial_stack_size = 1024;
+/* Initial stack size.  Defaults to one page.  */
+static size_t initial_stack_size;
 
 /* Default soft stack limit is 1M words (4 or 8 megabytes).  */
 static size_t default_max_stack_size = 1024 * 1024;
@@ -711,9 +729,15 @@ 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;
+  initial_stack_size = page_size / sizeof (SCM);
+
+  {
+    int size;
+    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
@@ -753,13 +777,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 +819,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);
 
@@ -817,6 +848,11 @@ make_vm (void)
 
   vp->stack_size = initial_stack_size;
   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->ip         = NULL;
@@ -831,8 +867,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 +883,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
@@ -971,7 +1014,7 @@ vm_expand_stack (struct scm_vm *vp)
      stack marker can trace the stack.  */
   if (stack_size > vp->stack_size)
     {
-      SCM *old_stack;
+      SCM *old_stack, *new_stack;
       size_t new_size;
       scm_t_ptrdiff reloc;
 
@@ -979,7 +1022,17 @@ vm_expand_stack (struct scm_vm *vp)
       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);
+      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 ();
+
+      vp->stack_base = new_stack;
       vp->stack_size = new_size;
       vp->stack_limit = vp->stack_base + new_size;
       reloc = vp->stack_base - old_stack;