X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Factors.scm;h=b651d553232742f263b511c7cf76212b0d32b9c6;hp=c694c489992abd9a99a9aca57f2afc605103e822;hb=f768ab48d6a073412021e8ce56508cdeef45a444;hpb=3d6f2e7cd2ec140db3a32c0f2a999b63b718a935 diff --git a/8sync/actors.scm b/8sync/actors.scm index c694c48..b651d55 100644 --- a/8sync/actors.scm +++ b/8sync/actors.scm @@ -165,23 +165,42 @@ ;;; See: https://web.archive.org/web/20081223021934/http://mumble.net/~jar/articles/oo-moon-weinreb.html ;;; (also worth seeing: http://mumble.net/~jar/articles/oo.html ) +;; This is the internal, generalized message sending method. +;; Users shouldn't use it! Use the <-foo forms instead. + +;; @@: Could we get rid of some of the conditional checks through +;; some macro-foo? +(define-inlinable (send-message xtra-params from-actor to-id action + replying-to-message wants-reply? + message-body-args) + (if replying-to-message + (set-message-replied! replying-to-message #t)) + (let* ((hive (actor-hive from-actor)) + (new-message + (make-message (hive-gen-message-id hive) to-id + (actor-id from-actor) action + message-body-args + #:wants-reply wants-reply? + #:in-reply-to + (if replying-to-message + (message-id replying-to-message) + #f)))) + ;; TODO: add xtra-params to both of these + (if wants-reply? + (abort-to-prompt (hive-prompt (actor-hive from-actor)) + from-actor new-message) + (8sync (hive-process-message hive new-message))))) + + (define (<- from-actor to-id action . message-body-args) "Send a message from an actor to another actor" - (let* ((hive (actor-hive from-actor)) - (message (make-message (hive-gen-message-id hive) to-id - (actor-id from-actor) action - message-body-args))) - (8sync (hive-process-message hive message)))) + (send-message '() from-actor to-id action + #f #f message-body-args)) (define (<-wait from-actor to-id action . message-body-args) "Send a message from an actor to another, but wait until we get a response" - (let* ((hive (actor-hive from-actor)) - (abort-to (hive-prompt (actor-hive from-actor))) - (message (make-message (hive-gen-message-id hive) to-id - (actor-id from-actor) action - message-body-args - #:wants-reply #t))) - (abort-to-prompt abort-to from-actor message))) + (send-message '() from-actor to-id action + #f #t message-body-args)) ;; TODO: Intelligently ~propagate(ish) errors on -wait functions. ;; We might have `send-message-wait-brazen' to allow callers to @@ -190,38 +209,18 @@ (define (<-reply from-actor original-message . message-body-args) "Reply to a message" - (set-message-replied! original-message #t) - (let* ((hive (actor-hive from-actor)) - (new-message (make-message (hive-gen-message-id hive) - (message-from original-message) - (actor-id from-actor) '*reply* - message-body-args - #:in-reply-to (message-id original-message)))) - (8sync (hive-process-message hive new-message)))) + (send-message '() from-actor (message-from original-message) '*reply* + original-message #f message-body-args)) (define (<-auto-reply from-actor original-message) "Auto-reply to a message. Internal use only!" - (set-message-replied! original-message #t) - (let* ((hive (actor-hive from-actor)) - (new-message (make-message (hive-gen-message-id hive) - (message-from original-message) - (actor-id from-actor) '*auto-reply* - '() - #:in-reply-to (message-id original-message)))) - (8sync (hive-process-message hive new-message)))) + (send-message '() from-actor (message-from original-message) '*auto-reply* + original-message #f '())) (define (<-reply-wait from-actor original-message . message-body-args) "Reply to a messsage, but wait until we get a response" - (set-message-replied! original-message #t) - (let* ((hive (actor-hive from-actor)) - (abort-to (hive-prompt (actor-hive from-actor))) - (new-message (make-message (hive-gen-message-id hive) - (message-from original-message) - (actor-id from-actor) '*reply* - message-body-args - #:wants-reply #t - #:in-reply-to (message-id original-message)))) - (abort-to-prompt abort-to from-actor new-message))) + (send-message '() from-actor (message-from original-message) '*reply* + original-message #t message-body-args)) @@ -512,45 +511,50 @@ to come after class definition." result)))))) (define (resume-waiting-coroutine) - (cond - ((or (eq? (message-action message) '*reply*) - (eq? (message-action message) '*auto-reply*)) - (call-catching-coroutine - (lambda () - (match (hash-remove! (hive-waiting-coroutines hive) - (message-in-reply-to message)) - ((_ . (resume-actor-id . kont)) - (if (not (equal? (message-to message) - resume-actor-id)) - (throw 'resuming-to-wrong-actor - "Attempted to resume a coroutine to the wrong actor!" - #:expected-actor-id (message-to message) - #:got-actor-id resume-actor-id - #:message message)) - (let (;; @@: How should we resolve resuming coroutines to actors who are - ;; now gone? - (actor (resolve-actor-to)) - (result (kont message))) - (maybe-autoreply actor) - result)) - (#f (throw 'no-waiting-coroutine - "message in-reply-to tries to resume nonexistent coroutine" - message)))))) - ;; Yikes, we must have gotten an error or something back - (else - ;; @@: Not what we want in the long run? - ;; What we'd *prefer* to do is to resume this message - ;; and throw an error inside the message handler - ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!) - (hash-remove! (hive-waiting-coroutines hive) - (message-in-reply-to message)) - (let ((explaination - (if (eq? (message-action message) '*reply*) - "Won't resume coroutine; got an *error* as a reply" - "Won't resume coroutine because action is not *reply*"))) - (throw 'hive-unresumable-coroutine - explaination - #:message message))))) + (case (message-action message) + ;; standard reply / auto-reply + ((*reply* *auto-reply*) + (call-catching-coroutine + (lambda () + (match (hash-remove! (hive-waiting-coroutines hive) + (message-in-reply-to message)) + ((_ . (resume-actor-id . kont)) + (if (not (equal? (message-to message) + resume-actor-id)) + (throw 'resuming-to-wrong-actor + "Attempted to resume a coroutine to the wrong actor!" + #:expected-actor-id (message-to message) + #:got-actor-id resume-actor-id + #:message message)) + (let (;; @@: How should we resolve resuming coroutines to actors who are + ;; now gone? + (actor (resolve-actor-to)) + (result (kont message))) + (maybe-autoreply actor) + result)) + (#f (throw 'no-waiting-coroutine + "message in-reply-to tries to resume nonexistent coroutine" + message)))))) + ;; Yikes, an error! + ((*error*) + ;; @@: Not what we want in the long run? + ;; What we'd *prefer* to do is to resume this message + ;; and throw an error inside the message handler + ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!) + (hash-remove! (hive-waiting-coroutines hive) + (message-in-reply-to message)) + (let ((explaination + (if (eq? (message-action message) '*reply*) + "Won't resume coroutine; got an *error* as a reply" + "Won't resume coroutine because action is not *reply*"))) + (throw 'hive-unresumable-coroutine + explaination #:message message))) + ;; Unhandled action for a reply! + (else + (throw 'hive-unresumable-coroutine + "Won't resume coroutine, nonsense action on reply message" + #:action (message-action message) + #:message message)))) (define (process-remote-message) ;; Find the ambassador