Permalink
Browse files

tests/select_ping_pong and remove deadlock detection for `select` for…

… now
  • Loading branch information...
tianyicui committed Oct 4, 2012
1 parent ff02df8 commit 1dd92f3191f01730ae1fbb56fa8f756d7a06200d
Showing with 57 additions and 25 deletions.
  1. +5 −7 TODO.md
  2. +8 −0 src/prim_func.ml
  3. +2 −17 src/prim_macro.ml
  4. +3 −1 tests/go_test.ml
  5. +1 −0 tests/select_ping_pong.out
  6. +38 −0 tests/select_ping_pong.scm
View
12 TODO.md
@@ -1,19 +1,17 @@
-* current
- * continuous refactor
- * GOROUTINES AND CHANNELS!
- * more and more tests, esp with `select`
-
* 0.1
+ * small scope refactor
* ocamldoc
* 0.2
- * buffered chan
+ * BUG: when two fibers are using `select` to communicate to each other, they will block forever
+ * FEATURE: dead lock detection in `select`
+ * FEATURE: buffered chan
+ * TASK: audit correct usage of `top_level` in macro
* later
* more complete and compliant stdlib and tests
* more I/O functions
* see comments in `stdlib.scm`
- * audit correct usage of `top_level` in macro
* Use `Event.select` to implement a high-perf `select` macro
* A global symbol table (using Weak)
* user-defined macro
View
@@ -130,6 +130,12 @@ let force value =
Promise.force (unpack_promise value)
;;
+let random_integer param =
+ let n = unpack_num param
+ in
+ number (Random.int n)
+;;
+
let eqv a b =
match a, b with
| Sexp x, Sexp y ->
@@ -303,6 +309,8 @@ let prim_functions =
"force", unary_op force;
+ "random-integer", unary_op random_integer;
+
"eqv?", bool_any_binop eqv;
"eq?", bool_any_binop eq;
"equal?", bool_any_binop equal;
View
@@ -359,34 +359,19 @@ let select env params =
| ExprList exprs ->
snd (Eval.eval_all env exprs)
in
- let is_blocked =
- ref false
- in
- let blocked () =
- if not !is_blocked then
- (is_blocked := true;
- Runtime.Fiber.blocked ())
- in
- let unblocked () =
- if !is_blocked then
- (is_blocked := false;
- Runtime.Fiber.unblocked ())
- in
let clauses =
L.map compile_clause params
in
let rec go lst =
match lst with
| [] ->
- (blocked ();
- Thread.yield ();
+ (Thread.yield ();
go clauses)
| (test, action) :: rest ->
(match run_test test with
| None -> go rest
| Some value ->
- (unblocked ();
- run_action action value)
+ run_action action value
)
in
if [] = clauses then
View
@@ -82,7 +82,9 @@ let _ =
test "(define ch (make-chan)) (go (receive ch)) (sleep 20) (select ((receive ch) 1) ((send ch 2) 2) (else 3))" "2";
test "(define ch (make-chan)) (go (send ch 42)) (sleep 20) (select ((receive ch) => (lambda (x) (+ x x))) ((send ch 2) 2) (else 3))" "84";
test "(define ch (make-chan)) (go (send ch 42)) (sleep 20) (select ((receive ch) => -) ((send ch 2) 2) (else 3))" "-42";
- test_exn "(define ch (make-chan)) (select ((send ch 42)) ((receive ch)))" Dead_lock;
+ (* TODO Dead_lock in select
+ test_exn "(define ch (make-chan)) (select ((send ch 42)) ((receive ch)))" Dead_lock;
+ *)
test "(define ch (make-chan)) (go (sleep 200) (send ch 42)) (select ((send ch 42)) ((receive ch)))" "42";
prerr_string "All passed!\n"
View
@@ -0,0 +1,38 @@
+(define ping-chan-0 (make-chan))
+(define ping-chan-1 (make-chan))
+(define ping-chan-2 (make-chan))
+(define ping-chan-3 (make-chan))
+(define pong-chan-0 (make-chan))
+(define pong-chan-1 (make-chan))
+(define pong-chan-2 (make-chan))
+(define pong-chan-3 (make-chan))
+
+(define (select-receive chan-0 chan-1 chan-2 chan-3)
+ (select
+ ((receive chan-0))
+ ((receive chan-1))
+ ((receive chan-2))
+ ((receive chan-3))))
+
+(define (random-send x . chan-list)
+ (let* ((n (length chan-list))
+ (i (random-integer n)))
+ (send (list-ref chan-list i) x)))
+
+(define (ping n)
+ (if (/= n 0)
+ (begin
+ (write (select-receive ping-chan-0 ping-chan-1 ping-chan-2 ping-chan-3))
+ (newline)
+ (random-send 'pong pong-chan-0 pong-chan-1 pong-chan-2 pong-chan-3)
+ (ping (- n 1)))))
+
+(define (pong n)
+ (if (/= n 0)
+ (begin
+ (random-send 'ping ping-chan-0 ping-chan-1 ping-chan-2 ping-chan-3)
+ (write (select-receive pong-chan-0 pong-chan-1 pong-chan-2 pong-chan-3))
+ (newline)
+ (pong (- n 1)))))
+
+(go (ping 5) (pong 5))

0 comments on commit 1dd92f3

Please sign in to comment.