[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-813-gc2247b7
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-813-gc2247b7 |
|
Date: |
Sat, 22 Mar 2014 15:04:03 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c2247b782a9234bb9aedee5204c30daf1d01a510
The branch, master has been updated
via c2247b782a9234bb9aedee5204c30daf1d01a510 (commit)
via 0463a927c4ba4e941a3e7d100c629adf7e64b7c2 (commit)
from 48c2a5395ab647e61fb8f22c344beeded02b8218 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c2247b782a9234bb9aedee5204c30daf1d01a510
Author: Andy Wingo <address@hidden>
Date: Sat Mar 22 15:49:31 2014 +0100
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.
commit 0463a927c4ba4e941a3e7d100c629adf7e64b7c2
Author: Andy Wingo <address@hidden>
Date: Sat Mar 22 15:42:15 2014 +0100
Define a C fluid for current-warning-port
* libguile/ports.c (scm_current_input_port, scm_current_output_port)
(scm_current_error_port): Fix declarations to C99.
(scm_current_warning_port, scm_set_current_warning_port): Rework to
use a C fluid, like scm_current_error_port.
(scm_init_ports): Initialize and define the warning port fluid.
* libguile/init.c (scm_init_standard_ports): Init the current warning
port.
* module/ice-9/boot-9.scm: Remove definitions for current-warning-port.
Instead, steal it from the boot objtable with port-parameterize!.
-----------------------------------------------------------------------
Summary of changes:
libguile/continuations.c | 7 ++-
libguile/deprecated.c | 17 ++++++-
libguile/deprecated.h | 13 +++--
libguile/error.c | 10 +---
libguile/error.h | 4 +-
libguile/eval.c | 1 +
libguile/gc-malloc.c | 7 ++-
libguile/gc.c | 64 ++++++++++++++++++++++
libguile/gc.h | 3 +-
libguile/init.c | 3 +-
libguile/ports.c | 43 ++++++++-------
libguile/throw.c | 87 +++++++++++++++++++++++++-----
libguile/throw.h | 4 ++
libguile/vm.c | 7 ++-
module/ice-9/boot-9.scm | 19 +------
module/system/repl/error-handling.scm | 2 +-
test-suite/standalone/Makefile.am | 3 +
test-suite/standalone/test-out-of-memory | 60 ++++++++++++++++++++
18 files changed, 277 insertions(+), 77 deletions(-)
create mode 100755 test-suite/standalone/test-out-of-memory
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 1d67761..f28d59a 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 8de28ad..bbfba10 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 d02fc79..ae1fb04 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 26cf5b6..b61e90b 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 1611fd5..6985dbc 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 39e66c5..2488ee2 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 63e6705..d229b90 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 2bcdaff..eacd5e2 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 61fc9a2..8b3ae79 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/init.c b/libguile/init.c
index 54f73a9..81cf997 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ * 2004, 2006, 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
@@ -222,6 +222,7 @@ scm_init_standard_ports ()
(scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
scm_set_current_error_port
(scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
+ scm_set_current_warning_port (scm_current_error_port ());
}
diff --git a/libguile/ports.c b/libguile/ports.c
index e256d65..060c4fb 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -391,10 +391,11 @@ SCM_DEFINE (scm_i_set_port_property_x,
"%set-port-property!", 3, 0, 0,
static SCM cur_inport_fluid = SCM_BOOL_F;
static SCM cur_outport_fluid = SCM_BOOL_F;
static SCM cur_errport_fluid = SCM_BOOL_F;
+static SCM cur_warnport_fluid = SCM_BOOL_F;
static SCM cur_loadport_fluid = SCM_BOOL_F;
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
- (),
+ (void),
"Return the current input port. This is the default port used\n"
"by many input procedures. Initially, @code{current-input-port}\n"
"returns the @dfn{standard input} in Unix and C terminology.")
@@ -408,7 +409,7 @@ SCM_DEFINE (scm_current_input_port, "current-input-port",
0, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
- (),
+ (void),
"Return the current output port. This is the default port used\n"
"by many output procedures. Initially,\n"
"@code{current-output-port} returns the @dfn{standard output} in\n"
@@ -423,7 +424,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port",
0, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
- (),
+ (void),
"Return the port to which errors and warnings should be sent (the\n"
"@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port
@@ -435,23 +436,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port",
0, 0, 0,
}
#undef FUNC_NAME
-static SCM current_warning_port_var;
-static scm_i_pthread_once_t current_warning_port_once =
SCM_I_PTHREAD_ONCE_INIT;
-
-static void
-init_current_warning_port_var (void)
-{
- current_warning_port_var
- = scm_c_private_variable ("guile", "current-warning-port");
-}
-
-SCM
-scm_current_warning_port (void)
+SCM_DEFINE (scm_current_warning_port, "current-warning-port", 0, 0, 0,
+ (void),
+ "Return the port to which diagnostic warnings should be sent.")
+#define FUNC_NAME s_scm_current_warning_port
{
- scm_i_pthread_once (¤t_warning_port_once,
- init_current_warning_port_var);
- return scm_call_0 (scm_variable_ref (current_warning_port_var));
+ if (scm_is_true (cur_warnport_fluid))
+ return scm_fluid_ref (cur_warnport_fluid);
+ else
+ return SCM_BOOL_F;
}
+#undef FUNC_NAME
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
(),
@@ -510,11 +505,15 @@ SCM_DEFINE (scm_set_current_error_port,
"set-current-error-port", 1, 0, 0,
SCM
scm_set_current_warning_port (SCM port)
+#define FUNC_NAME "set-current-warning-port"
{
- scm_i_pthread_once (¤t_warning_port_once,
- init_current_warning_port_var);
- return scm_call_1 (scm_variable_ref (current_warning_port_var), port);
+ SCM owarnp = scm_fluid_ref (cur_warnport_fluid);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_fluid_set_x (cur_warnport_fluid, port);
+ return owarnp;
}
+#undef FUNC_NAME
void
@@ -3197,6 +3196,7 @@ scm_init_ports ()
cur_inport_fluid = scm_make_fluid ();
cur_outport_fluid = scm_make_fluid ();
cur_errport_fluid = scm_make_fluid ();
+ cur_warnport_fluid = scm_make_fluid ();
cur_loadport_fluid = scm_make_fluid ();
scm_i_port_weak_set = scm_c_make_weak_set (31);
@@ -3217,6 +3217,7 @@ scm_init_ports ()
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
scm_c_define ("%current-output-port-fluid", cur_outport_fluid);
scm_c_define ("%current-error-port-fluid", cur_errport_fluid);
+ scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid);
}
/*
diff --git a/libguile/throw.c b/libguile/throw.c
index bef1ecf..b9a4ab5 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 531aadd..e2da731 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 88c75fd..b4ebbc7 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, ®isters, resume);
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 9c1bdc4..4d5d603 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -206,9 +206,6 @@ file with the given name already exists, the effect is
unspecified."
(define pk peek)
-;; Temporary definition; replaced later.
-(define current-warning-port current-error-port)
-
(define (warn . stuff)
(newline (current-warning-port))
(display ";;; WARNING " (current-warning-port))
@@ -1043,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)
@@ -1541,23 +1539,12 @@ CONV is not applied to the initial value."
(port-parameterize! current-output-port %current-output-port-fluid
output-port? "expected an output port")
(port-parameterize! current-error-port %current-error-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-warning-port %current-warning-port-fluid
output-port? "expected an output port"))
-;;; {Warnings}
-;;;
-
-(define current-warning-port
- (make-parameter (current-error-port)
- (lambda (x)
- (if (output-port? x)
- x
- (error "expected an output port" x)))))
-
-
-
-
;;; {Languages}
;;;
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index eea7b97..94a9f2a 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 6f252f4..d2f4300 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 0000000..0fc5a2e
--- /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:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-813-gc2247b7,
Andy Wingo <=