X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=actors.git;a=blobdiff_plain;f=actors.scm;h=fc266a33d0f3601cdc83c0745fe619fe5ed130d7;hp=8a581b9cc818eee305b1ea8faf6540379cef91ce;hb=HEAD;hpb=3b3f13a56eb0719f02d2eb580dd5f3ec392fa4b8

diff --git a/actors.scm b/actors.scm
index 8a581b9..1c19346 100644
--- a/actors.scm
+++ b/actors.scm
@@ -1,143 +1,178 @@
-(import srfi-69 matchable)
+(module actors
+  (make-actor
+   make-actor-with-address
+   send-message
+   run
+   send-and-run
+   restart
+   enable-trace
+   disable-trace
+   save-actors
+   save-actors-to
+   load-actors
+   load-actors-from)
+
+  (import scheme
+          (chicken base)
+          srfi-69
+          matchable
+          s11n)
+
+  (define trace-enabled #f) ;used for debugging
+
+  (define (enable-trace)
+    (set! trace-enabled #t))
+
+  (define (disable-trace)
+    (set! trace-enabled #f))
 
-(define trace-enabled #t)
 
 ;;;
 ;;; Actor creation
 ;;;
 
-(define actor-table (make-hash-table))
+  (define actor-table (make-hash-table))
 
-(define (make-actor-with-address address behaviour)
-  (hash-table-set! actor-table address behaviour)
-  address)
+  (define (make-actor-with-address address behaviour)
+    (if trace-enabled
+        (print "Making actor with address " address))
+    (hash-table-set! actor-table address behaviour)
+    address)
 
-(define next-actor-address 1)
+  (define next-actor-address 1)
 
-(define (make-actor behaviour)
-  (make-actor-with-address next-actor-address behaviour)
-  (let ((address next-actor-address))
-    (set! next-actor-address (+ next-actor-address 1))
-    address))
+  (define (make-actor behaviour)
+    (make-actor-with-address next-actor-address behaviour)
+    (let ((address next-actor-address))
+      (set! next-actor-address (+ next-actor-address 1))
+      address))
 
+  
 ;;;
 ;;; Message dispatch
 ;;;
 
-(define (dispatch-message address message)
-  (if trace-enabled
-      (print "Dispatching message " message " to " address))
-  (let ((behaviour (hash-table-ref/default actor-table address '())))
-    (if (null? behaviour)
-        (print "Warning: discarded message " message " to unknown actor " address)
-        (let ((value (apply behaviour (cons address message))))
-          (match value
-            ('done (hash-table-delete! actor-table address))
-            ('sleep 'do-nothing)
-            (else
-             hash-table-set! actor-table address value))))))
+  (define (dispatch-message address message)
+    (if trace-enabled
+        (print "Dispatching message " message " to " address))
+    (let ((behaviour (hash-table-ref/default actor-table address '())))
+      (if (null? behaviour)
+          (print "Warning: discarded message " message " to unknown actor " address)
+          (let ((value (apply behaviour (cons address message))))
+            (case value
+              ((sleep) 'do-nothing)
+              ((done)
+               (if trace-enabled
+                   (print "Deleting actor " address))
+               (hash-table-delete! actor-table address))
+              (else
+               (if trace-enabled
+                   (print "Updating behaviour of " address))
+               (hash-table-set! actor-table address value)))))))
+
 
 ;;;
 ;;; FIFO queue implementation
 ;;;
 
-(define (make-fifo)
-  (define (cell val prev next)
-    (list val prev next))
-  (define cell-val car)
-  (define cell-prev cadr)
-  (define cell-next caddr)
-  (define (set-cell-prev! cell prev-cell)
-    (set-car! (cdr cell) prev-cell))
-  (define (set-cell-next! cell next-cell)
-    (set-car! (cddr cell) next-cell))
-
-  (let ((head '())
-        (tail '()))
-    (lambda (cmd . args)
-      (case cmd
-        ((empty?) (null? head))
-        ((push) (if (not (= (length args) 1))
-                    (error "Wrong number of arguments to push.")
-                    (if (not (null? head))
-                        (let ((old-head head))
-                          (set! head (cell (car args) '() old-head))
-                          (set-cell-prev! old-head head))
-                        (begin
-                          ;; Initialize list
-                          (set! head (cell (car args) '() '()))
-                          (set! tail head)))))
-        ((pop) (if (not (= (length args) 0))
-                   (error "Wrong number of arguments to pop.")
-                   (if (null? head)
-                       (error "FIFO empty.")
-                       (let ((old-tail tail))
-                         (set! tail (cell-prev old-tail))
-                         (if (null? tail)
-                             (set! head '())
-                             (set-cell-next! tail '()))
-                         (cell-val old-tail)))))))))
-
-(define (fifo-push fifo x)
-  (fifo 'push x))
-
-(define (fifo-pop fifo)
-  (fifo 'pop))
-
-(define (fifo-empty? fifo)
-  (fifo 'empty?))
+  (define (make-fifo)
+    (define (cell val prev next)
+      (list val prev next))
+    (define cell-val car)
+    (define cell-prev cadr)
+    (define cell-next caddr)
+    (define (set-cell-prev! cell prev-cell)
+      (set-car! (cdr cell) prev-cell))
+    (define (set-cell-next! cell next-cell)
+      (set-car! (cddr cell) next-cell))
+
+    (let ((head '())
+          (tail '()))
+      (lambda (cmd . args)
+        (case cmd
+          ((empty?) (null? head))
+          ((push) (if (not (= (length args) 1))
+                      (error "Wrong number of arguments to push.")
+                      (if (not (null? head))
+                          (let ((old-head head))
+                            (set! head (cell (car args) '() old-head))
+                            (set-cell-prev! old-head head))
+                          (begin
+                            ;; Initialize list
+                            (set! head (cell (car args) '() '()))
+                            (set! tail head)))))
+          ((pop) (if (not (= (length args) 0))
+                     (error "Wrong number of arguments to pop.")
+                     (if (null? head)
+                         (error "FIFO empty.")
+                         (let ((old-tail tail))
+                           (set! tail (cell-prev old-tail))
+                           (if (null? tail)
+                               (set! head '())
+                               (set-cell-next! tail '()))
+                           (cell-val old-tail)))))))))
+
+  (define (fifo-push fifo x)
+    (fifo 'push x))
+
+  (define (fifo-pop fifo)
+    (fifo 'pop))
+
+  (define (fifo-empty? fifo)
+    (fifo 'empty?))
 
 
 ;;;
 ;;; Message queue
 ;;;
 
-(define message-queue (make-fifo))
+  (define message-queue (make-fifo))
+
+  (define (next-addressed-msg)
+    (if (fifo-empty? message-queue)
+        '()
+        (fifo-pop message-queue)))
 
-(define (next-addressed-msg)
-  (if (fifo-empty? message-queue)
-      '()
-      (fifo-pop message-queue)))
+  (define (send-message actor . message)
+    (if trace-enabled
+        (print "Queued message " message " to " actor))
+    (fifo-push message-queue (cons actor message)))
 
-(define (send-message actor . message)
-  (if trace-enabled
-      (print "Queued message " message " to " actor))
-  (fifo-push message-queue (cons actor message)))
+  (define (process-next-message)
+    (let ((addressed-msg (next-addressed-msg)))
+      (if (null? addressed-msg)
+          '()
+          (let ((address (car addressed-msg))
+                (message (cdr addressed-msg)))
+            (dispatch-message address message)))))
 
-(define (process-next-message)
-  (let ((addressed-msg (next-addressed-msg)))
-    (if (null? addressed-msg)
-        '()
-        (let ((address (car addressed-msg))
-              (message (cdr addressed-msg)))
-          (dispatch-message address message)))))
+  (define (run)
+    (unless (null? (process-next-message))
+      (run)))
 
-(define (run)
-  (unless (null? (process-next-message))
-    (run)))
+  (define (send-and-run actor . message)
+    (apply send-message (cons actor message))
+    (run))
 
-(define (send-and-run actor . message)
-  (apply send-message (cons actor message))
-  (run))
+  (define (restart)
+    (set! message-queue (make-fifo))
+    (set! actor-table (make-hash-table)))
 
 ;;;
-;;; Testing
+;;; Serialization
 ;;;
 
-(define factorial
-  (make-actor-with-address 'factorial
-   (lambda (self customer . message)
-     (match message
-       ((n) (send-message self customer n 1) 'sleep)
-       ((0 acc) (send-message customer acc) 'done)
-       ((n acc) (send-message self customer (- n 1) (* acc n)) 'sleep)))))
-
-(define println
-  (make-actor-with-address 'println
-   (lambda (self . message)
-     (apply print message)
-     'sleep)))
-
-(send-message factorial println 5)
-(send-message factorial println 7)
-(run)
+  (define (save-actors-to filename)
+    (with-output-to-file filename
+      (lambda ()
+        (serialize (hash-table->alist actor-table)))))
+
+  (define (save-actors)
+    (save-actors-to "image"))
+
+  (define (load-actors-from filename)
+    (set! actor-table
+      (alist->hash-table (with-input-from-file filename deserialize))))
+
+  (define (load-actors)
+    load-actors-from "image"))