Apply checks for stack overflow.

eval.c

@@ -293,7 +293,7 @@ sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags,
                              sexp num_args, sexp bc, sexp vars) {
   sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE);
   sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags;
-  sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args;
+  sexp_procedure_num_args(proc) = sexp_unbox_fixnum(num_args);
   sexp_procedure_code(proc) = bc;
   sexp_procedure_vars(proc) = vars;
   return proc;

include/chibi/features.h

@@ -183,6 +183,12 @@
 /*   this enabled. */
 /* #define SEXP_USE_CHECK_STACK 0 */
 
+/* uncomment this to disable growing the stack on overflow */
+/*   If enabled, chibi attempts to grow the stack on overflow, */
+/*   up to SEXP_MAX_STACK_SIZE, otherwise a failed stack check */
+/*   will just raise an error immediately. */
+/* #define SEXP_USE_GROW_STACK 0 */
+
 /* #define SEXP_USE_DEBUG_VM 0 */
 /*   Experts only. */
 /*   For *very* verbose output on every VM operation. */
@@ -530,6 +536,14 @@
 #define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_USE_GROW_STACK
+#define SEXP_USE_GROW_STACK SEXP_USE_CHECK_STACK && ! SEXP_USE_NO_FEATURES
+#endif
+
+#ifndef SEXP_USE_LONG_PROCEDURE_ARGS
+#define SEXP_USE_LONG_PROCEDURE_ARGS ! SEXP_USE_NO_FEATURES
+#endif
+
 #ifndef SEXP_INIT_BCODE_SIZE
 #define SEXP_INIT_BCODE_SIZE 128
 #endif

include/chibi/sexp.h

@@ -184,6 +184,12 @@ typedef int sexp_sint_t;
 #define sexp_heap_align(n) sexp_align(n, 4)
 #endif
 
+#if SEXP_USE_LONG_PROCEDURE_ARGS
+typedef int sexp_proc_num_args_t;
+#else
+typedef short sexp_proc_num_args_t;
+#endif
+
 typedef struct sexp_struct *sexp;
 
 #define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1))
@@ -355,7 +361,7 @@ struct sexp_struct {
     } bytecode;
     struct {
       char flags;
-      unsigned short num_args;
+      sexp_proc_num_args_t num_args;
       sexp bc, vars;
     } procedure;
     struct {

vm.c

@@ -1,5 +1,5 @@
 /*  vm.c -- stack-based virtual machine backend               */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #if SEXP_USE_DEBUG_VM > 1
@@ -652,11 +652,12 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
 
 /*********************** the virtual machine **************************/
 
-#if SEXP_USE_CHECK_STACK
+#if SEXP_USE_GROW_STACK
-static int sexp_grow_stack (sexp ctx) {
+static int sexp_grow_stack (sexp ctx, int min_size) {
   sexp stack, old_stack = sexp_context_stack(ctx), *from, *to;
   int i, size = sexp_stack_length(old_stack), new_size;
   new_size = size * 2;
+  if (new_size < min_size) new_size = min_size;
   if (new_size > SEXP_MAX_STACK_SIZE) {
     if (size == SEXP_MAX_STACK_SIZE)
       return 0;
@@ -677,6 +678,8 @@ static int sexp_grow_stack (sexp ctx) {
       sexp_context_stack(ctx) = stack;
   return 1;
 }
+#else
+#define sexp_grow_stack(ctx, min_size) 0
 #endif
 
 static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) {
@@ -694,7 +697,7 @@ static sexp sexp_restore_stack (sexp ctx, sexp saved) {
   sexp *from = sexp_vector_data(saved), *to;
 #if SEXP_USE_CHECK_STACK
   if ((len+64 >= sexp_stack_length(sexp_context_stack(ctx)))
-      && !sexp_grow_stack(ctx))
+      && !sexp_grow_stack(ctx, len+64))
     return sexp_global(ctx, SEXP_G_OOS_ERROR);
 #endif
   to = sexp_stack_data(sexp_context_stack(ctx));
@@ -812,6 +815,21 @@ static sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
 }
 #endif
 
+#if SEXP_USE_CHECK_STACK
+#define sexp_ensure_stack(n)                                   \
+  if (top+n >= sexp_stack_length(sexp_context_stack(ctx))) {   \
+    sexp_context_top(ctx) = top;                               \
+    if (sexp_grow_stack(ctx, n)) {                             \
+      stack = sexp_stack_data(sexp_context_stack(ctx));        \
+    } else {                                                   \
+      _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR);              \
+      goto end_loop;                                           \
+    }                                                          \
+  }
+#else
+#define sexp_ensure_stack(n)
+#endif
+
 sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   unsigned char *ip;
   sexp bc, cp, *stack = sexp_stack_data(sexp_context_stack(ctx));
@@ -938,6 +956,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     top -= 2;
   apply1:
     i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
+    sexp_ensure_stack(i + 64);
     top += i;
     for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
       _ARG1 = sexp_car(tmp2);
@@ -962,17 +981,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     fp = sexp_unbox_fixnum(tmp2);
     goto make_call;
   case SEXP_OP_CALL:
-#if SEXP_USE_CHECK_STACK
+    sexp_ensure_stack(64);  /* TODO: pre-compute stack needed for each proc */
-    if (top+64 >= sexp_stack_length(sexp_context_stack(ctx))) {
-      sexp_context_top(ctx) = top;
-      if (sexp_grow_stack(ctx)) {
-        stack = sexp_stack_data(sexp_context_stack(ctx));
-      } else {
-        _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR);
-        goto end_loop;
-      }
-    }
-#endif
     _ALIGN_IP();
     i = sexp_unbox_fixnum(_WORD0);
     tmp1 = _ARG1;
@@ -988,7 +997,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     }
     if (! sexp_procedurep(tmp1))
       sexp_raise("non procedure application", sexp_list1(ctx, tmp1));
-    j = i - sexp_unbox_fixnum(sexp_procedure_num_args(tmp1));
+    j = i - sexp_procedure_num_args(tmp1);
     if (j < 0)
       sexp_raise("not enough args",
                  sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));