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

Make ground async-channel always available, rather than dynamically 

scoped to run-ground. This is important because (spawn-timer-driver),
for example, is called outside run-ground and spawns a thread that
communicates with ground via the ground async-channel. When we move to
running multiple grounds at once, we will have to revisit the
parameterization scheme here.
This commit is contained in:
Tony Garnock-Jones 2014-06-21 11:36:59 -04:00
parent ac6efba7a5
commit 90af8c3584
1 changed files with 33 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
minimart/ground.rkt
View File

@ -21,14 +21,12 @@
;; (Parameterof (Option AsyncChannel)) ;; (Parameterof (Option AsyncChannel))
;; Communication channel from auxiliary (usually driver) threads to ;; Communication channel from auxiliary (usually driver) threads to
;; the currently-active ground VM. ;; the currently-active ground VM.
(define current-ground-event-async-channel (make-parameter #f)) (define current-ground-event-async-channel (make-parameter (make-async-channel)))
;; Any -> Void ;; Any -> Void
;; Sends a (non-feedback) message at the ground-VM metalevel. ;; Sends a (non-feedback) message at the ground-VM metalevel.
(define (send-ground-message body) (define (send-ground-message body)
(match (current-ground-event-async-channel) (async-channel-put (current-ground-event-async-channel) (send body)))
[(? async-channel? ch) (async-channel-put ch (send body))]
[_ (error 'send-ground-message "Called outside dynamic scope of run-ground")]))
;; RacketEvent -> RacketEvent ;; RacketEvent -> RacketEvent
;; Wraps a CML-style Racket event with a handler that sends the event ;; Wraps a CML-style Racket event with a handler that sends the event
@ -61,35 +59,34 @@
;; Action* -> Void ;; Action* -> Void
;; Runs a ground VM, booting the outermost World with the given Actions. ;; Runs a ground VM, booting the outermost World with the given Actions.
(define (run-ground . boot-actions) (define (run-ground . boot-actions)
(parameterize ((current-ground-event-async-channel (make-async-channel))) (let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '()))
(let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '())) (define active-gestalt (process-gestalt p))
(define active-gestalt (process-gestalt p)) (define event-list (if inert?
(define event-list (if inert? active-events
active-events (cons idle-handler active-events)))
(cons idle-handler active-events))) (if (and (null? event-list) (gestalt-empty? active-gestalt))
(if (and (null? event-list) (gestalt-empty? active-gestalt)) (begin (log-info "run-ground: Terminating because inert")
(begin (log-info "run-ground: Terminating because inert") (void))
(void)) (let ((e (apply sync (current-ground-event-async-channel) event-list)))
(let ((e (apply sync (current-ground-event-async-channel) event-list))) (match (deliver-event e -2 p)
(match (deliver-event e -2 p) [#f ;; inert
[#f ;; inert (await-interrupt #t p active-events)]
(await-interrupt #t p active-events)] [(transition new-state actions)
[(transition new-state actions) (let process-actions ((actions (flatten actions)) (g active-gestalt))
(let process-actions ((actions (flatten actions)) (g active-gestalt)) (match actions
(match actions ['()
['() (await-interrupt #f
(await-interrupt #f (struct-copy process p
(struct-copy process p [gestalt g]
[gestalt g] [state new-state])
[state new-state]) (extract-active-events g))]
(extract-active-events g))] [(cons a actions)
[(cons a actions) (match a
(match a [(routing-update gestalt)
[(routing-update gestalt) (process-actions actions gestalt)]
(process-actions actions gestalt)] [(quit)
[(quit) (log-info "run-ground: Terminating by request")
(log-info "run-ground: Terminating by request") (void)]
(void)] [_
[_ (log-warning "run-ground: ignoring useless meta-action ~v" a)
(log-warning "run-ground: ignoring useless meta-action ~v" a) (process-actions actions g)])]))])))))
(process-actions actions g)])]))]))))))