New: stack overflow protection.

* configure: detect getrlimit, producing HAVE_RLIMIT in
config.h.

* eval.c (do_eval, do_expand): Call gc_stack_check inline
function to check stack pointer against limit.

* gc.c (gc_stack_bottom): Static becomes extern, so inline
function in gc.h can refer to it.
(gc_stack_limit): New global variable.
(gc_init): If we have rlimit, then probe RLIMIT_STACK.
If the stack is sufficiently large, then enable the stack
overflow protection, which kicks in when the stack pointer
appears to be within a certain percentage of the limit.
(set_stack_limit, get_stack_limit): New static functions.
(gc_late_init): Register set-stack-limit and get-stack-limit
intrinsics.
(gc_stack_overflow): New function.

* gc.h (gc_stack_bottom, gc_stack_limit, gc_stack_overflow):
Declared.
(gc_stack_check): New inline function.

* lib.c (stack_overflow_s): New symbol variable.
(obj_print_impl): Call gc_stack_check to protect recursive
printing againts overflow.

* lib.h (stack_overflow_s): Declared.

* unwind.c (uw_init): Register stack-overflow symbol as a an
exception symbol subtyped from error.
(uw_unwind_to_exit_point): When dealing with an unhandled
exception, turn off the stack limit, so we can print the
messages without triggering it in a loop.

* vm.c (vm_execute_closure, vm_funcall_common): Insert
gc_stack_check to the top of the execution of every VM
function.

* txr.1: Documented.

* share/txr/stdlib/doc-syms.tl: Updated.

10 files changed, 169 insertions, 3 deletions

diff --git a/configure b/configure
index 26a0f225..0f2b97ff 100755
--- a/configure
+++ b/configure
@@ -3721,6 +3721,25 @@ else
   printf "no\n"
 fi
 
+printf "Checking for getrlimit ... "
+cat > conftest.c <<!
+#include <sys/resource.h>
+
+int main(void)
+{
+  struct rlimit rl;
+  int res = getrlimit(RLIMIT_STACK, &rl);
+  return 0;
+}
+!
+
+if conftest ; then
+  printf "yes\n"
+  printf "#define HAVE_RLIMIT 1\n" >> config.h
+else
+  printf "no\n"
+fi
+
 #
 # Dependent variables
 #
diff --git a/eval.c b/eval.c
index cdf251a4..b4ed3845 100644
--- a/eval.c
+++ b/eval.c
@@ -1560,6 +1560,8 @@ static val do_eval(val form, val env, val ctx,
 
   sig_check_fast();
 
+  gc_stack_check();
+
   if (form && symbolp(form)) {
     if (!bindable(form)) {
       ret = form;
@@ -4673,6 +4675,8 @@ static val do_expand(val form, val menv)
 {
   val macro = nil;
 
+  gc_stack_check();
+
   menv = default_null_arg(menv);
 
 again:
diff --git a/gc.c b/gc.c
index 974cefde..4b7c0a8c 100644
--- a/gc.c
+++ b/gc.c
@@ -36,6 +36,9 @@
 #if HAVE_VALGRIND
 #include <valgrind/memcheck.h>
 #endif
+#if HAVE_RLIMIT
+#include <sys/resource.h>
+#endif
 #include "lib.h"
 #include "stream.h"
 #include "hash.h"
@@ -84,7 +87,9 @@ int opt_gc_debug;
 #if HAVE_VALGRIND
 int opt_vg_debug;
 #endif
-static val *gc_stack_bottom;
+
+val *gc_stack_bottom;
+val *gc_stack_limit;
 
 static val *prot_stack[PROT_STACK_SIZE];
 static val **prot_stack_limit = prot_stack + PROT_STACK_SIZE;
@@ -888,6 +893,15 @@ int gc_inprogress(void)
 void gc_init(val *stack_bottom)
 {
   gc_stack_bottom = stack_bottom;
+#if HAVE_RLIMIT
+  struct rlimit rl;
+  if (getrlimit(RLIMIT_STACK, &rl) == 0) {
+    if (rl.rlim_cur > 512 * 1024) {
+      rlim_t lim = (rl.rlim_cur - rl.rlim_cur / 16) / sizeof (val);
+      gc_stack_limit = gc_stack_bottom - lim;
+    }
+  }
+#endif
 }
 
 void gc_mark(val obj)
@@ -970,6 +984,27 @@ static val gc_set_delta(val delta)
   return nil;
 }
 
+static val set_stack_limit(val limit)
+{
+  val self = lit("set-stack-limit");
+  val *gsl = gc_stack_limit;
+
+  if (limit == nil || limit == zero) {
+    gc_stack_limit = 0;
+  } else {
+    ucnum lim = c_unum(limit, self);
+    gc_stack_limit = gc_stack_bottom - lim / sizeof (val);
+  }
+
+  return if2(gsl, num((gc_stack_bottom - gsl) * sizeof (val)));
+}
+
+static val get_stack_limit(void)
+{
+  val *gsl = gc_stack_limit;
+  return if2(gsl, num((gc_stack_bottom - gsl) * sizeof (val)));
+}
+
 static val gc_wrap(val full)
 {
   if (gc_enabled) {
@@ -1051,6 +1086,8 @@ void gc_late_init(void)
   reg_fun(intern(lit("finalize"), user_package), func_n3o(gc_finalize, 2));
   reg_fun(intern(lit("call-finalizers"), user_package),
           func_n1(gc_call_finalizers));
+  reg_fun(intern(lit("set-stack-limit"), user_package), func_n1(set_stack_limit));
+  reg_fun(intern(lit("get-stack-limit"), user_package), func_n0(get_stack_limit));
 }
 
 /*
@@ -1161,3 +1198,8 @@ void gc_free_all(void)
     }
   }
 }
+
+void gc_stack_overflow(void)
+{
+  uw_throwf(stack_overflow_s, lit("computation exceeded stack limit"), nao);
+}
diff --git a/gc.h b/gc.h
index 9b41492c..309a8912 100644
--- a/gc.h
+++ b/gc.h
@@ -74,3 +74,13 @@ INLINE val zap(volatile val *loc) { val ret = *loc; *loc = nil; return ret; }
 #else
 #define z(lvalue) (lvalue)
 #endif
+
+extern val *gc_stack_bottom;
+extern val *gc_stack_limit;
+void gc_stack_overflow(void);
+INLINE void gc_stack_check(void)
+{
+  val v;
+  if (&v < gc_stack_limit)
+    gc_stack_overflow();
+}
diff --git a/lib.c b/lib.c
index 0ce2e43b..cf629d6a 100644
--- a/lib.c
+++ b/lib.c
@@ -112,7 +112,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, alloc_error_s;
+val timeout_error_s, system_error_s, alloc_error_s, stack_overflow_s;
 val path_not_found_s, path_exists_s, path_permission_s;
 val warning_s, defr_warning_s, restart_s, continue_s;
 val gensym_counter_s, length_s;
@@ -12492,6 +12492,7 @@ static void obj_init(void)
   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);
+  stack_overflow_s = intern(lit("stack-overflow"), user_package);
   path_not_found_s = intern(lit("path-not-found"), user_package);
   path_exists_s = intern(lit("path-exists"), user_package);
   path_permission_s = intern(lit("path-permission"), user_package);
@@ -13031,6 +13032,8 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
   val ret = obj;
   cnum save_depth = ctx->depth;
 
+  gc_stack_check();
+
   if (check_emit_circle(obj, out, ctx, self))
     return ret;
 
diff --git a/lib.h b/lib.h
index 262d6468..97a7dbd4 100644
--- a/lib.h
+++ b/lib.h
@@ -517,7 +517,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, alloc_error_s;
+extern val timeout_error_s, system_error_s, alloc_error_s, stack_overflow_s;
 extern val path_not_found_s, path_exists_s, path_permission_s;
 extern val warning_s, defr_warning_s, restart_s, continue_s;
 extern val gensym_counter_s, length_s;
diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index 006cf9d1..31e71438 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -859,6 +859,7 @@
       ("get-obj" "N-0315B229")
       ("get-prop" "N-00663AE2")
       ("get-sig-handler" "N-02E1B6FA")
+      ("get-stack-limit" "N-02492D13")
       ("get-string" "N-00BE9AAC")
       ("get-string-from-stream" "N-037412EE")
       ("getaddrinfo" "N-0363FE99")
@@ -1624,6 +1625,7 @@
       ("set-prop" "N-03663AE4")
       ("set-right" "N-033F7D05")
       ("set-sig-handler" "N-02E1B6FA")
+      ("set-stack-limit" "N-02492D13")
       ("setegid" "N-03897D65")
       ("setenv" "N-002E0364")
       ("seteuid" "N-03897D65")
diff --git a/txr.1 b/txr.1
index cdd9df69..79d3c78e 100644
--- a/txr.1
+++ b/txr.1
@@ -72284,6 +72284,86 @@ only correct under an explicit
 .code call-finalizers
 but incorrect under spontaneous reclamation driven by garbage collection.
 
+.SS* Stack Overflow Protection
+
+\*(TX features a rudimentary mechanism for guarding against stack overflow
+situations, which cause the \*(TX process to crash. This capability is separate
+from and exists in addition to the possibility of catching a
+.code sig-segv
+(segmentation violation) signal upon stack overflow using
+.codn set-sig-handler .
+
+The stack overflow guard mechanism is based on \*(TX, at certain key places
+in the execution, checking the current position of the stack relative to
+a predetermined limit. If the position exceeds the limit, then an exception
+of type
+.codn stack-overflow ,
+derived from
+.codn error ,
+is thrown.
+
+The stack overflow guard mechanism is enabled at startup on those platforms
+where it is possible to inquire the system about the stack limit, and where the
+stack limit is at least 512 kilobytes.  \*(TX configures the limit to within a
+certain percentage of the actual value. If it is not possible to determine the
+system's stack limit, or it is too low, then the mechanism is disabled.
+
+The
+.code get-stack-limit
+and
+.code set-stack-limit
+functions are provided to manipulate the stack limit.
+
+The mechanism cannot contain absolutely all sources of stack overflow threat
+under all conditions. External functions are not protected, and not all
+internal functions are monitored. If \*(TX is close to the limit, but
+a function is called whose stack growth is not monitored, such as
+an external function or unmonitored internal function, it is possible that
+the stack may overflow anyway.
+
+.coNP Functions @ get-stack-limit and @ set-stack-limit
+.synb
+.mets (get-stack-limit)
+.mets (set-stack-limit << value )
+.syne
+.desc
+The
+.code get-stack-limit
+returns the current value of the stack limit. If the guard mechanism is
+not enabled, it returns
+.codn nil ,
+otherwise it returns a positive integer, which is measured in bytes.
+
+The
+.code set-stack-limit
+configures the stack limit according to
+.metn value ,
+possibly enabling or disabling the guard mechanism, and returns the previous
+stack limit in exactly the same manner as
+.codn get-stack-limit .
+
+The
+.meta value
+must be a non-negative integer or else the symbol
+.codn nil .
+
+The values zero or
+.code nil
+disable the guard mechanism. Positive integer values set the limit.
+The value may be truncated to a multiple of some denomination or
+otherwise adjusted, so that a subsequent call to
+.code get-stack-limit
+need not retrieve that exact value.
+
+If
+.meta value
+is too close to the system stack limit or beyond, the effectiveness
+of the stack overflow detection mechanism is compromised.
+Likewise, if
+.meta value
+is too low, the operation of \*(TX shall become unreliable. Values
+smaller than 326767 bytes are strongly discouraged.
+
 .SS* Modularization
 .coNP Variable @ self-path
 .desc
diff --git a/unwind.c b/unwind.c
index 3cb47a9a..13089c3c 100644
--- a/unwind.c
+++ b/unwind.c
@@ -120,6 +120,8 @@ static void uw_unwind_to_exit_point(void)
     val sym = unhandled_ex.ca.sym;
     val args = unhandled_ex.ca.args;
 
+    gc_stack_limit = 0;
+
     dyn_env = nil;
 
     if (opt_loglevel >= 1) {
@@ -1256,6 +1258,7 @@ void uw_init(void)
   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(stack_overflow_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);
diff --git a/vm.c b/vm.c
index da06d156..f3aada5c 100644
--- a/vm.c
+++ b/vm.c
@@ -1115,6 +1115,8 @@ val vm_execute_closure(val fun, struct args *args)
   cnum ix = 0;
   vm_word_t argw = 0;
 
+  gc_stack_check();
+
   vm_reset(&vm, vd, dspl, vc->nlvl - 1, vc->ip);
 
   vm.dspl = coerce(struct vm_env *, frame + vc->nreg);
@@ -1174,6 +1176,7 @@ val vm_execute_closure(val fun, struct args *args)
   int frsz = vd->nlvl * 2 + vc->nreg;                                        \
   val *frame = coerce(val *, zalloca(sizeof *frame * frsz));                 \
   struct vm_env *dspl = coerce(struct vm_env *, frame + vc->nreg);           \
+  gc_stack_check();                                                          \
   vm_reset(&vm, vd, dspl, vc->nlvl - 1, vc->ip);                             \
   vm.dspl = coerce(struct vm_env *, frame + vc->nreg);                       \
   frame[0] = nil;                                                            \