From f24d784945aa108bc579ce5bd777dc17361bcb6f Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Thu, 5 Sep 2019 16:37:06 +0200 Subject: [PATCH] Actors is now a module. --- actors.scm | 214 ++++++++++++++++++++++------------------- testing_counter.scm | 2 +- testing_factorial1.scm | 4 +- testing_factorial2.scm | 2 +- testing_factorial3.scm | 2 +- 5 files changed, 119 insertions(+), 105 deletions(-) diff --git a/actors.scm b/actors.scm index 263acdc..884920d 100644 --- a/actors.scm +++ b/actors.scm @@ -1,128 +1,142 @@ -(import srfi-69 matchable) +(module actors + (make-actor + make-actor-with-address + send-message + run + send-and-run + trace-enabled) + + (import scheme + (chicken base) + srfi-69 + matchable) + + (define trace-enabled #f) ;used for debugging -(define trace-enabled #f) ;;; ;;; Actor creation ;;; -(define actor-table (make-hash-table)) + (define actor-table (make-hash-table)) -(define (make-actor-with-address address behaviour) - (if trace-enabled - (print "Making actor with address " address)) - (hash-table-set! actor-table address behaviour) - address) + (define (make-actor-with-address address behaviour) + (if trace-enabled + (print "Making actor with address " address)) + (hash-table-set! actor-table address behaviour) + address) -(define next-actor-address 1) + (define next-actor-address 1) -(define (make-actor behaviour) - (make-actor-with-address next-actor-address behaviour) - (let ((address next-actor-address)) - (set! next-actor-address (+ next-actor-address 1)) - address)) + (define (make-actor behaviour) + (make-actor-with-address next-actor-address behaviour) + (let ((address next-actor-address)) + (set! next-actor-address (+ next-actor-address 1)) + address)) + ;;; ;;; Message dispatch ;;; -(define (dispatch-message address message) - (if trace-enabled - (print "Dispatching message " message " to " address)) - (let ((behaviour (hash-table-ref/default actor-table address '()))) - (if (null? behaviour) - (print "Warning: discarded message " message " to unknown actor " address) - (let ((value (apply behaviour (cons address message)))) - (case value - ((sleep) 'do-nothing) - ((done) - (if trace-enabled - (print "Deleting actor " address)) - (hash-table-delete! actor-table address)) - (else - (if trace-enabled - (print "Updating behaviour of " address)) - (hash-table-set! actor-table address value))))))) + (define (dispatch-message address message) + (if trace-enabled + (print "Dispatching message " message " to " address)) + (let ((behaviour (hash-table-ref/default actor-table address '()))) + (if (null? behaviour) + (print "Warning: discarded message " message " to unknown actor " address) + (let ((value (apply behaviour (cons address message)))) + (case value + ((sleep) 'do-nothing) + ((done) + (if trace-enabled + (print "Deleting actor " address)) + (hash-table-delete! actor-table address)) + (else + (if trace-enabled + (print "Updating behaviour of " address)) + (hash-table-set! actor-table address value))))))) + ;;; ;;; FIFO queue implementation ;;; -(define (make-fifo) - (define (cell val prev next) - (list val prev next)) - (define cell-val car) - (define cell-prev cadr) - (define cell-next caddr) - (define (set-cell-prev! cell prev-cell) - (set-car! (cdr cell) prev-cell)) - (define (set-cell-next! cell next-cell) - (set-car! (cddr cell) next-cell)) - - (let ((head '()) - (tail '())) - (lambda (cmd . args) - (case cmd - ((empty?) (null? head)) - ((push) (if (not (= (length args) 1)) - (error "Wrong number of arguments to push.") - (if (not (null? head)) - (let ((old-head head)) - (set! head (cell (car args) '() old-head)) - (set-cell-prev! old-head head)) - (begin - ;; Initialize list - (set! head (cell (car args) '() '())) - (set! tail head))))) - ((pop) (if (not (= (length args) 0)) - (error "Wrong number of arguments to pop.") - (if (null? head) - (error "FIFO empty.") - (let ((old-tail tail)) - (set! tail (cell-prev old-tail)) - (if (null? tail) - (set! head '()) - (set-cell-next! tail '())) - (cell-val old-tail))))))))) - -(define (fifo-push fifo x) - (fifo 'push x)) - -(define (fifo-pop fifo) - (fifo 'pop)) - -(define (fifo-empty? fifo) - (fifo 'empty?)) + (define (make-fifo) + (define (cell val prev next) + (list val prev next)) + (define cell-val car) + (define cell-prev cadr) + (define cell-next caddr) + (define (set-cell-prev! cell prev-cell) + (set-car! (cdr cell) prev-cell)) + (define (set-cell-next! cell next-cell) + (set-car! (cddr cell) next-cell)) + + (let ((head '()) + (tail '())) + (lambda (cmd . args) + (case cmd + ((empty?) (null? head)) + ((push) (if (not (= (length args) 1)) + (error "Wrong number of arguments to push.") + (if (not (null? head)) + (let ((old-head head)) + (set! head (cell (car args) '() old-head)) + (set-cell-prev! old-head head)) + (begin + ;; Initialize list + (set! head (cell (car args) '() '())) + (set! tail head))))) + ((pop) (if (not (= (length args) 0)) + (error "Wrong number of arguments to pop.") + (if (null? head) + (error "FIFO empty.") + (let ((old-tail tail)) + (set! tail (cell-prev old-tail)) + (if (null? tail) + (set! head '()) + (set-cell-next! tail '())) + (cell-val old-tail))))))))) + + (define (fifo-push fifo x) + (fifo 'push x)) + + (define (fifo-pop fifo) + (fifo 'pop)) + + (define (fifo-empty? fifo) + (fifo 'empty?)) ;;; ;;; Message queue ;;; -(define message-queue (make-fifo)) - -(define (next-addressed-msg) - (if (fifo-empty? message-queue) - '() - (fifo-pop message-queue))) + (define message-queue (make-fifo)) -(define (send-message actor . message) - (if trace-enabled - (print "Queued message " message " to " actor)) - (fifo-push message-queue (cons actor message))) - -(define (process-next-message) - (let ((addressed-msg (next-addressed-msg))) - (if (null? addressed-msg) + (define (next-addressed-msg) + (if (fifo-empty? message-queue) '() - (let ((address (car addressed-msg)) - (message (cdr addressed-msg))) - (dispatch-message address message))))) - -(define (run) - (unless (null? (process-next-message)) + (fifo-pop message-queue))) + + (define (send-message actor . message) + (if trace-enabled + (print "Queued message " message " to " actor)) + (fifo-push message-queue (cons actor message))) + + (define (process-next-message) + (let ((addressed-msg (next-addressed-msg))) + (if (null? addressed-msg) + '() + (let ((address (car addressed-msg)) + (message (cdr addressed-msg))) + (dispatch-message address message))))) + + (define (run) + (unless (null? (process-next-message)) + (run))) + + (define (send-and-run actor . message) + (apply send-message (cons actor message)) (run))) - -(define (send-and-run actor . message) - (apply send-message (cons actor message)) - (run)) diff --git a/testing_counter.scm b/testing_counter.scm index 55a0812..0b25876 100644 --- a/testing_counter.scm +++ b/testing_counter.scm @@ -1,4 +1,4 @@ -(load "actors.scm") +(import actors) (define trace-enabled #t) diff --git a/testing_factorial1.scm b/testing_factorial1.scm index 6600661..188dc32 100644 --- a/testing_factorial1.scm +++ b/testing_factorial1.scm @@ -1,4 +1,4 @@ -(load "actors.scm") +(import actors) (define trace-enabled #t) @@ -17,5 +17,5 @@ 'sleep))) (send-message factorial println 5) -(send-message factorial println 7) +;;(send-message factorial println 7) (run) diff --git a/testing_factorial2.scm b/testing_factorial2.scm index 363b61b..bba678e 100644 --- a/testing_factorial2.scm +++ b/testing_factorial2.scm @@ -1,4 +1,4 @@ -(load "actors.scm") +(import actors) (define trace-enabled #t) diff --git a/testing_factorial3.scm b/testing_factorial3.scm index 1cb9dd9..29d3f85 100644 --- a/testing_factorial3.scm +++ b/testing_factorial3.scm @@ -1,4 +1,4 @@ -(load "actors.scm") +(import actors) (define trace-enabled #t) -- 2.20.1