Out-of-memory situations raise exceptions instead of aborting

* libguile/gc.c (scm_oom_fn, scm_init_gc): Install an out-of-memory
  handler that raises an unwind-only out-of-memory exception.
  (scm_gc_warn_proc, scm_init_gc): Install a warning proc that tries to
  print to the current warning port, if the current warning port is a
  file port.
  (scm_gc_after_nonlocal_exit): New interface.  Should be called after a
  nonlocal return to potentially collect memory; otherwise allocations
  could try to expand again when they should collect.

* libguile/continuations.c (scm_i_make_continuation):
* libguile/eval.c (eval):
* libguile/throw.c (catch):
* libguile/vm.c (scm_call_n): Call scm_gc_after_nonlocal_exit after
  nonlocal returns.

* libguile/throw.c (abort_to_prompt, throw_without_pre_unwind): Rework
  to avoid allocating memory.
  (scm_report_out_of_memory): New interface.
  (scm_init_throw): Pre-allocate the arguments for stack-overflow and
  out-of-memory errors.

* module/ice-9/boot-9.scm: Add an out-of-memory exception printer.
* module/system/repl/error-handling.scm (call-with-error-handling): Add
  out-of-memory to the report-keys set.

* libguile/gc-malloc.c (scm_realloc): Call scm_report_out_of_memory if
  realloc fails.

* libguile/error.h:
* libguile/error.c:
* libguile/deprecated.h:
* libguile/deprecated.c (scm_memory_error): Deprecate.

* test-suite/standalone/Makefile.am:
* test-suite/standalone/test-out-of-memory: New test case.

16 files changed, 251 insertions, 39 deletions

diff --git a/libguile/continuations.c b/libguile/continuations.c
index 1d677610b..f28d59afc 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,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
@@ -161,7 +161,10 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
       return make_continuation_trampoline (cont);
     }
   else
-    return SCM_UNDEFINED;
+    {
+      scm_gc_after_nonlocal_exit ();
+      return SCM_UNDEFINED;
+    }
 }
 #undef FUNC_NAME
 
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 8de28ada0..bbfba10d3 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2,7 +2,7 @@
    deprecate something, move it here when that is feasible.
 */
 
-/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 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
@@ -78,6 +78,21 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
 
 
 
+SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
+void
+scm_memory_error (const char *subr)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_memory_error is deprecated.  Use scm_report_out_of_memory to raise "
+     "an exception, or abort() to cause the program to exit.");
+
+  fprintf (stderr, "FATAL: memory error in %s\n", subr);
+  abort ();
+}
+
+
+
+
 void
 scm_i_init_deprecated ()
 {
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index d02fc7976..ae1fb04c4 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
 #ifndef SCM_DEPRECATED_H
 #define SCM_DEPRECATED_H
 
-/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 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
@@ -140,9 +140,14 @@ typedef scm_i_t_array scm_i_t_array__GONE__REPLACE_WITH__scm_t_array;
 
 /* Deprecated 26-05-2011, as the GC_STUBBORN API doesn't do anything any
    more.  */
-SCM_API SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
-				       scm_t_bits ccr, scm_t_bits cdr);
+SCM_DEPRECATED SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_DEPRECATED SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+                                              scm_t_bits ccr, scm_t_bits cdr);
+
+
+
+SCM_DEPRECATED SCM scm_memory_alloc_key;
+SCM_DEPRECATED void scm_memory_error (const char *subr) SCM_NORETURN;
 
 
 
diff --git a/libguile/error.c b/libguile/error.c
index 26cf5b6d6..b61e90b37 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010,
- *   2012, 2013 Free Software Foundation, Inc.
+ *   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
@@ -291,14 +291,6 @@ scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *sz
 }
 
 
-SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
-void
-scm_memory_error (const char *subr)
-{
-  fprintf (stderr, "FATAL: memory error in %s\n", subr);
-  abort ();
-}
-
 SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
 void
 scm_misc_error (const char *subr, const char *message, SCM args)
diff --git a/libguile/error.h b/libguile/error.h
index 1611fd529..6985dbc4a 100644
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -3,7 +3,7 @@
 #ifndef SCM_ERROR_H
 #define SCM_ERROR_H
 
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008, 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
@@ -31,7 +31,6 @@ SCM_API SCM scm_num_overflow_key;
 SCM_API SCM scm_out_of_range_key;
 SCM_API SCM scm_args_number_key;
 SCM_API SCM scm_arg_type_key;
-SCM_API SCM scm_memory_alloc_key;
 SCM_API SCM scm_misc_error_key;
 
 
@@ -67,7 +66,6 @@ SCM_INTERNAL void scm_i_wrong_type_arg_symbol (SCM symbol, int pos,
 					       SCM bad_value) SCM_NORETURN;
 SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
 				     SCM bad_value, const char *sz) SCM_NORETURN;
-SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;
 SCM_API void scm_misc_error (const char *subr, const char *message,
 			     SCM args) SCM_NORETURN;
 SCM_INTERNAL void scm_init_error (void);
diff --git a/libguile/eval.c b/libguile/eval.c
index 39e66c5d7..2488ee272 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -462,6 +462,7 @@ eval (SCM x, SCM env)
         if (SCM_I_SETJMP (registers))
           {
             /* The prompt exited nonlocally. */
+            scm_gc_after_nonlocal_exit ();
             proc = handler;
             vp = scm_the_vm ();
             args = scm_i_prompt_pop_abort_args_x (vp);
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index 63e670564..d229b90d9 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- *   2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   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
@@ -138,7 +138,10 @@ scm_realloc (void *mem, size_t size)
   if (ptr)
     return ptr;
 
-  scm_memory_error ("realloc");
+  scm_report_out_of_memory ();
+
+  /* Not reached.  */
+  return NULL;
 }
 
 void *
diff --git a/libguile/gc.c b/libguile/gc.c
index 2bcdaffc8..eacd5e256 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -192,6 +192,68 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
 
 #endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */
 
+
+
+
+static int needs_gc_after_nonlocal_exit = 0;
+
+/* Arrange to throw an exception on failed allocations.  */
+static void*
+scm_oom_fn (size_t nbytes)
+{
+  needs_gc_after_nonlocal_exit = 1;
+  scm_report_out_of_memory ();
+  return NULL;
+}
+
+/* Called within GC -- cannot allocate GC memory.  */
+static void
+scm_gc_warn_proc (char *fmt, GC_word arg)
+{
+  SCM port;
+  FILE *stream = NULL;
+
+  port = scm_current_warning_port ();
+  if (!SCM_OPPORTP (port))
+    return;
+
+  if (SCM_FPORTP (port))
+    {
+      int fd;
+      scm_force_output (port);
+      if (!SCM_OPPORTP (port))
+        return;
+      fd = dup (SCM_FPORT_FDES (port));
+      if (fd == -1)
+        perror ("Failed to dup warning port fd");
+      else
+        {
+          stream = fdopen (fd, "a");
+          if (!stream)
+            {
+              perror ("Failed to open stream for warning port");
+              close (fd);
+            }
+        }
+    }
+
+  fprintf (stream ? stream : stderr, fmt, arg);
+
+  if (stream)
+    fclose (stream);
+}
+
+void
+scm_gc_after_nonlocal_exit (void)
+{
+  if (needs_gc_after_nonlocal_exit)
+    {
+      needs_gc_after_nonlocal_exit = 0;
+      GC_gcollect_and_unmap ();
+    }
+}
+
+
 
 
 /* Hooks.  */
@@ -724,6 +786,8 @@ scm_init_gc ()
   scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
   scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
 
+  GC_set_oom_fn (scm_oom_fn);
+  GC_set_warn_proc (scm_gc_warn_proc);
   GC_set_start_callback (run_before_gc_c_hook);
 
 #include "libguile/gc.x"
diff --git a/libguile/gc.h b/libguile/gc.h
index 61fc9a2d5..8b3ae79fd 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -4,7 +4,7 @@
 #define SCM_GC_H
 
 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006,
- *   2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2007, 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
@@ -326,6 +326,7 @@ SCM_API void scm_gc_register_root (SCM *p);
 SCM_API void scm_gc_unregister_root (SCM *p);
 SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
 SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
+SCM_INTERNAL void scm_gc_after_nonlocal_exit (void);
 SCM_INTERNAL void scm_storage_prehistory (void);
 SCM_INTERNAL void scm_init_gc_protect_object (void);
 SCM_INTERNAL void scm_init_gc (void);
diff --git a/libguile/throw.c b/libguile/throw.c
index bef1ecf03..b9a4ab514 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -22,6 +22,7 @@
 # include <config.h>
 #endif
 
+#include <alloca.h>
 #include <stdio.h>
 #include <unistdio.h>
 #include "libguile/_scm.h"
@@ -119,6 +120,8 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
     {
       /* A non-local return.  */
 
+      scm_gc_after_nonlocal_exit ();
+
       /* 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);
@@ -168,11 +171,39 @@ default_exception_handler (SCM k, SCM args)
   abort ();
 }
 
+/* A version of scm_abort_to_prompt_star that avoids the need to cons
+   "tag" to "args", because we might be out of memory.  */
+static void
+abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
+{
+  SCM *argv;
+  size_t i;
+  long n;
+
+  n = scm_ilength (args) + 1;
+  argv = alloca (sizeof (SCM)*n);
+  argv[0] = tag;
+  for (i = 1; i < n; i++, args = scm_cdr (args))
+    argv[i] = scm_car (args);
+
+  scm_c_abort (scm_the_vm (), prompt_tag, n, argv, NULL);
+
+  /* Oh, what, you're still here? The abort must have been reinstated. Actually,
+     that's quite impossible, given that we're already in C-land here, so...
+     abort! */
+
+  abort ();
+}
+
 static SCM
 throw_without_pre_unwind (SCM tag, SCM args)
 {
   SCM eh;
 
+  /* This function is not only the boot implementation of "throw", it is
+     also called in response to resource allocation failures such as
+     stack-overflow or out-of-memory.  For that reason we need to be
+     careful to avoid allocating memory.  */
   for (eh = scm_fluid_ref (exception_handler_fluid);
        scm_is_true (eh);
        eh = scm_c_vector_ref (eh, 0))
@@ -185,17 +216,20 @@ throw_without_pre_unwind (SCM tag, SCM args)
 
       if (scm_is_true (scm_c_vector_ref (eh, 3)))
         {
-          char *key_chars;
+          const char *key_chars;
+
+          if (scm_i_is_narrow_symbol (tag))
+            key_chars = scm_i_symbol_chars (tag);
+          else
+            key_chars = "(wide symbol)";
 
-          key_chars = scm_to_locale_string (scm_symbol_to_string (tag));
           fprintf (stderr, "Warning: Unwind-only `%s' exception; "
                    "skipping pre-unwind handler.\n", key_chars);
-          free (key_chars);
         }
 
       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));
+        abort_to_prompt (prompt_tag, tag, args);
     }
 
   default_exception_handler (tag, args);
@@ -571,22 +605,31 @@ scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
 }
 
 SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
+SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
+
+static SCM stack_overflow_args = SCM_BOOL_F;
+static SCM out_of_memory_args = SCM_BOOL_F;
+
+/* Since these two functions may be called in response to resource
+   exhaustion, we have to avoid allocating memory.  */
 
 void
 scm_report_stack_overflow (void)
 {
-  /* Arguments as if from:
+  if (scm_is_false (stack_overflow_args))
+    abort ();
+  throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args);
 
-       scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
+  /* Not reached.  */
+  abort ();
+}
 
-     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);
+void
+scm_report_out_of_memory (void)
+{
+  if (scm_is_false (out_of_memory_args))
+    abort ();
+  throw_without_pre_unwind (scm_out_of_memory_key, out_of_memory_args);
 
   /* Not reached.  */
   abort ();
@@ -607,6 +650,22 @@ scm_init_throw ()
   throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
                                                        throw_without_pre_unwind));
 
+  /* Arguments as if from:
+
+       scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
+
+     We build the arguments manually because we throw without running
+     pre-unwind handlers.  (Pre-unwind handlers could rewind the
+     stack.)  */
+  stack_overflow_args = scm_list_4 (SCM_BOOL_F,
+                                    scm_from_latin1_string ("Stack overflow"),
+                                    SCM_BOOL_F,
+                                    SCM_BOOL_F);
+  out_of_memory_args = scm_list_4 (SCM_BOOL_F,
+                                   scm_from_latin1_string ("Out of memory"),
+                                   SCM_BOOL_F,
+                                   SCM_BOOL_F);
+
 #include "libguile/throw.x"
 }
 
diff --git a/libguile/throw.h b/libguile/throw.h
index 531aadd33..e2da73170 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -85,6 +85,10 @@ SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return);
    handlers.  */
 SCM_API void scm_report_stack_overflow (void);
 
+/* This throws to the `out-of-memory' key, without running pre-unwind
+   handlers.  */
+SCM_API void scm_report_out_of_memory (void);
+
 SCM_API SCM scm_throw (SCM key, SCM args);
 SCM_INTERNAL void scm_init_throw (void);
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 88c75fd33..b4ebbc724 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1236,8 +1236,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);
   }
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 37918cdfb..4d5d603ae 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1040,6 +1040,7 @@ for key @var{k}, then invoke @var{thunk}."
   (set-exception-printer! 'no-data scm-error-printer)
   (set-exception-printer! 'no-recovery scm-error-printer)
   (set-exception-printer! 'null-pointer-error scm-error-printer)
+  (set-exception-printer! 'out-of-memory scm-error-printer)
   (set-exception-printer! 'out-of-range scm-error-printer)
   (set-exception-printer! 'program-error scm-error-printer)
   (set-exception-printer! 'read-error scm-error-printer)
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index eea7b9701..94a9f2a66 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -43,7 +43,7 @@
 (define* (call-with-error-handling thunk #:key
                                    (on-error 'debug) (post-error 'catch)
                                    (pass-keys '(quit)) (trap-handler 'debug)
-                                   (report-keys '(stack-overflow)))
+                                   (report-keys '(stack-overflow out-of-memory)))
   (let ((in (current-input-port))
         (out (current-output-port))
         (err (current-error-port)))
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index 6f252f4cf..d2f430050 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -267,4 +267,7 @@ TESTS += test-smob-mark
 check_SCRIPTS += test-stack-overflow
 TESTS += test-stack-overflow
 
+check_SCRIPTS += test-out-of-memory
+TESTS += test-out-of-memory
+
 EXTRA_DIST += ${check_SCRIPTS}
diff --git a/test-suite/standalone/test-out-of-memory b/test-suite/standalone/test-out-of-memory
new file mode 100755
index 000000000..0fc5a2e9e
--- /dev/null
+++ b/test-suite/standalone/test-out-of-memory
@@ -0,0 +1,60 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+(unless (defined? 'setrlimit)
+  ;; Without an rlimit, this test can take down your system, as it
+  ;; consumes all of your memory.  That doesn't seem like something we
+  ;; should run as part of an automated test suite.
+  (exit 0))
+
+(catch #t
+  ;; Silence GC warnings.
+  (lambda ()
+    (current-warning-port (open-output-file "/dev/null")))
+  (lambda (k . args)
+    (print-exception (current-error-port) #f k args)
+    (write "Skipping test.\n" (current-error-port))
+    (exit 0)))
+
+;; 100 MB.
+(define *limit* (* 100 1024 1024))
+
+(call-with-values (lambda () (getrlimit 'as))
+  (lambda (soft hard)
+    (unless (and soft (< soft *limit*))
+      (setrlimit 'as (if hard (min *limit* hard) *limit*) hard))))
+
+(define (test thunk)
+  (catch 'out-of-memory
+    (lambda ()
+      (thunk)
+      (error "should not be reached"))
+    (lambda _
+      #t)))
+
+(use-modules (rnrs bytevectors))
+
+(test (lambda ()
+        ;; A vector with a billion elements doesn't fit into 100 MB.
+        (make-vector #e1e9)))
+(test (lambda ()
+        ;; Likewise for a bytevector.  This is different from the above,
+        ;; as the elements of a bytevector are not traced by GC.
+        (make-bytevector #e1e9)))
+(test (lambda ()
+        ;; This one is the kicker -- we allocate pairs until the heap
+        ;; can't expand.  This is the hardest test to deal with because
+        ;; the error-handling machinery has no memory in which to work.
+        (iota #e1e8)))
+(test (lambda ()
+        ;; The same, but also causing allocating during the unwind
+        ;; (ouch!)
+        (dynamic-wind
+          (lambda () #t)
+          (lambda () (iota #e1e8))
+          (lambda () (iota #e1e8)))))
+
+;; Local Variables:
+;; mode: scheme
+;; End: