actors.scm

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