~ chicken-core (chicken-5) 5b5b3f74e631f0168b4b9725dcbf10e1a8fcbfb4
commit 5b5b3f74e631f0168b4b9725dcbf10e1a8fcbfb4
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Oct 31 19:57:38 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sat Sep 10 22:58:21 2016 +1200
Dynamically resize temporary stack when needed.
When the argcount is extremely large, the temporary stack can be resized
to fit the arguments on GC. The default temporary stack size can thus be
lowered, because the size no longer has to fit the worst case.
This fixes #1098.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 4b8d797d..545d6858 100644
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,8 @@
- The default error handler now truncates very long condition
messages (thanks to Lemonboy).
- Weak symbol GC (-:w) no longer drops random symbols (#1173).
+ - The number of arguments to procedures, both via "apply" and direct
+ invocation, are now limited only by the C stack size (#1098).
- Syntax expander
- DSSSL lambda lists have improved hygiene, so they don't need
diff --git a/chicken.h b/chicken.h
index d4518352..f5a706fb 100644
--- a/chicken.h
+++ b/chicken.h
@@ -600,7 +600,7 @@ static inline int isinf_ld (long double x)
#define C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR 2
#define C_BAD_ARGUMENT_TYPE_ERROR 3
#define C_UNBOUND_VARIABLE_ERROR 4
-#define C_TOO_MANY_PARAMETERS_ERROR 5
+/* Unused: 5 */
#define C_OUT_OF_MEMORY_ERROR 6
#define C_DIVISION_BY_ZERO_ERROR 7
#define C_OUT_OF_RANGE_ERROR 8
@@ -1717,7 +1717,6 @@ C_fctexport void C_bad_min_argc(int c, int n) C_noret;
C_fctexport void C_bad_argc_2(int c, int n, C_word closure) C_noret;
C_fctexport void C_bad_min_argc_2(int c, int n, C_word closure) C_noret;
C_fctexport void C_stack_overflow(void) C_noret;
-C_fctexport void C_temp_stack_overflow(void) C_noret;
C_fctexport void C_unbound_error(C_word sym) C_noret;
C_fctexport void C_no_closure_error(C_word x) C_noret;
C_fctexport void C_div_by_zero_error(char *loc) C_noret;
diff --git a/library.scm b/library.scm
index e95542f9..6676d03b 100644
--- a/library.scm
+++ b/library.scm
@@ -4199,7 +4199,7 @@ EOF
(if fn (list fn) '()))))
((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))
((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))
- ((5) (apply ##sys#signal-hook #:limit-error loc "parameter limit exceeded" args))
+ ;; ((5) ...unused...)
((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))
((7) (apply ##sys#signal-hook #:arithmetic-error loc "division by zero" args))
((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 2d0393df..bbd71f20 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -194,6 +194,8 @@ compiler itself) accept a small set of runtime options:
; {{-:aNUMBER}} : Specifies the length of the buffer for recording a trace of the last invoked procedures. Defaults to 16.
+; {{-:ANUMBER}} : Specifies fixed "temporary stack" size. This is used mostly for {{apply}}. If you supply a zero size (the default), the stack will be dynamically reallocated as needed.
+
; {{-:b}} : Enter a read-eval-print-loop when an error is encountered.
; {{-:B}} : Sounds a bell (ASCII 7) on every major garbage collection.
diff --git a/runtime.c b/runtime.c
index 56379ff0..e930b883 100644
--- a/runtime.c
+++ b/runtime.c
@@ -162,7 +162,7 @@ static C_TLS int timezone;
#define WEAK_COUNTER_MASK 3
#define WEAK_COUNTER_MAX 2
-#define TEMPORARY_STACK_SIZE 4096
+#define DEFAULT_TEMPORARY_STACK_SIZE 1024
#define STRING_BUFFER_SIZE 4096
#define DEFAULT_MUTATION_STACK_SIZE 1024
#define PROFILE_TABLE_SIZE 1024
@@ -398,7 +398,9 @@ static C_TLS C_byte
static C_TLS C_uword
heapspace1_size,
heapspace2_size,
- heap_size;
+ heap_size,
+ temporary_stack_size,
+ fixed_temporary_stack_size = 0;
static C_TLS C_char
buffer[ STRING_BUFFER_SIZE ],
*private_repository = NULL,
@@ -671,10 +673,11 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);
/* Allocate temporary stack: */
- if((C_temporary_stack_limit = (C_word *)C_malloc(TEMPORARY_STACK_SIZE * sizeof(C_word))) == NULL)
+ temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;
+ if((C_temporary_stack_limit = (C_word *)C_malloc(temporary_stack_size * sizeof(C_word))) == NULL)
return 0;
- C_temporary_stack_bottom = C_temporary_stack_limit + TEMPORARY_STACK_SIZE;
+ C_temporary_stack_bottom = C_temporary_stack_limit + temporary_stack_size;
C_temporary_stack = C_temporary_stack_bottom;
/* Allocate mutation stack: */
@@ -1308,6 +1311,7 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
" -:B sound bell on major GC\n"
" -:G force GUI mode\n"
" -:aSIZE set trace-buffer/call-chain size\n"
+ " -:ASIZE set fixed temporary stack size\n"
" -:H dump heap state on exit\n"
" -:S do not handle segfaults or other serious conditions\n"
"\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"
@@ -1369,6 +1373,10 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
C_trace_buffer_size = arg_val(ptr);
goto next;
+ case 'A':
+ fixed_temporary_stack_size = arg_val(ptr);
+ goto next;
+
case 't':
*symbols = arg_val(ptr);
goto next;
@@ -1618,11 +1626,6 @@ void barf(int code, char *loc, ...)
c = 1;
break;
- case C_TOO_MANY_PARAMETERS_ERROR:
- msg = C_text("parameter limit exceeded");
- c = 0;
- break;
-
case C_OUT_OF_MEMORY_ERROR:
msg = C_text("not enough memory");
c = 0;
@@ -2426,14 +2429,6 @@ void C_stack_overflow_with_msg(C_char *msg)
barf(C_STACK_OVERFLOW_ERROR, NULL);
}
-void C_temp_stack_overflow(void)
-{
- /* Just raise a "too many parameters" error; it isn't very useful to
- show a different message here. */
- barf(C_TOO_MANY_PARAMETERS_ERROR, NULL);
-}
-
-
void C_unbound_error(C_word sym)
{
barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
@@ -2771,7 +2766,7 @@ C_mutate_slot(C_word *slot, C_word val)
bytes = newmssize * sizeof(C_word *);
if(debug_mode)
- C_dbg(C_text("debug"), C_text("resizing mutation-stack from %uk to %uk ...\n"),
+ C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),
(mssize * sizeof(C_word *)) / 1024, bytes / 1024);
mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, bytes);
@@ -2794,9 +2789,36 @@ C_mutate_slot(C_word *slot, C_word val)
void C_save_and_reclaim(void *trampoline, int n, C_word *av)
{
+ C_word new_size = nmax(1UL << (int)ceil(log2(n)), DEFAULT_TEMPORARY_STACK_SIZE);
+
assert(av > C_temporary_stack_bottom || av < C_temporary_stack_limit);
assert(C_temporary_stack == C_temporary_stack_bottom);
+ /* Don't *immediately* slam back to default size */
+ if (new_size < temporary_stack_size)
+ new_size = temporary_stack_size >> 1;
+
+ if (new_size != temporary_stack_size) {
+
+ if(fixed_temporary_stack_size)
+ panic(C_text("fixed temporary stack overflow (\"apply\" called with too many arguments?)"));
+
+ if(debug_mode) {
+ C_dbg(C_text("debug"), C_text("resizing temporary stack dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),
+ C_wordstobytes(temporary_stack_size) / 1024,
+ C_wordstobytes(new_size) / 1024);
+ }
+
+ C_free(C_temporary_stack_limit);
+
+ if((C_temporary_stack_limit = (C_word *)C_malloc(new_size * sizeof(C_word))) == NULL)
+ panic(C_text("out of memory - could not resize temporary stack"));
+
+ C_temporary_stack_bottom = C_temporary_stack_limit + new_size;
+ C_temporary_stack = C_temporary_stack_bottom;
+ temporary_stack_size = new_size;
+ }
+
C_temporary_stack = C_temporary_stack_bottom - n;
assert(C_temporary_stack >= C_temporary_stack_limit);
@@ -4556,7 +4578,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_fix(C_getpid());
case C_fix(34): /* effective maximum for procedure arguments */
- return C_fix(TEMPORARY_STACK_SIZE);
+ return C_fix(stack_size / 2); /* An educated guess :) */
case C_fix(35): /* unused */
/* used to be apply-hook indicator */
diff --git a/tests/apply-test.scm b/tests/apply-test.scm
index 4996dd0d..5c43d827 100644
--- a/tests/apply-test.scm
+++ b/tests/apply-test.scm
@@ -1,29 +1,34 @@
(require-extension srfi-1)
-(when (feature? 'manyargs) (print "many arguments supported."))
+;; Non-manyarg CHICKENs are no longer made
+(assert (feature? 'manyargs))
(define (foo . args)
(when (pair? args)
(assert (= (length args) (last args)))))
-(printf "testing 'apply' with 0..~A (maximum apply argument count)...\n" 2000)
+(printf "testing 'apply' with 0..~A...\n" 2000)
(do ((i 0 (add1 i)))
((>= i 2000))
(apply foo (iota i 1)))
+(print "testing 'apply' with 10000...")
+(apply foo (list-tabulate 10000 add1))
+
(let-syntax
((invoke-directly
(ir-macro-transformer
- (lambda (i r c)
- `(begin
- (print "invoking directly with 0..50...")
- ;; Lowest edge cases
- ,@(list-tabulate 50 (lambda (i) `(foo ,@(iota i 1))))
- (printf "invoking directly with ~A..~A (maximum ~A direct argument count)...\n"
- ,(- 2000 50) 2000
- (cond-expand (compiling "compiled") (else "interpreted")))
- ;; Highest edge cases
- ,@(list-tabulate
- 50 (lambda (i) `(foo ,@(iota (- 2000 i) 1)))))))))
- (print "If this segfaults on x86-64, try updating GCC (4.5 has a code-generation bug):")
- (invoke-directly))
+ (lambda (e r c)
+ (let ((proc (cadr e))
+ (count (caddr e))
+ (end (cadddr e))
+ (message (car (cddddr e))))
+ `(begin
+ (printf "invoking directly with ~A..~A (~A)...\n"
+ ,(- end count) ,end ,message)
+ ,@(list-tabulate
+ count
+ (lambda (i)
+ `(,proc ,@(list-tabulate (- end i) add1))))))))))
+ (invoke-directly foo 50 50 "Lower edge case")
+ (invoke-directly foo 50 2000 "Lower edge case"))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 28ba4c88..dbdd2525 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -114,6 +114,15 @@ if errorlevel 1 exit /b 1
if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
+a.out -:A10k
+
+if errorlevel 1 (
+ echo apply test with limited temp stack failed as it should.
+) else (
+ echo apply test with limited temp stack didn't fail
+ exit /b 1
+)
+
%compile% test-gc-hooks.scm
if errorlevel 1 exit /b 1
a.out
diff --git a/tests/runtests.sh b/tests/runtests.sh
index d5d6f8e3..fa7043ab 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -146,6 +146,13 @@ echo "======================================== runtime tests ..."
$interpret -s apply-test.scm
$compile apply-test.scm
./a.out
+if ./a.out -:A10k; then
+ echo "apply test with limited temp stack didn't fail"
+ exit 1
+else
+ echo "apply test with limited temp stack failed as it should."
+fi
+
$compile test-gc-hooks.scm
./a.out
Trap