Loading

xp.scm

  1. (import (fibers))
  2. (import (fibers channels))
  3.  
  4. (import (ice-9 threads))
  5.  
  6. (define channel (make-channel))
  7.  
  8.  
  9. (let loop ((index (- (current-processor-count) 7)))
  10.   (unless (zero? index)
  11.     (call-with-new-thread
  12.      (lambda ()
  13.        (let continue ((message (get-message channel)))
  14.          (let ((thunk (car message))
  15.                (return (cdr message)))
  16.            (let ((out (thunk)))
  17.              (put-message return out)))
  18.          (continue (get-message channel))))
  19.      pk)
  20.     (loop (- index 1))))
  21.  
  22. (define (fib n)
  23.   (cond
  24.     ((= n 0) 0)
  25.     ((= n 1) 1)
  26.     (else (+ (fib (- n 1)) (fib (- n 2))))))
  27.  
  28. (define (exec thunk)
  29.   (let ((return (make-channel)))
  30.     (put-message channel (cons thunk return))
  31.     (get-message return)))
  32.  
  33. (define (compute n)
  34.   (pk 'out (exec (lambda () (fib n)))))
  35.  
  36. (define (main)
  37.   (let loop ((index 16))
  38.     (unless (zero? index)
  39.       (spawn-fiber (lambda () (compute (expt 2 5))))
  40.       (loop (- index 1))))
  41.   (sleep 10))
  42.  
  43.  
  44. (run-fibers main #:parallelism 1 #:drain? #t #:hz 0)