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

Add #:linkage for during/actor and the new supervise/actor to communicate properly

This commit is contained in:
Tony Garnock-Jones 2016-12-07 09:47:39 +13:00
parent f440911e7f
commit d9905df4e5
2 changed files with 34 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
racket/syndicate/actor.rkt
View File

@ -289,9 +289,14 @@
(define-syntax (actor stx) (define-syntax (actor stx)
(syntax-parse stx (syntax-parse stx
[(_ name:name O ...) [(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
#:name "#:name")
(~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()])
#:name "#:linkage"))
...
O ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(let ((spawn-action (actor-action #:name name.N (react O ...)))) (let ((spawn-action (actor-action #:name name-expr (react linkage-expr ... O ...))))
(if (syndicate-effects-available?) (if (syndicate-effects-available?)
(schedule-action! spawn-action) (schedule-action! spawn-action)
spawn-action)))])) spawn-action)))]))
@ -477,9 +482,9 @@
;; 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 #:name name.N (w.wrapper #:linkage [(assert inst)
(assert inst) (stop-when (retracted (observe inst)))]
(stop-when (retracted (observe inst))) #:name name.N
O ...)))))])) O ...)))))]))
(define-syntax (begin/dataflow stx) (define-syntax (begin/dataflow stx)

31
racket/syndicate/supervise.rkt
View File

@ -2,7 +2,8 @@
;; Extremely simple single-actor supervision ;; Extremely simple single-actor supervision
;; Vastly simplified compared to the available options in OTP ;; Vastly simplified compared to the available options in OTP
(provide supervise) (provide supervise
supervise/actor)
(require racket/exn) (require racket/exn)
(require "core.rkt") (require "core.rkt")
@ -19,23 +20,39 @@
(syntax-parse stx (syntax-parse stx
[(_ name:actor-name expr ...) [(_ name:actor-name expr ...)
(syntax/loc stx (syntax/loc stx
(supervise* (lambda () name.N) (lambda () expr ...)))])) (supervise* (lambda () name.N)
void
(lambda () expr ...)))]))
(define (supervise* supervisor-name-thunk actor-producing-thunk) (define-syntax (supervise/actor stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
#:name "#:name")
(~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()])
#:name "#:linkage"))
...
O ...)
(syntax/loc stx
(supervise* (lambda () name-expr)
(lambda () linkage-expr ... (void))
(lambda () (actor O ...))))]))
(define (supervise* supervisor-name-thunk linkage-thunk actor-producing-thunk)
;; Awkward: the name applies to any and all potential supervisors ;; Awkward: the name applies to any and all potential supervisors
;; produced by actor spawns in actor-producing-thunk. ;; produced by actor spawns in actor-producing-thunk.
(with-store [(current-action-transformer (with-store [(current-action-transformer
(supervise-spawn supervisor-name-thunk (current-action-transformer)))] (supervise-spawn supervisor-name-thunk linkage-thunk (current-action-transformer)))]
(actor-producing-thunk))) (actor-producing-thunk)))
(define ((supervise-spawn supervisor-name-thunk previous-action-transformer) ac) (define ((supervise-spawn supervisor-name-thunk linkage-thunk previous-action-transformer) ac)
(match (previous-action-transformer ac) (match (previous-action-transformer ac)
[(? spawn? s) (supervise** (or (supervisor-name-thunk) (gensym 'supervisor)) s)] [(? spawn? s) (supervise** (or (supervisor-name-thunk) (gensym 'supervisor)) linkage-thunk s)]
[other other])) [other other]))
(define (supervise** supervisor-name supervisee-spawn-action) (define (supervise** supervisor-name linkage-thunk supervisee-spawn-action)
(actor-action #:name supervisor-name (actor-action #:name supervisor-name
(react (react
(linkage-thunk) ;; may contain e.g. linkage instructions from during/actor
(field [done? #f]) (field [done? #f])
(stop-when (rising-edge (done?))) (stop-when (rising-edge (done?)))