gistfile1.scm

;; Inspired by http://www.icsi.berkeley.edu/~nweaver/multitask.scm

(define (make-queue l r)
  (cons l r))

(define (queue-push queue val)
  (make-queue (cons val (car queue))
              (cdr queue)))

(define (queue-pop queue)
  (if (null? (cdr queue))
      (let ((nr (reverse (car queue))))
        (values (make-queue '()
                            (cdr nr))
                (car nr)))
      (values (make-queue (car queue)
                          (cddr queue))
              (cadr queue))))

(define (queue-null? queue)
  (and (null? (car queue))
       (null? (cdr queue))))

(define tasks (make-queue '() '()))
(define pid-counter 0)
(define active-pid 0)
(define mailboxes (make-eqv-hashtable))

(define (alloc-pid)
  (let ((pid (+ 1 pid-counter)))
    (set! pid-counter pid)
    pid))

(define (push-task proc pid)
  (set! tasks (queue-push tasks
                          (cons pid proc))))

(define (next-task)
  (let-values (((queue task) (queue-pop tasks)))
    (set! tasks queue)
    (set! active-pid (car task))
    ((cdr task) '())))

(define exit
  (let ((exit exit))
    (lambda (pid)
      (hashtable-delete! mailboxes pid)
      (if (queue-null? tasks)
          (exit)
          (next-task)))))

(define (fork fn)
  (let* ((pid (alloc-pid))
         (parent active-pid)
         (thunk (lambda (unused)
                  (fn parent)
                  (exit pid))))
    (hashtable-set! mailboxes pid (make-queue '() '()))
    (push-task thunk pid)
    pid))

(define (yield)
  (call/cc
   (lambda (cont)
     (push-task cont active-pid)
     (next-task))))

(define (send-msg pid msg)
  (cond ((hashtable-ref mailboxes pid #f)
         => (lambda (q)
              (hashtable-set!
               mailboxes
               pid
               (queue-push q (cons active-pid msg)))))
        (error 'send-msg "unknown pid" pid)))

(define (pop-msg)
  (let ((q (hashtable-ref mailboxes active-pid #f)))
    (assert q) ; should not happen
    (if (queue-null? q)
        #f
        (let-values (((queue msg) (queue-pop q)))
          (hashtable-set! mailboxes active-pid queue)
          msg))))

(hashtable-set! mailboxes 0 (make-queue '() '()))

(let ((child (fork (lambda (p)
                     (format #t "sending to ~a" p)
                     (send-msg p 'hello)))))
  (format #t "child ~a started\n" child)
  (yield)
  (format #t "\nreceived ~a\n" (pop-msg)))