1:
; file: "ring.scm"
2:
3:
(declare (standard-bindings))
4:
5:
(define (joes-challenge n m)
6:
7:
  (define (create-processes)
8:
9:
    (declare (fixnum) (not safe))
10:
11:
    (define (iota n)
12:
      (iota-aux n '()))
13:
14:
    (define (iota-aux n lst)
15: .12%
      (if (= n 0)
16:
          lst
17: .02%
          (iota-aux (- n 1) (cons n lst))))
18:
19:
    (let* ((1-to-n
20:
            (iota n))
21:
           (channels
22:
            (list->vector
23: .05%
             (map (lambda (i) (open-vector))
24:
                  1-to-n)))
25:
           (processes
26:
            (map (lambda (i)
27: .12%
                   (let ((input (vector-ref channels (modulo (- i 1) n)))
28: .17%
                         (output (vector-ref channels (modulo i n))))
29: .05%
                     (make-thread
30:
                      (lambda ()
31: .36%
                        (let loop ((j m))
32: 6.21%
                          (if (> j 0)
33: 4.65%
                              (let ((message (read input)))
34: 42.69%
                                (write message output)
35: 16.5%
                                (force-output output)
36: 29.04%
                                (loop (- j 1)))))))))
37:
                 1-to-n)))
38:
      (write 'go (vector-ref channels 1))
39:
      (force-output (vector-ref channels 1))
40:
      processes))
41:
42:
  (let* ((point1
43:
          (cpu-time))
44:
         (processes
45:
          (create-processes))
46:
         (point2
47:
          (cpu-time)))
48:
49:
    (for-each thread-start! processes)
50:
    (thread-join! (car processes))
51:
52:
    (let ((point3
53:
           (cpu-time)))
54:
55:
      (display n)
56:
      (display " ")
57:
      (display (/ (- point2 point1) n))
58:
      (display " ")
59:
      (display (/ (- point3 point2) (* n m)))
60:
      (newline))))
61:
62:
(define (ring n)
63:
  (if (and (integer? n)
64:
		(exact? n)
65:
		(>= n 2)
66:
		(<= n 1000000))
67:
      (let ((m (quotient 1000000 n)))
68:
	(joes-challenge n m))
69:
      (error "invalid arg to ring")))
70:
71:
(ring 10000)