diff --git a/src/mac/cw/MrEd.r b/src/mac/cw/MrEd.r index d154f50ec6..903e907a66 100644 --- a/src/mac/cw/MrEd.r +++ b/src/mac/cw/MrEd.r @@ -21,9 +21,12 @@ data 'DITL' (129) { }; data 'DITL' (101, preload) { - $"0001 0000 0000 0030 0038 0044 0072 0404" /* .......0.8.D.r.. */ - $"5175 6974 0000 0000 000E 0022 0021 0094" /* Quit.......".!.” */ - $"880E 4F75 7420 6F66 204D 656D 6F72 7921" /* ˆ.Out of Memory! */ + $"0001 0000 0000 004E 009C 0062 00D6 0404" /* .......N.œ.b.Ö.. */ + $"5175 6974 0000 0000 000E 0022 003F 015C" /* Quit.......".?.\ */ + $"883A 5468 6520 504C 5420 5363 6865 6D65" /* ˆ:The PLT Scheme */ + $"2076 6972 7475 616C 206D 6163 6869 6E65" /* virtual machine */ + $"2069 7320 6F75 7420 6F66 206D 656D 6F72" /* is out of memor */ + $"792E 2041 626F 7274 696E 672E" /* y. Aborting. */ }; data 'DITL' (128) { @@ -41,7 +44,7 @@ data 'ALRT' (100, "my alert") { }; data 'ALRT' (101, "Out of memory", preload) { - $"0082 009A 00D7 0143 0065 5555 300A" /* .‚.š.×.C.eUU0 */ + $"0082 009A 00F5 020B 0065 5555 300A" /* .‚.š.õ...eUU0 */ }; data 'PICT' (129) { diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index 0ab3eb3b2f..392bd9ba85 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -3148,21 +3148,23 @@ extern "C" { static void MrEdOutOfMemory(void) { + /* Hopefully we have enough memory for a message dialog under + Windows and Mac OS X: */ #ifdef wx_mac Alert(101, NULL); - ExitToShell(); -#else -#ifdef wx_x - printf("mred: out of memory\n"); #endif - _exit(-1); +#ifdef wx_win + MessageBox(NULL, + "PLT Scheme virtual machine is out of memory. Aborting.", + "Out of Memory", + MB_OK); #endif + /* For X, mzscheme already writes to stderr (and maybe syslog). */ } void *wxOutOfMemory() { - MrEdOutOfMemory(); - return NULL; + scheme_out_of_memory_abort(); } extern "C" { @@ -3321,12 +3323,7 @@ wxFrame *MrEdApp::OnInit(void) #if !defined(USE_SENORA_GC) && !defined(MZ_PRECISE_GC) GC_set_warn_proc(CAST_IGNORE MrEdIgnoreWarnings); #endif -#if 0 - /* Used to be set for the sake of Mac OS Classic. Now, - setting GC_out_of_memory for 3m means that it's ok - to fail when a limit is reached. We don't want that. */ - GC_out_of_memory = (OOM_ptr)MrEdOutOfMemory; -#endif + scheme_set_report_out_of_memory(MrEdOutOfMemory); #ifdef SGC_STD_DEBUGGING scheme_external_dump_info = dump_cpp_info; diff --git a/src/mzscheme/gc2/compact.c b/src/mzscheme/gc2/compact.c index 7f0ba951c4..55828be396 100644 --- a/src/mzscheme/gc2/compact.c +++ b/src/mzscheme/gc2/compact.c @@ -149,6 +149,7 @@ void (*GC_collect_start_callback)(void); void (*GC_collect_end_callback)(void); void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used); void (*GC_out_of_memory)(void); +void (*GC_report_out_of_memory)(void); unsigned long (*GC_get_thread_stack_base)(void); void (*GC_mark_xtagged)(void *obj); diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index de13b72863..3d2be614fe 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -99,6 +99,11 @@ GC2_EXTERN void (*GC_out_of_memory)(void); Called by GC when it can't satify a memory request. GC_out_of_memory() might perform a longjmp. */ +GC2_EXTERN void (*GC_report_out_of_memory)(void); +/* + Called by GC when it has to give up, maybe due to running out of memory + during a collection. */ + GC2_EXTERN void GC_dump(void); /* Dumps memory state info to stderr. */ diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 95301fbbac..2b98b4072f 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -128,6 +128,7 @@ void (*GC_collect_start_callback)(void); void (*GC_collect_end_callback)(void); void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used); void (*GC_out_of_memory)(void); +void (*GC_report_out_of_memory)(void); unsigned long (*GC_get_thread_stack_base)(void); void (*GC_mark_xtagged)(void *obj); void (*GC_fixup_xtagged)(void *obj); @@ -148,6 +149,14 @@ static unsigned long in_unsafe_allocation_mode = 0; static void (*unsafe_allocation_abort)(); static void garbage_collect(int); +static void out_of_memory() +{ + if (GC_report_out_of_memory) + GC_report_out_of_memory(); + GCPRINT(GCOUTF, "The system has run out of memory!\n"); + abort(); +} + inline static void check_used_against_max(size_t len) { used_pages += (len / APAGE_SIZE) + (((len % APAGE_SIZE) == 0) ? 0 : 1); @@ -163,9 +172,9 @@ inline static void check_used_against_max(size_t len) if(used_pages > max_used_pages) { /* nope, no go. there's simply too much memory allocated. Inform the thunk and then die semi-gracefully */ - if(GC_out_of_memory) - GC_out_of_memory(); - GCPRINT(GCOUTF, "The system has run out of memory!\n"); abort(); + if (GC_out_of_memory) + GC_out_of_memory(); + out_of_memory(); } } } @@ -392,6 +401,7 @@ static struct mpage *malloc_mpage() { struct mpage *page; page = malloc(sizeof(struct mpage)); + if (!page) out_of_memory(); memset(page, 0, sizeof(struct mpage)); return page; } @@ -445,6 +455,7 @@ static void *allocate_big(size_t sizeb, int type) addr = malloc_dirty_pages(round_to_apage_size(sizeb), APAGE_SIZE); else addr = malloc_pages(round_to_apage_size(sizeb), APAGE_SIZE); + if (!addr) out_of_memory(); bpage->addr = addr; bpage->size = sizeb; bpage->big_page = 1; @@ -557,7 +568,7 @@ void *GC_malloc_one_tagged(size_t s) { return allocate(s, PAGE_TAGGED); } void *GC_malloc_one_xtagged(size_t s) { return allocate(s, PAGE_XTAGGED); } void *GC_malloc_array_tagged(size_t s) { return allocate(s, PAGE_TARRAY); } void *GC_malloc_atomic(size_t s) { return allocate(s, PAGE_ATOMIC); } -void *GC_malloc_atomic_uncollectable(size_t s) { void *p = malloc(s); memset(p, 0, s); return p; } +void *GC_malloc_atomic_uncollectable(size_t s) { void *p = malloc(s); if (!p) out_of_memory(); memset(p, 0, s); return p; } void *GC_malloc_allow_interior(size_t s) {return allocate_big(s, PAGE_ARRAY);} void *GC_malloc_atomic_allow_interior(size_t s) {return allocate_big(s, PAGE_ATOMIC);} void *GC_malloc_tagged_allow_interior(size_t s) {return allocate_big(s, PAGE_TAGGED);} @@ -741,6 +752,7 @@ inline static void resize_gen0(unsigned long new_size) while(alloced_size < new_size) { work = malloc_mpage(); addr = malloc_pages(GEN0_PAGE_SIZE, APAGE_SIZE); + if (!addr) out_of_memory(); work->addr = addr; if(prev) prev->next = work; @@ -898,6 +910,7 @@ static void backtrace_new_page(struct mpage *page) /* This is a little wastefull for big pages, because we'll only use the first few words: */ page->backtrace = (void **)malloc_pages(APAGE_SIZE, APAGE_SIZE); + if (!page->backtrace) out_of_memory(); } static void free_backtrace(struct mpage *page) @@ -1061,7 +1074,7 @@ static struct immobile_box *immobile_boxes = NULL; void **GC_malloc_immobile_box(void *p) { struct immobile_box *ib = malloc(sizeof(struct immobile_box)); - if(!ib) GCERR((GCOUTF, "Couldn't allocate space for immobile box!\n")); + if (!ib) out_of_memory(); ib->p = p; ib->next = immobile_boxes; ib->prev = NULL; if(ib->next) ib->next->prev = ib; immobile_boxes = ib; @@ -1310,6 +1323,7 @@ inline static void register_new_thread(void *t, void *c) struct gc_thread_info *work; work = (struct gc_thread_info *)malloc(sizeof(struct gc_thread_info)); + if (!work) out_of_memory(); ((Scheme_Thread *)t)->gc_info = work; work->owner = current_owner((Scheme_Custodian *)c); work->thread = t; @@ -1427,6 +1441,7 @@ inline static void push_ptr(void *ptr) /* This happens at the very beginning */ if(!int_top) { int_top = (struct stacklet*)malloc(STACK_PART_SIZE); + if (!int_top) out_of_memory(); int_top->prev = int_top->next = NULL; int_top->top = PPTR(int_top) + 4; int_top->end = PPTR(NUM(int_top) + STACK_PART_SIZE); @@ -1442,6 +1457,7 @@ inline static void push_ptr(void *ptr) } else { /* we don't, so we need to allocate one */ int_top->next = (struct stacklet*)malloc(STACK_PART_SIZE); + if (!int_top->next) out_of_memory(); int_top->next->prev = int_top; int_top = int_top->next; int_top->next = NULL; @@ -1539,6 +1555,7 @@ inline static int create_blank_owner_set(void) for (i = 1; i < owner_table_top; i++) { if (!owner_table[i]) { owner_table[i] = malloc(sizeof(struct ot_entry)); + if (!owner_table[i]) out_of_memory(); bzero(owner_table[i], sizeof(struct ot_entry)); return i; } @@ -1551,6 +1568,7 @@ inline static int create_blank_owner_set(void) owner_table_top *= 2; naya = (struct ot_entry **)malloc(owner_table_top*sizeof(struct ot_entry*)); + if (!naya) out_of_memory(); memcpy(naya, owner_table, old_top*sizeof(struct ot_entry*)); owner_table = naya; bzero((char*)owner_table + (sizeof(struct ot_entry*) * old_top), @@ -1892,6 +1910,7 @@ inline static void add_account_hook(int type,void *c1,void *c2,unsigned long b) if(!work) { work = malloc(sizeof(struct account_hook)); + if (!work) out_of_memory(); work->type = type; work->c1 = c1; work->c2 = c2; work->amount = b; work->next = hooks; hooks = work; } @@ -2265,6 +2284,7 @@ void GC_mark(const void *const_p) void *addr; work = malloc_mpage(); addr = malloc_dirty_pages(APAGE_SIZE, APAGE_SIZE); + if (!addr) out_of_memory(); work->addr = addr; work->generation = 1; work->page_type = type; @@ -2696,6 +2716,7 @@ struct mpage *allocate_compact_target(struct mpage *work) npage = malloc_mpage(); addr = malloc_dirty_pages(APAGE_SIZE, APAGE_SIZE); + if (!addr) out_of_memory(); npage->addr = addr; npage->previous_size = npage->size = PREFIX_SIZE; npage->generation = 1; @@ -2999,11 +3020,6 @@ static void protect_old_pages(void) flush_protect_page_ranges(0); } -static void gc_overmem_abort() -{ - GCERR((GCOUTF, "ERROR: out of memory during collection!\n")); -} - #if 0 extern double scheme_get_inexact_milliseconds(void); # define TIME_DECLS() double start, task_start @@ -3057,7 +3073,7 @@ static void garbage_collect(int force_full) /* we don't want the low-level allocator freaking because we've gone past half the available memory */ in_unsafe_allocation_mode = 1; - unsafe_allocation_abort = gc_overmem_abort; + unsafe_allocation_abort = out_of_memory; TIME_INIT(); diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index de53e76a8d..2964103272 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -80,6 +80,8 @@ scheme_raise scheme_log_level_p scheme_log scheme_log_message +scheme_log_abort +scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m scheme_case_lambda_wrong_count diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 0aff5c145f..06551c05c3 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -80,6 +80,8 @@ scheme_raise scheme_log_level_p scheme_log scheme_log_message +scheme_log_abort +scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m scheme_case_lambda_wrong_count diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index 95b7b291da..10c2121d96 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -82,6 +82,8 @@ EXPORTS scheme_log_level_p scheme_log scheme_log_message + scheme_log_abort + scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m scheme_case_lambda_wrong_count diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index 3b5fc05555..dedbc0d149 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -82,6 +82,8 @@ EXPORTS scheme_log_level_p scheme_log scheme_log_message + scheme_log_abort + scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m scheme_case_lambda_wrong_count diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 6215692ea7..91d015b174 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1756,6 +1756,9 @@ MZ_EXTERN int scheme_get_external_event_fd(void); MZ_EXTERN void scheme_set_stack_base(void *base, int no_auto_statics); MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics); +typedef void (*Scheme_Report_Out_Of_Memory_Proc)(void); +MZ_EXTERN void scheme_set_report_out_of_memory(Scheme_Report_Out_Of_Memory_Proc p); + /* Stack-preparation start-up: */ typedef int (*Scheme_Nested_Main)(void *data); MZ_EXTERN int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data); diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 1650b65ad1..0fb36e3f88 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -2583,6 +2583,8 @@ static mzReportEventProc mzReportEvent; void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data) { + /* This function must avoid GC allocation when called with the + configuration of scheme_log_abort(). */ Scheme_Logger *orig_logger; Scheme_Object *queue, *q, *msg = NULL, *b; Scheme_Log_Reader *lr; @@ -2683,10 +2685,10 @@ void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len memcpy(naya + slen + 2, buffer, len); naya[slen + 2 + len] = 0; buffer = naya; - len += slen + 2; + len += slen + 2; } - a[0] = buffer; - mzReportEvent(hEventLog, ty, 1 /* category */, + a[0] = buffer; + mzReportEvent(hEventLog, ty, 1 /* category */, (sev << 30) | 2 /* message */, NULL, 1, 0, @@ -2771,6 +2773,26 @@ void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len } } +void scheme_log_abort(char *buffer) +{ + Scheme_Logger logger; + long ts; + + memset(&logger, 0, sizeof(logger)); + + logger.name = NULL; + logger.parent = NULL; + logger.want_level = SCHEME_LOG_FATAL; + + ts = 0; + logger.timestamp = &ts; + logger.local_timestamp = ts; + logger.syslog_level = init_syslog_level; + logger.stderr_level = init_stderr_level; + + scheme_log_message(&logger, SCHEME_LOG_FATAL, buffer, strlen(buffer), scheme_false); +} + static int extract_level(const char *who, int which, int argc, Scheme_Object **argv) { Scheme_Object *v; diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 07691b4b63..0e4d234c4c 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -58,6 +58,8 @@ extern int scheme_num_copied_stacks; static unsigned long scheme_primordial_os_thread_stack_base; static THREAD_LOCAL unsigned long scheme_os_thread_stack_base; +static Scheme_Report_Out_Of_Memory_Proc more_report_out_of_memory; + #if defined(MZ_XFORM) && !defined(MZ_PRECISE_GC) void **GC_variable_stack; #endif @@ -107,6 +109,9 @@ void scheme_set_stack_base(void *base, int no_auto_statics) } #endif use_registered_statics = no_auto_statics; +#if defined(MZ_PRECISE_GC) + GC_report_out_of_memory = scheme_out_of_memory_abort; +#endif } void scheme_set_current_os_thread_stack_base(void *base) @@ -180,6 +185,19 @@ extern unsigned long scheme_get_stack_base() return (unsigned long)GC_get_stack_base(); } +void scheme_out_of_memory_abort() +{ + scheme_log_abort("PLT Scheme virtual machine has run out of memory; aborting"); + if (more_report_out_of_memory) + more_report_out_of_memory(); + abort(); +} + +void scheme_set_report_out_of_memory(Scheme_Report_Out_Of_Memory_Proc p) +{ + more_report_out_of_memory = p; +} + /************************************************************************/ /* memory utils */ /************************************************************************/ diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index b64f009d9b..bae0ff0fc0 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -182,6 +182,8 @@ MZ_EXTERN int scheme_log_level_p(Scheme_Logger *logger, int level); MZ_EXTERN void scheme_log(Scheme_Logger *logger, int level, int flags, char *msg, ...); MZ_EXTERN void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data); +MZ_EXTERN void scheme_log_abort(char *buffer); +MZ_EXTERN void scheme_out_of_memory_abort(); MZ_EXTERN void scheme_wrong_count(const char *name, int minc, int maxc, int argc, Scheme_Object **argv); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index d5c16562d9..93184822e0 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -144,6 +144,8 @@ int (*scheme_log_level_p)(Scheme_Logger *logger, int level); void (*scheme_log)(Scheme_Logger *logger, int level, int flags, char *msg, ...); void (*scheme_log_message)(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data); +void (*scheme_log_abort)(char *buffer); +void (*scheme_out_of_memory_abort)(); void (*scheme_wrong_count)(const char *name, int minc, int maxc, int argc, Scheme_Object **argv); void (*scheme_wrong_count_m)(const char *name, int minc, int maxc, diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 31445d5ca7..8be0b9fa93 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -88,6 +88,8 @@ scheme_extension_table->scheme_log_level_p = scheme_log_level_p; scheme_extension_table->scheme_log = scheme_log; scheme_extension_table->scheme_log_message = scheme_log_message; + scheme_extension_table->scheme_log_abort = scheme_log_abort; + scheme_extension_table->scheme_out_of_memory_abort = scheme_out_of_memory_abort; scheme_extension_table->scheme_wrong_count = scheme_wrong_count; scheme_extension_table->scheme_wrong_count_m = scheme_wrong_count_m; scheme_extension_table->scheme_case_lambda_wrong_count = scheme_case_lambda_wrong_count; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 709b979df5..67411f13bb 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -88,6 +88,8 @@ #define scheme_log_level_p (scheme_extension_table->scheme_log_level_p) #define scheme_log (scheme_extension_table->scheme_log) #define scheme_log_message (scheme_extension_table->scheme_log_message) +#define scheme_log_abort (scheme_extension_table->scheme_log_abort) +#define scheme_out_of_memory_abort (scheme_extension_table->scheme_out_of_memory_abort) #define scheme_wrong_count (scheme_extension_table->scheme_wrong_count) #define scheme_wrong_count_m (scheme_extension_table->scheme_wrong_count_m) #define scheme_case_lambda_wrong_count (scheme_extension_table->scheme_case_lambda_wrong_count)