X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=sam.git;a=blobdiff_plain;f=sam.scm;h=fbe800e53436138590f3674c7900b7e86e851e39;hp=93906b958bd0472bfe4ff5583acdc7266ab8cca9;hb=HEAD;hpb=3001c497e5536bb767303d96a6b65e2ad040e754

diff --git a/sam.scm b/sam.scm
index 93906b9..fbe800e 100644
--- a/sam.scm
+++ b/sam.scm
@@ -1,8 +1,8 @@
 ;; Simple Actor Machine
 ;;
 ;; A virtual machine which houses a population of actors which can
-;; communicate using messages with actors on the same machine or other
-;; machines via the network.
+;; communicate using messages with actors on the same host or other
+;; hosts via the network.
 
 (import scheme
         (chicken base)
@@ -11,13 +11,15 @@
         (chicken port)
         (chicken process-context)
         (chicken file)
+        (chicken condition)
         matchable
         srfi-18 ; threads
         srfi-69 ; hash-table
         uuid ; ids for actors
         uri-generic
         udp
-        fifo)
+        fifo
+        sam-macros)
 
 ;; Global variables
 
@@ -28,8 +30,42 @@
 
 (define sam-version "0.1")
 
-;; Actors
+;; Logging
+
+(define (log-msg . args)
+  (with-output-to-port (current-error-port)
+    (lambda ()
+      (apply print (cons "## " args)))))
+
+(define (log-trace . args)
+  (with-output-to-port (current-error-port)
+    (lambda ()
+      (if trace (apply log-msg args)))))
+
+(define (->stringrep arg)
+  (with-output-to-string
+    (lambda ()
+      (write arg))))
+
+;; Behaviours
+;; (See also macros defined in sam-macros.scm.)
+
+(define (beh-proc beh)
+  (cadr beh))
+(define (beh-parent beh)
+  (caddr beh))  
 
+(define root-beh
+  (make-beh : #f (self)
+            (('ping recipient) =>
+             (send-message recipient 'pong))))
+
+(define (beh? x)
+  (and (pair? x)
+       (not (null? x))
+       (eq? (car x) 'beh)))
+
+;; Actors
 
 (define (make-address host port id)
   (list id host port))
@@ -72,16 +108,23 @@
     address))
 
 (define (deliver-message address . message)
-  (if trace (print "Delivering to " address ": " message))
   (let ((id (address-id address)))
-    (let ((behaviour (hash-table-ref/default actor-table id '())))
-      (if (null? behaviour)
-          (print "Warning: discarded message " message
-                 " to unknown actor id " id)
-          (match (apply (hash-table-ref actor-table id) (cons address message))
-            ('done (hash-table-delete! actor-table id))
-            ('sleep 'do-nothing)
-            (new-beh (hash-table-set! actor-table id new-beh)))))))
+    (log-trace "DELIVERING to " id ": " (->stringrep message))
+    (let loop ((beh (hash-table-ref/default actor-table id #f)))
+      (if beh
+          (condition-case
+              (match (apply (beh-proc beh) (cons address message))
+                ('done (hash-table-delete! actor-table id))
+                ('pass
+                 (log-trace "Passing to parent behaviour...")
+                 (loop (beh-parent beh)))
+                ((? beh? new-beh) (hash-table-set! actor-table id new-beh))
+                (else
+                 'do-nothing)) ; sleep is now the default
+            (o (exn)
+             (log-msg "Warning: actor " id " crashed evaluating message " (->stringrep message))
+             (print-error-message o)))
+          (log-msg "Warning: DISCARDING message to unknown actor " id ": " (->stringrep message))))))
 
 ;; Scheduler
 
@@ -91,6 +134,7 @@
 (define local-queue (make-fifo))
 
 (define (send-message address . message)
+  (log-trace "SENDING to " address ": " (->stringrep message))
   (apply (if (address-local? address)
              send-local-message
              send-network-message)
@@ -149,7 +193,7 @@
              ((address message ...)
               (apply send-message (cons address message)))
              (else
-              (print "Warning: received badly formatted message string '" str "'"))))
+              (log-msg "Warning: received badly formatted message string '" str "'"))))
          (loop))))))
 
 ;; System interface
@@ -181,29 +225,35 @@
 
 ;; System initialization
 
-(define (system-beh self . message)
-  (match message
+(define-beh system-beh
+  (self)
 
-    (('shutdown)
-     (print "## System actor received shutdown message.")
-     (exit 0)
-     'done)
+  (('shutdown) =>
+   (log-msg "System actor received shutdown message.")
+   (exit 0)
+   'done)
 
-    (('print strings ...)
-     (apply print strings)
-     'sleep)
+  (('print strings ...) =>
+   (apply print strings))
 
-    (('read reader)
-     (mutex-lock! reader-queue-mutex)
-     (fifo-push reader-queue reader)
-     (mutex-unlock! reader-available-mutex)
-     (mutex-unlock! reader-queue-mutex)
-     'sleep)))
+  (('read reader) =>
+   (mutex-lock! reader-queue-mutex)
+   (fifo-push reader-queue reader)
+   (mutex-unlock! reader-available-mutex)
+   (mutex-unlock! reader-queue-mutex)))
 
 (define (boot-sam)
   (start-console)
   (start-network-listener)
-  (send-message (make-actor main-beh) (make-actor system-beh))
+  (let ((system (make-actor system-beh))
+        (main #f))
+    (condition-case
+        (begin
+          (set! main (make-actor main-beh)))
+      ((exn)
+       (log-msg "Error starting main actor. Is main-beh defined?")
+       (exit 1)))
+    (send-message main system))
   (start-scheduler))
 
 (define (print-usage)
@@ -212,7 +262,6 @@
          "Usage: sam -h|--help\n"
          "       sam [-n hostname] [-p port] source-file-1 [source-file-2 [...]] "))
 
-
 (let loop ((args (cdr (argv))))
   (match args
     (((or "-h" "--help"))
@@ -222,14 +271,18 @@
      (loop rest))
     (((or "-n" "--hostname") hstr rest ...)
      (set! sam-host hstr)
-     (loop rest)
-    (((? file-exists? filename) rest ...))
-     (print* "Loading " filename "...")
+     (loop rest))
+    (((or "-t" "--trace") rest ...)
+     (log-msg "Enabling trace debugging")
+     (set! trace #t)
+     (loop rest))
+    (((? file-exists? filename) rest ...)
+     (log-msg "Loading " filename)
      (load filename)
-     (print " done.")
      (loop rest))
     (()
-     (boot-sam host port main-beh))
+     (log-msg "Booting SAM\n")
+     (boot-sam))
     (else
      (print "Unrecognised argument '" (car args) "'.\n")
      (print-usage))))