diff --git a/blocking-box.rkt b/blocking-box.rkt index 374d47c..f33e7bc 100644 --- a/blocking-box.rkt +++ b/blocking-box.rkt @@ -7,24 +7,32 @@ blocking-box-value set-blocking-box!) -(struct blocking-box (semaphore ch)) +(struct blocking-box (thread set-ch get-ch)) (define (make-blocking-box) - (blocking-box (make-semaphore 1) (make-channel))) + (define set-ch (make-channel)) + (define get-ch (make-channel)) + (blocking-box (thread/suspend-to-kill (lambda () (manager set-ch get-ch))) + set-ch + get-ch)) + +(define (manager s g) + (define v (channel-get s)) + (let loop () + (sync (handle-evt s (lambda (ignored-new-v) (loop))) + (handle-evt (channel-put-evt g v) (lambda (dummy) (loop)))))) (define (blocking-box-evt b) - ;; wrap the event to avoid exposing too much authority - (wrap-evt (blocking-box-ch b) values)) + (guard-evt + (lambda () + ;; Ensure the manager is running within our custodian: + (thread-resume (blocking-box-thread b) (current-thread)) + (blocking-box-get-ch b)))) (define (blocking-box-value b) (sync (blocking-box-evt b))) (define (set-blocking-box! b v) - (define c (blocking-box-ch b)) - (thread (lambda () - (when (semaphore-try-wait? (blocking-box-semaphore b)) - ;; We are first (and therefore only) claimant of the box. - (let loop () - (channel-put c v) - (loop))))) - (void)) + ;; Ensure the manager is running within our custodian: + (thread-resume (blocking-box-thread b) (current-thread)) + (channel-put (blocking-box-set-ch b) v))