1 ;; Simple Actor Machine
3 ;; A virtual machine which houses a population of actors which can
4 ;; communicate using messages with actors on the same host or other
5 ;; hosts via the network.
12 (chicken process-context)
28 (define sam-host "localhost")
29 (define sam-port 8000)
31 (define sam-version "0.1")
35 (define (log-msg . args)
36 (with-output-to-port (current-error-port)
38 (apply print (cons "## " args)))))
40 (define (log-trace . args)
41 (with-output-to-port (current-error-port)
43 (if trace (apply log-msg args)))))
45 (define (->stringrep arg)
46 (with-output-to-string
51 ;; (See also macros defined in sam-macros.scm.)
53 (define (beh-proc beh)
55 (define (beh-parent beh)
61 (send-message recipient 'pong)
66 (define (make-address host port id)
69 (define (make-local-address . args)
70 (make-address sam-host
76 (define (address-id address)
78 (define (address-host address)
80 (define (address-port address)
82 (define (address->string address)
84 (make-uri #:scheme "actor"
85 #:host (address-host address)
86 #:port (address-port address)
87 #:path (list '/ (address-id address)))))
88 (define (string->address str)
89 (let ((uri (uri-reference str)))
90 (make-address (uri-host uri)
92 (cadr (uri-path uri)))))
94 (define (address-local? address)
95 (and (equal? (address-host address) sam-host)
96 (equal? (address-port address) sam-port)))
98 (define actor-table (make-hash-table))
100 (define (make-actor beh)
101 (let* ((address (make-local-address))
102 (id (address-id address)))
103 (hash-table-set! actor-table id beh)
106 (define (deliver-message address . message)
107 (let ((id (address-id address)))
108 (log-trace "DELIVERING to " id ": " (->stringrep message))
109 (let loop ((beh (hash-table-ref/default actor-table id #f)))
112 (match (apply (beh-proc beh) (cons address message))
113 ('done (hash-table-delete! actor-table id))
116 (log-trace "Passing to parent behaviour...")
117 (loop (beh-parent beh)))
118 ((? procedure? new-beh) (hash-table-set! actor-table id new-beh))
120 (log-msg "Warning: behaviour of actor " id " returned invalid value.")))
122 (log-msg "Warning: actor " id " crashed evaluating message " (->stringrep message))
123 (print-error-message o)))
124 (log-msg "Warning: DISCARDING message to unknown actor " id ": " (->stringrep message))))))
128 (define local-queue-mutex (make-mutex "message queue"))
129 (define message-available-mutex (make-mutex "message available"))
130 (mutex-lock! message-available-mutex #f #f)
131 (define local-queue (make-fifo))
133 (define (send-message address . message)
134 (log-trace "SENDING to " address ": " (->stringrep message))
135 (apply (if (address-local? address)
137 send-network-message)
138 (cons address message)))
140 (define (send-local-message address . message)
141 (mutex-lock! local-queue-mutex)
142 (fifo-push local-queue (cons address message))
143 (mutex-unlock! message-available-mutex)
144 (mutex-unlock! local-queue-mutex))
146 (define (send-network-message address . message)
147 (let ((s (udp-open-socket))
148 (packet (with-output-to-string
150 (write (cons address message))))))
153 (address-host address)
154 (address-port address))
156 (udp-close-socket s)))
158 (define (send-message-later address time . message)
162 (apply send-message (cons address message)))))
164 (define (next-local-message)
166 (mutex-lock! message-available-mutex #f #f)
167 (mutex-lock! local-queue-mutex)
168 (set! res (fifo-pop local-queue))
169 (if (not (fifo-empty? local-queue))
170 (mutex-unlock! message-available-mutex))
171 (mutex-unlock! local-queue-mutex)
174 (define (start-scheduler)
176 (apply deliver-message (next-local-message))
182 (define (start-network-listener)
185 (let ((s (udp-open-socket*)))
186 (udp-bind! s #f sam-port)
188 (let-values (((n str) (udp-recv s 65536)))
189 (match (with-input-from-string str read)
190 ((address message ...)
191 (apply send-message (cons address message)))
193 (log-msg "Warning: received badly formatted message string '" str "'"))))
198 (define reader-queue-mutex (make-mutex "reader queue"))
199 (define reader-available-mutex (make-mutex "reader available"))
200 (mutex-lock! reader-available-mutex #f #f)
201 (define reader-queue (make-fifo))
203 (define (next-reader)
205 (mutex-lock! reader-available-mutex #f #f)
206 (mutex-lock! reader-queue-mutex)
207 (set! res (fifo-pop reader-queue))
208 (if (not (fifo-empty? reader-queue))
209 (mutex-unlock! reader-available-mutex))
210 (mutex-unlock! reader-queue-mutex)
213 (define (start-console)
217 (let ((reader (next-reader)))
218 (##sys#thread-block-for-i/o! (current-thread) 0 #t)
220 (send-message reader (read-line)))
223 ;; System initialization
225 (define-beh system-beh
228 (log-msg "System actor received shutdown message.")
232 (('print strings ...) =>
233 (apply print strings)
237 (mutex-lock! reader-queue-mutex)
238 (fifo-push reader-queue reader)
239 (mutex-unlock! reader-available-mutex)
240 (mutex-unlock! reader-queue-mutex)
245 (start-network-listener)
246 (let ((system (make-actor system-beh))
250 (set! main (make-actor main-beh)))
252 (log-msg "Error starting main actor. Is main-beh defined?")
254 (send-message main system))
257 (define (print-usage)
258 (print "Simple Actor Machine v" sam-version "\n"
260 "Usage: sam -h|--help\n"
261 " sam [-n hostname] [-p port] source-file-1 [source-file-2 [...]] "))
263 (let loop ((args (cdr (argv))))
265 (((or "-h" "--help"))
267 (((or "-p" "--port") pstr rest ...)
268 (set! sam-port (string->number pstr))
270 (((or "-n" "--hostname") hstr rest ...)
273 (((or "-t" "--trace") rest ...)
274 (log-msg "Enabling trace debugging")
277 (((? file-exists? filename) rest ...)
278 (log-msg "Loading " filename)
282 (log-msg "Booting SAM\n")
285 (print "Unrecognised argument '" (car args) "'.\n")