>From 4da8b12255ec4014c6430557e1f6eb01a483081b Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Wed, 24 Jul 2013 21:05:10 +0200 Subject: [PATCH] Add checks for hitting the rest arg count limit on direct procedure application. Fixes some of the confusion from #910 --- NEWS | 2 ++ chicken.h | 4 +++- runtime.c | 7 +++++++ tests/apply-test.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++------ tests/runtests.bat | 4 ++++ tests/runtests.sh | 2 ++ 6 files changed, 68 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index a13e423..0f77a4c 100644 --- a/NEWS +++ b/NEWS @@ -46,6 +46,8 @@ - Runtime system - Special events in poll() are now handled, avoiding hangs in threaded apps. + - When invoking procedures with many rest arguments directly (not via APPLY), + raise an error when argument count limit was reached instead of crashing. - C API - Deprecated C_get_argument[_2] and C_get_environment_variable[_2] functions. diff --git a/chicken.h b/chicken.h index 6d5d7f9..d09d3e3 100644 --- a/chicken.h +++ b/chicken.h @@ -1003,7 +1003,7 @@ extern double trunc(double); #define C_save(x) (*(--C_temporary_stack) = (C_word)(x)) #define C_adjust_stack(n) (C_temporary_stack -= (n)) #define C_rescue(x, i) (C_temporary_stack[ i ] = (x)) -#define C_save_rest(s, c, n) for(va_start(v, s); c-- > (n); C_save(va_arg(v, C_word))) +#define C_save_rest(s, c, n) do { if((C_temporary_stack - (c - (n))) < C_temporary_stack_limit) C_temp_stack_overflow(); for(va_start(v, s); c-- > (n); C_save(va_arg(v, C_word))); }while(0) #define C_rest_count(c) ((C_temporary_stack_bottom - C_temporary_stack) - (c)) #define C_restore (*(C_temporary_stack++)) #define C_heaptop ((C_word **)(&C_fromspace_top)) @@ -1584,6 +1584,7 @@ C_varextern C_TLS time_t C_startup_time_seconds; C_varextern C_TLS C_word *C_temporary_stack, *C_temporary_stack_bottom, + *C_temporary_stack_limit, *C_stack_limit; C_varextern C_TLS C_long C_timer_interrupt_counter, @@ -1689,6 +1690,7 @@ 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/runtime.c b/runtime.c index d8bea05..bbeb2f6 100644 --- a/runtime.c +++ b/runtime.c @@ -2383,6 +2383,13 @@ 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) { diff --git a/tests/apply-test.scm b/tests/apply-test.scm index d05356b..81697a5 100644 --- a/tests/apply-test.scm +++ b/tests/apply-test.scm @@ -1,14 +1,58 @@ (require-extension srfi-1) -(define manyargs (feature? 'manyargs)) +(define max-argcount ##sys#apply-argument-limit) -(when manyargs (print "many arguments supported.")) +(begin-for-syntax + (define max-direct-argcount + (cond-expand + ;; This depends the temp stack's size (as does max-argcount w/ manyargs). + ;; We can't use the foreign value for C_TEMPORARY_STACK_SIZE here because + ;; we're evaluating this in the compiler, not compiling it (confused yet?) + (compiling 2048) + ;; But in interpreted mode, everything boils down to "apply", so if no apply + ;; hack is available, we're more limited in csi than in csc. + (else ##sys#apply-argument-limit)))) + +(when (feature? 'manyargs) (print "many arguments supported.")) (define (foo . args) (when (pair? args) (assert (= (length args) (last args))))) -(let ((max (if manyargs 500 100))) - (do ((i 0 (add1 i))) - ((>= i max)) - (apply foo (iota i 1)))) +(printf "testing 'apply' with 0..~A (maximum apply argument count)...\n" max-argcount) +(do ((i 0 (add1 i))) + ((>= i max-argcount)) + (apply foo (iota i 1))) + +(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" + ,(- max-direct-argcount 50) ,max-direct-argcount + (cond-expand (compiling "compiled") (else "interpreted"))) + ;; Highest edge cases + ,@(list-tabulate + 50 (lambda (i) `(foo ,@(iota (- max-direct-argcount i) 1))))))))) + (print "If this segfaults on x86-64, try updating GCC (4.5 has a code-generation bug):") + (invoke-directly)) + +(define-syntax assert-argcount-error + (syntax-rules () + ((_ expr) + (assert (condition-case (begin expr #f) + ((exn runtime limit) 'a-okay)))))) + +(print "testing 'apply' can detect calls of too many arguments...") +(assert-argcount-error (apply foo (iota (add1 max-argcount) 1))) + +(print "testing direct invocation can detect calls of too many arguments...") +(let-syntax ((invoke-directly-with-too-many-args + (ir-macro-transformer + (lambda (i r c) + `(assert-argcount-error (foo ,@(iota (add1 max-direct-argcount) 1))))))) + (invoke-directly-with-too-many-args)) diff --git a/tests/runtests.bat b/tests/runtests.bat index c56f9a8..25f77f8 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -105,6 +105,10 @@ if errorlevel 1 ( echo ======================================== runtime tests ... %interpret% -s apply-test.scm if errorlevel 1 exit /b 1 +%compile% apply-test.scm +if errorlevel 1 exit /b 1 +a.out +if errorlevel 1 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 83c828d..352c35b 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -134,6 +134,8 @@ fi echo "======================================== runtime tests ..." $interpret -s apply-test.scm +$compile apply-test.scm +./a.out $compile test-gc-hooks.scm ./a.out -- 1.8.2.3