X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Factors.scm;h=fdeccf39090d6cddb9cdbd273f3db2a616c00d5b;hp=869d4ad699a52f7b70ce5319352760dcd925c2b4;hb=cef6072905deb71f3f2277dda21a78595d295901;hpb=f3569fb835395ee0df67663bd187663102a3c985 diff --git a/8sync/actors.scm b/8sync/actors.scm index 869d4ad..fdeccf3 100644 --- a/8sync/actors.scm +++ b/8sync/actors.scm @@ -1,5 +1,5 @@ ;;; 8sync --- Asynchronous programming for Guile -;;; Copyright (C) 2016 Christopher Allan Webber +;;; Copyright © 2016, 2017 Christopher Allan Webber ;;; ;;; This file is part of 8sync. ;;; @@ -25,6 +25,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:use-module (8sync agenda) + #:use-module (8sync rmeta-slot) #:export (;; utilities... ought to go in their own module big-random-number big-random-number-string @@ -233,8 +234,9 @@ (define (<-reply original-message . message-body-args) "Reply to a message" - (send-message '() (%current-actor) (message-from original-message) '*reply* - original-message #f message-body-args)) + (when (message-needs-reply? original-message) + (send-message '() (%current-actor) (message-from original-message) '*reply* + original-message #f message-body-args))) (define (<-reply* send-options original-message . message-body-args) "Like <-reply, but allows extra parameters via send-options" @@ -243,7 +245,8 @@ (send-message send-options actor (message-from original-message) '*reply* original-message #f message-body-args)) - (apply really-send send-options)) + (when (message-needs-reply? original-message) + (apply really-send send-options))) (define (<-auto-reply actor original-message) "Auto-reply to a message. Internal use only!" @@ -252,10 +255,12 @@ (define (<-reply-wait original-message . message-body-args) "Reply to a messsage, but wait until we get a response" - (wait-maybe-handle-errors - (send-message '() (%current-actor) - (message-from original-message) '*reply* - original-message #t message-body-args))) + (if (message-needs-reply? original-message) + (wait-maybe-handle-errors + (send-message '() (%current-actor) + (message-from original-message) '*reply* + original-message #t message-body-args)) + #f)) (define (<-reply-wait* send-options original-message . message-body-args) @@ -267,7 +272,8 @@ (message-from original-message) '*reply* original-message #t message-body-args) send-options)) - (apply really-send send-options)) + (when (message-needs-reply? original-message) + (apply really-send send-options))) (define* (wait-maybe-handle-errors message #:key accept-errors @@ -289,34 +295,25 @@ raise an exception if an error." (define (actor-inheritable-message-handler actor message) (define action (message-action message)) - (define (find-message-handler return) - (for-each (lambda (this-class) - (define actions - (or (and (class-slot-definition this-class 'actions) - (class-slot-ref this-class 'actions)) - '())) - (for-each (match-lambda - ((action-name . method) - (when (eq? action-name action) - (return method)))) - actions)) - (class-precedence-list (class-of actor))) + (define method + (class-rmeta-ref (class-of actor) 'actions action + #:equals? eq? #:cache-set! hashq-set! + #:cache-ref hashq-ref)) + (unless method (throw 'action-not-found "No appropriate action handler found for actor" #:action action #:actor actor #:message message)) - (define method - (call/ec find-message-handler)) (apply method actor message (message-body message))) (define-syntax-rule (build-actions (symbol method) ...) "Construct an alist of (symbol . method), where the method is wrapped with wrap-apply to facilitate live hacking and allow the method definition to come after class definition." - (list - (cons (quote symbol) - (wrap-apply method)) ...)) + (build-rmeta-slot + (list (cons (quote symbol) + (wrap-apply method)) ...))) (define-class () ;; An address object @@ -334,8 +331,15 @@ to come after class definition." #:allocation #:each-subclass #:getter actor-message-handler) + ;; valid values are: + ;; - #t as in, send the init message, but don't wait (default) + ;; - 'wait, as in wait on the init message + ;; - #f as in don't bother to init + (should-init #:init-value #t + #:allocation #:each-subclass) + ;; This is the default, "simple" way to inherit and process messages. - (actions #:init-value (build-actions + (actions #:init-thunk (build-actions ;; Default init method is to do nothing. (*init* (const #f)) ;; Default cleanup method is to do nothing. @@ -386,7 +390,7 @@ to come after class definition." (action ...) slots ...) (define-class class inherits - (actions #:init-value (build-actions action ...) + (actions #:init-thunk (build-actions action ...) #:allocation #:each-subclass) slots ...)) @@ -420,7 +424,7 @@ to come after class definition." (prompt #:init-thunk make-prompt-tag #:getter hive-prompt) (actions #:allocation #:each-subclass - #:init-value + #:init-thunk (build-actions ;; This is in the case of an ambassador failing to forward a ;; message... it reports it back to the hive @@ -439,10 +443,14 @@ to come after class definition." (hash-map->list (lambda (actor-id actor) actor-id) (hive-actor-registry hive))) (for-each (lambda (actor-id) - ;; @@: This could maybe just be <-, but we want actors - ;; to be used to the expectation in all circumstances - ;; that their init method is "waited on". - (<-wait actor-id '*init*)) + (let* ((actor (hash-ref (hive-actor-registry hive) + actor-id))) + (match (slot-ref actor 'should-init) + (#f #f) + ('wait + (<-wait actor-id '*init*)) + (_ + (<- actor-id '*init*))))) actor-ids)) (define-method (hive-handle-failed-forward (hive ) message) @@ -679,11 +687,15 @@ that method for documentation." (actor (apply make actor-class #:hive hive #:id actor-id - init-args))) + init-args)) + (actor-should-init (slot-ref actor 'should-init))) (hive-register-actor! hive actor) - ;; Wait on actor to init - (when send-init? - (<-wait actor-id '*init*)) + ;; Maybe run actor init method + (when (and send-init? actor-should-init) + (let ((send-method + (if (eq? actor-should-init 'wait) + <-wait <-))) + (send-method actor-id '*init*))) ;; return the actor id actor-id))