Change spawn processing to include initial-assertions
This commit is contained in:
parent
f9a477832a
commit
11de40ce98
|
@ -433,8 +433,8 @@
|
||||||
(define current-touching #f)
|
(define current-touching #f)
|
||||||
(define current-coordinate-maps (hash))
|
(define current-coordinate-maps (hash))
|
||||||
|
|
||||||
(define-values (proc pending-transition)
|
(define-values (proc pending-transition _initial-assertions-always-empty)
|
||||||
(actor->process+transition (dataspace-actor boot-actions)))
|
(actor->process+transition/assertions (dataspace-actor boot-actions)))
|
||||||
(define event-queue (make-queue))
|
(define event-queue (make-queue))
|
||||||
|
|
||||||
(define target-frame-rate 60)
|
(define target-frame-rate 60)
|
||||||
|
|
|
@ -83,6 +83,7 @@
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
(require (for-syntax syntax/srcloc))
|
(require (for-syntax syntax/srcloc))
|
||||||
|
(require "syntax-classes.rkt")
|
||||||
|
|
||||||
(require (prefix-in core: "core.rkt"))
|
(require (prefix-in core: "core.rkt"))
|
||||||
(require (prefix-in core: "dataspace.rkt"))
|
(require (prefix-in core: "dataspace.rkt"))
|
||||||
|
@ -272,10 +273,6 @@
|
||||||
(pattern (~seq #:let clauses))
|
(pattern (~seq #:let clauses))
|
||||||
(pattern (~seq) #:attr clauses #'()))
|
(pattern (~seq) #:attr clauses #'()))
|
||||||
|
|
||||||
(define-splicing-syntax-class name
|
|
||||||
(pattern (~seq #:name N))
|
|
||||||
(pattern (~seq) #:attr N #'#f))
|
|
||||||
|
|
||||||
(define-splicing-syntax-class when-pred
|
(define-splicing-syntax-class when-pred
|
||||||
(pattern (~seq #:when Pred))
|
(pattern (~seq #:when Pred))
|
||||||
(pattern (~seq) #:attr Pred #'#t))
|
(pattern (~seq) #:attr Pred #'#t))
|
||||||
|
@ -289,33 +286,53 @@
|
||||||
|
|
||||||
(define-syntax (actor-action stx)
|
(define-syntax (actor-action stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ name:name script ...)
|
[(_ name:name assertions:assertions script ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(core:make-actor
|
(core:make-actor
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(list actor-behavior
|
(list actor-behavior
|
||||||
(boot-actor (lambda () (begin/void-default script ...)))
|
(boot-actor (lambda () (begin/void-default script ...)))
|
||||||
name.N))))]))
|
name.N))
|
||||||
|
assertions.P))]))
|
||||||
|
|
||||||
(define-syntax (spawn stx)
|
(define-syntax (spawn stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
|
[(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
|
||||||
#:name "#:name")
|
#:name "#:name")
|
||||||
|
(~optional (~seq #:assertions assertions-expr)
|
||||||
|
#:name "#:assertions")
|
||||||
|
(~optional (~seq #:assertions* assertions*-expr)
|
||||||
|
#:name "#:assertions*")
|
||||||
(~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()])
|
(~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()])
|
||||||
#:name "#:linkage"))
|
#:name "#:linkage"))
|
||||||
...
|
...
|
||||||
O ...)
|
O ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(let ((spawn-action (actor-action #:name name-expr (react linkage-expr ... O ...))))
|
(let ((spawn-action (actor-action
|
||||||
|
#:name name-expr
|
||||||
|
#:assertions*
|
||||||
|
#,(cond
|
||||||
|
[(attribute assertions-expr)
|
||||||
|
(when (attribute assertions*-expr)
|
||||||
|
(raise-syntax-error
|
||||||
|
'spawn
|
||||||
|
"Both #:assertions and #:assertions* supplied"
|
||||||
|
stx))
|
||||||
|
#'(pattern->trie '<initial-spawn-assertions> assertions-expr)]
|
||||||
|
[(attribute assertions*-expr)
|
||||||
|
#'assertions*-expr]
|
||||||
|
[else
|
||||||
|
#'trie-empty])
|
||||||
|
(react linkage-expr ... O ...))))
|
||||||
(if (syndicate-effects-available?)
|
(if (syndicate-effects-available?)
|
||||||
(schedule-action! spawn-action)
|
(schedule-action! spawn-action)
|
||||||
spawn-action)))]))
|
spawn-action)))]))
|
||||||
|
|
||||||
(define-syntax (spawn* stx)
|
(define-syntax (spawn* stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ name:name script ...)
|
[(_ name:name assertions:assertions script ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(let ((spawn-action (actor-action #:name name.N script ...)))
|
(let ((spawn-action (actor-action #:name name.N #:assertions* assertions.P script ...)))
|
||||||
(if (syndicate-effects-available?)
|
(if (syndicate-effects-available?)
|
||||||
(schedule-action! spawn-action)
|
(schedule-action! spawn-action)
|
||||||
spawn-action)))]))
|
spawn-action)))]))
|
||||||
|
@ -485,7 +502,9 @@
|
||||||
|
|
||||||
(define-syntax (during/spawn stx)
|
(define-syntax (during/spawn stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ P w:actor-wrapper name:name parent-let:let-option oncrash:on-crash-option O ...)
|
[(_ 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 E-stx (syntax/loc #'P (asserted P)))
|
||||||
(define-values (_proj _pat _bindings instantiated)
|
(define-values (_proj _pat _bindings instantiated)
|
||||||
(analyze-pattern E-stx #'P))
|
(analyze-pattern E-stx #'P))
|
||||||
|
@ -520,6 +539,7 @@
|
||||||
(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.P
|
||||||
O ...)))))]))
|
O ...)))))]))
|
||||||
|
|
||||||
(define-syntax (begin/dataflow stx)
|
(define-syntax (begin/dataflow stx)
|
||||||
|
@ -1104,6 +1124,11 @@
|
||||||
(current-pending-scripts (make-empty-pending-scripts))
|
(current-pending-scripts (make-empty-pending-scripts))
|
||||||
(current-action-transformer values)]
|
(current-action-transformer values)]
|
||||||
(with-current-facet '() #f
|
(with-current-facet '() #f
|
||||||
|
(schedule-action! (core:retract ?))
|
||||||
|
;; Retract any initial-assertions we might have been given. We
|
||||||
|
;; must ensure that we explicitly maintain them: retracting them
|
||||||
|
;; here prevents us from accidentally relying on their
|
||||||
|
;; persistence from our creation.
|
||||||
(schedule-script! script-proc)
|
(schedule-script! script-proc)
|
||||||
(run-scripts!))))
|
(run-scripts!))))
|
||||||
|
|
||||||
|
@ -1186,7 +1211,9 @@
|
||||||
(struct-out endpoint)
|
(struct-out endpoint)
|
||||||
|
|
||||||
suspend-script
|
suspend-script
|
||||||
suspend-script*))
|
suspend-script*
|
||||||
|
|
||||||
|
capture-actor-actions))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Script suspend-and-resume.
|
;; Script suspend-and-resume.
|
||||||
|
|
|
@ -133,8 +133,8 @@
|
||||||
(assert (active-window active-id))))
|
(assert (active-window active-id))))
|
||||||
|
|
||||||
(define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...)
|
(define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...)
|
||||||
(let-values (((proc initial-transition)
|
(let-values (((proc initial-transition _initial-assertions-always-empty)
|
||||||
(actor->process+transition (dataspace-actor boot-actions))))
|
(actor->process+transition/assertions (dataspace-actor boot-actions))))
|
||||||
(big-bang (interpret-actions (bb proc
|
(big-bang (interpret-actions (bb proc
|
||||||
'()
|
'()
|
||||||
'()
|
'()
|
||||||
|
|
|
@ -62,7 +62,8 @@
|
||||||
clean-transition
|
clean-transition
|
||||||
|
|
||||||
update-process-state
|
update-process-state
|
||||||
actor->process+transition)
|
boot->process+transition
|
||||||
|
actor->process+transition/assertions)
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require (only-in racket/list flatten))
|
(require (only-in racket/list flatten))
|
||||||
|
@ -71,11 +72,16 @@
|
||||||
(require "mux.rkt")
|
(require "mux.rkt")
|
||||||
(require "pretty.rkt")
|
(require "pretty.rkt")
|
||||||
|
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
(require (for-syntax syntax/parse))
|
||||||
|
(require (for-syntax syntax/srcloc))
|
||||||
|
(require "syntax-classes.rkt")
|
||||||
|
|
||||||
;; Events = Patches ∪ Messages
|
;; Events = Patches ∪ Messages
|
||||||
(struct message (body) #:prefab)
|
(struct message (body) #:prefab)
|
||||||
|
|
||||||
;; Actions ⊃ Events
|
;; Actions ⊃ Events
|
||||||
(struct actor (boot) #:prefab)
|
(struct actor (boot initial-assertions) #:prefab)
|
||||||
(struct quit-dataspace () #:prefab) ;; NB. An action. Compare (quit), a Transition.
|
(struct quit-dataspace () #:prefab) ;; NB. An action. Compare (quit), a Transition.
|
||||||
|
|
||||||
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
||||||
|
@ -160,14 +166,18 @@
|
||||||
(define (update-process-state i new-state)
|
(define (update-process-state i new-state)
|
||||||
(struct-copy process i [state new-state]))
|
(struct-copy process i [state new-state]))
|
||||||
|
|
||||||
(define (actor->process+transition s)
|
(define (boot->process+transition boot-proc)
|
||||||
(match-define (list beh t name) ((actor-boot s)))
|
(match-define (list beh t name) (boot-proc))
|
||||||
(values (process name beh 'undefined-initial-state) t))
|
(values (process name beh 'undefined-initial-state) t))
|
||||||
|
|
||||||
|
(define (actor->process+transition/assertions s)
|
||||||
|
(define-values (proc t) (boot->process+transition (actor-boot s)))
|
||||||
|
(values proc t (actor-initial-assertions s)))
|
||||||
|
|
||||||
(define (make-quit #:exception [exn #f] . actions)
|
(define (make-quit #:exception [exn #f] . actions)
|
||||||
(quit exn actions))
|
(quit exn actions))
|
||||||
|
|
||||||
(define (make-actor actor-producing-thunk)
|
(define (make-actor actor-producing-thunk initial-assertions)
|
||||||
(actor (let ((parameterization (current-parameterization)))
|
(actor (let ((parameterization (current-parameterization)))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(call-with-parameterization
|
(call-with-parameterization
|
||||||
|
@ -179,32 +189,26 @@
|
||||||
(call-with-parameterization parameterization (lambda () (raw-beh e s))))
|
(call-with-parameterization parameterization (lambda () (raw-beh e s))))
|
||||||
txn
|
txn
|
||||||
name)]
|
name)]
|
||||||
[other other]))))))) ;; punt on error checking to dataspace boot code
|
[other other]))))) ;; punt on error checking to dataspace boot code
|
||||||
|
initial-assertions))
|
||||||
|
|
||||||
(define-syntax boot-process
|
(define-syntax (boot-process stx)
|
||||||
(syntax-rules ()
|
(syntax-parse stx
|
||||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
[(_ name:name assertions:assertions behavior-exp initial-state-exp initial-action-tree-exp)
|
||||||
(make-actor (lambda ()
|
#'(make-actor (lambda ()
|
||||||
(list behavior-exp
|
(list behavior-exp
|
||||||
(transition initial-state-exp initial-action-tree-exp)
|
(transition initial-state-exp initial-action-tree-exp)
|
||||||
name-exp)))]
|
name.N))
|
||||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
assertions.P)]))
|
||||||
(make-actor (lambda ()
|
|
||||||
(list behavior-exp
|
|
||||||
(transition initial-state-exp initial-action-tree-exp)
|
|
||||||
#f)))]))
|
|
||||||
|
|
||||||
(define-syntax actor/stateless
|
(define-syntax (actor/stateless stx)
|
||||||
(syntax-rules ()
|
(syntax-parse stx
|
||||||
[(_ #:name name-exp behavior-exp initial-action-tree-exp)
|
[(_ name:name assertions:assertions behavior-exp initial-action-tree-exp)
|
||||||
(boot-process #:name name-exp
|
#'(boot-process #:name name.N
|
||||||
(stateless-behavior-wrap behavior-exp)
|
#:assertions* assertions.P
|
||||||
(void)
|
(stateless-behavior-wrap behavior-exp)
|
||||||
initial-action-tree-exp)]
|
(void)
|
||||||
[(_ behavior-exp initial-action-tree-exp)
|
initial-action-tree-exp)]))
|
||||||
(boot-process (stateless-behavior-wrap behavior-exp)
|
|
||||||
(void)
|
|
||||||
initial-action-tree-exp)]))
|
|
||||||
|
|
||||||
(define ((stateless-behavior-wrap b) e state)
|
(define ((stateless-behavior-wrap b) e state)
|
||||||
(match (b e)
|
(match (b e)
|
||||||
|
|
|
@ -20,6 +20,11 @@
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
(require "protocol/standard-relay.rkt")
|
(require "protocol/standard-relay.rkt")
|
||||||
|
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
(require (for-syntax syntax/parse))
|
||||||
|
(require (for-syntax syntax/srcloc))
|
||||||
|
(require "syntax-classes.rkt")
|
||||||
|
|
||||||
;; Sentinel
|
;; Sentinel
|
||||||
(define missing-process (process #f #f #f))
|
(define missing-process (process #f #f #f))
|
||||||
|
|
||||||
|
@ -109,14 +114,11 @@
|
||||||
(queue-append-list (dataspace-pending-action-queue w)
|
(queue-append-list (dataspace-pending-action-queue w)
|
||||||
(for/list [(a actions)] (cons label a)))]))
|
(for/list [(a actions)] (cons label a)))]))
|
||||||
|
|
||||||
(define-syntax dataspace-actor
|
(define-syntax (dataspace-actor stx)
|
||||||
(syntax-rules ()
|
(syntax-parse stx
|
||||||
[(dataspace-actor #:name name-exp boot-action ...)
|
[(dataspace-actor name:name boot-action ...)
|
||||||
(spawn-standard-relay
|
#'(spawn-standard-relay
|
||||||
(make-dataspace-actor #:name name-exp (lambda () (list boot-action ...))))]
|
(make-dataspace-actor #:name name.N (lambda () (list boot-action ...))))]))
|
||||||
[(dataspace-actor boot-action ...)
|
|
||||||
(spawn-standard-relay
|
|
||||||
(make-dataspace-actor (lambda () (list boot-action ...))))]))
|
|
||||||
|
|
||||||
(define (make-dataspace boot-actions)
|
(define (make-dataspace boot-actions)
|
||||||
(dataspace (mux)
|
(dataspace (mux)
|
||||||
|
@ -128,7 +130,8 @@
|
||||||
(<actor> (lambda ()
|
(<actor> (lambda ()
|
||||||
(list dataspace-handle-event
|
(list dataspace-handle-event
|
||||||
(transition (make-dataspace (boot-actions-thunk)) '())
|
(transition (make-dataspace (boot-actions-thunk)) '())
|
||||||
name))))
|
name))
|
||||||
|
trie-empty))
|
||||||
|
|
||||||
(define (inert? w)
|
(define (inert? w)
|
||||||
(and (queue-empty? (dataspace-pending-action-queue w))
|
(and (queue-empty? (dataspace-pending-action-queue w))
|
||||||
|
@ -156,7 +159,7 @@
|
||||||
|
|
||||||
(define ((perform-action label a) w)
|
(define ((perform-action label a) w)
|
||||||
(match a
|
(match a
|
||||||
[(<actor> boot)
|
[(<actor> boot initial-assertions)
|
||||||
(invoke-process (mux-next-pid (dataspace-mux w)) ;; anticipate pid allocation
|
(invoke-process (mux-next-pid (dataspace-mux w)) ;; anticipate pid allocation
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(match (boot)
|
(match (boot)
|
||||||
|
@ -168,7 +171,7 @@
|
||||||
other)]))
|
other)]))
|
||||||
(lambda (results)
|
(lambda (results)
|
||||||
(match-define (list behavior initial-transition name) results)
|
(match-define (list behavior initial-transition name) results)
|
||||||
(create-process label w behavior initial-transition name))
|
(create-process label w behavior initial-transition initial-assertions name))
|
||||||
(lambda (exn)
|
(lambda (exn)
|
||||||
(log-error "Spawned process in dataspace ~a died with exception:\n~a"
|
(log-error "Spawned process in dataspace ~a died with exception:\n~a"
|
||||||
(current-actor-path)
|
(current-actor-path)
|
||||||
|
@ -198,40 +201,40 @@
|
||||||
[(targeted-event (cons pid remaining-path) e)
|
[(targeted-event (cons pid remaining-path) e)
|
||||||
(transition (send-event/guard label (target-event remaining-path e) pid w) '())]))
|
(transition (send-event/guard label (target-event remaining-path e) pid w) '())]))
|
||||||
|
|
||||||
(define (create-process parent-label w behavior initial-transition name)
|
(define (create-process parent-label w behavior initial-transition initial-assertions name)
|
||||||
(if (not initial-transition)
|
(define-values (postprocess initial-state initial-actions)
|
||||||
(transition w '()) ;; Uh, ok
|
(match (clean-transition initial-transition)
|
||||||
(let ()
|
[#f
|
||||||
(define-values (postprocess initial-state initial-actions)
|
(values (lambda (w pid)
|
||||||
(match (clean-transition initial-transition)
|
(trace-actor-spawn parent-label pid (process name behavior (void)))
|
||||||
[(and q (<quit> exn initial-actions0))
|
w)
|
||||||
(values (lambda (w pid)
|
#f
|
||||||
(trace-actor-spawn parent-label pid (process name behavior (void)))
|
'())]
|
||||||
(trace-actor-exit pid exn)
|
[(and q (<quit> exn initial-actions0))
|
||||||
(disable-process pid exn w))
|
(values (lambda (w pid)
|
||||||
#f
|
(trace-actor-spawn parent-label pid (process name behavior (void)))
|
||||||
(append initial-actions0 (list 'quit)))]
|
(trace-actor-exit pid exn)
|
||||||
[(and t (transition initial-state initial-actions0))
|
(disable-process pid exn w))
|
||||||
(values (lambda (w pid)
|
#f
|
||||||
(trace-actor-spawn parent-label pid (process name behavior initial-state))
|
(append initial-actions0 (list 'quit)))]
|
||||||
(mark-pid-runnable w pid))
|
[(and t (transition initial-state initial-actions0))
|
||||||
initial-state
|
(values (lambda (w pid)
|
||||||
initial-actions0)]))
|
(trace-actor-spawn parent-label pid (process name behavior initial-state))
|
||||||
(define-values (initial-patch remaining-initial-actions)
|
(mark-pid-runnable w pid))
|
||||||
(match initial-actions
|
initial-state
|
||||||
[(cons (? patch? p) rest) (values p rest)]
|
initial-actions0)]))
|
||||||
[other (values patch-empty other)]))
|
(define initial-patch (patch initial-assertions trie-empty))
|
||||||
(define-values (new-mux new-pid delta delta-aggregate)
|
(define-values (new-mux new-pid delta delta-aggregate)
|
||||||
(mux-add-stream (dataspace-mux w) initial-patch))
|
(mux-add-stream (dataspace-mux w) initial-patch))
|
||||||
(let* ((w (struct-copy dataspace w
|
(let* ((w (struct-copy dataspace w
|
||||||
[process-table (hash-set (dataspace-process-table w)
|
[process-table (hash-set (dataspace-process-table w)
|
||||||
new-pid
|
new-pid
|
||||||
(process name
|
(process name
|
||||||
behavior
|
behavior
|
||||||
initial-state))]))
|
initial-state))]))
|
||||||
(w (enqueue-actions (postprocess w new-pid) new-pid remaining-initial-actions)))
|
(w (enqueue-actions (postprocess w new-pid) new-pid initial-actions)))
|
||||||
(trace-action-produced new-pid initial-patch)
|
(trace-action-produced new-pid initial-patch)
|
||||||
(deliver-patches w new-mux new-pid delta delta-aggregate)))))
|
(deliver-patches w new-mux new-pid delta delta-aggregate)))
|
||||||
|
|
||||||
(define (deliver-patches w new-mux acting-label delta delta-aggregate)
|
(define (deliver-patches w new-mux acting-label delta delta-aggregate)
|
||||||
(define-values (patches meta-action)
|
(define-values (patches meta-action)
|
||||||
|
|
|
@ -5,6 +5,11 @@
|
||||||
;;
|
;;
|
||||||
;; Expected output:
|
;; Expected output:
|
||||||
;; flag: 'clear
|
;; flag: 'clear
|
||||||
|
;; flag: 'set
|
||||||
|
;; - '(saw ping)
|
||||||
|
;;
|
||||||
|
;; Previously expected output:
|
||||||
|
;; flag: 'clear
|
||||||
;; - 'first
|
;; - 'first
|
||||||
;; flag: 'set
|
;; flag: 'set
|
||||||
;; - '(saw ping)
|
;; - '(saw ping)
|
||||||
|
|
|
@ -9,8 +9,8 @@
|
||||||
;;
|
;;
|
||||||
;; Correct output:
|
;; Correct output:
|
||||||
;; x=123 v=999
|
;; x=123 v=999
|
||||||
;; finally for x=124 v=999
|
|
||||||
;; x=124 v=999
|
;; x=124 v=999
|
||||||
|
;; finally for x=124 v=999
|
||||||
;;
|
;;
|
||||||
;; Should eventually be turned into some kind of test case.
|
;; Should eventually be turned into some kind of test case.
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,42 @@
|
||||||
|
#lang syndicate/actor
|
||||||
|
;; Demonstrates glitch preservation in during/spawn.
|
||||||
|
;;
|
||||||
|
;; Previously, `spawn` was expanded in place into the new actor's
|
||||||
|
;; initial actions. This reordering was confusing, as demonstrated
|
||||||
|
;; here: the reordering of `spawn` ahead of the retraction of previous
|
||||||
|
;; supply caused uninterrupted supply, even though demand had glitched
|
||||||
|
;; and the supply instance had been replaced.
|
||||||
|
;;
|
||||||
|
;; Buggy output:
|
||||||
|
;;
|
||||||
|
;; Asserting demand.
|
||||||
|
;; Supply asserted.
|
||||||
|
;; Glitching demand.
|
||||||
|
;; Demand now steady.
|
||||||
|
;;
|
||||||
|
;; Correct output:
|
||||||
|
;;
|
||||||
|
;; Asserting demand.
|
||||||
|
;; Supply asserted.
|
||||||
|
;; Glitching demand.
|
||||||
|
;; Demand now steady.
|
||||||
|
;; Supply retracted.
|
||||||
|
;; Supply asserted.
|
||||||
|
|
||||||
|
(spawn (during/spawn 'demand
|
||||||
|
(assert 'intermediate-demand)))
|
||||||
|
|
||||||
|
(spawn (during/spawn 'intermediate-demand
|
||||||
|
(assert 'supply)))
|
||||||
|
|
||||||
|
(spawn* (react (on (asserted 'supply) (printf "Supply asserted.\n"))
|
||||||
|
(on (retracted 'supply) (printf "Supply retracted.\n")))
|
||||||
|
(until (asserted (observe 'demand)))
|
||||||
|
(printf "Asserting demand.\n")
|
||||||
|
(assert! 'demand)
|
||||||
|
(until (asserted 'supply))
|
||||||
|
(printf "Glitching demand.\n")
|
||||||
|
(retract! 'demand)
|
||||||
|
(flush!)
|
||||||
|
(assert! 'demand)
|
||||||
|
(printf "Demand now steady.\n"))
|
|
@ -0,0 +1,63 @@
|
||||||
|
#lang syndicate/actor
|
||||||
|
;; Demonstrates responsibility transfer.
|
||||||
|
;;
|
||||||
|
;; Previously, `spawn` was expanded in place into the new actor's
|
||||||
|
;; initial actions. This reordering was confusing, as demonstrated in
|
||||||
|
;; example-responsibility-transfer-1.rkt, motivating a change in the
|
||||||
|
;; `actor` constructor to make it carry not only a boot procedure but
|
||||||
|
;; a set of initial assertions.
|
||||||
|
;;
|
||||||
|
;; Correct output:
|
||||||
|
;;
|
||||||
|
;; Supply 1 asserted.
|
||||||
|
;;
|
||||||
|
;; If only (A) is commented out:
|
||||||
|
;;
|
||||||
|
;; Supply 1 asserted.
|
||||||
|
;; Supply 1 retracted.
|
||||||
|
;; Supply 1 asserted.
|
||||||
|
;;
|
||||||
|
;; We see this because `service-1`'s initial patch takes effect
|
||||||
|
;; *after* previously queued actions -- namely, the patch from
|
||||||
|
;; `factory-1` retracting (observe (list 'X 1)). The effect of the
|
||||||
|
;; #:assertions clause is to start `service-1` off with some
|
||||||
|
;; assertions even before it has produced any actions at all.
|
||||||
|
;;
|
||||||
|
;; If only (B) is commented out:
|
||||||
|
;;
|
||||||
|
;; Supply 1 asserted.
|
||||||
|
;; Supply 1 retracted.
|
||||||
|
;;
|
||||||
|
;; We see this because even though `service-1` is given initial
|
||||||
|
;; assertions, the HLL *clears them* as part of its startup. It
|
||||||
|
;; requires the user to explicitly add endpoints for the assertions to
|
||||||
|
;; be maintained. Think of the `#:assertions` as *transient*, just for
|
||||||
|
;; the transition between the startup and normal running phases.
|
||||||
|
;;
|
||||||
|
;; If both (A) and (B) are commented out:
|
||||||
|
;;
|
||||||
|
;; Supply 1 asserted.
|
||||||
|
;; Supply 1 retracted.
|
||||||
|
;;
|
||||||
|
;; This is straightforwardly because once `factory-1`'s assertion of
|
||||||
|
;; (observe (list 'X 1)) is withdrawn, there are no instructions for
|
||||||
|
;; any other party to take it over.
|
||||||
|
|
||||||
|
(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)))
|
|
@ -14,9 +14,9 @@
|
||||||
;;
|
;;
|
||||||
;; +outer "first"
|
;; +outer "first"
|
||||||
;; +show
|
;; +show
|
||||||
|
;; +outer "second"
|
||||||
;; -show
|
;; -show
|
||||||
;; -outer "first"
|
;; -outer "first"
|
||||||
;; +outer "second"
|
|
||||||
;; +show
|
;; +show
|
||||||
;;
|
;;
|
||||||
;; Should eventually be turned into some kind of test case.
|
;; Should eventually be turned into some kind of test case.
|
||||||
|
|
|
@ -12,6 +12,15 @@
|
||||||
(on (retracted (a $v))
|
(on (retracted (a $v))
|
||||||
(printf "Retracted: ~v\n" v)))
|
(printf "Retracted: ~v\n" v)))
|
||||||
|
|
||||||
|
(firewall [(allow (observe (m 'ok1)))
|
||||||
|
(allow (observe (a 'ok1)))]
|
||||||
|
(on (asserted $x)
|
||||||
|
(printf "Observed assertion ~v\n" x))
|
||||||
|
(on (retracted $x)
|
||||||
|
(printf "Observed retraction ~v\n" x))
|
||||||
|
(on (message $x)
|
||||||
|
(printf "Observed message ~v\n" x)))
|
||||||
|
|
||||||
(firewall [(allow (m 'ok1))
|
(firewall [(allow (m 'ok1))
|
||||||
(allow (m 'ok2))]
|
(allow (m 'ok2))]
|
||||||
(on-start (send! (m 'ok1))
|
(on-start (send! (m 'ok1))
|
||||||
|
@ -48,12 +57,3 @@
|
||||||
(on-start (firewall [(allow ?)
|
(on-start (firewall [(allow ?)
|
||||||
(forbid (a 'ok-parent2))]
|
(forbid (a 'ok-parent2))]
|
||||||
(assert (a _)))))
|
(assert (a _)))))
|
||||||
|
|
||||||
(firewall [(allow (observe (m 'ok1)))
|
|
||||||
(allow (observe (a 'ok1)))]
|
|
||||||
(on (asserted $x)
|
|
||||||
(printf "Observed assertion ~v\n" x))
|
|
||||||
(on (retracted $x)
|
|
||||||
(printf "Observed retraction ~v\n" x))
|
|
||||||
(on (message $x)
|
|
||||||
(printf "Observed message ~v\n" x)))
|
|
||||||
|
|
|
@ -50,10 +50,12 @@
|
||||||
|
|
||||||
(define (spawn-firewall limit inner-spawn)
|
(define (spawn-firewall limit inner-spawn)
|
||||||
(make-actor (lambda ()
|
(make-actor (lambda ()
|
||||||
(define-values (proc initial-transition) (actor->process+transition inner-spawn))
|
(define-values (proc initial-transition)
|
||||||
|
(boot->process+transition (actor-boot inner-spawn)))
|
||||||
(list firewall-handle-event
|
(list firewall-handle-event
|
||||||
(firewall-transition initial-transition (firewall limit proc))
|
(firewall-transition initial-transition (firewall limit proc))
|
||||||
(process-name proc)))))
|
(process-name proc)))
|
||||||
|
(limit-trie limit (actor-initial-assertions inner-spawn))))
|
||||||
|
|
||||||
(define (firewall-transition t f)
|
(define (firewall-transition t f)
|
||||||
(match t
|
(match t
|
||||||
|
|
|
@ -175,5 +175,5 @@
|
||||||
;; actor -> AssertionSet
|
;; actor -> AssertionSet
|
||||||
;; Returns the final set of active assertions at groundmost level.
|
;; Returns the final set of active assertions at groundmost level.
|
||||||
(define (run-ground* s)
|
(define (run-ground* s)
|
||||||
(define-values (proc t) (actor->process+transition s))
|
(define-values (proc t initial-assertions) (actor->process+transition/assertions s))
|
||||||
(process-transition t proc trie-empty 0))
|
(process-transition t proc initial-assertions 0))
|
||||||
|
|
|
@ -21,6 +21,11 @@
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require (only-in racket/list flatten))
|
(require (only-in racket/list flatten))
|
||||||
|
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
(require (for-syntax syntax/parse))
|
||||||
|
(require (for-syntax syntax/srcloc))
|
||||||
|
(require "../syntax-classes.rkt")
|
||||||
|
|
||||||
(require "scn.rkt")
|
(require "scn.rkt")
|
||||||
(require "../trie.rkt")
|
(require "../trie.rkt")
|
||||||
(require (except-in "../core.rkt"
|
(require (except-in "../core.rkt"
|
||||||
|
@ -120,32 +125,24 @@
|
||||||
[state new-underlying-state])
|
[state new-underlying-state])
|
||||||
monolithic-actions)])))
|
monolithic-actions)])))
|
||||||
|
|
||||||
(define-syntax actor-monolithic
|
(define-syntax (actor-monolithic stx)
|
||||||
(syntax-rules ()
|
(syntax-parse stx
|
||||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
[(_ name:name assertions:assertions behavior-exp initial-state-exp initial-action-tree-exp)
|
||||||
(make-actor (lambda ()
|
#'(make-actor (lambda ()
|
||||||
(list (wrap-monolithic-behaviour behavior-exp)
|
(list (wrap-monolithic-behaviour behavior-exp)
|
||||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||||
(clean-actions initial-action-tree-exp))
|
(clean-actions initial-action-tree-exp))
|
||||||
name-exp)))]
|
name.N))
|
||||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
assertions.P)]))
|
||||||
(make-actor (lambda ()
|
|
||||||
(list (wrap-monolithic-behaviour behavior-exp)
|
|
||||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
|
||||||
(clean-actions initial-action-tree-exp))
|
|
||||||
#f)))]))
|
|
||||||
|
|
||||||
(define-syntax actor-monolithic/stateless
|
(define-syntax (actor-monolithic/stateless stx)
|
||||||
(syntax-rules ()
|
(syntax-parse stx
|
||||||
[(_ #:name name-exp behavior-exp initial-action-tree-exp)
|
[(_ name:name assertions:assertions behavior-exp initial-action-tree-exp)
|
||||||
(actor-monolithic #:name name-exp
|
#'(actor-monolithic #:name name.N
|
||||||
(stateless-behavior-wrap behavior-exp)
|
#:assertions* assertions.P
|
||||||
(void)
|
(stateless-behavior-wrap behavior-exp)
|
||||||
initial-action-tree-exp)]
|
(void)
|
||||||
[(_ behavior-exp initial-action-tree-exp)
|
initial-action-tree-exp)]))
|
||||||
(actor-monolithic (stateless-behavior-wrap behavior-exp)
|
|
||||||
(void)
|
|
||||||
initial-action-tree-exp)]))
|
|
||||||
|
|
||||||
(define ((stateless-behavior-wrap b) e state)
|
(define ((stateless-behavior-wrap b) e state)
|
||||||
(match (b e)
|
(match (b e)
|
||||||
|
|
|
@ -91,7 +91,8 @@
|
||||||
inbound-parenthesis
|
inbound-parenthesis
|
||||||
inner-spawn)
|
inner-spawn)
|
||||||
(make-actor (lambda ()
|
(make-actor (lambda ()
|
||||||
(define-values (proc initial-transition) (actor->process+transition inner-spawn))
|
(define-values (proc initial-transition)
|
||||||
|
(boot->process+transition (actor-boot inner-spawn)))
|
||||||
(define initial-relay-state (relay outbound?
|
(define initial-relay-state (relay outbound?
|
||||||
outbound-assertion
|
outbound-assertion
|
||||||
outbound-parenthesis
|
outbound-parenthesis
|
||||||
|
@ -103,7 +104,8 @@
|
||||||
(transition-bind (inject-relay-subscription initial-relay-state)
|
(transition-bind (inject-relay-subscription initial-relay-state)
|
||||||
initial-transition)
|
initial-transition)
|
||||||
initial-relay-state)
|
initial-relay-state)
|
||||||
(process-name proc)))))
|
(process-name proc)))
|
||||||
|
(actor-initial-assertions inner-spawn)))
|
||||||
|
|
||||||
(define (pretty-print-relay r p)
|
(define (pretty-print-relay r p)
|
||||||
(fprintf p "RELAY ~a/~a\n"
|
(fprintf p "RELAY ~a/~a\n"
|
||||||
|
|
|
@ -124,10 +124,11 @@
|
||||||
(on-start
|
(on-start
|
||||||
(catch-exns
|
(catch-exns
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(define-values (initial-proc initial-transition)
|
(define-values (initial-proc initial-transition initial-assertions)
|
||||||
(actor->process+transition supervisee-spawn-action))
|
(actor->process+transition/assertions supervisee-spawn-action))
|
||||||
(proc initial-proc)
|
(proc initial-proc)
|
||||||
(supervisee-name (process-name initial-proc))
|
(supervisee-name (process-name initial-proc))
|
||||||
|
(patch! (patch initial-assertions trie-empty))
|
||||||
initial-transition)
|
initial-transition)
|
||||||
handle-transition!))
|
handle-transition!))
|
||||||
|
|
||||||
|
|
|
@ -10,6 +10,7 @@
|
||||||
|
|
||||||
(require (except-in syndicate dataspace))
|
(require (except-in syndicate dataspace))
|
||||||
(require (only-in syndicate/actor spawn spawn* dataspace schedule-action!))
|
(require (only-in syndicate/actor spawn spawn* dataspace schedule-action!))
|
||||||
|
(require (only-in (submod syndicate/actor implementation-details) capture-actor-actions))
|
||||||
(require syndicate/hierarchy)
|
(require syndicate/hierarchy)
|
||||||
(require syndicate/store)
|
(require syndicate/store)
|
||||||
|
|
||||||
|
@ -29,9 +30,11 @@
|
||||||
#f]))
|
#f]))
|
||||||
|
|
||||||
(define (spawn-threaded-actor spawn-action-thunk)
|
(define (spawn-threaded-actor spawn-action-thunk)
|
||||||
|
(match-define (list (<actor> boot-proc initial-assertions))
|
||||||
|
(clean-actions (capture-actor-actions spawn-action-thunk)))
|
||||||
(make-actor (lambda ()
|
(make-actor (lambda ()
|
||||||
(define path (current-actor-path))
|
(define path (current-actor-path))
|
||||||
(define thd (thread (lambda () (run-thread path spawn-action-thunk))))
|
(define thd (thread (lambda () (run-thread path boot-proc))))
|
||||||
(thread (lambda ()
|
(thread (lambda ()
|
||||||
(sync (thread-dead-evt thd))
|
(sync (thread-dead-evt thd))
|
||||||
(send-ground-message (thread-quit #f '()) #:path path)
|
(send-ground-message (thread-quit #f '()) #:path path)
|
||||||
|
@ -39,9 +42,10 @@
|
||||||
(signal-background-activity! #t)
|
(signal-background-activity! #t)
|
||||||
(list proxy-behaviour
|
(list proxy-behaviour
|
||||||
(transition (proxy-state thd) '())
|
(transition (proxy-state thd) '())
|
||||||
'threaded-proxy))))
|
'threaded-proxy))
|
||||||
|
initial-assertions))
|
||||||
|
|
||||||
(define (run-thread actor-path spawn-action-thunk)
|
(define (run-thread actor-path boot-proc)
|
||||||
(define actor-path-rev (reverse actor-path))
|
(define actor-path-rev (reverse actor-path))
|
||||||
|
|
||||||
(define (process-transition proc t)
|
(define (process-transition proc t)
|
||||||
|
@ -65,7 +69,7 @@
|
||||||
(signal-background-activity! #f)
|
(signal-background-activity! #f)
|
||||||
(deliver-event (thread-receive) proc))
|
(deliver-event (thread-receive) proc))
|
||||||
|
|
||||||
(call-with-values (lambda () (actor->process+transition (spawn-action-thunk)))
|
(call-with-values (lambda () (boot->process+transition boot-proc))
|
||||||
process-transition))
|
process-transition))
|
||||||
|
|
||||||
(define-syntax spawn/thread
|
(define-syntax spawn/thread
|
||||||
|
|
|
@ -46,10 +46,11 @@ this facility for testing.
|
||||||
(define (spawn-upside-down inner-spawn)
|
(define (spawn-upside-down inner-spawn)
|
||||||
(make-actor (lambda ()
|
(make-actor (lambda ()
|
||||||
(define-values (proc initial-transition)
|
(define-values (proc initial-transition)
|
||||||
(actor->process+transition inner-spawn))
|
(boot->process+transition (actor-boot inner-spawn)))
|
||||||
(list (upside-down-behavior (process-behavior proc))
|
(list (upside-down-behavior (process-behavior proc))
|
||||||
(upside-down-transition initial-transition)
|
(upside-down-transition initial-transition)
|
||||||
(process-name proc)))))
|
(process-name proc)))
|
||||||
|
(actor-initial-assertions inner-spawn)))
|
||||||
|
|
||||||
;; Transition -> Transition
|
;; Transition -> Transition
|
||||||
(define (upside-down-transition t)
|
(define (upside-down-transition t)
|
||||||
|
@ -111,4 +112,4 @@ this facility for testing.
|
||||||
(define (turn-trie-rightside-up t)
|
(define (turn-trie-rightside-up t)
|
||||||
(define upside-downs (trie-project t (upside-down (?!))))
|
(define upside-downs (trie-project t (upside-down (?!))))
|
||||||
(define inbounds (trie-project t (?! (inbound ?))))
|
(define inbounds (trie-project t (?! (inbound ?))))
|
||||||
(trie-union upside-downs inbounds))
|
(trie-union upside-downs inbounds))
|
||||||
|
|
Loading…
Reference in New Issue