actors.scm

   1 (import srfi-69 matchable)
   2
   3 ;;;
   4 ;;; Actor creation
   5 ;;;
   6
   7 (define actor-table (make-hash-table))
   8
   9 (define (make-actor-with-address address behaviour)
  10   (hash-table-set! actor-table address behaviour)
  11   address)
  12
  13 (define next-actor-address 1)
  14
  15 (define (make-actor behaviour)
  16   (make-actor-with-address next-actor-address behaviour)
  17   (let ((address next-actor-address))
  18     (set! next-actor-address (+ next-actor-address 1))
  19     address))
  20
  21 ;;;
  22 ;;; Message dispatch
  23 ;;;
  24
  25 (define (dispatch-message address message)
  26   (print "Dispatching message " message " to " address)
  27   (let* ((behaviour (hash-table-ref actor-table address))
  28          (value (behaviour address message)))
  29     (match value
  30       ('done (hash-table-delete! actor-table address))
  31       ('sleep 'do-nothing)
  32       (else
  33        hash-table-set! actor-table address value))))
  34
  35 ;;;
  36 ;;; FIFO queue implementation
  37 ;;;
  38
  39 (define (make-fifo)
  40   (define (cell val prev next)
  41     (list val prev next))
  42   (define cell-val car)
  43   (define cell-prev cadr)
  44   (define cell-next caddr)
  45   (define (set-cell-prev! cell prev-cell)
  46     (set-car! (cdr cell) prev-cell))
  47   (define (set-cell-next! cell next-cell)
  48     (set-car! (cddr cell) next-cell))
  49
  50   (let ((head '())
  51         (tail '()))
  52     (lambda (cmd . args)
  53       (case cmd
  54         ((empty?) (null? head))
  55         ((push) (if (not (= (length args) 1))
  56                     (error "Wrong number of arguments to push.")
  57                     (if (not (null? head))
  58                         (let ((old-head head))
  59                           (set! head (cell (car args) '() old-head))
  60                           (set-cell-prev! old-head head))
  61                         (begin
  62                           ;; Initialize list
  63                           (set! head (cell (car args) '() '()))
  64                           (set! tail head)))))
  65         ((pop) (if (not (= (length args) 0))
  66                    (error "Wrong number of arguments to pop.")
  67                    (if (null? head)
  68                        (error "FIFO empty.")
  69                        (let ((old-tail tail))
  70                          (set! tail (cell-prev old-tail))
  71                          (if (null? tail)
  72                              (set! head '())
  73                              (set-cell-next! tail '()))
  74                          (cell-val old-tail)))))))))
  75
  76 (define (fifo-push fifo x)
  77   (fifo 'push x))
  78
  79 (define (fifo-pop fifo)
  80   (fifo 'pop))
  81
  82 (define (fifo-empty? fifo)
  83   (fifo 'empty?))
  84
  85
  86 ;;;
  87 ;;; Message queue
  88 ;;;
  89
  90 (define message-queue (make-fifo))
  91
  92 (define (next-addressed-msg)
  93   (if (fifo-empty? message-queue)
  94       '()
  95       (fifo-pop message-queue)))
  96
  97 (define (send-message actor message)
  98   (print "Queued message " message " to " actor)
  99   (fifo-push message-queue (cons actor message)))
 100
 101 (define (run)
 102   (let ((addressed-msg (next-addressed-msg)))
 103     (if (null? addressed-msg)
 104         'done
 105         (let ((address (car addressed-msg))
 106               (message (cdr addressed-msg)))
 107           (dispatch-message address message)
 108           (run)))))
 109
 110 ;;;
 111 ;;; Testing
 112 ;;;
 113
 114 (define factorial
 115   (make-actor
 116    (lambda (self message)
 117      (match message
 118        ((n) (send-message self (list n 1)) 'sleep)
 119        ((0 acc) (print acc) 'done)
 120        ((n acc) (send-message self (list (- n 1) (* acc n))) 'sleep)))))
 121
 122 ;(send-message factorial '(5))