;;; 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
;; There are more methods for the hive, but there's
;; no reason for the outside world to look at them maybe?
hive-id
- hive-create-actor hive-create-actor*
+ bootstrap-actor bootstrap-actor*
create-actor create-actor*
self-destruct
<- <-* <-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
;; This is the default, "simple" way to inherit and process messages.
(actions #:init-value (build-actions
+ ;; Default init method is to do nothing.
+ (*init* (const #f))
;; Default cleanup 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
;; This is in the case of an ambassador failing to forward a
;; message... it reports it back to the hive
(*failed-forward* hive-handle-failed-forward)
+ ;; These are called at start and end of run-hive
+ (*init-all* hive-handle-init-all)
(*cleanup-all* hive-handle-cleanup-all))))
+(define-method (hive-handle-init-all (hive <hive>) message)
+ "Run *init* method on all actors in registry"
+ ;; We have to do this hack and run over the list
+ ;; twice, because hash-for-each would result in an unrewindable
+ ;; continuation, and to avoid the hash-map changing during the
+ ;; middle of this.
+ (define actor-ids
+ (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*))
+ actor-ids))
+
(define-method (hive-handle-failed-forward (hive <hive>) message)
"Handle an ambassador failing to forward a message"
'TODO)
(define-method (hive-handle-cleanup-all (hive <hive>) message)
"Send a message to all actors in our registry to clean themselves up."
- ;; Unfortunately we have to do this hack and run over the list
+ ;; We have to do this hack and run over the list
;; twice, because hash-for-each would result in an unrewindable
- ;; continuation.
+ ;; continuation, and to avoid the hash-map changing during the
+ ;; middle of this.
(define actor-ids
(hash-map->list (lambda (actor-id actor) actor-id)
(hive-actor-registry hive)))
(hash-set! (hive-actor-registry hive) (actor-id actor) actor))
(define-method (%hive-create-actor (hive <hive>) actor-class
- init id-cookie)
- "Actual method called by hive-create-actor.
+ init-args id-cookie send-init?)
+ "Actual method called by bootstrap-actor / create-actor.
Since this is a define-method it can't accept fancy define* arguments,
-so this gets called from the nicer hive-create-actor interface. See
+so this gets called from the nicer bootstrap-actor interface. See
that method for documentation."
(let* ((actor-id (hive-gen-actor-id hive id-cookie))
(actor (apply make actor-class
#:hive hive
#:id actor-id
- init)))
+ init-args)))
(hive-register-actor! hive actor)
+ ;; Wait on actor to init
+ (when send-init?
+ (<-wait actor-id '*init*))
;; return the actor id
actor-id))
-(define* (hive-create-actor hive actor-class #:rest init)
- "Create an actor on HIVE using ACTOR-CLASS passing in INIT args"
+(define* (bootstrap-actor hive actor-class #:rest init-args)
+ "Create an actor on HIVE using ACTOR-CLASS passing in INIT-ARGS args"
(%hive-create-actor hive actor-class
- init (symbol->string (class-name actor-class))))
+ init-args (symbol->string (class-name actor-class))
+ #f))
-(define* (hive-create-actor* hive actor-class id-cookie #:rest init)
+(define* (bootstrap-actor* hive actor-class id-cookie #:rest init-args)
"Create an actor, but also allow customizing a 'cookie' added to the id
for debugging"
(%hive-create-actor hive actor-class
- init id-cookie))
+ init-args id-cookie
+ #f))
(define (call-with-message message proc)
"Applies message body arguments into procedure, with message as first
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."
;; TODO: move send-message and friends here...?
-(define* (create-actor from-actor actor-class #:rest init)
+(define* (create-actor from-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*)."
(%hive-create-actor (actor-hive from-actor) actor-class
- init #f))
+ init-args #f #t))
-(define* (create-actor* from-actor actor-class id-cookie #:rest init)
+(define* (create-actor* from-actor actor-class id-cookie #:rest init-args)
"Create an instance of actor-class. Return the new actor's id.
Like create-actor, but permits supplying an id-cookie."
(%hive-create-actor (actor-hive from-actor) actor-class
- init id-cookie))
+ init-args id-cookie #t))
(define* (self-destruct actor #:key (cleanup #t))
;;; =========================
(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 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