63 lines
1.9 KiB
Scheme
63 lines
1.9 KiB
Scheme
(define (cml-fork sig-ch thunk)
|
|
(let* ((ch (cml-sync-ch/make-channel))
|
|
(res-ch (cml-sync-ch/make-channel))
|
|
(sig-rv (cml-sync-ch/receive-rv sig-ch))
|
|
(process (fork thunk))
|
|
(proc-done-rv (cml-sync-ch/receive-rv ch)))
|
|
|
|
(spawn
|
|
(lambda ()
|
|
(let lp ()
|
|
(cml-rv/select
|
|
(cml-rv/wrap sig-rv
|
|
(lambda (sig) (if (not (wait process wait/poll))
|
|
(begin (signal-process process sig)
|
|
(lp)))))
|
|
(cml-rv/wrap proc-done-rv
|
|
(lambda (res) (cml-sync-ch/send res-ch res))))))
|
|
(format #t "cml-fork: signals (for ~a)\n" (proc:pid process)))
|
|
|
|
(spawn (lambda ()
|
|
(cml-sync-ch/send ch (wait process)))
|
|
(format #t "cml-fork: waiting (for ~a)\n" (proc:pid process)))
|
|
|
|
(cml-sync-ch/receive-rv res-ch)))
|
|
|
|
(define (cml-fork/collecting fds sig-ch thunk)
|
|
(let* ((ch (cml-sync-ch/make-channel))
|
|
(res-ch (cml-sync-ch/make-channel))
|
|
(sig-rv (cml-sync-ch/receive-rv sig-ch))
|
|
;; from scsh-0.6.6/scsh/scsh.scm
|
|
(channels (map (lambda (ignore)
|
|
(call-with-values temp-file-channel cons))
|
|
fds))
|
|
(read-ports (map car channels))
|
|
(write-ports (map cdr channels))
|
|
(process (fork (lambda ()
|
|
(for-each close-input-port read-ports)
|
|
(for-each move->fdes write-ports fds)
|
|
(apply exec-path (thunk)))))
|
|
(proc-done-rv (cml-sync-ch/receive-rv ch)))
|
|
|
|
(spawn
|
|
(lambda ()
|
|
(let ((exitno (wait process)))
|
|
(cml-sync-ch/send ch (append (list exitno)
|
|
(map port->string read-ports)))))
|
|
(format #t "cml-fork/collecting: waiting (for ~a)\n" (proc:pid process)))
|
|
|
|
(spawn
|
|
(lambda ()
|
|
(let loop ()
|
|
(cml-rv/select
|
|
(cml-rv/wrap sig-rv
|
|
(lambda (sig) (if (not (wait process wait/poll))
|
|
(begin (signal-process process sig)
|
|
(loop)))))
|
|
(cml-rv/wrap proc-done-rv
|
|
(lambda (res) (cml-sync-ch/send res-ch res))))))
|
|
(format #t "cml-fork/collecting: signals (for ~a)\n" (proc:pid process)))
|
|
|
|
(for-each close-output-port write-ports)
|
|
(cml-sync-ch/receive-rv res-ch)))
|