From 90af8c358454e04fed067acd06132b42b9a9c500 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 11:36:59 -0400 Subject: [PATCH] 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. --- minimart/ground.rkt | 69 ++++++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 36 deletions(-) diff --git a/minimart/ground.rkt b/minimart/ground.rkt index b98db44..581da42 100644 --- a/minimart/ground.rkt +++ b/minimart/ground.rkt @@ -21,14 +21,12 @@ ;; (Parameterof (Option AsyncChannel)) ;; Communication channel from auxiliary (usually driver) threads to ;; 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 ;; Sends a (non-feedback) message at the ground-VM metalevel. (define (send-ground-message body) - (match (current-ground-event-async-channel) - [(? async-channel? ch) (async-channel-put ch (send body))] - [_ (error 'send-ground-message "Called outside dynamic scope of run-ground")])) + (async-channel-put (current-ground-event-async-channel) (send body))) ;; RacketEvent -> RacketEvent ;; Wraps a CML-style Racket event with a handler that sends the event @@ -61,35 +59,34 @@ ;; Action* -> Void ;; Runs a ground VM, booting the outermost World with the given 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 '())) - (define active-gestalt (process-gestalt p)) - (define event-list (if inert? - active-events - (cons idle-handler active-events))) - (if (and (null? event-list) (gestalt-empty? active-gestalt)) - (begin (log-info "run-ground: Terminating because inert") - (void)) - (let ((e (apply sync (current-ground-event-async-channel) event-list))) - (match (deliver-event e -2 p) - [#f ;; inert - (await-interrupt #t p active-events)] - [(transition new-state actions) - (let process-actions ((actions (flatten actions)) (g active-gestalt)) - (match actions - ['() - (await-interrupt #f - (struct-copy process p - [gestalt g] - [state new-state]) - (extract-active-events g))] - [(cons a actions) - (match a - [(routing-update gestalt) - (process-actions actions gestalt)] - [(quit) - (log-info "run-ground: Terminating by request") - (void)] - [_ - (log-warning "run-ground: ignoring useless meta-action ~v" a) - (process-actions actions g)])]))])))))) + (let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '())) + (define active-gestalt (process-gestalt p)) + (define event-list (if inert? + active-events + (cons idle-handler active-events))) + (if (and (null? event-list) (gestalt-empty? active-gestalt)) + (begin (log-info "run-ground: Terminating because inert") + (void)) + (let ((e (apply sync (current-ground-event-async-channel) event-list))) + (match (deliver-event e -2 p) + [#f ;; inert + (await-interrupt #t p active-events)] + [(transition new-state actions) + (let process-actions ((actions (flatten actions)) (g active-gestalt)) + (match actions + ['() + (await-interrupt #f + (struct-copy process p + [gestalt g] + [state new-state]) + (extract-active-events g))] + [(cons a actions) + (match a + [(routing-update gestalt) + (process-actions actions gestalt)] + [(quit) + (log-info "run-ground: Terminating by request") + (void)] + [_ + (log-warning "run-ground: ignoring useless meta-action ~v" a) + (process-actions actions g)])]))])))))