Debugging scheduler.

diff --git a/fifo.scm b/fifo.scm
index ab5eda0..14b24f1 100644 (file)
--- a/fifo.scm
+++ b/fifo.scm
@@ -2,6 +2,7 @@
     (make-fifo
      fifo-push
      fifo-pop
+     fifo-empty?
      fifo->list)
 
   (import scheme
@@ -38,6 +39,7 @@
                  (set! head '())
                  (set-cell-next! tail '()))
              (cell-val old-tail)))
+          ((empty?) (null? head))
           ((->list)
            (let loop ((this-cell head))
              (if (null? this-cell)
@@ -51,5 +53,8 @@
   (define (fifo-pop fifo)
     (fifo 'pop))
 
+  (define (fifo-empty? fifo)
+    (fifo 'empty?))
+
   (define (fifo->list fifo)
     (fifo '->list)))

diff --git a/sam.scm b/sam.scm
index 5c5ec88..82f3d7f 100644 (file)
--- a/sam.scm
+++ b/sam.scm
@@ -7,7 +7,7 @@
         (chicken string)
         matchable
         srfi-18 ; threads
-        srfi-69 ; hashtable
+        srfi-69 ; hash-table
         udp
         fifo)
 
@@ -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,8 +35,8 @@
 
 (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)))
@@ -44,7 +46,7 @@
           (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)))))))
+            (new-beh (hash-table-set! actor-table actor new-beh)))))))
 
 ;; Scheduler
 
@@ -77,10 +79,11 @@
 
 (define (next-local-message)
   (let ((res #f))
-    (mutex-lock! message-available-mutex)
+    (mutex-lock! message-available-mutex #f #f)
     (mutex-lock! local-queue-mutex)
     (set! res (fifo-pop local-queue))
-    (mutex-unlock! message-available-mutex)
+    (if (not (fifo-empty? local-queue))
+      (mutex-unlock! message-available-mutex))
     (mutex-unlock! local-queue-mutex)
     res))
 
@@ -91,6 +94,17 @@
        (apply deliver-message next-addressed-message)
        (loop (next-local-message))))))
 
+
+;; 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)