X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Factors.scm;h=1b120ba77916e1e3f9bd08029cfa4398218a5e66;hp=1f5bd3c1cb38c6a3c834e8a0e5ef1b04ffd2e04a;hb=d23b593a5810b38d2517a44c09d49b2835c59e16;hpb=063be529581b7004dae5ecb106bcf33729b9fef7 diff --git a/8sync/actors.scm b/8sync/actors.scm index 1f5bd3c..1b120ba 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. ;;; @@ -51,7 +51,7 @@ build-actions - define-simple-actor + define-actor make-hive @@ -73,7 +73,7 @@ <- <-* <-wait <-wait* <-reply <-reply* <-reply-wait <-reply-wait* - call-with-message msg-receive msg-val + call-with-message mbody-receive mbody-val run-hive bootstrap-message @@ -233,8 +233,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 +244,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 +254,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 +271,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 @@ -334,6 +339,13 @@ 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 ;; Default init method is to do nothing. @@ -342,22 +354,9 @@ to come after class definition." (*cleanup* (const #f))) #:allocation #:each-subclass)) -;;; So these are the nicer representations of addresses. -;;; However, they don't serialize so easily with scheme read/write, so we're -;;; using the simpler cons cell version below for now. - -;; (define-record-type
-;; (make-address actor-id hive-id) ; @@: Do we want the trailing -id? -;; address? -;; (actor-id address-actor-id) -;; (hive-id address-hive-id)) -;; -;; (set-record-type-printer! -;;
-;; (lambda (record port) -;; (format port "" -;; (address-actor-id record) (address-hive-id record)))) -;; +;;; 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) (vector actor-id hive-id)) @@ -395,10 +394,13 @@ to come after class definition." ;;; Actor utilities ;;; =============== -(define-syntax-rule (define-simple-actor class action ...) - (define-class class () +(define-syntax-rule (define-actor class inherits + (action ...) + slots ...) + (define-class class inherits (actions #:init-value (build-actions action ...) - #:allocation #:each-subclass))) + #:allocation #:each-subclass) + slots ...)) ;;; The Hive @@ -449,10 +451,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) @@ -689,11 +695,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)) @@ -715,21 +725,21 @@ for debugging" argument. Similar to call-with-values in concept." (apply proc message (message-body message))) -;; (msg-receive (<- bar baz) +;; (mbody-receive (<- bar baz) ;; (baz) ;; basil) -;; Emacs: (put 'msg-receive 'scheme-indent-function 2) +;; Emacs: (put 'mbody-receive 'scheme-indent-function 2) ;; @@: Or receive-msg or receieve-message or?? -(define-syntax-rule (msg-receive arglist message body ...) +(define-syntax-rule (mbody-receive arglist message body ...) "Call body with arglist (which can accept arguments like lambda*) applied from the message-body of message." (call-with-message message (lambda* arglist body ...))) -(define (msg-val message) +(define (mbody-val message) "Retrieve the first value from the message-body of message. Like single value return from a procedure call. Probably the most common case when waiting on a reply from some action invocation." @@ -776,17 +786,32 @@ its '*cleanup* action handler." ;;; ========================= (define* (run-hive hive initial-tasks - #:key (cleanup #t)) - "Start up an agenda and run HIVE in it with INITIAL-TASKS." + #:key (cleanup #t) + (handle-signals (list SIGINT SIGTERM))) + "Start up an agenda and run HIVE in it with INITIAL-TASKS. + +Keyword arguments: + - #:cleanup: Whether to run *cleanup* on all actors. + - #:handle-sigactions: a list of signals to set up interrupt + handlers for, so cleanup sill still happen as expected. + Defaults to a list of SIGINT and SIGTERM." (dynamic-wind (const #f) (lambda () - (let* ((queue (list->q - (cons (bootstrap-message hive (actor-id hive) '*init-all*) - initial-tasks))) - (agenda (make-agenda #:pre-unwind-handler print-error-and-continue - #:queue queue))) - (run-agenda agenda))) + (define (run-it escape) + (define (handle-signal signum) + (restore-signals) + (escape signum)) + (for-each (lambda (signum) + (sigaction signum handle-signal)) + handle-signals) + (let* ((queue (list->q + (cons (bootstrap-message hive (actor-id hive) '*init-all*) + initial-tasks))) + (agenda (make-agenda #:pre-unwind-handler print-error-and-continue + #:queue queue))) + (run-agenda agenda))) + (call/ec run-it)) ;; Run cleanup (lambda () (when cleanup