summaryrefslogtreecommitdiff
path: root/benchmarks/local-ping-pong.scm
blob: 400421b2f6f8c190988c24ae45422bb3d5d09407 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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)))