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

fix Ctl-C problems in parallel `raco setup'

Browse Source 
The main problem was that when a place catches an exception,
it would continue in breaks-disabled mode. Also improve
`parallel-do' to detects additional breaks when waiting on
places and propagate them, in case a place was running something
that ate the initial break.
This commit is contained in:
Matthew Flatt 2011-10-11 15:54:22 -06:00
parent fe9e34f938
commit c74bce598b
1 changed files with 20 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/setup/parallel-do.rkt
View File

@ -288,15 +288,25 @@
;; Finish normally: ;; Finish normally:
(set! normal-finish? #t)) (set! normal-finish? #t))
(lambda () (lambda ()
(unless normal-finish? (define (break-all)
;; There was an exception, so tell workers to stop:
(for ([p workers]) (for ([p workers])
(with-handlers ([exn? log-exn]) (with-handlers ([exn? log-exn])
(wrkr/break p)))) (wrkr/break p))))
;; Wait for workers to complete: (unless normal-finish?
;; There was an exception, so tell workers to stop:
(break-all))
;; Wait for workers to complete; pass any break request on
;; to the worker places, in case they ignored an earlier
;; break for some reason:
(let loop ()
(with-handlers* ([exn:break? (lambda (exn)
(break-all)
(loop))])
(parameterize-break
#t
(for ([p workers]) (for ([p workers])
(with-handlers ([exn? log-exn]) (with-handlers ([exn:fail? log-exn])
(wrkr/wait p)))))) (wrkr/wait p)))))))))
(define list-queue% (define list-queue%
(class* object% (work-queue<%>) (class* object% (work-queue<%>)
@ -405,7 +415,9 @@
(send/resp (list 'DONE result))) (send/resp (list 'DONE result)))
(define (send/errorp message) (define (send/errorp message)
(send/resp (list 'ERROR message))) (send/resp (list 'ERROR message)))
(with-handlers ([exn:fail? (lambda (x) (send/errorp (exn-message x)) (loop (add1 i)))]) (with-handlers* ([exn:fail? (lambda (x)
(send/errorp (exn-message x))
(loop (add1 i)))])
(parameterize ([current-output-port out-str-port] (parameterize ([current-output-port out-str-port]
[current-error-port err-str-port]) [current-error-port err-str-port])
(let ([msg (pdo-recv)]) (let ([msg (pdo-recv)])