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