83 lines
2.9 KiB
Racket
83 lines
2.9 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/bool racket/match racket/async-channel)
|
|
|
|
(provide make-worker-thread worker-thread? worker-thread-working? worker-thread-waiting?
|
|
worker-thread-put worker-thread-try-put
|
|
worker-thread-get worker-thread-try-get
|
|
worker-thread-wait
|
|
worker-thread-send
|
|
worker-thread-kill)
|
|
|
|
(struct worker-thread (state message-channel result-channel thread) #:mutable #:transparent)
|
|
(struct values-result (value-list) #:transparent)
|
|
(struct error-result (value) #:transparent)
|
|
|
|
(define (make-worker-thread handle-message)
|
|
(define msg-ch (make-channel))
|
|
(define res-ch (make-async-channel))
|
|
(define (loop)
|
|
(with-handlers ([(λ (e) #t) (λ (e) (async-channel-put res-ch (error-result e)))])
|
|
(define msg (channel-get msg-ch))
|
|
(define res (call-with-values (λ () (handle-message msg))
|
|
(λ value-list (values-result value-list))))
|
|
(async-channel-put res-ch res))
|
|
(loop))
|
|
(worker-thread 'waiting msg-ch res-ch (thread loop)))
|
|
|
|
(define (worker-thread-working? r)
|
|
(symbol=? (worker-thread-state r) 'working))
|
|
|
|
(define (worker-thread-waiting? r)
|
|
(symbol=? (worker-thread-state r) 'waiting))
|
|
|
|
(define (worker-thread-get* r get fail-thunk)
|
|
(match-define (worker-thread state msg-ch res-ch th) r)
|
|
(case state
|
|
[(working) (define res (get res-ch))
|
|
(when res (set-worker-thread-state! r 'waiting))
|
|
(match res
|
|
[(values-result value-list) (apply values value-list)]
|
|
[(error-result value) (raise value)]
|
|
[#f (fail-thunk)])]
|
|
[(waiting) (fail-thunk)]))
|
|
|
|
(define (worker-thread-try-get r [fail-thunk (λ () #f)])
|
|
(worker-thread-get* r async-channel-try-get fail-thunk))
|
|
|
|
(define (worker-thread-get-fail)
|
|
(error 'worker-thread-get "cannot get a value from a waiting worker thread"))
|
|
|
|
(define (worker-thread-get r [fail-thunk worker-thread-get-fail])
|
|
(worker-thread-get* r async-channel-get fail-thunk))
|
|
|
|
(define (worker-thread-wait r)
|
|
(when (worker-thread-working? r) (worker-thread-get r))
|
|
(void))
|
|
|
|
(define (worker-thread-put* r msg fail-thunk)
|
|
(match-define (worker-thread state msg-ch res-ch th) r)
|
|
(case state
|
|
[(waiting) (channel-put msg-ch msg)
|
|
(set-worker-thread-state! r 'working)
|
|
#t]
|
|
[(working) (fail-thunk)]))
|
|
|
|
(define (worker-thread-try-put r msg [fail-thunk (λ () #f)])
|
|
(worker-thread-put* r msg fail-thunk))
|
|
|
|
(define (worker-thread-put-fail)
|
|
(error 'worker-thread-put "cannot send a message to a working worker thread"))
|
|
|
|
(define (worker-thread-put r msg [fail-thunk worker-thread-put-fail])
|
|
(worker-thread-put* r msg fail-thunk))
|
|
|
|
(define (worker-thread-send r msg)
|
|
(worker-thread-wait r)
|
|
(worker-thread-put r msg)
|
|
(worker-thread-get r))
|
|
|
|
(define (worker-thread-kill r)
|
|
(match-define (worker-thread state msg-ch res-ch th) r)
|
|
(kill-thread th))
|