Debugging scheduler.

[sam.git] / sam.scm

diff --git a/sam.scm b/sam.scm
index 431cd1c..82f3d7f 100644 (file)
--- a/sam.scm
+++ b/sam.scm
@@ -7,9 +7,9 @@
         (chicken string)
         matchable
         srfi-18 ; threads
-        srfi-69 ; hashtable
-        udp6
-        uri-generic)
+        srfi-69 ; hash-table
+        udp
+        fifo)
 
 ;; Actors
 
@@ -24,6 +24,8 @@
 
 (define (address-id address) (car address))
 (define (address-machine address) (cdr address))
+(define (make-address id machine)
+  (cons id machine))
 
 (define (address-local? address)
   (equal? (address-machine address)
@@ -33,23 +35,24 @@
 
 (define (make-actor beh)
   (let* ((id next-actor-id))
-    (hash-table-put! id beh)
-    (cons id this-machine)))
+    (hash-table-set! actor-table id beh)
+    (make-address id this-machine)))
   
 (define (deliver-message 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 " address)
-        (match (apply (hash-table-ref actor-table id) (cons address message))
-          ('done (hash-table-delete! actor-table actor))
-          ('sleep 'do-nothing)
-          (new-beh (hash-table-put! actor new-beh))))))
+    (let ((behaviour (hash-table-ref/default actor-table id '())))
+      (if (null? behaviour)
+          (print "Warning: discarded message" message " to unknown actor " address)
+          (match (apply (hash-table-ref actor-table id) (cons address message))
+            ('done (hash-table-delete! actor-table actor))
+            ('sleep 'do-nothing)
+            (new-beh (hash-table-set! actor-table actor new-beh)))))))
 
 ;; Scheduler
 
 (define local-queue-mutex (make-mutex "message queue"))
 (define message-available-mutex (make-mutex "message available"))
+(mutex-lock! message-available-mutex #f #f)
 (define local-queue (make-fifo))
 
 (define (send-message address . message)
@@ -61,6 +64,7 @@
 (define (send-local-message address . message)
   (mutex-lock! local-queue-mutex)
   (fifo-push local-queue (cons address message))
+  (mutex-unlock! message-available-mutex)
   (mutex-unlock! local-queue-mutex))
 
 (define (send-network-message address . message)
@@ -75,10 +79,11 @@
 
 (define (next-local-message)
   (let ((res #f))
+    (mutex-lock! message-available-mutex #f #f)
     (mutex-lock! local-queue-mutex)
-    (set! res (if (fifo-empty? local-queue)
-                  #f
-                  (fifo-pop local-queue)))
+    (set! res (fifo-pop local-queue))
+    (if (not (fifo-empty? local-queue))
+      (mutex-unlock! message-available-mutex))
     (mutex-unlock! local-queue-mutex)
     res))
 
@@ -86,9 +91,20 @@
   (make-thread
    (lambda ()
      (let loop ((next-addressed-message (next-local-message)))
-       (if next-addressed-message
-           (apply deliver-message next-addressed-message)
-           (begin
-             (lo))))))
+       (apply deliver-message next-addressed-message)
+       (loop (next-local-message))))))
 
-  (thread-start!))
+
+;; Testing
+
+(thread-start! scheduler-thread)
+
+(define println
+  (make-actor (lambda (self . message)
+                (apply print message)
+                'sleep)))
+
+(print println)
+(send-message println "Hello, world!")
+
+(thread-join! scheduler-thread)