X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=sam.git;a=blobdiff_plain;f=sam.scm;h=82f3d7f3eac319fe15c95c96efb3baa8f06feaff;hp=5c5ec886a760d2e65394379e202b8e32d9512892;hb=ae2621e0018bd23c301f4da4ee1990bb6e02d71f;hpb=bf8a20a40dd9e5d963498a0fe43ef5fea52d07c6 diff --git a/sam.scm b/sam.scm index 5c5ec88..82f3d7f 100644 --- 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)