suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs & thread: detect plumber-flush errors on place exit

Browse Source
This commit is contained in:
Matthew Flatt 2019-05-01 13:46:46 -06:00
parent cfeef54a28
commit fb968db7a5
2 changed files with 21 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
racket/src/thread/place.rkt
View File

@ -54,10 +54,20 @@
(set-custodian-place! orig-cust new-place) (set-custodian-place! orig-cust new-place)
(define done-waiting (place-done-waiting new-place)) (define done-waiting (place-done-waiting new-place))
(define (default-exit v) (define (default-exit v)
(plumber-flush-all orig-plumber) (define flush-failed? #f)
(plumber-flush-all/wrap orig-plumber
;; detect whether there's an error on a flush
(lambda (proc h)
(call-with-continuation-prompt
(lambda ()
(proc h))
(default-continuation-prompt-tag)
(lambda (thunk)
(set! flush-failed? #t)
(call-with-continuation-prompt thunk)))))
(atomically (atomically
(host:mutex-acquire lock) (host:mutex-acquire lock)
(set-place-queued-result! new-place (if (byte? v) v 0)) (set-place-queued-result! new-place (if flush-failed? 1 (if (byte? v) v 0)))
(place-has-activity! new-place) (place-has-activity! new-place)
(unsafe-custodian-unregister new-place (place-custodian-ref new-place)) (unsafe-custodian-unregister new-place (place-custodian-ref new-place))
(host:mutex-release lock)) (host:mutex-release lock))
@ -98,13 +108,13 @@
(set-place-wakeup-handle! new-place (sandman-get-wakeup-handle)) (set-place-wakeup-handle! new-place (sandman-get-wakeup-handle))
(host:condition-signal started) ; place is sufficiently started (host:condition-signal started) ; place is sufficiently started
(host:mutex-release lock) (host:mutex-release lock)
(finish)) (finish)
(default-exit 0))
(default-continuation-prompt-tag) (default-continuation-prompt-tag)
(lambda (thunk) (lambda (thunk)
;; Thread ended with escape => exit with status 1 ;; Thread ended with escape => exit with status 1
(call-with-continuation-prompt thunk) (call-with-continuation-prompt thunk)
(default-exit 1))) (default-exit 1))))))
(default-exit 0))))
(lambda (result) (lambda (result)
;; Place is done, so save the result and alert anyone waiting on ;; Place is done, so save the result and alert anyone waiting on
;; the place ;; the place

8
racket/src/thread/plumber.rkt
View File

@ -5,6 +5,7 @@
make-plumber make-plumber
plumber? plumber?
plumber-flush-all plumber-flush-all
plumber-flush-all/wrap
plumber-add-flush! plumber-add-flush!
plumber-flush-handle? plumber-flush-handle?
plumber-flush-handle-remove! plumber-flush-handle-remove!
@ -39,10 +40,13 @@
(define/who (plumber-flush-all p) (define/who (plumber-flush-all p)
(check who plumber? p) (check who plumber? p)
(plumber-flush-all/wrap p (lambda (proc h) (proc h))))
(define (plumber-flush-all/wrap p app)
(for ([(h proc) (in-hash (plumber-callbacks p))]) (for ([(h proc) (in-hash (plumber-callbacks p))])
(proc h)) (app proc h))
(for ([(h proc) (in-hash (plumber-weak-callbacks p))]) (for ([(h proc) (in-hash (plumber-weak-callbacks p))])
(proc h))) (app proc h)))
(define/who (plumber-flush-handle-remove! h) (define/who (plumber-flush-handle-remove! h)
(check who plumber-flush-handle? h) (check who plumber-flush-handle? h)