107 lines
4.1 KiB
Racket
107 lines
4.1 KiB
Racket
#lang racket/base
|
|
|
|
;; Library for engines: preemptable processes
|
|
|
|
(require racket/contract/base)
|
|
|
|
(provide
|
|
engine?
|
|
(contract-out (engine (((any/c . -> . any) . -> . any) . -> . engine?))
|
|
(engine-run ((or/c evt? real?) engine? . -> . boolean?))
|
|
(engine-result (engine? . -> . any))
|
|
(engine-kill (engine? . -> . any))))
|
|
|
|
;; An X-engine-object is
|
|
;; (make-engine-object thread semaphore channel channel X)
|
|
(define-struct engine-object (worker can-stop-lock done-ch ex-ch result)
|
|
#:mutable)
|
|
|
|
;; engine : ((bool ->) -> X) -> X-engine-object
|
|
(define (engine f)
|
|
;;(printf "2. new engine\n")
|
|
(let* ([can-stop-lock (make-semaphore 1)]
|
|
[done-ch (make-channel)]
|
|
[ex-ch (make-channel)]
|
|
[proceed-sema (make-semaphore)]
|
|
[stop-enabled? #t]
|
|
[enable-stop
|
|
(lambda (enable?)
|
|
;;(printf "3. enabling ~a\n" enable?)
|
|
(cond
|
|
[(and enable? (not stop-enabled?))
|
|
(semaphore-post can-stop-lock)
|
|
(set! stop-enabled? #t)]
|
|
[(and (not enable?) stop-enabled?)
|
|
(semaphore-wait can-stop-lock)
|
|
(set! stop-enabled? #f)])
|
|
;;(printf "3. finished enabling\n")
|
|
)]
|
|
[tid (thread (lambda ()
|
|
(semaphore-wait proceed-sema)
|
|
;;(printf "3. creating engine thread\n")
|
|
(with-handlers ([(lambda (exn) #t)
|
|
(lambda (exn)
|
|
(enable-stop #t)
|
|
(channel-put ex-ch exn))])
|
|
(let ([v (f enable-stop)])
|
|
(enable-stop #t)
|
|
(channel-put done-ch v)))))])
|
|
(begin0 (make-engine-object tid can-stop-lock done-ch ex-ch #f)
|
|
(thread-suspend tid)
|
|
(semaphore-post proceed-sema))))
|
|
|
|
;; engine : real-number X-engine-object -> bool
|
|
(define (engine-run timeout w)
|
|
(if (engine-object-worker w)
|
|
(let ([can-stop-lock (engine-object-can-stop-lock w)]
|
|
[worker (engine-object-worker w)])
|
|
#;(printf "2. starting engine\n")
|
|
(thread-resume worker)
|
|
(dynamic-wind
|
|
void
|
|
;; Let the co-routine run...
|
|
(lambda ()
|
|
(sync (choice-evt (wrap-evt (if (evt? timeout)
|
|
timeout
|
|
(alarm-evt (+ timeout (current-inexact-milliseconds))))
|
|
(lambda (x)
|
|
#;(printf "2. alarm-evt\n")
|
|
(semaphore-wait can-stop-lock)
|
|
(thread-suspend worker)
|
|
(semaphore-post can-stop-lock)
|
|
#f))
|
|
(wrap-evt (engine-object-done-ch w)
|
|
(lambda (res)
|
|
#;(printf "2. engine-done-evt\n")
|
|
(set-engine-object-result! w res)
|
|
(engine-kill w)
|
|
#t))
|
|
(wrap-evt (engine-object-ex-ch w)
|
|
(lambda (exn)
|
|
#;(printf "2. ex-evt\n")
|
|
(engine-kill w)
|
|
(raise exn))))))
|
|
;; In case we escape through a break:
|
|
(lambda ()
|
|
(when (thread-running? worker)
|
|
(semaphore-wait can-stop-lock)
|
|
(thread-suspend worker)
|
|
(semaphore-post can-stop-lock)))))
|
|
#t))
|
|
|
|
;; engine-result : X-engine-object -> X
|
|
(define (engine-result w)
|
|
(engine-object-result w))
|
|
|
|
;; engine-kill : X-engine-object ->
|
|
(define (engine-kill w)
|
|
(set-engine-object-can-stop-lock! w #f)
|
|
(set-engine-object-done-ch! w #f)
|
|
(set-engine-object-ex-ch! w #f)
|
|
(when (engine-object-worker w)
|
|
(kill-thread (engine-object-worker w))
|
|
(set-engine-object-worker! w #f)))
|
|
|
|
(define (engine? x)
|
|
(engine-object? x))
|