From 3001c497e5536bb767303d96a6b65e2ad040e754 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sat, 1 May 2021 22:35:55 +0200 Subject: [PATCH] SAM now runs the show. --- Makefile | 7 + sam.scm | 431 +++++++++++++++++++++++++++++-------------------------- 2 files changed, 235 insertions(+), 203 deletions(-) create mode 100644 Makefile diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..34bd08b --- /dev/null +++ b/Makefile @@ -0,0 +1,7 @@ +all: sam + +%.so: %.scm + csc -s -J $< + +sam: sam.scm fifo.so + csc sam.scm diff --git a/sam.scm b/sam.scm index 88ae320..93906b9 100644 --- a/sam.scm +++ b/sam.scm @@ -4,208 +4,233 @@ ;; communicate using messages with actors on the same machine or other ;; machines via the network. -(module sam - (boot-sam - make-actor - send-message - send-message-later - address->string - string->address) - - (import scheme - (chicken base) - (chicken io) - (chicken string) - (chicken port) - (chicken process-context) - matchable - srfi-18 ; threads - srfi-69 ; hash-table - uuid ; ids for actors - uri-generic - udp - fifo) - - (define trace #f) - - ;; Actors - - (define sam-host "localhost") - (define sam-port 8000) - - (define (make-address host port id) - (list id host port)) - - (define (make-local-address . args) - (make-address sam-host - sam-port - (if (null? args) - (uuid) - (car args)))) - - (define (address-id address) - (car address)) - (define (address-host address) - (cadr address)) - (define (address-port address) - (caddr address)) - (define (address->string address) - (uri->string - (make-uri #:scheme "actor" - #:host (address-host address) - #:port (address-port address) - #:path (list '/ (address-id address))))) - (define (string->address str) - (let ((uri (uri-reference str))) - (make-address (uri-host uri) - (uri-port uri) - (cadr (uri-path uri))))) - - (define (address-local? address) - (and (equal? (address-host address) sam-host) - (equal? (address-port address) sam-port))) - - (define actor-table (make-hash-table)) - - (define (make-actor beh) - (let* ((address (make-local-address)) - (id (address-id address))) - (hash-table-set! actor-table id beh) - 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))))))) - - ;; 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) - (apply (if (address-local? address) - send-local-message - send-network-message) - (cons address message))) - - (define (send-local-message address . message) +(import scheme + (chicken base) + (chicken io) + (chicken string) + (chicken port) + (chicken process-context) + (chicken file) + matchable + srfi-18 ; threads + srfi-69 ; hash-table + uuid ; ids for actors + uri-generic + udp + fifo) + +;; Global variables + +(define trace #f) + +(define sam-host "localhost") +(define sam-port 8000) + +(define sam-version "0.1") + +;; Actors + + +(define (make-address host port id) + (list id host port)) + +(define (make-local-address . args) + (make-address sam-host + sam-port + (if (null? args) + (uuid) + (car args)))) + +(define (address-id address) + (car address)) +(define (address-host address) + (cadr address)) +(define (address-port address) + (caddr address)) +(define (address->string address) + (uri->string + (make-uri #:scheme "actor" + #:host (address-host address) + #:port (address-port address) + #:path (list '/ (address-id address))))) +(define (string->address str) + (let ((uri (uri-reference str))) + (make-address (uri-host uri) + (uri-port uri) + (cadr (uri-path uri))))) + +(define (address-local? address) + (and (equal? (address-host address) sam-host) + (equal? (address-port address) sam-port))) + +(define actor-table (make-hash-table)) + +(define (make-actor beh) + (let* ((address (make-local-address)) + (id (address-id address))) + (hash-table-set! actor-table id beh) + 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))))))) + +;; 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) + (apply (if (address-local? address) + send-local-message + send-network-message) + (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) + (let ((s (udp-open-socket)) + (packet (with-output-to-string + (lambda () + (write (cons address message)))))) + (udp-bind! s #f 0) + (udp-connect! s + (address-host address) + (address-port address)) + (udp-send s packet) + (udp-close-socket s))) + +(define (send-message-later address time . message) + (thread-start! + (lambda () + (thread-sleep! time) + (apply send-message (cons address message))))) + +(define (next-local-message) + (let ((res #f)) + (mutex-lock! message-available-mutex #f #f) (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) - (let ((s (udp-open-socket)) - (packet (with-output-to-string - (lambda () - (write (cons address message)))))) - (udp-bind! s #f 0) - (udp-connect! s - (address-host address) - (address-port address)) - (udp-send s packet) - (udp-close-socket s))) - - (define (send-message-later address time . message) - (thread-start! - (lambda () - (thread-sleep! time) - (apply send-message (cons address message))))) - - (define (next-local-message) - (let ((res #f)) - (mutex-lock! message-available-mutex #f #f) - (mutex-lock! local-queue-mutex) - (set! res (fifo-pop local-queue)) - (if (not (fifo-empty? local-queue)) - (mutex-unlock! message-available-mutex)) - (mutex-unlock! local-queue-mutex) - res)) - - (define (start-scheduler) - (let loop () - (apply deliver-message (next-local-message)) - (loop))) - - - ;; Network - - (define (start-network-listener) - (thread-start! - (lambda () - (let ((s (udp-open-socket*))) - (udp-bind! s #f sam-port) - (let loop () - (let-values (((n str) (udp-recv s 65536))) - (match (with-input-from-string str read) - ((address message ...) - (apply send-message (cons address message))) - (else - (print "Warning: received badly formatted message string '" str "'")))) - (loop)))))) - - ;; System interface - - (define reader-queue-mutex (make-mutex "reader queue")) - (define reader-available-mutex (make-mutex "reader available")) - (mutex-lock! reader-available-mutex #f #f) - (define reader-queue (make-fifo)) - - (define (next-reader) - (let ((res #f)) - (mutex-lock! reader-available-mutex #f #f) - (mutex-lock! reader-queue-mutex) - (set! res (fifo-pop reader-queue)) - (if (not (fifo-empty? reader-queue)) - (mutex-unlock! reader-available-mutex)) - (mutex-unlock! reader-queue-mutex) - res)) - - (define (start-console) - (thread-start! - (lambda () + (set! res (fifo-pop local-queue)) + (if (not (fifo-empty? local-queue)) + (mutex-unlock! message-available-mutex)) + (mutex-unlock! local-queue-mutex) + res)) + +(define (start-scheduler) + (let loop () + (apply deliver-message (next-local-message)) + (loop))) + + +;; Network + +(define (start-network-listener) + (thread-start! + (lambda () + (let ((s (udp-open-socket*))) + (udp-bind! s #f sam-port) (let loop () - (let ((reader (next-reader))) - (##sys#thread-block-for-i/o! (current-thread) 0 #t) - (thread-yield!) - (send-message reader (read-line))) - (loop))))) - - ;; System initialization - - (define (system-beh self . message) - (match message - - (('shutdown) - (print "## System actor received shutdown message.") - (exit 0) - 'done) - - (('print strings ...) - (apply print strings) - 'sleep) - - (('read reader) - (mutex-lock! reader-queue-mutex) - (fifo-push reader-queue reader) - (mutex-unlock! reader-available-mutex) - (mutex-unlock! reader-queue-mutex) - 'sleep))) - - (define (boot-sam host port main-beh) - (set! sam-host host) - (set! sam-port port) - (start-console) - (start-network-listener) - (send-message (make-actor main-beh) (make-actor system-beh)) - (start-scheduler))) + (let-values (((n str) (udp-recv s 65536))) + (match (with-input-from-string str read) + ((address message ...) + (apply send-message (cons address message))) + (else + (print "Warning: received badly formatted message string '" str "'")))) + (loop)))))) + +;; System interface + +(define reader-queue-mutex (make-mutex "reader queue")) +(define reader-available-mutex (make-mutex "reader available")) +(mutex-lock! reader-available-mutex #f #f) +(define reader-queue (make-fifo)) + +(define (next-reader) + (let ((res #f)) + (mutex-lock! reader-available-mutex #f #f) + (mutex-lock! reader-queue-mutex) + (set! res (fifo-pop reader-queue)) + (if (not (fifo-empty? reader-queue)) + (mutex-unlock! reader-available-mutex)) + (mutex-unlock! reader-queue-mutex) + res)) + +(define (start-console) + (thread-start! + (lambda () + (let loop () + (let ((reader (next-reader))) + (##sys#thread-block-for-i/o! (current-thread) 0 #t) + (thread-yield!) + (send-message reader (read-line))) + (loop))))) + +;; System initialization + +(define (system-beh self . message) + (match message + + (('shutdown) + (print "## System actor received shutdown message.") + (exit 0) + 'done) + + (('print strings ...) + (apply print strings) + 'sleep) + + (('read reader) + (mutex-lock! reader-queue-mutex) + (fifo-push reader-queue reader) + (mutex-unlock! reader-available-mutex) + (mutex-unlock! reader-queue-mutex) + 'sleep))) + +(define (boot-sam) + (start-console) + (start-network-listener) + (send-message (make-actor main-beh) (make-actor system-beh)) + (start-scheduler)) + +(define (print-usage) + (print "Simple Actor Machine v" sam-version "\n" + "\n" + "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")) + (print-usage)) + (((or "-p" "--port") pstr rest ...) + (set! sam-port (string->number pstr)) + (loop rest)) + (((or "-n" "--hostname") hstr rest ...) + (set! sam-host hstr) + (loop rest) + (((? file-exists? filename) rest ...)) + (print* "Loading " filename "...") + (load filename) + (print " done.") + (loop rest)) + (() + (boot-sam host port main-beh)) + (else + (print "Unrecognised argument '" (car args) "'.\n") + (print-usage)))) + -- 2.20.1