From 94bd5369b50f346bd628d7710e8b67c792e65a0c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 11 Jul 2014 07:27:36 +0100 Subject: [PATCH] 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 | 5 +---- racket/src/racket/src/eval.c | 7 +------ racket/src/racket/src/fun.c | 25 ++++++++----------------- racket/src/racket/src/schpriv.h | 2 ++ racket/src/racket/src/thread.c | 20 +++++++++++++++++--- 5 files changed, 29 insertions(+), 30 deletions(-) diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index e15f1c5c00..66ca5c9f04 100644 --- a/racket/src/racket/src/error.c +++ b/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; - p->tail_buffer = NULL; /* so args aren't zeroed */ - tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size); - p->tail_buffer = tb; + scheme_realloc_tail_buffer(p); } /* minc = 1 -> name is really a case-lambda or native proc */ diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index c02b15c415..3031bce177 100644 --- a/racket/src/racket/src/eval.c +++ b/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; - - 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; + scheme_realloc_tail_buffer(scheme_current_thread); } static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, Scheme_Object **runstack) diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 0b277f1cc7..1d5fd6f733 100644 --- a/racket/src/racket/src/fun.c +++ b/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) { - 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; - } + if (p->ku.apply.tail_rands == p->tail_buffer) + scheme_realloc_tail_buffer(p); } } @@ -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) { - 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; - } + if (p->ku.apply.tail_rands == p->tail_buffer) + scheme_realloc_tail_buffer(p); rator = p->ku.apply.tail_rator; rands = p->ku.apply.tail_rands; @@ -1620,12 +1612,11 @@ 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; - tb = MALLOC_N(Scheme_Object *, num_rands); - p->tail_buffer = tb; + a = MALLOC_N(Scheme_Object *, num_rands); + p->tail_buffer = a; p->tail_buffer_size = num_rands; - } - a = p->tail_buffer; + } else + a = p->tail_buffer; p->ku.apply.tail_rands = a; for (i = num_rands; i--; ) { a[i] = rands[i]; diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 42770f4fca..e691d84db1 100644 --- a/racket/src/racket/src/schpriv.h +++ b/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); diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 180527a689..8337e6a2a5 100644 --- a/racket/src/racket/src/thread.c +++ b/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); } } }