actors.scm

   1 (module actors
   2   (make-actor
   3    make-actor-with-address
   4    send-message
   5    run
   6    send-and-run
   7    trace-enabled)
   8
   9   (import scheme
  10           (chicken base)
  11           srfi-69
  12           matchable)
  13
  14   (define trace-enabled #f) ;used for debugging
  15
  16
  17 ;;;
  18 ;;; Actor creation
  19 ;;;
  20
  21   (define actor-table (make-hash-table))
  22
  23   (define (make-actor-with-address address behaviour)
  24     (if trace-enabled
  25         (print "Making actor with address " address))
  26     (hash-table-set! actor-table address behaviour)
  27     address)
  28
  29   (define next-actor-address 1)
  30
  31   (define (make-actor behaviour)
  32     (make-actor-with-address next-actor-address behaviour)
  33     (let ((address next-actor-address))
  34       (set! next-actor-address (+ next-actor-address 1))
  35       address))
  36
  37
  38 ;;;
  39 ;;; Message dispatch
  40 ;;;
  41
  42   (define (dispatch-message address message)
  43     (if trace-enabled
  44         (print "Dispatching message " message " to " address))
  45     (let ((behaviour (hash-table-ref/default actor-table address '())))
  46       (if (null? behaviour)
  47           (print "Warning: discarded message " message " to unknown actor " address)
  48           (let ((value (apply behaviour (cons address message))))
  49             (case value
  50               ((sleep) 'do-nothing)
  51               ((done)
  52                (if trace-enabled
  53                    (print "Deleting actor " address))
  54                (hash-table-delete! actor-table address))
  55               (else
  56                (if trace-enabled
  57                    (print "Updating behaviour of " address))
  58                (hash-table-set! actor-table address value)))))))
  59
  60
  61 ;;;
  62 ;;; FIFO queue implementation
  63 ;;;
  64
  65   (define (make-fifo)
  66     (define (cell val prev next)
  67       (list val prev next))
  68     (define cell-val car)
  69     (define cell-prev cadr)
  70     (define cell-next caddr)
  71     (define (set-cell-prev! cell prev-cell)
  72       (set-car! (cdr cell) prev-cell))
  73     (define (set-cell-next! cell next-cell)
  74       (set-car! (cddr cell) next-cell))
  75
  76     (let ((head '())
  77           (tail '()))
  78       (lambda (cmd . args)
  79         (case cmd
  80           ((empty?) (null? head))
  81           ((push) (if (not (= (length args) 1))
  82                       (error "Wrong number of arguments to push.")
  83                       (if (not (null? head))
  84                           (let ((old-head head))
  85                             (set! head (cell (car args) '() old-head))
  86                             (set-cell-prev! old-head head))
  87                           (begin
  88                             ;; Initialize list
  89                             (set! head (cell (car args) '() '()))
  90                             (set! tail head)))))
  91           ((pop) (if (not (= (length args) 0))
  92                      (error "Wrong number of arguments to pop.")
  93                      (if (null? head)
  94                          (error "FIFO empty.")
  95                          (let ((old-tail tail))
  96                            (set! tail (cell-prev old-tail))
  97                            (if (null? tail)
  98                                (set! head '())
  99                                (set-cell-next! tail '()))
 100                            (cell-val old-tail)))))))))
 101
 102   (define (fifo-push fifo x)
 103     (fifo 'push x))
 104
 105   (define (fifo-pop fifo)
 106     (fifo 'pop))
 107
 108   (define (fifo-empty? fifo)
 109     (fifo 'empty?))
 110
 111
 112 ;;;
 113 ;;; Message queue
 114 ;;;
 115
 116   (define message-queue (make-fifo))
 117
 118   (define (next-addressed-msg)
 119     (if (fifo-empty? message-queue)
 120         '()
 121         (fifo-pop message-queue)))
 122
 123   (define (send-message actor . message)
 124     (if trace-enabled
 125         (print "Queued message " message " to " actor))
 126     (fifo-push message-queue (cons actor message)))
 127
 128   (define (process-next-message)
 129     (let ((addressed-msg (next-addressed-msg)))
 130       (if (null? addressed-msg)
 131           '()
 132           (let ((address (car addressed-msg))
 133                 (message (cdr addressed-msg)))
 134             (dispatch-message address message)))))
 135
 136   (define (run)
 137     (unless (null? (process-next-message))
 138       (run)))
 139
 140   (define (send-and-run actor . message)
 141     (apply send-message (cons actor message))
 142     (run)))