;;; 8sync --- Asynchronous programming for Guile
-;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of 8sync.
;;;
build-actions
- define-simple-actor
+ define-actor
<hive>
make-hive
(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"
(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!"
(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)
(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
#: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.
(*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 <address>
-;; (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!
-;; <address>
-;; (lambda (record port)
-;; (format port "<address: ~s@~s>"
-;; (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))
;;; Actor utilities
;;; ===============
-(define-syntax-rule (define-simple-actor class action ...)
- (define-class class (<actor>)
+(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 ...))
\f
;;; The Hive
(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 <hive>) message)
(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))
;;; =========================
(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
projects / 8sync.git / blobdiff