Make FLUSH-ALL-PORTS blocking so FORK will do something more sensible.
Previously, (begin (display "ha!") (newline) (fork (lambda () 'foo))) would print "ha!" twice because FLUSH-ALL-PORTS would not finish before the actual FORK.
This commit is contained in:
parent
9a06464234
commit
380fee6612
|
@ -545,9 +545,30 @@
|
|||
(cond ((null? thunks)
|
||||
#f)
|
||||
(else
|
||||
(for-each (structure-ref threads spawn) thunks)
|
||||
(let loop ((threads
|
||||
(map spawn-thread thunks))
|
||||
(new-threads '()))
|
||||
(cond
|
||||
((not (null? threads))
|
||||
(if ((structure-ref threads-internal thread-continuation)
|
||||
(car threads))
|
||||
(loop (cdr threads)
|
||||
(cons (car threads) new-threads))
|
||||
(loop (cdr threads) new-threads)))
|
||||
((not (null? new-threads))
|
||||
(loop new-threads '()))))
|
||||
#t))))
|
||||
|
||||
(define (spawn-thread thunk)
|
||||
(let ((placeholder (make-placeholder)))
|
||||
(spawn
|
||||
(lambda ()
|
||||
(placeholder-set!
|
||||
placeholder
|
||||
((structure-ref threads-internal current-thread)))
|
||||
(thunk)))
|
||||
(placeholder-value placeholder)))
|
||||
|
||||
;;; Extend R4RS i/o ops to handle file descriptors.
|
||||
;;; -----------------------------------------------
|
||||
|
||||
|
|
Loading…
Reference in New Issue