#: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)
#:use-module (ice-9 pretty-print)
actor-id
actor-message-handler
+ %current-actor
+
;;; Commenting out the <address> type for now;
;;; it may be back when we have better serializers
;; <address>
<- <-wait <-reply <-reply-wait
- call-with-message msg-receive =>
+ call-with-message msg-receive msg-val
ez-run-hive
bootstrap-message
;;; ========
+;; @@: We may want to add a deferred-reply to the below, similar to
+;; what we had in XUDD, for actors which do their own response
+;; queueing.... ie, that might receive messages but need to shelve
+;; them to be acted upon after something else is taken care of.
+
(define-record-type <message>
(make-message-intern id to from action
body in-reply-to wants-reply
(hive #:init-keyword #:hive
#:accessor actor-hive)
;; How we receive and process new messages
- (message-handler #:allocation #:each-subclass))
+ (message-handler #:init-value (wrap-apply actor-inheritable-message-handler)
+ ;; @@: There's no reason not to use #:class instead of
+ ;; #:each-subclass anywhere in this file, except for
+ ;; Guile bug #25211 (#:class is broken in Guile 2.2)
+ #:allocation #:each-subclass)
+
+ ;; This is the default, "simple" way to inherit and process messages.
+ (actions #:init-value '()
+ #:allocation #:each-subclass))
+
+(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)))
+ (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-method (actor-message-handler (actor <actor>))
(slot-ref actor 'message-handler))
"Render the full actor id as a human-readable string"
(address->string (actor-id actor)))
+(define %current-actor
+ (make-parameter #f))
+
\f
;;; Actor utilities
(actor-id hive) '*error*
new-message-body
#:in-reply-to (message-id original-message))))
- (8sync (hive-process-message hive new-message))))
+ ;; We only return a thunk, rather than run 8sync here, because if
+ ;; we ran 8sync in the middle of a catch we'd end up with an
+ ;; unresumable continuation.
+ (lambda () (hive-process-message hive new-message))))
(define-method (hive-process-message (hive <hive>) message)
"Handle one message, or forward it via an ambassador"
actor))
(define (call-catching-coroutine thunk)
+ (define queued-error-handling-thunk #f)
(define (call-catching-errors)
;; TODO: maybe parameterize (or attach to hive) and use
;; maybe-catch-all from agenda.scm
(if (message-needs-reply? message)
;; If the message is waiting on a reply, let them know
;; something went wrong.
- (hive-reply-with-error hive message key args))
+ ;; However, we have to do it outside of this catch
+ ;; routine, or we'll end up in an unrewindable continuation
+ ;; situation.
+ (set! queued-error-handling-thunk
+ (hive-reply-with-error hive message key args)))
;; print error message
- (apply print-error-and-continue key args))))
+ (apply print-error-and-continue key args)))
+ ;; @@: This is a kludge. See above for why.
+ (if queued-error-handling-thunk
+ (8sync (queued-error-handling-thunk))))
(call-with-prompt (hive-prompt hive)
call-catching-errors
(lambda (kont actor message)
(lambda ()
(define message-handler (actor-message-handler actor))
;; @@: Should a more general error handling happen here?
- (let ((result
- (message-handler actor message)))
- (maybe-autoreply actor)
- ;; Returning result allows actors to possibly make a run-request
- ;; at the end of handling a message.
- ;; ... We do want that, right?
- result)))))
+ (parameterize ((%current-actor actor))
+ (let ((result
+ (message-handler actor message)))
+ (maybe-autoreply actor)
+ ;; Returning result allows actors to possibly make a run-request
+ ;; at the end of handling a message.
+ ;; ... We do want that, right?
+ result))))))
(define (resume-waiting-coroutine)
(cond
;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
;; @@: Or receive-msg or receieve-message or??
-(define-syntax-rule (msg-receive arglist the-message body ...)
- (call-with-message the-message
+(define-syntax-rule (msg-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 ...)))
-;; Emacs: (put '=> 'scheme-indent-function 2)
-;;; An experimental alias.
-(define-syntax-rule (=> rest ...)
- (msg-receive rest ...))
-
+(define (msg-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."
+ (call-with-message message
+ (lambda (_ val) val)))
\f
;;; Various API methods for actors to interact with the system