tiny Actor-model

pong.scm

;;==============Tiny framework of Actor-model=========================
(use-modules (ice-9 control) (ice-9 match) (ice-9 q))

(define *mailbox* (make-hash-table))
(define *task-queue* (make-q))
(define (gen-pid n) (gensym (format #f "actor-~a-" n)))

(define-syntax-rule (! pid msg)
  (let ((mq (hashq-ref *mailbox* pid)))
    (if mq
        (enq! mq msg)
        (error '! "send msg: invalid pid" pid))))

(define-syntax-rule (has-task?)
  (not (q-empty? *task-queue*)))

(define-syntax-rule (self)
  (if (has-task?)
      (car (q-front *task-queue*))
      (error 'self "No task!")))

(define-syntax-rule (receive body ...)
  (let lp()
    (match (hashq-ref *mailbox* (self))
      ((or #f (? q-empty?)) (abort 'sleep) (lp))
      ;; Very important!!! We must schedule the process after each receive scheduled,
      ;; or we failed to capture the correct continuation here. Don't blame me if you
      ;; see ghost when remove it, follow me to keep your safe!!!
      (mq ((lambda (_) (match _ body ...)) (deq! mq)) (abort 'sleep)))))

(define-syntax-rule (%schedule)
  (when (has-task?) ((cdr (q-front *task-queue*)))))

(define-syntax-rule (active-scheduler)
  (% (%schedule) scheduler))

(define (scheduler k s)
  (%
   (case s
     ((sleep)
      (let ((pid (car (deq! *task-queue*))))
        (enq! *task-queue* (cons pid k))
        (%schedule)))
     ((quit)
      (hashq-remove! *mailbox* (car (deq! *task-queue*)))
      (%schedule))
     ((clean)
      (deq! *task-queue*)
      (%schedule))
     (else (error scheduler "no!" s)))
   scheduler))

(define (spawn proc args)
  (let ((pid (gen-pid (procedure-name proc))))
    (hashq-set! *mailbox* pid (make-q))
    (enq! *task-queue* (cons pid (lambda () (apply proc args) (abort 'quit))))
    pid))



;;=================Start ping-pong===================

(define (ping . args)
  (match args
    ((0 pong-pid)
     (! pong-pid 'finished)
     (format #t "ping finished~%"))
    ((n pong-pid)
     (! pong-pid (list 'ping (self)))
     (receive
      ('pong
       (format #t "ping received pong~%")))
     (ping (1- n) pong-pid))))

(define (pong)
  (receive
   ('finished
    (format #t "pong finished~%"))
   (('ping ping-pid)
    (format #t "pong received ping~%")
    (! ping-pid 'pong)
    (pong))))

(define (start n)
  (let ((pong-pid (spawn pong '())))
    (for-each (lambda (i) (spawn ping (list 3 pong-pid))) (iota n))
    (active-scheduler)))

Updated for optimizing.

• Bad news: Guile-2.0 can't run more than 2500 actors
• Good news: Guile-2.1 works for more than 10000 actors smoothly, it's not fast at present, but it just take advantage of 1 core yet. We'll manage to use SMP then.

@amirouche definitely I'll have a post for it ;-)