Make odd? and even? future-safe

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) 

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))))
     
   )
 

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 */ 

src/racket/src/number.c

@@ -38,6 +38,8 @@
 #include <float.h>
 #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);

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[]);