diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index cb6fd6e..b747d1b 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -4,7 +4,8 @@ (struct-out capture) (for-syntax analyse-pattern - instantiate-pattern + instantiate-pattern->pattern + instantiate-pattern->value desc->key desc->skeleton-proj desc->skeleton-stx @@ -78,14 +79,14 @@ [_ (list 'atom stx)])) - (define (instantiate-pattern stx) + (define (instantiate-pattern->pattern stx) (syntax-case stx ($) [(ctor piece ...) (struct-info? (id-value #'ctor)) - (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern #'(piece ...))))] + (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))] [(list piece ...) (list-id? #'list) - (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern #'(piece ...))))] + (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))] [id (dollar-id? #'id) (undollar #'id)] @@ -94,6 +95,25 @@ [id (discard-id? #'id) #'id] + [other + #'other])) + + (define (instantiate-pattern->value stx) + (syntax-case stx ($) + [(ctor piece ...) + (struct-info? (id-value #'ctor)) + (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->value #'(piece ...))))] + [(list piece ...) + (list-id? #'list) + (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))] + [id + (dollar-id? #'id) + (undollar #'id)] + [($ id p) + #'id] + [id + (discard-id? #'id) + #'(discard)] [other #'other]))) diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt index 2315b5b..4cf5efa 100644 --- a/syndicate/syntax.rkt +++ b/syndicate/syntax.rkt @@ -18,7 +18,7 @@ on-stop on during - ;; during/spawn + during/spawn begin/dataflow define/dataflow @@ -69,6 +69,7 @@ (require racket/set) (require syndicate/dataflow) +(require syndicate/protocol/instance) (begin-for-syntax (define-splicing-syntax-class actor-wrapper @@ -363,53 +364,51 @@ (define-syntax (during stx) (syntax-parse stx [(_ P O ...) - (define Q-stx (instantiate-pattern #'P)) (quasisyntax/loc stx (on (asserted P) - (react (stop-when (retracted #,Q-stx)) + (react (stop-when (retracted #,(instantiate-pattern->pattern #'P))) O ...)))])) -;; (define-syntax (during/spawn stx) -;; (syntax-parse stx -;; [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option -;; oncrash:on-crash-option -;; O ...) -;; (define E-stx (syntax/loc #'P (asserted P))) -;; (define-values (_proj _pat _bindings instantiated) -;; (analyze-pattern E-stx #'P)) -;; (quasisyntax/loc stx -;; (on #,E-stx -;; (let* ((id (gensym 'during/spawn)) -;; (p #,instantiated) ;; this is the concrete assertion corresponding to demand -;; (inst (instance id p))) ;; this is the assertion representing supply -;; (react (stop-when (asserted inst) -;; ;; Supply (inst) appeared before demand (p) retracted. -;; ;; Transition to a state where we monitor demand, but also -;; ;; express interest in supply: this latter acts as a signal -;; ;; to the supply that it should stick around. We react to -;; ;; retraction of supply before retraction of demand by -;; ;; invoking the on-crash expression, if supplied. Once -;; ;; demand is retracted, this facet terminates, retracting -;; ;; its interest in supply, thereby signalling to the supply -;; ;; that it is no longer wanted. -;; (react (stop-when (retracted inst) ;; NOT OPTIONAL -;; #,@(if (attribute oncrash.expr) -;; #'(oncrash.expr) -;; #'())) -;; (stop-when (retracted p)))) -;; (stop-when (retracted p) -;; ;; Demand (p) retracted before supply (inst) appeared. We -;; ;; MUST wait for the supply to fully appear so that we can -;; ;; reliably tell it to shut down. We must maintain interest -;; ;; in supply until we see supply, and then terminate, thus -;; ;; signalling to supply that it is no longer wanted. -;; (react (stop-when (asserted inst))))) -;; (let parent-let.clauses -;; (w.wrapper #:linkage [(assert inst) -;; (stop-when (retracted (observe inst)))] -;; #:name name.N -;; #:assertions* assertions.P -;; O ...)))))])) +(define-syntax (during/spawn stx) + (syntax-parse stx + [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option + oncrash:on-crash-option + O ...) + (define Q-stx (instantiate-pattern->pattern #'P)) + (quasisyntax/loc stx + (on (asserted P) + (let* ((id (gensym 'during/spawn)) + (inst (instance id #,(instantiate-pattern->value #'P))) + ;; ^ this is the assertion representing supply + ) + (react (stop-when (asserted inst) + ;; Supply (inst) appeared before demand (p) retracted. + ;; Transition to a state where we monitor demand, but also + ;; express interest in supply: this latter acts as a signal + ;; to the supply that it should stick around. We react to + ;; retraction of supply before retraction of demand by + ;; invoking the on-crash expression, if supplied. Once + ;; demand is retracted, this facet terminates, retracting + ;; its interest in supply, thereby signalling to the supply + ;; that it is no longer wanted. + (react (stop-when (retracted inst) ;; NOT OPTIONAL + #,@(if (attribute oncrash.expr) + #'(oncrash.expr) + #'())) + (stop-when (retracted #,Q-stx)))) + (stop-when (retracted #,Q-stx) + ;; Demand (p) retracted before supply (inst) appeared. We + ;; MUST wait for the supply to fully appear so that we can + ;; reliably tell it to shut down. We must maintain interest + ;; in supply until we see supply, and then terminate, thus + ;; signalling to supply that it is no longer wanted. + (react (stop-when (asserted inst))))) + (let parent-let.clauses + (w.wrapper #:linkage [(assert inst) + (stop-when (retracted (observe inst)))] + #:name name.N + #:assertions [assertions.exprs ...] + O ...)))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Queries @@ -614,6 +613,65 @@ ) (lambda () + (spawn #:name 'factory-1 + (on (asserted (list 'X 1)) + (spawn #:name 'service-1 + #:assertions [(observe (list 'X 1))] ;; (A) + (stop-when (retracted (list 'X 1))) ;; (B) + (on (message 'dummy))) ;; exists just to keep the service alive if + ;; there are no other endpoints + ;; spawn executes *before* teardown of this on-asserted endpoint, and thus + ;; before the patch withdrawing (observe (list 'X 1)). + (stop-current-facet))) + + (spawn (on (asserted (observe (list 'X $supplier))) + (printf "Supply ~v asserted.\n" supplier) + (assert! (list 'X supplier))) + (on (retracted (observe (list 'X $supplier))) + (printf "Supply ~v retracted.\n" supplier))) + ) + + #;(lambda () + (spawn #:name 'demand-watcher + (during/spawn 'demand + #:name (gensym 'intermediate-demand-asserter) + (assert 'intermediate-demand))) + + (spawn #:name 'intermediate-demand-watcher + (during/spawn 'intermediate-demand + #:name (gensym 'supply-asserter) + (assert 'supply))) + + (spawn* #:name 'driver + (react (on (asserted 'supply) (log-info "Supply asserted.")) + (on (retracted 'supply) (log-info "Supply retracted."))) + (until (asserted (observe 'demand))) + (log-info "Asserting demand.") + (assert! 'demand) + (until (asserted 'supply)) + (log-info "Glitching demand.") + (retract! 'demand) + (flush!) + (assert! 'demand) + (log-info "Demand now steady.")) + ) + + #;(lambda () + ;; Trivial example program to demonstrate tracing + + (assertion-struct one-plus (n m)) + + (spawn #:name 'add1-server + (during/spawn (observe (one-plus $n _)) + #:name (list 'solving 'one-plus n) + (assert (one-plus n (+ n 1))))) + + (spawn #:name 'client-process + (stop-when (asserted (one-plus 3 $value)) + (printf "1 + 3 = ~a\n" value))) + ) + + #;(lambda () ;; .../racket/syndicate/examples/actor/example-partial-retraction.rkt ;; (struct ready (what) #:prefab)