Add local ping-pong benchmark

1 files changed, 39 insertions, 0 deletions

diff --git a/benchmarks/local-ping-pong.scm b/benchmarks/local-ping-pong.scm
new file mode 100644
index 0000000..400421b
--- /dev/null
+++ b/benchmarks/local-ping-pong.scm
@@ -0,0 +1,39 @@
+#!/usr/bin/env guile
+# -*- scheme -*-
+!#
+
+(use-modules (ice-9 match)
+             (fibers)
+             (fibers channels))
+
+(define (run-ping-pong message-count)
+  (let ((ch (make-channel)))
+    (spawn-fiber (lambda ()
+                   (let lp ()
+                     (put-message ch (get-message ch))
+                     (lp))))
+    (let lp ((n 0))
+      (when (< n message-count)
+        (put-message ch n)
+        (get-message ch)
+        (lp (1+ n))))))
+
+(define (test pair-count message-count)
+  (let ((done (make-channel)))
+    (for-each (lambda (_)
+                (spawn-fiber (lambda ()
+                               (run-ping-pong message-count)
+                               (put-message done 'done))
+                             #:parallel? #t))
+              (iota pair-count))
+    (for-each (lambda (_) (get-message done))
+              (iota pair-count))))
+
+(define (main args)
+  (match args
+    ((_ pair-count message-count)
+     (let ((pair-count (string->number pair-count))
+           (message-count (string->number message-count)))
+       (run-fibers (lambda () (test pair-count message-count)))))))
+
+(when (batch-mode?) (main (program-arguments)))