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

Change spawn processing to include initial-assertions

This commit is contained in:
Tony Garnock-Jones 2017-08-05 19:36:15 -04:00
parent f9a477832a
commit 11de40ce98
18 changed files with 291 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/syndicate-gl/2d.rkt
View File

@ -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)

49
racket/syndicate/actor.rkt
View File

@ -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.

4
racket/syndicate/big-bang.rkt
View File

@ -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
racket/syndicate/core.rkt
View File

@ -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,32 +189,26 @@
(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 ()
(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)))]))
(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.N))
assertions.P)]))
(define-syntax actor/stateless
(syntax-rules ()
[(_ #:name name-exp behavior-exp initial-action-tree-exp)
(boot-process #:name name-exp
(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)]))
(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)]))
(define ((stateless-behavior-wrap b) e state)
(match (b e)

93
racket/syndicate/dataspace.rkt
View File

@ -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,40 +201,40 @@
[(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-values (postprocess initial-state initial-actions)
(match (clean-transition initial-transition)
[(and q (<quit> exn initial-actions0))
(values (lambda (w pid)
(trace-actor-spawn parent-label pid (process name behavior (void)))
(trace-actor-exit pid exn)
(disable-process pid exn w))
#f
(append initial-actions0 (list 'quit)))]
[(and t (transition initial-state initial-actions0))
(values (lambda (w pid)
(trace-actor-spawn parent-label pid (process name behavior initial-state))
(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-values (new-mux new-pid delta delta-aggregate)
(mux-add-stream (dataspace-mux w) initial-patch))
(let* ((w (struct-copy dataspace w
[process-table (hash-set (dataspace-process-table w)
new-pid
(process name
behavior
initial-state))]))
(w (enqueue-actions (postprocess w new-pid) new-pid remaining-initial-actions)))
(trace-action-produced new-pid initial-patch)
(deliver-patches w new-mux new-pid delta delta-aggregate)))))
(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)))
(trace-actor-exit pid exn)
(disable-process pid exn w))
#f
(append initial-actions0 (list 'quit)))]
[(and t (transition initial-state initial-actions0))
(values (lambda (w pid)
(trace-actor-spawn parent-label pid (process name behavior initial-state))
(mark-pid-runnable w pid))
initial-state
initial-actions0)]))
(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
[process-table (hash-set (dataspace-process-table w)
new-pid
(process name
behavior
initial-state))]))
(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)))
(define (deliver-patches w new-mux acting-label delta delta-aggregate)
(define-values (patches meta-action)

5
racket/syndicate/examples/actor/example-action-after-suspension.rkt
View File

@ -5,6 +5,11 @@
;;
;; Expected output:
;; flag: 'clear
;; flag: 'set
;; - '(saw ping)
;;
;; Previously expected output:
;; flag: 'clear
;; - 'first
;; flag: 'set
;; - '(saw ping)

2
racket/syndicate/examples/actor/example-during-criterion-snapshotting.rkt
View File

@ -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.

42
racket/syndicate/examples/actor/example-responsibility-transfer-1.rkt Normal file
View File

@ -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"))

63
racket/syndicate/examples/actor/example-responsibility-transfer-2.rkt Normal file
View File

@ -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)))

2
racket/syndicate/examples/actor/example-synthetic-patch.rkt
View File

@ -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.

18
racket/syndicate/examples/actor/firewall-demo.rkt
View File

@ -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)))

6
racket/syndicate/firewall.rkt
View File

@ -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

4
racket/syndicate/ground.rkt
View File

@ -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))

47
racket/syndicate/monolithic/core.rkt
View File

@ -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,32 +125,24 @@
[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 ()
(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)))]))
(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.N))
assertions.P)]))
(define-syntax actor-monolithic/stateless
(syntax-rules ()
[(_ #:name name-exp behavior-exp initial-action-tree-exp)
(actor-monolithic #:name name-exp
(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)]))
(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)]))
(define ((stateless-behavior-wrap b) e state)
(match (b e)

6
racket/syndicate/relay.rkt
View File

@ -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"

5
racket/syndicate/supervise.rkt
View File

@ -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!))

12
racket/syndicate/threaded.rkt
View File

@ -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

7
racket/syndicate/upside-down.rkt
View File

@ -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)
@ -111,4 +112,4 @@ this facility for testing.
(define (turn-trie-rightside-up t)
(define upside-downs (trie-project t (upside-down (?!))))
(define inbounds (trie-project t (?! (inbound ?))))
(trie-union upside-downs inbounds))
(trie-union upside-downs inbounds))