diff --git a/code/error.lisp b/code/error.lisp index 6f6f669e3c1f8c49db97531e139b16c1e01d6aae..8aae037039323c6033b6792df438378699369c86 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.76 2003/07/20 11:02:48 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.77 2003/10/24 02:56:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -22,7 +22,7 @@ (export '(layout-invalid condition-function-name simple-control-error simple-file-error simple-program-error simple-parse-error simple-style-warning simple-undefined-function - stack-overflow)) + stack-overflow heap-overflow)) (in-package "LISP") (export '(break error warn cerror @@ -951,6 +951,13 @@ (declare (ignore condition)) (format stream "Control stack overflow")))) +#+heap-overflow-check +(define-condition heap-overflow (storage-condition) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "Heap (dynamic space) overflow")))) + (define-condition type-error (error) ((datum :reader type-error-datum :initarg :datum) (expected-type :reader type-error-expected-type :initarg :expected-type)) diff --git a/code/interr.lisp b/code/interr.lisp index 783f196b129b655b2f839833e71ffdf402c29c6d..6a593b962a2acffdf59e85a00d44d7928ebbdfc3 100644 --- a/code/interr.lisp +++ b/code/interr.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.42 2003/05/26 20:20:32 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.43 2003/10/24 02:56:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,8 @@ (in-package "KERNEL") (export '(infinite-error-protect find-caller-name *maximum-error-depth* - red-zone-hit yellow-zone-hit)) + red-zone-hit yellow-zone-hit + dynamic-space-overflow-error-hit dynamic-space-overflow-warning-hit)) @@ -657,4 +658,19 @@ Returning to Top-Level.~@:>~2%") (throw 'lisp::top-level-catcher nil)) +#+heap-overflow-check +(defun dynamic-space-overflow-warning-hit () + (let ((debug:*stack-top-hint* nil)) + ;; Don't reserve any more pages + (setf lisp::reserved-heap-pages 0) + (format *error-output* + "~2&~@<Imminent dynamic space overflow has occurred: ~ + Only a small amount of dynamic space is available now. ~ + Please note that you will be returned to the Top-Level without ~ + warning if you run out of space while debugging.~@:>~%") + (infinite-error-protect (error 'heap-overflow)))) + +#+heap-overflow-check +(defun dynamic-space-overflow-error-hit () + (throw 'lisp::top-level-catcher nil)) diff --git a/code/lispinit.lisp b/code/lispinit.lisp index e584f98e0283a42920a4f4e786c067aaba80d547..3f2d2fb08189c4d170c214e639eff74b65875ea8 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.72 2003/09/25 02:40:12 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.73 2003/10/24 02:56:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -38,6 +38,9 @@ #+stack-checking (sys:register-lisp-runtime-feature :stack-checking) +#+heap-overflow-check +(sys:register-lisp-runtime-feature :heap-overflow-check) + ;;; Make the error system enable interrupts. (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum @@ -616,6 +619,13 @@ (defconstant eofs-before-quit 10) +(defparameter *reserved-heap-pages* 256 + "How many pages to reserve from the total heap space so we can handle +heap overflow.") + +#+heap-overflow-check +(alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long) + (defun %top-level () "Top-level READ-EVAL-PRINT loop. Do not call this." (let ((* nil) (** nil) (*** nil) @@ -631,6 +641,8 @@ (loop (scrub-control-stack) (fresh-line) + ;; Reset reserved pages in the heap + #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*) (princ (if (functionp *prompt*) (funcall *prompt*) *prompt*)) diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index a8db59f4d36c164688ea304aee5c31a56baadd05..cb6cb741b14913f14c8334e5a6a3793889e5bf39 100644 --- a/compiler/generic/new-genesis.lisp +++ b/compiler/generic/new-genesis.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.62 2003/10/13 21:51:04 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.63 2003/10/24 02:56:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -707,6 +707,10 @@ (progn (frob kernel::yellow-zone-hit) (frob kernel::red-zone-hit)) + #+heap-overflow-check + (progn + (frob kernel::dynamic-space-overflow-error-hit) + (frob kernel::dynamic-space-overflow-warning-hit)) (frob di::handle-breakpoint) (frob di::handle-function-end-breakpoint) (frob lisp::fdefinition-object)) diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp index becd961fb05d93b05d1904c1f5ce586d1ae68edf..2595e54f8ad0b9ae39fcf96ea01be39d887f6fe1 100644 --- a/compiler/sparc/parms.lisp +++ b/compiler/sparc/parms.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.46 2003/10/09 21:55:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.47 2003/10/24 02:57:00 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -210,7 +210,10 @@ (export '(halt-trap pending-interrupt-trap error-trap cerror-trap breakpoint-trap function-end-breakpoint-trap - after-breakpoint-trap allocation-trap pseudo-atomic-trap + after-breakpoint-trap allocation-trap + dynamic-space-overflow-error-trap + dynamic-space-overflow-warning-trap + pseudo-atomic-trap object-not-list-trap object-not-instance-trap trace-table-normal trace-table-call-site trace-table-function-prologue trace-table-function-epilogue)) @@ -222,7 +225,10 @@ cerror breakpoint function-end-breakpoint - after-breakpoint) + after-breakpoint + dynamic-space-overflow-warning + dynamic-space-overflow-error + ) ;; Make sure this starts AFTER the last element of the above enum! (defenum (:prefix object-not- :suffix -trap :start 16) @@ -263,6 +269,8 @@ kernel::internal-error #+stack-checking kernel::yellow-zone-hit #+stack-checking kernel::red-zone-hit + #+heap-overflow-check kernel::dynamic-space-overflow-warning-hit + #+heap-overflow-check kernel::dynamic-space-overflow-error-hit di::handle-breakpoint lisp::fdefinition-object @@ -354,7 +362,7 @@ ;;;; ;;;; This value is added to alloc-tn to indicate a pseudo-atomic ;;;; section. -(defconstant pseudo-atomic-value (ash 1 (1- vm:lowtag-bits))) +(defconstant pseudo-atomic-value (ash 1 (1- vm::lowtag-bits))) ;;;; Pseudo-atomic-interrupted-mask ;;;; diff --git a/lisp/gencgc.c b/lisp/gencgc.c index 7ebc3e4d41a98518e848c94bee0587500438a959..1b0e8ab02e5e2f107535f9ff7d370819dabc64b3 100644 --- a/lisp/gencgc.c +++ b/lisp/gencgc.c @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.45 2003/10/16 16:18:03 toy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.46 2003/10/24 02:57:00 toy Exp $ * */ @@ -270,6 +270,16 @@ volatile unsigned long long bytes_allocated_sum = 0; */ unsigned long auto_gc_trigger = 0xffffffff; +/* + * Number of pages to reserve for heap overflow. We want some space + * available on the heap when we are close to a heap overflow, so we + * can handle the overflow. But how much do we really need? I (rtoy) + * think 256 pages is probably a decent amount. (That's 1 MB for x86, + * 2 MB for sparc, which has 8K pages.) + */ + +unsigned long reserved_heap_pages = 256; + /* * The src. and dest. generations. Set before a GC starts scavenging. */ @@ -706,6 +716,43 @@ void *current_region_end_addr; /* The generation currently being allocated to. X */ static int gc_alloc_generation; +/* Handle heap overflow here, maybe. */ +static void +handle_heap_overflow(const char* msg, int size) +{ + unsigned long heap_size_mb; + + if (msg) + { + fprintf(stderr, msg, size); + } +#ifndef SPARSE_BLOCK_SIZE +#define SPARSE_BLOCK_SIZE (0) +#endif + + /* Figure out how many MB of heap we have */ + heap_size_mb = (dynamic_space_size + SPARSE_BLOCK_SIZE) >> 20; + + fprintf(stderr, " CMUCL has run out of dynamic heap space (%lu MB).\n", heap_size_mb); + /* Try to handle heap overflow somewhat gracefully if we can. */ +#if defined(trap_DynamicSpaceOverflow) || defined(FEATURE_HEAP_OVERFLOW_CHECK) + if (reserved_heap_pages == 0) + { + fprintf(stderr, "\n Returning to top-level.\n"); + do_dynamic_space_overflow_error(); + } + else + { + fprintf(stderr, " You can control heap size with the -dynamic-space-size commandline option.\n"); + do_dynamic_space_overflow_warning(); + } +#else + print_generation_stats(1); + + exit(1); +#endif +} + /* * Find a new region with room for at least the given number of bytes. * @@ -787,12 +834,8 @@ static void gc_alloc_new_region(int nbytes, int unboxed, } /* Check for a failure */ - if (first_page >= dynamic_space_pages) { - fprintf(stderr, "!!! CMUCL has run out of dynamic heap space. You can control heap size\n"); - fprintf(stderr, "!!! with the -dynamic-space-size commandline option.\n"); - fprintf(stderr, "*A2 gc_alloc_new_region failed, nbytes=%d.\n", nbytes); - print_generation_stats(1); - exit(1); + if (first_page >= dynamic_space_pages - reserved_heap_pages) { + handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n", nbytes); } gc_assert(!PAGE_WRITE_PROTECTED(first_page)); @@ -835,12 +878,8 @@ static void gc_alloc_new_region(int nbytes, int unboxed, while (restart_page < dynamic_space_pages && bytes_found < nbytes); /* Check for a failure */ - if (restart_page >= dynamic_space_pages && bytes_found < nbytes) { - fprintf(stderr, "!!! CMUCL has run out of dynamic heap space. You can control heap size\n"); - fprintf(stderr, "!!! with the -dynamic-space-size commandline option.\n"); - fprintf(stderr, "*A1 gc_alloc_new_region failed, nbytes=%d.\n", nbytes); - print_generation_stats(1); - exit(1); + if (restart_page >= (dynamic_space_pages - reserved_heap_pages) && bytes_found < nbytes) { + handle_heap_overflow("*A1 gc_alloc_new_region failed, nbytes=%d.\n", nbytes); } #if 0 @@ -1235,12 +1274,8 @@ static void *gc_alloc_large(int nbytes, int unboxed, } /* Check for a failure */ - if (first_page >= dynamic_space_pages) { - fprintf(stderr, "!!! CMUCL has run out of dynamic heap space. You can control heap size\n"); - fprintf(stderr, "!!! with the -dynamic-space-size commandline option.\n"); - fprintf(stderr, "*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes); - print_generation_stats(1); - exit(1); + if (first_page >= dynamic_space_pages - reserved_heap_pages) { + handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes); } gc_assert(!PAGE_WRITE_PROTECTED(first_page)); @@ -1277,12 +1312,8 @@ static void *gc_alloc_large(int nbytes, int unboxed, while ((restart_page < dynamic_space_pages) && (bytes_found < nbytes)); /* Check for a failure */ - if (restart_page >= dynamic_space_pages && bytes_found < nbytes) { - fprintf(stderr, "*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes); - fprintf(stderr, "!!! CMUCL has run out of dynamic heap space. You can control heap size\n"); - fprintf(stderr, "!!! with the -dynamic-space-size commandline option.\n"); - print_generation_stats(1); - exit(1); + if (restart_page >= (dynamic_space_pages - reserved_heap_pages) && bytes_found < nbytes) { + handle_heap_overflow("*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes); } #if 0 diff --git a/lisp/interrupt.c b/lisp/interrupt.c index 6e0a315c84469c49bcd5e8d097a7059bd69fa7fc..3eda3821aa47065ea8517b2f20a04f56c1e293b9 100644 --- a/lisp/interrupt.c +++ b/lisp/interrupt.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.30 2003/07/19 14:10:16 emarsden Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.31 2003/10/24 02:57:00 toy Exp $ */ /* Interrupt handing magic. */ @@ -630,6 +630,21 @@ unsigned long install_handler(int signal, } #endif +void +interrupt_handle_space_overflow(lispobj error, struct sigcontext *context) +{ + + build_fake_control_stack_frame (context); + /* This part should be common to all non-x86 ports */ + SC_PC(context) = (long) ((struct function *) PTR (error))->code; + SC_NPC(context) = SC_PC(context) + 4; + SC_REG(context, reg_NARGS) = 0; + SC_REG(context, reg_LIP) = (long) ((struct function *) PTR (error))->code; + SC_REG(context, reg_CFP) = (long) current_control_frame_pointer; + /* This is sparc specific */ + SC_REG(context, reg_CODE) = ((long) PTR(error)) + type_FunctionPointer; +} + void interrupt_init(void) { int i; diff --git a/lisp/sparc-arch.c b/lisp/sparc-arch.c index ba7607716889b50cd0638a4e5162475d022ed981..6a5b9f9aa031625c93d6de0ccb767174483c6f9a 100644 --- a/lisp/sparc-arch.c +++ b/lisp/sparc-arch.c @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/sparc-arch.c,v 1.18 2003/10/16 16:21:59 toy Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/sparc-arch.c,v 1.19 2003/10/24 02:57:00 toy Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -426,6 +426,20 @@ static void sigill_handler(HANDLER_ARGS) sizeof(unsigned long)); break; +#ifdef trap_DynamicSpaceOverflowWarning + case trap_DynamicSpaceOverflowWarning: + arch_skip_instruction(context); + interrupt_handle_space_overflow(SymbolFunction(DYNAMIC_SPACE_OVERFLOW_WARNING_HIT), + context); + break; +#endif +#ifdef trap_DynamicSpaceOverflowError + case trap_DynamicSpaceOverflowError: + arch_skip_instruction(context); + interrupt_handle_space_overflow(SymbolFunction(DYNAMIC_SPACE_OVERFLOW_ERROR_HIT), + context); + break; +#endif default: interrupt_handle_now(signal, code, context); break; diff --git a/lisp/sparc-assem.S b/lisp/sparc-assem.S index 3dbc6b46b3a6634633e4a96d3714931c547a5ba7..ad3b2648aea7e93ce5cc979fe16ca917cdba6f9f 100644 --- a/lisp/sparc-assem.S +++ b/lisp/sparc-assem.S @@ -18,6 +18,8 @@ #define _call_into_c call_into_c #define _flush_icache flush_icache #define _do_pending_interrupt do_pending_interrupt +#define _do_dynamic_space_overflow_error do_dynamic_space_overflow_error +#define _do_dynamic_space_overflow_warning do_dynamic_space_overflow_warning #ifdef GENCGC /*#define _collect_garbage collect_garbage*/ #define _fpu_save fpu_save @@ -370,6 +372,26 @@ _do_pending_interrupt: nop SET_SIZE(_do_pending_interrupt) +#ifdef trap_DynamicSpaceOverflowError + .global _do_dynamic_space_overflow_error + FUNCDEF(_do_dynamic_space_overflow_error) +_do_dynamic_space_overflow_error: + unimp trap_DynamicSpaceOverflowError + retl + nop + SET_SIZE(_do_dynamic_space_overflow_error) +#endif + +#ifdef trap_DynamicSpaceOverflowWarning + .global _do_dynamic_space_overflow_warning + FUNCDEF(_do_dynamic_space_overflow_warning) +_do_dynamic_space_overflow_warning: + unimp trap_DynamicSpaceOverflowWarning + retl + nop + SET_SIZE(_do_dynamic_space_overflow_warning) +#endif + #ifdef LINKAGE_TABLE /* * Call into C code to resolve a linkage entry.