Working on scheduler.

diff --git a/fifo.scm b/fifo.scm
index d2cea22..ab5eda0 100644 (file)
--- a/fifo.scm
+++ b/fifo.scm
@@ -2,12 +2,10 @@
     (make-fifo
      fifo-push
      fifo-pop
     (make-fifo
      fifo-push
      fifo-pop

-     fifo-empty?

      fifo->list)
 
   (import scheme
      fifo->list)
 
   (import scheme

-          (chicken base)
-          srfi-18)
+          (chicken base))

 
   (define (make-fifo)
     (define (cell val prev next)
 
   (define (make-fifo)
     (define (cell val prev next)


@@ -21,12 +19,9 @@
       (set-car! (cddr cell) next-cell))
 
     (let ((head '())
       (set-car! (cddr cell) next-cell))
 
     (let ((head '())

-          (tail '())
-          (pop-mutex (make-mutex)))
-      (mutex-lock! pop-mutex #f #f)
+          (tail '()))

       (lambda (cmd . args)
         (case cmd
       (lambda (cmd . args)
         (case cmd

-          ((empty?) (null? head))

           ((push)
            (if (not (null? head))
                (let ((old-head head))
           ((push)
            (if (not (null? head))
                (let ((old-head head))


@@ -35,37 +30,26 @@
                (begin
                  ;; Initialize list
                  (set! head (cell (car args) '() '()))
                (begin
                  ;; Initialize list
                  (set! head (cell (car args) '() '()))

-                 (set! tail head)
-                 (mutex-unlock! pop-mutex))))
+                 (set! tail head))))

           ((pop)
           ((pop)

-           (mutex-lock! pop-mutex #f #f)
-           (if (null? head)
-               (error "FIFO empty.")
-               (let ((old-tail tail))
-                 (set! tail (cell-prev old-tail))
-                 (if (null? tail)
-                     (set! head '())
-                     (begin
-                       (set-cell-next! tail '())
-                       (mutex-unlock! pop-mutex #f #f)))
-                 (cell-val old-tail)))))
-        ((->list) (if (not (= (length args) 0))
-                      (error "Wrong number of arguments to ->list.")
-                      (let loop ((this-cell head))
-                        (if (null? this-cell)
-                            '()
-                            (cons (cell-val this-cell)
-                                  (loop (cell-next this-cell))))))))))
+           (let ((old-tail tail))
+             (set! tail (cell-prev old-tail))
+             (if (null? tail)
+                 (set! head '())
+                 (set-cell-next! tail '()))
+             (cell-val old-tail)))
+          ((->list)
+           (let loop ((this-cell head))
+             (if (null? this-cell)
+                 '()
+                 (cons (cell-val this-cell)
+                       (loop (cell-next this-cell))))))))))

   
   

-

   (define (fifo-push fifo x)
     (fifo 'push x))
 
   (define (fifo-pop fifo)
     (fifo 'pop))
 
   (define (fifo-push fifo x)
     (fifo 'push x))
 
   (define (fifo-pop fifo)
     (fifo 'pop))
 

-  (define (fifo-empty? fifo)
-    (fifo 'empty?))
-

   (define (fifo->list fifo)
     (fifo '->list)))
   (define (fifo->list fifo)
     (fifo '->list)))

diff --git a/sam.scm b/sam.scm
index 431cd1c..5c5ec88 100644 (file)
--- a/sam.scm
+++ b/sam.scm
@@ -8,8 +8,8 @@
         matchable
         srfi-18 ; threads
         srfi-69 ; hashtable
         matchable
         srfi-18 ; threads
         srfi-69 ; hashtable

-        udp6
-        uri-generic)
+        udp
+        fifo)

 
 ;; Actors
 
 
 ;; Actors
 


@@ -38,18 +38,19 @@
   
 (define (deliver-message address . message)
   (let ((id (address-id address)))
   
 (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-put! actor new-beh)))))))

 
 ;; Scheduler
 
 (define local-queue-mutex (make-mutex "message queue"))
 (define message-available-mutex (make-mutex "message available"))
 
 ;; 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)
 (define local-queue (make-fifo))
 
 (define (send-message address . message)


@@ -61,6 +62,7 @@
 (define (send-local-message address . message)
   (mutex-lock! local-queue-mutex)
   (fifo-push local-queue (cons address message))
 (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)
   (mutex-unlock! local-queue-mutex))
 
 (define (send-network-message address . message)


@@ -75,10 +77,10 @@
 
 (define (next-local-message)
   (let ((res #f))
 
 (define (next-local-message)
   (let ((res #f))

+    (mutex-lock! message-available-mutex)

     (mutex-lock! local-queue-mutex)
     (mutex-lock! local-queue-mutex)

-    (set! res (if (fifo-empty? local-queue)
-                  #f
-                  (fifo-pop local-queue)))
+    (set! res (fifo-pop local-queue))
+    (mutex-unlock! message-available-mutex)

     (mutex-unlock! local-queue-mutex)
     res))
 
     (mutex-unlock! local-queue-mutex)
     res))
 


@@ -86,9 +88,9 @@
   (make-thread
    (lambda ()
      (let loop ((next-addressed-message (next-local-message)))
   (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!))
+(thread-start! scheduler-thread)
+
+(thread-join! scheduler-thread)