From c2247b782a9234bb9aedee5204c30daf1d01a510 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 22 Mar 2014 15:49:31 +0100 Subject: [PATCH] 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. --- 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/throw.c | 87 ++++++++++++++++++++---- libguile/throw.h | 4 ++ libguile/vm.c | 7 +- module/ice-9/boot-9.scm | 1 + module/system/repl/error-handling.scm | 2 +- test-suite/standalone/Makefile.am | 3 + test-suite/standalone/test-out-of-memory | 60 ++++++++++++++++ 16 files changed, 251 insertions(+), 39 deletions(-) create mode 100755 test-suite/standalone/test-out-of-memory 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 #endif +#include #include #include #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, ®isters, 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: -- 2.20.1