actors.scm

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