X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=8sync%2Factors.scm;h=f9a95ceb681ef0bf99cc52205d3ed249e7abe704;hb=2e61438643691be6b1ba232459801b9745689a41;hp=2dcc310a7b24baa3cd017dd456e9a6676daf43fb;hpb=61cc590c027a28d903164e85c36b90be1dbf6159;p=8sync.git diff --git a/8sync/actors.scm b/8sync/actors.scm index 2dcc310..f9a95ce 100644 --- a/8sync/actors.scm +++ b/8sync/actors.scm @@ -19,6 +19,7 @@ (define-module (8sync actors) #:use-module (oop goops) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 control) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -58,8 +59,6 @@ actor-init! actor-cleanup! - actor-alive? - build-actions define-actor @@ -87,7 +86,9 @@ ;; Maybe the wrong place for this, or for it to be exported. ;; But it's used in websockets' server implementation at least... - live-wrap)) + live-wrap + + *debug-actor-ids*)) ;; For ids (set! *random-state* (random-state-from-platform)) @@ -158,7 +159,7 @@ ;; This is the internal, generalized message sending method. ;; Users shouldn't use it! Use the <-foo forms instead. -(define-inlinable (%<- wants-reply from-actor to action args message-id in-reply-to) +(define (%<- wants-reply from-actor to action args message-id in-reply-to) ;; Okay, we need to deal with message ids. ;; Could we get rid of them? :\ ;; It seems if we can use eq? and have messages be immutable then @@ -166,7 +167,7 @@ ;; If we need to track replies across hive boundaries we could ;; register unique ids across the ambassador barrier. (match to - (#(_ _ (? channel? channel) dead?) + (($
_ _ (? channel? channel) dead?) (let ((message (make-message message-id to (and from-actor (actor-id from-actor)) action args @@ -177,12 +178,18 @@ (put-operation channel message) (wait-operation dead?))))) ;; TODO: put remote addresses here. - (#(actor-id hive-id #f #f) + (($
actor-id hive-id #f #f) ;; Here we'd make a call to our hive... 'TODO) ;; A message sent to nobody goes nowhere. ;; TODO: Should we display a warning here, probably? - (#f #f))) + (#f #f) + ;; We shouldn't technically be passing in actors but rather their + ;; addresses, but often actors want to message themselves and + ;; this makes that slightly easier. + ((? (lambda (x) (is-a? x )) actor) + (%<- wants-reply from-actor (actor-id actor) action + args message-id in-reply-to)))) (define (<- to action . args) (define from-actor (*current-actor*)) @@ -192,16 +199,13 @@ (big-random-number-string)) #f)) -;; TODO: this should abort to the prompt, then check for errors -;; when resuming. - (define (<-wait to action . args) (define prompt (*actor-prompt*)) (when (not prompt) (error "Tried to <-wait without being in an actor's context...")) (let ((reply (abort-to-prompt prompt '<-wait to action args))) - (cond ((eq? action '*error*) + (cond ((eq? (message-action reply) '*error*) (throw 'hive-unresumable-coroutine "Won't resume coroutine; got an *error* as a reply" #:message reply)) @@ -239,10 +243,7 @@ to come after class definition." (live-wrap method)) ...))) (define-class () - ;; An address object... a vector of #(actor-id hive-id inbox-channel dead?) - ;; - inbox-channel is the receiving channel (as opposed to actor-inbox-deq) - ;; - dead? is a fibers condition variable which is set once this actor - ;; kicks the bucket + ;; An
object (id #:init-keyword #:address #:getter actor-id) @@ -283,24 +284,37 @@ to come after class definition." (define-method (actor-cleanup! (actor )) 'no-op) -;;; Addresses are vectors where the first part is the actor-id and -;;; the second part is the hive-id. This works well enough... they -;;; look decent being pretty-printed. - -(define (make-address actor-id hive-id channel dead?) - (vector actor-id hive-id channel dead?)) - -(define (address-actor-id address) - (vector-ref address 0)) - -(define (address-hive-id address) - (vector-ref address 1)) - -(define (address-channel address) - (vector-ref address 2)) - -(define (address-dead? address) - (vector-ref address 3)) +;;; Every actor has an address, which is how its identified. +;;; We also pack in some routing information. +(define-record-type
+ (make-address actor-id hive-id channel dead?) + address? + ;; Unique-to-this-actor-on-this-hive part + (actor-id address-actor-id) + ;; Unique identifier for the hive we're connected to. + ;; If we don't have a "direct" link to the other actor through + ;; a channel, we'll have to look up if our hive has a way to route + ;; to the other hive. + (hive-id address-hive-id) + ;; The receiving channel (as opposed to actor-inbox-deq) + (channel address-channel) + ;; A fibers condition variable which is set once this actor kicks + ;; the bucket + (dead? address-dead?)) + +(set-record-type-printer! +
+ (lambda (address port) + (format port "
" + (address->string address) + (if (address-channel address) + (string-append + ":local" + (if (atomic-box-ref + ((@@ (fibers conditions) condition-signalled?) + (address-dead? address))) + " :dead" "")) + ":remote")))) (define (address->string address) (string-append (address-actor-id address) "@" @@ -311,14 +325,10 @@ to come after class definition." This compares the actor-id and hive-id but ignores the channel and dead? condition." - (match address1 - (#(actor-id-1 hive-id-1 _ _) - (match address2 - (#(actor-id-2 hive-id-2) - (and (equal? actor-id-1 actor-id-2) - (and (equal? hive-id-1 hive-id-2)))) - (_ #f))) - (_ #f))) + (and (equal? (address-actor-id address1) + (address-actor-id address2)) + (equal? (address-hive-id address1) + (address-hive-id address2)))) (define (actor-id-actor actor) "Get the actor id component of the actor-id" @@ -368,10 +378,9 @@ and handling them." (lambda vals ;; Return reply if necessary (when (message-wants-reply message) - (when (message-wants-reply message) - (%<- #f actor (message-from message) '*reply* - vals ((actor-msg-id-generator actor)) - (message-id message))))))) + (%<- #f actor (message-from message) '*reply* + vals ((actor-msg-id-generator actor)) + (message-id message)))))) (const #t) (let ((err (current-error-port))) (lambda (key . args) @@ -645,14 +654,22 @@ to spawn-hive... all remaining arguments passed to run-fibers." ;; return the address address)) +;;; Whether or not to attach the class' name as a cookie by default in +;;; create-actor +(define *debug-actor-ids* + (make-parameter #t)) + (define* (create-actor actor-class #:rest init-args) "Create an instance of actor-class. Return the new actor's id. This is the method actors should call directly (unless they want to supply an id-cookie, in which case they should use create-actor*)." - (%create-actor actor-class init-args #f #t)) - + (%create-actor actor-class init-args + (if (*debug-actor-ids*) + (symbol->string (class-name actor-class)) + #f) + #t)) (define* (create-actor* actor-class id-cookie #:rest init-args) "Create an instance of actor-class. Return the new actor's id. @@ -672,14 +689,3 @@ its '*cleanup* action handler." (*actor-prompt* #f) (actor-cleanup! actor)) -;; From a patch I sent to Fibers... -(define (condition-signalled? cvar) - "Return @code{#t} if @var{cvar} has already been signalled. - -In general you will want to use @code{wait} or @code{wait-operation} to -wait on a condition. However, sometimes it is useful to see whether or -not a condition has already been signalled without blocking." - (atomic-box-ref ((@@ (fibers conditions) condition-signalled?) cvar))) - -(define (actor-alive? actor) - (condition-signalled? (address-dead? (actor-id actor))))