diff --git a/collects/future-visualizer/private/visualizer-data.rkt b/collects/future-visualizer/private/visualizer-data.rkt index ff5fb3b3e4..41677a8241 100644 --- a/collects/future-visualizer/private/visualizer-data.rkt +++ b/collects/future-visualizer/private/visualizer-data.rkt @@ -31,6 +31,7 @@ jitcompile-event? synchronization-event? runtime-synchronization-event? + runtime-block-event? gc-event? work-event? final-event? @@ -183,8 +184,8 @@ (define (runtime-synchronization-event? evt) (and (synchronization-event? evt) (= (process-id evt) RT-THREAD-ID))) -;;runtime-block-evt? : (or event indexed-future-event future-event) -> bool -(define (runtime-block-evt? evt) +;;runtime-block-event? : (or event indexed-future-event future-event) -> bool +(define (runtime-block-event? evt) (and (runtime-thread-evt? evt) (equal? (what evt) 'block))) ;;runtime-sync-evt? : (or event indexed-future-event future-event) -> bool @@ -443,7 +444,7 @@ (define sync-hash (make-hash)) (define rt-hash (make-hash)) (for ([evt (in-list (filter runtime-synchronization-event? evts))]) - (define isblock (runtime-block-evt? evt)) + (define isblock (runtime-block-event? evt)) (define ophash (if isblock block-hash sync-hash)) (hash-update! ophash (event-prim-name evt) diff --git a/collects/tests/future/future.rkt b/collects/tests/future/future.rkt index 743c2d8f38..f8787ab768 100644 --- a/collects/tests/future/future.rkt +++ b/collects/tests/future/future.rkt @@ -2,7 +2,14 @@ (require scheme/future scheme/list - rackunit) + rackunit + (only-in future-visualizer/trace trace-futures) + (only-in future-visualizer/private/visualizer-data runtime-block-event?)) + +;Test whether a futures program hits any barricades +(define-syntax-rule (blocks? e ...) + (let ([log (trace-futures e ...)]) + (> (length (filter runtime-block-event? log)) 0))) #|Need to add expressions which raise exceptions inside a future thunk which can be caught at the touch site @@ -859,6 +866,62 @@ We should also test deep continuations. (for/list ([i 10]) (func (lambda () (list-ref l 50000))))) (for/list ([i 10]) 50001))) + + ;Basic odd?/even? tests + (let ([fa (func (λ () + (and (odd? 33) (odd? 103.0))))] + [fb (func (λ () + (or (odd? 32) (odd? 102.0))))] + [fc (func (λ () + (and (even? 32) (even? 32.0))))] + [fd (func (λ () + (or (even? 33) (even? 103.0))))]) + (sleep 0.2) + (check-true (touch fa)) + (check-false (touch fb)) + (check-true (touch fc)) + (check-false (touch fd))) + + ;Stress test for odd?/even? + (define N 1000) + (define MAX 1000) + (define (rnd x) + (case (random 3) + [(0) + (define n (random MAX)) + (case (random 2) + [(0) (- 0 n)] ;negative + [(1) n])] ;positive + [(1) ;float + (+ (random MAX) .0)] + [(2) ;bignum + (expt 2 (+ (random MAX) 65))])) + + (define (test-even-odd) + (define ns (build-list N rnd)) + (define fs (for/list ([n (in-list ns)]) + (func (λ () + (or (odd? n) (even? n)))))) + (map touch fs)) + + ;Only test for non-blocking when actually running parallel futures + (when (eq? func future) + (check-false (blocks? (void (test-even-odd))))) + + ;Make sure we don't crash in error cases for odd?/even? + (let ([fa (func (λ () + (even? 43.33)))] + [fb (func (λ () + (odd? 7.0+3.2i)))] + [fc (func (λ () + (even? -inf.0)))] + [fd (func (λ () + (odd? +inf.0)))]) + (sleep 0.2) + (check-exn exn:fail:contract? (λ () (touch fa))) + (check-exn exn:fail:contract? (λ () (touch fb))) + (check-exn exn:fail:contract? (λ () (touch fc))) + (check-exn exn:fail:contract? (λ () (touch fd)))) ) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 0a14998a51..388c591751 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -2778,6 +2778,18 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts, /* Fetch the future descriptor for this thread */ future = fts->thread->current_ft; + if (!for_overflow) { + /* Check if this prim in fact does have a + safe C version */ + if (func == scheme_even_p || func == scheme_odd_p) { + prim_iS_s f = (prim_iS_s)func; + Scheme_Object *ret; + ret = f(future->arg_i0, future->arg_S1); + future->retval_s = ret; + return; + } + } + /* Check whether we are in slow-path trace mode */ if (fts->is_runtime_thread) { /* On runtime thread - must be slow-path tracing */ diff --git a/src/racket/src/number.c b/src/racket/src/number.c index e39616ad9f..dde8990702 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -38,6 +38,8 @@ #include #endif +#include "jit_ts_protos.h" + #ifdef USE_SINGLE_FLOATS_AS_DEFAULT # ifndef MZ_USE_SINGLE_FLOATS # undef USE_SINGLE_FLOATS_AS_DEFAULT @@ -68,7 +70,7 @@ static Scheme_Object *single_flonum_p (int argc, Scheme_Object *argv[]); static Scheme_Object *real_to_single_flonum (int argc, Scheme_Object *argv[]); static Scheme_Object *real_to_double_flonum (int argc, Scheme_Object *argv[]); static Scheme_Object *exact_p (int argc, Scheme_Object *argv[]); -static Scheme_Object *even_p (int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_even_p (int argc, Scheme_Object *argv[]); static Scheme_Object *bitwise_or (int argc, Scheme_Object *argv[]); static Scheme_Object *bitwise_xor (int argc, Scheme_Object *argv[]); static Scheme_Object *bitwise_not (int argc, Scheme_Object *argv[]); @@ -410,7 +412,7 @@ scheme_init_number (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("odd?", p, env); - p = scheme_make_folding_prim(even_p, "even?", 1, 1, 1); + p = scheme_make_folding_prim(scheme_even_p, "even?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("even?", p, env); @@ -1486,9 +1488,16 @@ scheme_inexact_p (int argc, Scheme_Object *argv[]) return (v ? scheme_true : scheme_false); } +Scheme_Object *odd_p_error(int argc, Scheme_Object *argv[]) +{ + NEED_INTEGER(odd?); + + ESCAPED_BEFORE_HERE; +} Scheme_Object * scheme_odd_p (int argc, Scheme_Object *argv[]) + XFORM_SKIP_PROC { Scheme_Object *v = argv[0]; @@ -1504,13 +1513,23 @@ scheme_odd_p (int argc, Scheme_Object *argv[]) return (fmod(d, 2.0) == 0.0) ? scheme_false : scheme_true; } - NEED_INTEGER(odd?); + /* Otherwise, bail to the unsafe (error) path: */ + if (scheme_use_rtcall) + return scheme_rtcall_iS_s("[odd?]", SIG_iS_s, odd_p_error, argc, argv); + else + return odd_p_error(argc, argv); +} + +Scheme_Object *even_p_error(int argc, Scheme_Object *argv[]) +{ + NEED_INTEGER(even?); ESCAPED_BEFORE_HERE; } -static Scheme_Object * -even_p (int argc, Scheme_Object *argv[]) +Scheme_Object * +scheme_even_p (int argc, Scheme_Object *argv[]) + XFORM_SKIP_PROC { Scheme_Object *v = argv[0]; @@ -1526,9 +1545,11 @@ even_p (int argc, Scheme_Object *argv[]) return (fmod(d, 2.0) == 0.0) ? scheme_true : scheme_false; } - NEED_INTEGER(even?); - - ESCAPED_BEFORE_HERE; + /* Otherwise, bail to the unsafe (error) path: */ + if (scheme_use_rtcall) + return scheme_rtcall_iS_s("[even?]", SIG_iS_s, even_p_error, argc, argv); + else + return even_p_error(argc, argv); } static Scheme_Object *bin_lcm (Scheme_Object *n1, Scheme_Object *n2); diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 4ac1776cf5..9fdec67d23 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -2052,6 +2052,7 @@ int scheme_bin_lt_eq(const Scheme_Object *n1, const Scheme_Object *n2); Scheme_Object *scheme_sub1(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_add1(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_odd_p(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_even_p(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_expt(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_modulo(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_sqrt(int argc, Scheme_Object *argv[]);