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-coordinate-maps (hash))
|
||||
|
||||
(define-values (proc pending-transition)
|
||||
(actor->process+transition (dataspace-actor boot-actions)))
|
||||
(define-values (proc pending-transition _initial-assertions-always-empty)
|
||||
(actor->process+transition/assertions (dataspace-actor boot-actions)))
|
||||
(define event-queue (make-queue))
|
||||
|
||||
(define target-frame-rate 60)
|
||||
|
|
|
@ -83,6 +83,7 @@
|
|||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/parse))
|
||||
(require (for-syntax syntax/srcloc))
|
||||
(require "syntax-classes.rkt")
|
||||
|
||||
(require (prefix-in core: "core.rkt"))
|
||||
(require (prefix-in core: "dataspace.rkt"))
|
||||
|
@ -272,10 +273,6 @@
|
|||
(pattern (~seq #:let 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
|
||||
(pattern (~seq #:when Pred))
|
||||
(pattern (~seq) #:attr Pred #'#t))
|
||||
|
@ -289,33 +286,53 @@
|
|||
|
||||
(define-syntax (actor-action stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name script ...)
|
||||
[(_ name:name assertions:assertions script ...)
|
||||
(quasisyntax/loc stx
|
||||
(core:make-actor
|
||||
(lambda ()
|
||||
(list actor-behavior
|
||||
(boot-actor (lambda () (begin/void-default script ...)))
|
||||
name.N))))]))
|
||||
name.N))
|
||||
assertions.P))]))
|
||||
|
||||
(define-syntax (spawn stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
|
||||
#: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) '()])
|
||||
#:name "#:linkage"))
|
||||
...
|
||||
O ...)
|
||||
(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?)
|
||||
(schedule-action! spawn-action)
|
||||
spawn-action)))]))
|
||||
|
||||
(define-syntax (spawn* stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name script ...)
|
||||
[(_ name:name assertions:assertions script ...)
|
||||
(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?)
|
||||
(schedule-action! spawn-action)
|
||||
spawn-action)))]))
|
||||
|
@ -485,7 +502,9 @@
|
|||
|
||||
(define-syntax (during/spawn 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-values (_proj _pat _bindings instantiated)
|
||||
(analyze-pattern E-stx #'P))
|
||||
|
@ -520,6 +539,7 @@
|
|||
(w.wrapper #:linkage [(assert inst)
|
||||
(stop-when (retracted (observe inst)))]
|
||||
#:name name.N
|
||||
#:assertions* assertions.P
|
||||
O ...)))))]))
|
||||
|
||||
(define-syntax (begin/dataflow stx)
|
||||
|
@ -1104,6 +1124,11 @@
|
|||
(current-pending-scripts (make-empty-pending-scripts))
|
||||
(current-action-transformer values)]
|
||||
(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)
|
||||
(run-scripts!))))
|
||||
|
||||
|
@ -1186,7 +1211,9 @@
|
|||
(struct-out endpoint)
|
||||
|
||||
suspend-script
|
||||
suspend-script*))
|
||||
suspend-script*
|
||||
|
||||
capture-actor-actions))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Script suspend-and-resume.
|
||||
|
|
|
@ -133,8 +133,8 @@
|
|||
(assert (active-window active-id))))
|
||||
|
||||
(define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...)
|
||||
(let-values (((proc initial-transition)
|
||||
(actor->process+transition (dataspace-actor boot-actions))))
|
||||
(let-values (((proc initial-transition _initial-assertions-always-empty)
|
||||
(actor->process+transition/assertions (dataspace-actor boot-actions))))
|
||||
(big-bang (interpret-actions (bb proc
|
||||
'()
|
||||
'()
|
||||
|
|
|
@ -62,7 +62,8 @@
|
|||
clean-transition
|
||||
|
||||
update-process-state
|
||||
actor->process+transition)
|
||||
boot->process+transition
|
||||
actor->process+transition/assertions)
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in racket/list flatten))
|
||||
|
@ -71,11 +72,16 @@
|
|||
(require "mux.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
|
||||
(struct message (body) #:prefab)
|
||||
|
||||
;; Actions ⊃ Events
|
||||
(struct actor (boot) #:prefab)
|
||||
(struct actor (boot initial-assertions) #:prefab)
|
||||
(struct quit-dataspace () #:prefab) ;; NB. An action. Compare (quit), a Transition.
|
||||
|
||||
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
||||
|
@ -160,14 +166,18 @@
|
|||
(define (update-process-state i new-state)
|
||||
(struct-copy process i [state new-state]))
|
||||
|
||||
(define (actor->process+transition s)
|
||||
(match-define (list beh t name) ((actor-boot s)))
|
||||
(define (boot->process+transition boot-proc)
|
||||
(match-define (list beh t name) (boot-proc))
|
||||
(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)
|
||||
(quit exn actions))
|
||||
|
||||
(define (make-actor actor-producing-thunk)
|
||||
(define (make-actor actor-producing-thunk initial-assertions)
|
||||
(actor (let ((parameterization (current-parameterization)))
|
||||
(lambda ()
|
||||
(call-with-parameterization
|
||||
|
@ -179,30 +189,24 @@
|
|||
(call-with-parameterization parameterization (lambda () (raw-beh e s))))
|
||||
txn
|
||||
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
|
||||
(syntax-rules ()
|
||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
(make-actor (lambda ()
|
||||
(define-syntax (boot-process stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name assertions:assertions behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
#'(make-actor (lambda ()
|
||||
(list behavior-exp
|
||||
(transition initial-state-exp initial-action-tree-exp)
|
||||
name-exp)))]
|
||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
(make-actor (lambda ()
|
||||
(list behavior-exp
|
||||
(transition initial-state-exp initial-action-tree-exp)
|
||||
#f)))]))
|
||||
name.N))
|
||||
assertions.P)]))
|
||||
|
||||
(define-syntax actor/stateless
|
||||
(syntax-rules ()
|
||||
[(_ #:name name-exp behavior-exp initial-action-tree-exp)
|
||||
(boot-process #:name name-exp
|
||||
(define-syntax (actor/stateless stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name assertions:assertions behavior-exp initial-action-tree-exp)
|
||||
#'(boot-process #:name name.N
|
||||
#:assertions* assertions.P
|
||||
(stateless-behavior-wrap behavior-exp)
|
||||
(void)
|
||||
initial-action-tree-exp)]
|
||||
[(_ behavior-exp initial-action-tree-exp)
|
||||
(boot-process (stateless-behavior-wrap behavior-exp)
|
||||
(void)
|
||||
initial-action-tree-exp)]))
|
||||
|
||||
|
|
|
@ -20,6 +20,11 @@
|
|||
(require "core.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
|
||||
(define missing-process (process #f #f #f))
|
||||
|
||||
|
@ -109,14 +114,11 @@
|
|||
(queue-append-list (dataspace-pending-action-queue w)
|
||||
(for/list [(a actions)] (cons label a)))]))
|
||||
|
||||
(define-syntax dataspace-actor
|
||||
(syntax-rules ()
|
||||
[(dataspace-actor #:name name-exp boot-action ...)
|
||||
(spawn-standard-relay
|
||||
(make-dataspace-actor #:name name-exp (lambda () (list boot-action ...))))]
|
||||
[(dataspace-actor boot-action ...)
|
||||
(spawn-standard-relay
|
||||
(make-dataspace-actor (lambda () (list boot-action ...))))]))
|
||||
(define-syntax (dataspace-actor stx)
|
||||
(syntax-parse stx
|
||||
[(dataspace-actor name:name boot-action ...)
|
||||
#'(spawn-standard-relay
|
||||
(make-dataspace-actor #:name name.N (lambda () (list boot-action ...))))]))
|
||||
|
||||
(define (make-dataspace boot-actions)
|
||||
(dataspace (mux)
|
||||
|
@ -128,7 +130,8 @@
|
|||
(<actor> (lambda ()
|
||||
(list dataspace-handle-event
|
||||
(transition (make-dataspace (boot-actions-thunk)) '())
|
||||
name))))
|
||||
name))
|
||||
trie-empty))
|
||||
|
||||
(define (inert? w)
|
||||
(and (queue-empty? (dataspace-pending-action-queue w))
|
||||
|
@ -156,7 +159,7 @@
|
|||
|
||||
(define ((perform-action label a) w)
|
||||
(match a
|
||||
[(<actor> boot)
|
||||
[(<actor> boot initial-assertions)
|
||||
(invoke-process (mux-next-pid (dataspace-mux w)) ;; anticipate pid allocation
|
||||
(lambda ()
|
||||
(match (boot)
|
||||
|
@ -168,7 +171,7 @@
|
|||
other)]))
|
||||
(lambda (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)
|
||||
(log-error "Spawned process in dataspace ~a died with exception:\n~a"
|
||||
(current-actor-path)
|
||||
|
@ -198,12 +201,15 @@
|
|||
[(targeted-event (cons pid remaining-path) e)
|
||||
(transition (send-event/guard label (target-event remaining-path e) pid w) '())]))
|
||||
|
||||
(define (create-process parent-label w behavior initial-transition name)
|
||||
(if (not initial-transition)
|
||||
(transition w '()) ;; Uh, ok
|
||||
(let ()
|
||||
(define (create-process parent-label w behavior initial-transition initial-assertions name)
|
||||
(define-values (postprocess initial-state initial-actions)
|
||||
(match (clean-transition initial-transition)
|
||||
[#f
|
||||
(values (lambda (w pid)
|
||||
(trace-actor-spawn parent-label pid (process name behavior (void)))
|
||||
w)
|
||||
#f
|
||||
'())]
|
||||
[(and q (<quit> exn initial-actions0))
|
||||
(values (lambda (w pid)
|
||||
(trace-actor-spawn parent-label pid (process name behavior (void)))
|
||||
|
@ -217,10 +223,7 @@
|
|||
(mark-pid-runnable w pid))
|
||||
initial-state
|
||||
initial-actions0)]))
|
||||
(define-values (initial-patch remaining-initial-actions)
|
||||
(match initial-actions
|
||||
[(cons (? patch? p) rest) (values p rest)]
|
||||
[other (values patch-empty other)]))
|
||||
(define initial-patch (patch initial-assertions trie-empty))
|
||||
(define-values (new-mux new-pid delta delta-aggregate)
|
||||
(mux-add-stream (dataspace-mux w) initial-patch))
|
||||
(let* ((w (struct-copy dataspace w
|
||||
|
@ -229,9 +232,9 @@
|
|||
(process name
|
||||
behavior
|
||||
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)
|
||||
(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-values (patches meta-action)
|
||||
|
|
|
@ -5,6 +5,11 @@
|
|||
;;
|
||||
;; Expected output:
|
||||
;; flag: 'clear
|
||||
;; flag: 'set
|
||||
;; - '(saw ping)
|
||||
;;
|
||||
;; Previously expected output:
|
||||
;; flag: 'clear
|
||||
;; - 'first
|
||||
;; flag: 'set
|
||||
;; - '(saw ping)
|
||||
|
|
|
@ -9,8 +9,8 @@
|
|||
;;
|
||||
;; Correct output:
|
||||
;; x=123 v=999
|
||||
;; finally for x=124 v=999
|
||||
;; x=124 v=999
|
||||
;; finally for x=124 v=999
|
||||
;;
|
||||
;; 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"
|
||||
;; +show
|
||||
;; +outer "second"
|
||||
;; -show
|
||||
;; -outer "first"
|
||||
;; +outer "second"
|
||||
;; +show
|
||||
;;
|
||||
;; Should eventually be turned into some kind of test case.
|
||||
|
|
|
@ -12,6 +12,15 @@
|
|||
(on (retracted (a $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))
|
||||
(allow (m 'ok2))]
|
||||
(on-start (send! (m 'ok1))
|
||||
|
@ -48,12 +57,3 @@
|
|||
(on-start (firewall [(allow ?)
|
||||
(forbid (a 'ok-parent2))]
|
||||
(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)
|
||||
(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
|
||||
(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)
|
||||
(match t
|
||||
|
|
|
@ -175,5 +175,5 @@
|
|||
;; actor -> AssertionSet
|
||||
;; Returns the final set of active assertions at groundmost level.
|
||||
(define (run-ground* s)
|
||||
(define-values (proc t) (actor->process+transition s))
|
||||
(process-transition t proc trie-empty 0))
|
||||
(define-values (proc t initial-assertions) (actor->process+transition/assertions s))
|
||||
(process-transition t proc initial-assertions 0))
|
||||
|
|
|
@ -21,6 +21,11 @@
|
|||
(require racket/match)
|
||||
(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 "../trie.rkt")
|
||||
(require (except-in "../core.rkt"
|
||||
|
@ -120,30 +125,22 @@
|
|||
[state new-underlying-state])
|
||||
monolithic-actions)])))
|
||||
|
||||
(define-syntax actor-monolithic
|
||||
(syntax-rules ()
|
||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
(make-actor (lambda ()
|
||||
(define-syntax (actor-monolithic stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name assertions:assertions behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
#'(make-actor (lambda ()
|
||||
(list (wrap-monolithic-behaviour behavior-exp)
|
||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||
(clean-actions initial-action-tree-exp))
|
||||
name-exp)))]
|
||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
(make-actor (lambda ()
|
||||
(list (wrap-monolithic-behaviour behavior-exp)
|
||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||
(clean-actions initial-action-tree-exp))
|
||||
#f)))]))
|
||||
name.N))
|
||||
assertions.P)]))
|
||||
|
||||
(define-syntax actor-monolithic/stateless
|
||||
(syntax-rules ()
|
||||
[(_ #:name name-exp behavior-exp initial-action-tree-exp)
|
||||
(actor-monolithic #:name name-exp
|
||||
(define-syntax (actor-monolithic/stateless stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:name assertions:assertions behavior-exp initial-action-tree-exp)
|
||||
#'(actor-monolithic #:name name.N
|
||||
#:assertions* assertions.P
|
||||
(stateless-behavior-wrap behavior-exp)
|
||||
(void)
|
||||
initial-action-tree-exp)]
|
||||
[(_ behavior-exp initial-action-tree-exp)
|
||||
(actor-monolithic (stateless-behavior-wrap behavior-exp)
|
||||
(void)
|
||||
initial-action-tree-exp)]))
|
||||
|
||||
|
|
|
@ -91,7 +91,8 @@
|
|||
inbound-parenthesis
|
||||
inner-spawn)
|
||||
(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?
|
||||
outbound-assertion
|
||||
outbound-parenthesis
|
||||
|
@ -103,7 +104,8 @@
|
|||
(transition-bind (inject-relay-subscription initial-relay-state)
|
||||
initial-transition)
|
||||
initial-relay-state)
|
||||
(process-name proc)))))
|
||||
(process-name proc)))
|
||||
(actor-initial-assertions inner-spawn)))
|
||||
|
||||
(define (pretty-print-relay r p)
|
||||
(fprintf p "RELAY ~a/~a\n"
|
||||
|
|
|
@ -124,10 +124,11 @@
|
|||
(on-start
|
||||
(catch-exns
|
||||
(lambda ()
|
||||
(define-values (initial-proc initial-transition)
|
||||
(actor->process+transition supervisee-spawn-action))
|
||||
(define-values (initial-proc initial-transition initial-assertions)
|
||||
(actor->process+transition/assertions supervisee-spawn-action))
|
||||
(proc initial-proc)
|
||||
(supervisee-name (process-name initial-proc))
|
||||
(patch! (patch initial-assertions trie-empty))
|
||||
initial-transition)
|
||||
handle-transition!))
|
||||
|
||||
|
|
|
@ -10,6 +10,7 @@
|
|||
|
||||
(require (except-in syndicate dataspace))
|
||||
(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/store)
|
||||
|
||||
|
@ -29,9 +30,11 @@
|
|||
#f]))
|
||||
|
||||
(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 ()
|
||||
(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 ()
|
||||
(sync (thread-dead-evt thd))
|
||||
(send-ground-message (thread-quit #f '()) #:path path)
|
||||
|
@ -39,9 +42,10 @@
|
|||
(signal-background-activity! #t)
|
||||
(list proxy-behaviour
|
||||
(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 (process-transition proc t)
|
||||
|
@ -65,7 +69,7 @@
|
|||
(signal-background-activity! #f)
|
||||
(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))
|
||||
|
||||
(define-syntax spawn/thread
|
||||
|
|
|
@ -46,10 +46,11 @@ this facility for testing.
|
|||
(define (spawn-upside-down inner-spawn)
|
||||
(make-actor (lambda ()
|
||||
(define-values (proc initial-transition)
|
||||
(actor->process+transition inner-spawn))
|
||||
(boot->process+transition (actor-boot inner-spawn)))
|
||||
(list (upside-down-behavior (process-behavior proc))
|
||||
(upside-down-transition initial-transition)
|
||||
(process-name proc)))))
|
||||
(process-name proc)))
|
||||
(actor-initial-assertions inner-spawn)))
|
||||
|
||||
;; Transition -> Transition
|
||||
(define (upside-down-transition t)
|
||||
|
|
Loading…
Reference in New Issue