better reporting for out-of-memory failure

svn: r12218

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.. */
+	$"0001 0000 0000 004E 009C 0062 00D6 0404"            /* .......N.œ.b.Ö.. */
-	$"5175 6974 0000 0000 000E 0022 0021 0094"            /* Quit.......".!.” */
+	$"5175 6974 0000 0000 000E 0022 003F 015C"            /* Quit.......".?.\ */
-	$"880E 4F75 7420 6F66 204D 656D 6F72 7921"            /* ˆ.Out of Memory! */
+	$"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) {

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();
+  scheme_out_of_memory_abort();
-  return NULL;
 }
 
 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
+  scheme_set_report_out_of_memory(MrEdOutOfMemory);
-  /* 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
 
 #ifdef SGC_STD_DEBUGGING
   scheme_external_dump_info = dump_cpp_info;

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);

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. */

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);
@@ -165,7 +174,7 @@ inline static void check_used_against_max(size_t len)
 	     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();
+          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();
 

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

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

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

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

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);

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;
@@ -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;

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                               */
 /************************************************************************/

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);

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,

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;

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)