Add benchmarks.

3 files changed, 176 insertions, 0 deletions

diff --git a/benchmarks/chain.scm b/benchmarks/chain.scm
new file mode 100644
index 0000000..441cebf
--- /dev/null
+++ b/benchmarks/chain.scm
@@ -0,0 +1,52 @@
+#!/usr/bin/env guile
+# -*- scheme -*-
+!#
+
+(use-modules (ice-9 match)
+             (fibers)
+             (fibers channels))
+
+(define (make-chain link-count make-head make-link make-tail)
+  (let lp ((link-count link-count) (ch (make-head)))
+    (if (zero? link-count)
+        (make-tail ch)
+        (lp (1- link-count) (make-link ch)))))
+
+(define (test link-count message-count)
+  (get-message
+   (make-chain
+    link-count
+    (lambda ()
+      (let ((out (make-channel)))
+        (spawn-fiber (lambda ()
+                       (let lp ((n 0))
+                         (put-message out n)
+                         (lp (1+ n))))
+                     #:parallel? #t)
+        out))
+    (lambda (in)
+      (let ((out (make-channel)))
+        (spawn-fiber (lambda ()
+                       (let lp ()
+                         (put-message out (get-message in))
+                         (lp)))
+                     #:parallel? #t)
+        out))
+    (lambda (in)
+      (let ((out (make-channel)))
+        (spawn-fiber (lambda ()
+                       (let lp ()
+                         (if (< (get-message in) message-count)
+                             (lp)
+                             (put-message out 'done))))
+                     #:parallel? #t)
+        out)))))
+
+(define (main args)
+  (match args
+    ((_ link-count message-count)
+     (let ((link-count (string->number link-count))
+           (message-count (string->number message-count)))
+       (run-fibers (lambda () (test link-count message-count)))))))
+
+(when (batch-mode?) (main (program-arguments)))
diff --git a/benchmarks/diagonal.scm b/benchmarks/diagonal.scm
new file mode 100644
index 0000000..a80b1fc
--- /dev/null
+++ b/benchmarks/diagonal.scm
@@ -0,0 +1,87 @@
+#!/usr/bin/env guile
+# -*- scheme -*-
+!#
+
+(use-modules (ice-9 match)
+             (fibers)
+             (fibers channels))
+
+(define (make-squarer in)
+  (let ((out (make-channel)))
+    (spawn-fiber (lambda ()
+                   (let lp ()
+                     (let ((x (get-message in)))
+                       (put-message out (* x x))
+                       (lp))))
+                 #:parallel? #t)
+    out))
+
+(define (make-sqrter in)
+  (let ((out (make-channel)))
+    (spawn-fiber (lambda ()
+                   (let lp ()
+                     (let ((x (get-message in)))
+                       (put-message out (sqrt x))
+                       (lp))))
+                 #:parallel? #t)
+    out))
+
+(define (make-broadcaster in dimensions)
+  (let ((out (map (lambda (_) (make-channel))
+                  (iota dimensions))))
+    (spawn-fiber (lambda ()
+                   (let lp ()
+                     (let ((x (get-message in)))
+                       (for-each (lambda (ch) (put-message ch x))
+                                 out)
+                       (lp))))
+                 #:parallel? #t)
+    out))
+
+(define (make-summer in)
+  (let ((out (make-channel)))
+    (spawn-fiber (lambda ()
+                   (let lp ()
+                     (let lp ((sum 0) (in in))
+                       (match in
+                         (() (put-message out sum))
+                         ((ch . in) (lp (+ sum (get-message ch)) in))))
+                     (lp)))
+                 #:parallel? #t)
+    out))
+
+(define (make-counter)
+  (let ((out (make-channel)))
+    (spawn-fiber (lambda ()
+                   (let lp ((n 0))
+                     (put-message out n)
+                     (lp (1+ n))))
+                 #:parallel? #t)
+    out))
+
+(define (make-diagonal dimensions make-head make-tail)
+  (let ((ch (make-head)))
+    (let lp ((dimensions dimensions))
+      (when (positive? dimensions)
+        (make-tail ch)
+        (lp (1- dimensions))))))
+
+(define (test dimensions message-count)
+  (let* ((ints (make-counter))
+         (dims (make-broadcaster ints dimensions))
+         (squares (map make-squarer dims))
+         (sums (make-summer squares))
+         (lens (make-sqrter sums)))
+    (let lp ((n 0))
+      (when (< n message-count)
+        (get-message lens)
+        (lp (1+ n))))))
+
+(define (main args)
+  (match args
+    ((_ dimensions message-count)
+     (let ((dimensions (string->number dimensions))
+           (message-count (string->number message-count)))
+       (run-fibers (lambda () (test dimensions message-count)))))))
+
+(when (batch-mode?) (main (program-arguments)))
diff --git a/benchmarks/fan-out.scm b/benchmarks/fan-out.scm
new file mode 100644
index 0000000..31ace07
--- /dev/null
+++ b/benchmarks/fan-out.scm
@@ -0,0 +1,37 @@
+#!/usr/bin/env guile
+# -*- scheme -*-
+!#
+
+(use-modules (ice-9 match)
+             (fibers)
+             (fibers channels))
+
+(define (make-fan-out degree make-head make-tail)
+  (let ((ch (make-head)))
+    (let lp ((degree degree))
+      (when (positive? degree)
+        (make-tail ch)
+        (lp (1- degree))))))
+
+(define (test degree message-count)
+  (let ((ch (make-channel)))
+    (make-fan-out
+     degree
+     (lambda () ch)
+     (lambda (ch)
+       (spawn-fiber (lambda ()
+                      (let lp () (get-message ch) (lp)))
+                    #:parallel? #t)))
+    (let lp ((n 0))
+      (when (< n message-count)
+        (put-message ch n)
+        (lp (1+ n))))))
+
+(define (main args)
+  (match args
+    ((_ degree message-count)
+     (let ((degree (string->number degree))
+           (message-count (string->number message-count)))
+       (run-fibers (lambda () (test degree message-count)))))))
+
+(when (batch-mode?) (main (program-arguments)))