vm: Gracefully handle stack overflows.

Fixes <http://lists.gnu.org/archive/html/guile-user/2013-12/msg00017.html>.
Reported by rvclayton@verizon.net (R. Clayton).

* libguile/vm.c (reinstate_stack_reserve): New function.
  (vm_error_stack_overflow): Install it as an unwind handler.
* test-suite/tests/control.test ("the-vm")["stack overflow reinstates
  stack reserve"]: New test.

2 files changed, 29 insertions, 1 deletions

diff --git a/libguile/vm.c b/libguile/vm.c
index 62c1d6d88..d4c8b5fde 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -505,6 +505,15 @@ vm_error_wrong_type_apply (SCM proc)
              scm_list_1 (proc), scm_list_1 (proc));
 }
 
+/* Reinstate the stack reserve in the VM pointed to by DATA.  */
+static void
+reinstate_stack_reserve (void *data)
+{
+  struct scm_vm *vp = data;
+
+  vp->stack_limit -= VM_STACK_RESERVE_SIZE;
+}
+
 static void
 vm_error_stack_overflow (struct scm_vm *vp)
 {
@@ -516,7 +525,13 @@ vm_error_stack_overflow (struct scm_vm *vp)
     /* There is no space left on the stack.  FIXME: Do something more
        sensible here! */
     abort ();
+
+  /* Before throwing, install a handler that reinstates the reserve so
+     that subsequent overflows are gracefully handled.  */
+  scm_dynwind_begin (0);
+  scm_dynwind_unwind_handler (reinstate_stack_reserve, vp, 0);
   vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+  scm_dynwind_end ();
 }
 
 static void
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 5b292c4df..0d95dba8e 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -375,7 +375,20 @@
         (lambda (key vm)
           (and (eq? key 'foo)
                (eq? vm new-vm)
-               (eq? (the-vm) prev-vm)))))))
+               (eq? (the-vm) prev-vm))))))
+
+  (pass-if "stack overflow reinstates stack reserve"
+    ;; In Guile <= 2.0.9, only the first overflow would be gracefully
+    ;; handle; subsequent overflows would lead to an abort.  See
+    ;; <http://lists.gnu.org/archive/html/guile-user/2013-12/msg00017.html>.
+    (letrec ((foo (lambda () (+ 1 (foo)))))
+      (define (overflows?)
+        (catch 'vm-error foo
+          (lambda (key proc msg . rest)
+            (and (eq? 'vm-run proc)
+                 (->bool (string-contains msg "overflow"))))))
+
+      (and (overflows?) (overflows?) (overflows?)))))
 
 ;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
 ;; http://okmij.org/ftp/Scheme/delim-control-n.scm.  Public domain.