| 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) |