Revising out-of-memory handling.

We don't want to be aborting on OOM, but throwing an
exception.

* lib.c (alloc_error_s): New symbol variable.
(oom_realloc): Global variable removed.
(oom): New static function.
(chk_malloc, chk_malloc_gc_more, chk_calloc, chk_realloc):
Call oom instead of removed oom_realloc handler.
(env): Throw alloc-error rather than error by calling oom.
(obj_init): Initialize alloc_error_s.
(init): Drop function pointer argument; do not
initialize removed oom_realloc.

* lib.h (alloc_error_s): Declared.
(oom_realloc): Declaration removed.
(init): Declaration updated.

* txr.1: Type tree diagram includes alloc-error.

5 files changed, 20 insertions, 31 deletions

diff --git a/lib.c b/lib.c
index 3ea7b4e2..64387e17 100644
--- a/lib.c
+++ b/lib.c
@@ -105,7 +105,7 @@ val eof_s, eol_s, assert_s, name_s;
 val error_s, type_error_s, internal_error_s, panic_s;
 val numeric_error_s, range_error_s;
 val query_error_s, file_error_s, process_error_s, syntax_error_s;
-val timeout_error_s, system_error_s;
+val timeout_error_s, system_error_s, alloc_error_s;
 val warning_s, defr_warning_s, restart_s, continue_s;
 val gensym_counter_s, nullify_s, from_list_s, lambda_set_s, length_s;
 
@@ -127,8 +127,6 @@ val year_s, month_s, day_s, hour_s, min_s, sec_s, dst_s, gmtoff_s, zone_s;
 static val env_list;
 static val recycled_conses;
 
-mem_t *(*oom_realloc)(mem_t *, size_t);
-
 /* C99 inline instantiations. */
 #if __STDC_VERSION__ >= 199901L
 loc mkloc_fun(val *ptr, val obj);
@@ -2602,6 +2600,11 @@ val equal(val left, val right)
 
 alloc_bytes_t malloc_bytes;
 
+static void oom(void)
+{
+  uw_throwf(alloc_error_s, lit("out of memory"), nao);
+}
+
 mem_t *chk_malloc(size_t size)
 {
   mem_t *ptr = convert(mem_t *, malloc(size));
@@ -2609,7 +2612,7 @@ mem_t *chk_malloc(size_t size)
   assert (!async_sig_enabled);
 
   if (size && ptr == 0)
-    ptr = convert(mem_t *, oom_realloc(0, size));
+    oom();
   malloc_bytes += size;
   return ptr;
 }
@@ -2619,7 +2622,7 @@ mem_t *chk_malloc_gc_more(size_t size)
   mem_t *ptr = convert(mem_t *, malloc(size));
   assert (!async_sig_enabled);
   if (size && ptr == 0)
-    ptr = convert(mem_t *, oom_realloc(0, size));
+    oom();
   return ptr;
 }
 
@@ -2630,10 +2633,8 @@ mem_t *chk_calloc(size_t n, size_t size)
 
   assert (!async_sig_enabled);
 
-  if (size && ptr == 0) {
-    ptr = convert(mem_t *, oom_realloc(0, total));
-    memset(ptr, 0, total);
-  }
+  if (size && ptr == 0)
+    oom();
   malloc_bytes += total;
   return ptr;
 }
@@ -2645,7 +2646,7 @@ mem_t *chk_realloc(mem_t *old, size_t size)
   assert (!async_sig_enabled);
 
   if (size != 0 && newptr == 0)
-    newptr = oom_realloc(old, size);
+    oom();
   malloc_bytes += size;
   return newptr;
 }
@@ -10129,7 +10130,7 @@ val env(void)
     wchar_t *iter = env;
 
     if (iter == 0)
-      uw_throwf(error_s, lit("out of memory"), nao);
+      oom();
 
     for (; *iter; iter += wcslen(iter) + 1)
       ptail = list_collect(ptail, string(iter));
@@ -10281,6 +10282,7 @@ static void obj_init(void)
   syntax_error_s = intern(lit("syntax-error"), user_package);
   system_error_s = intern(lit("system-error"), user_package);
   timeout_error_s = intern(lit("timeout-error"), user_package);
+  alloc_error_s = intern(lit("alloc-error"), user_package);
   assert_s = intern(lit("assert"), user_package);
   warning_s = intern(lit("warning"), user_package);
   defr_warning_s = intern(lit("defr-warning"), user_package);
@@ -11459,12 +11461,11 @@ static void time_init(void)
 #endif
 }
 
-void init(mem_t *(*oom)(mem_t *, size_t), val *stack_bottom)
+void init(val *stack_bottom)
 {
   int gc_save;
   gc_save = gc_state(0);
 
-  oom_realloc = oom;
   gc_init(stack_bottom);
   obj_init();
   uw_init();
diff --git a/lib.h b/lib.h
index cc0a65d4..24d04695 100644
--- a/lib.h
+++ b/lib.h
@@ -467,7 +467,7 @@ extern val eof_s, eol_s, assert_s, name_s;
 extern val error_s, type_error_s, internal_error_s, panic_s;
 extern val numeric_error_s, range_error_s;
 extern val query_error_s, file_error_s, process_error_s, syntax_error_s;
-extern val timeout_error_s, system_error_s;
+extern val timeout_error_s, system_error_s, alloc_error_s;
 extern val warning_s, defr_warning_s, restart_s, continue_s;
 extern val gensym_counter_s;
 
@@ -483,8 +483,6 @@ extern val list_f, less_f, greater_f;
 
 extern val prog_string;
 
-extern mem_t *(*oom_realloc)(mem_t *, size_t);
-
 #if HAVE_ULONGLONG_T
 typedef ulonglong_t alloc_bytes_t;
 #else
@@ -1092,7 +1090,7 @@ val time_parse_local(val format, val string);
 val time_parse_utc(val format, val string);
 #endif
 
-void init(mem_t *(*oom_realloc)(mem_t *, size_t), val *stack_bottom);
+void init(val *stack_bottom);
 int compat_fixup(int compat_ver);
 void dump(val obj, val stream);
 void d(val obj);
diff --git a/txr.1 b/txr.1
index a36c0f27..1bab0f8d 100644
--- a/txr.1
+++ b/txr.1
@@ -35283,6 +35283,8 @@ subtype of every exception type:
                       |
                       +--- system-error
                       |
+                      +--- alloc-error
+                      |
                       +--- timeout-error
                       |
                       +--- assert
diff --git a/txr.c b/txr.c
index 16cecb63..2591b339 100644
--- a/txr.c
+++ b/txr.c
@@ -68,19 +68,6 @@ int opt_compat;
 int opt_dbg_expansion;
 val stdlib_path;
 
-/*
- * Can implement an emergency allocator here from a fixed storage
- * pool, which sets an OOM flag. Program can check flag
- * and gracefully terminate instead of aborting like this.
- */
-static mem_t *oom_realloc_handler(mem_t *old, size_t size)
-{
-  format(std_error, lit("~a: out of memory\n"), prog_string, nao);
-  if (opt_print_bindings)
-    put_line(lit("false"), std_output);
-  abort();
-}
-
 static void help(void)
 {
   val text = lit(
@@ -375,7 +362,7 @@ int main(int argc, char **argv)
   repress_privilege();
   progname = utf8_dup_from(argv[0] ? argv[0]: "txr");
   progname_u8 = argv[0];
-  init(oom_realloc_handler, &stack_bottom);
+  init(&stack_bottom);
   match_init();
   debug_init();
   sysroot_init();
diff --git a/unwind.c b/unwind.c
index e4cc28f3..80baf6ee 100644
--- a/unwind.c
+++ b/unwind.c
@@ -1038,6 +1038,7 @@ void uw_init(void)
   uw_register_subtype(file_error_s, error_s);
   uw_register_subtype(process_error_s, error_s);
   uw_register_subtype(system_error_s, error_s);
+  uw_register_subtype(alloc_error_s, error_s);
   uw_register_subtype(timeout_error_s, error_s);
   uw_register_subtype(assert_s, error_s);
   uw_register_subtype(syntax_error_s, error_s);