syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

during/spawn

This commit is contained in:
Tony Garnock-Jones 2018-04-22 21:07:35 +01:00
parent 1523ef17cf
commit e6d6f67021
2 changed files with 126 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
syndicate/pattern.rkt
View File

@ -4,7 +4,8 @@
(struct-out capture) (struct-out capture)
(for-syntax analyse-pattern (for-syntax analyse-pattern
instantiate-pattern instantiate-pattern->pattern
instantiate-pattern->value
desc->key desc->key
desc->skeleton-proj desc->skeleton-proj
desc->skeleton-stx desc->skeleton-stx
@ -78,14 +79,14 @@
[_ [_
(list 'atom stx)])) (list 'atom stx)]))
(define (instantiate-pattern stx) (define (instantiate-pattern->pattern stx)
(syntax-case stx ($) (syntax-case stx ($)
[(ctor piece ...) [(ctor piece ...)
(struct-info? (id-value #'ctor)) (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 piece ...)
(list-id? #'list) (list-id? #'list)
(quasisyntax/loc stx (list #,@(stx-map instantiate-pattern #'(piece ...))))] (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
[id [id
(dollar-id? #'id) (dollar-id? #'id)
(undollar #'id)] (undollar #'id)]
@ -94,6 +95,25 @@
[id [id
(discard-id? #'id) (discard-id? #'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
#'other]))) #'other])))

146
syndicate/syntax.rkt
View File

@ -18,7 +18,7 @@
on-stop on-stop
on on
during during
;; during/spawn during/spawn
begin/dataflow begin/dataflow
define/dataflow define/dataflow
@ -69,6 +69,7 @@
(require racket/set) (require racket/set)
(require syndicate/dataflow) (require syndicate/dataflow)
(require syndicate/protocol/instance)
(begin-for-syntax (begin-for-syntax
(define-splicing-syntax-class actor-wrapper (define-splicing-syntax-class actor-wrapper
@ -363,53 +364,51 @@
(define-syntax (during stx) (define-syntax (during stx)
(syntax-parse stx (syntax-parse stx
[(_ P O ...) [(_ P O ...)
(define Q-stx (instantiate-pattern #'P))
(quasisyntax/loc stx (quasisyntax/loc stx
(on (asserted P) (on (asserted P)
(react (stop-when (retracted #,Q-stx)) (react (stop-when (retracted #,(instantiate-pattern->pattern #'P)))
O ...)))])) O ...)))]))
;; (define-syntax (during/spawn stx) (define-syntax (during/spawn stx)
;; (syntax-parse stx (syntax-parse stx
;; [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option
;; oncrash:on-crash-option oncrash:on-crash-option
;; O ...) O ...)
;; (define E-stx (syntax/loc #'P (asserted P))) (define Q-stx (instantiate-pattern->pattern #'P))
;; (define-values (_proj _pat _bindings instantiated) (quasisyntax/loc stx
;; (analyze-pattern E-stx #'P)) (on (asserted P)
;; (quasisyntax/loc stx (let* ((id (gensym 'during/spawn))
;; (on #,E-stx (inst (instance id #,(instantiate-pattern->value #'P)))
;; (let* ((id (gensym 'during/spawn)) ;; ^ this is the assertion representing supply
;; (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)
;; (react (stop-when (asserted inst) ;; Supply (inst) appeared before demand (p) retracted.
;; ;; Supply (inst) appeared before demand (p) retracted. ;; Transition to a state where we monitor demand, but also
;; ;; Transition to a state where we monitor demand, but also ;; express interest in supply: this latter acts as a signal
;; ;; express interest in supply: this latter acts as a signal ;; to the supply that it should stick around. We react to
;; ;; to the supply that it should stick around. We react to ;; retraction of supply before retraction of demand by
;; ;; retraction of supply before retraction of demand by ;; invoking the on-crash expression, if supplied. Once
;; ;; invoking the on-crash expression, if supplied. Once ;; demand is retracted, this facet terminates, retracting
;; ;; demand is retracted, this facet terminates, retracting ;; its interest in supply, thereby signalling to the supply
;; ;; its interest in supply, thereby signalling to the supply ;; that it is no longer wanted.
;; ;; that it is no longer wanted. (react (stop-when (retracted inst) ;; NOT OPTIONAL
;; (react (stop-when (retracted inst) ;; NOT OPTIONAL #,@(if (attribute oncrash.expr)
;; #,@(if (attribute oncrash.expr) #'(oncrash.expr)
;; #'(oncrash.expr) #'()))
;; #'())) (stop-when (retracted #,Q-stx))))
;; (stop-when (retracted p)))) (stop-when (retracted #,Q-stx)
;; (stop-when (retracted p) ;; Demand (p) retracted before supply (inst) appeared. We
;; ;; Demand (p) retracted before supply (inst) appeared. We ;; MUST wait for the supply to fully appear so that we can
;; ;; MUST wait for the supply to fully appear so that we can ;; reliably tell it to shut down. We must maintain interest
;; ;; reliably tell it to shut down. We must maintain interest ;; in supply until we see supply, and then terminate, thus
;; ;; in supply until we see supply, and then terminate, thus ;; signalling to supply that it is no longer wanted.
;; ;; signalling to supply that it is no longer wanted. (react (stop-when (asserted inst)))))
;; (react (stop-when (asserted inst))))) (let parent-let.clauses
;; (let parent-let.clauses (w.wrapper #:linkage [(assert inst)
;; (w.wrapper #:linkage [(assert inst) (stop-when (retracted (observe inst)))]
;; (stop-when (retracted (observe inst)))] #:name name.N
;; #:name name.N #:assertions [assertions.exprs ...]
;; #:assertions* assertions.P O ...)))))]))
;; O ...)))))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Queries ;; Queries
@ -614,6 +613,65 @@
) )
(lambda () (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 ;; .../racket/syndicate/examples/actor/example-partial-retraction.rkt
;; ;;
(struct ready (what) #:prefab) (struct ready (what) #:prefab)