actors.scm

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