avoid over-large buffer for tail calls

Applying to a large number of arguments once causes the run-time
system to maintain a too-large buffer for managing tail calls in
the future. Decay the buffer size as it is reallocated.

racket/src/racket/src/error.c

@@ -1362,10 +1362,7 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
 
   if (argv == p->tail_buffer) {
     /* See calls in scheme_do_eval: */
-    GC_CAN_IGNORE Scheme_Object **tb;
+    scheme_realloc_tail_buffer(p);
-    p->tail_buffer = NULL; /* so args aren't zeroed */
-    tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
-    p->tail_buffer = tb;
   }
 
   /* minc = 1 -> name is really a case-lambda or native proc */

racket/src/racket/src/eval.c

@@ -1351,12 +1351,7 @@ static void unbound_global(Scheme_Object *obj)
 
 static void make_tail_buffer_safe()
 {
-  Scheme_Thread *p = scheme_current_thread;
+  scheme_realloc_tail_buffer(scheme_current_thread);
-
-  GC_CAN_IGNORE Scheme_Object **tb;
-  p->tail_buffer = NULL; /* so args aren't zeroed */
-  tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
-  p->tail_buffer = tb;
 }
 
 static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, Scheme_Object **runstack)

racket/src/racket/src/fun.c

@@ -1066,12 +1066,8 @@ void scheme_really_create_overflow(void *stack_base)
           p->values_buffer = NULL;
       } else if (reply == SCHEME_TAIL_CALL_WAITING) {
         p = scheme_current_thread;
-        if (p->ku.apply.tail_rands == p->tail_buffer) {
+        if (p->ku.apply.tail_rands == p->tail_buffer)
-          GC_CAN_IGNORE Scheme_Object **tb;
+          scheme_realloc_tail_buffer(p);
-          p->tail_buffer = NULL; /* so args aren't zeroed */
-          tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
-          p->tail_buffer = tb;
-        }
       }
     }
 
@@ -1366,12 +1362,8 @@ force_values(Scheme_Object *obj, int multi_ok)
     GC_CAN_IGNORE Scheme_Object **rands;
       
     /* Watch out for use of tail buffer: */
-    if (p->ku.apply.tail_rands == p->tail_buffer) {
+    if (p->ku.apply.tail_rands == p->tail_buffer)
-      GC_CAN_IGNORE Scheme_Object **tb;
+      scheme_realloc_tail_buffer(p);
-      p->tail_buffer = NULL; /* so args aren't zeroed */
-      tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
-      p->tail_buffer = tb;
-    }
 
     rator = p->ku.apply.tail_rator;
     rands = p->ku.apply.tail_rands;
@@ -1620,11 +1612,10 @@ scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
   if (num_rands) {
     Scheme_Object **a;
     if (num_rands > p->tail_buffer_size) {
-      Scheme_Object **tb;
+      a = MALLOC_N(Scheme_Object *, num_rands);
-      tb = MALLOC_N(Scheme_Object *, num_rands);
+      p->tail_buffer = a;
-      p->tail_buffer = tb;
       p->tail_buffer_size = num_rands;
-    }
+    } else
       a = p->tail_buffer;
     p->ku.apply.tail_rands = a;
     for (i = num_rands; i--; ) {

racket/src/racket/src/schpriv.h

@@ -665,6 +665,8 @@ void scheme_clear_thread_sync(Scheme_Thread *p);
 
 void scheme_zero_unneeded_rands(Scheme_Thread *p);
 
+void scheme_realloc_tail_buffer(Scheme_Thread *p);
+
 int scheme_can_break(Scheme_Thread *p);
 void scheme_thread_wait(Scheme_Object *thread);
 

racket/src/racket/src/thread.c

@@ -2505,7 +2505,21 @@ Scheme_Thread *scheme_make_thread(void *stack_base)
   return make_thread(NULL, NULL, NULL, NULL, stack_base);
 }
 
-static void scheme_check_tail_buffer_size(Scheme_Thread *p)
+void scheme_realloc_tail_buffer(Scheme_Thread *p)
+{
+  GC_CAN_IGNORE Scheme_Object **tb;
+
+  p->tail_buffer = NULL; /* so args aren't zeroed */
+
+  /* Decay cached size back toward the initial size: */
+  if (p->tail_buffer_size > (buffer_init_size << 1))
+    p->tail_buffer_size = p->tail_buffer_size >> 1;
+
+  tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
+  p->tail_buffer = tb;
+}
+
+static void check_tail_buffer_size(Scheme_Thread *p)
 {
   if (p->tail_buffer_size < buffer_init_size) {
     Scheme_Object **tb;
@@ -2523,7 +2537,7 @@ void scheme_set_tail_buffer_size(int s)
     buffer_init_size = s;
 
     for (p = scheme_first_thread; p; p = p->next) {
-      scheme_check_tail_buffer_size(p);
+      check_tail_buffer_size(p);
     }
   }
 }
@@ -5412,7 +5426,7 @@ void scheme_weak_resume_thread(Scheme_Thread *r)
       r->next->prev = r;
       r->ran_some = 1;
       schedule_in_set((Scheme_Object *)r, r->t_set_parent);
-      scheme_check_tail_buffer_size(r);
+      check_tail_buffer_size(r);
     }
   }
 }