+ reworked wait
+ wait-process-group does no longer a blocking wait(2)
This commit is contained in:
mainzelm
parent
3620d702f0
commit
69adcc41ba
142
scsh/procobj.scm
142
scsh/procobj.scm
|
|
@ -38,25 +38,15 @@
|
|||
;; until it wait(2)s and the strong pointer waits for wait(2) which is
|
||||
;; nothing but a deadlock
|
||||
|
||||
(define-record-type auto-init :auto-init
|
||||
(really-make-auto-init value init-thunk)
|
||||
(value auto-init-value set-auto-init-value!)
|
||||
(init-thunk auto-init-init-thunk))
|
||||
|
||||
(define (make-auto-init init-thunk)
|
||||
(really-make-auto-init (init-thunk) init-thunk))
|
||||
|
||||
(define-record-resumer :auto-init
|
||||
(lambda (record)
|
||||
(set-auto-init-value! record ((auto-init-init-thunk record)))))
|
||||
|
||||
(define process-table (make-auto-init make-integer-table))
|
||||
(define process-table (make-integer-table))
|
||||
(make-reinitializer (lambda ()
|
||||
(set! process-table (make-integer-table))))
|
||||
|
||||
(define (process-table-ref n)
|
||||
(weak-table-ref (auto-init-value process-table) n))
|
||||
(weak-table-ref process-table n))
|
||||
|
||||
(define (process-table-set! n val)
|
||||
(weak-table-set! (auto-init-value process-table) n val))
|
||||
(weak-table-set! process-table n val))
|
||||
|
||||
(define (maybe-pid->proc pid)
|
||||
(process-table-ref pid))
|
||||
|
|
@ -74,7 +64,7 @@
|
|||
(define (->proc proc/pid)
|
||||
(cond ((proc? proc/pid) proc/pid)
|
||||
((and (integer? proc/pid) (>= proc/pid 0))
|
||||
(pid->proc proc/pid))
|
||||
(pid->proc proc/pid 'create))
|
||||
(else (error "Illegal parameter" ->proc proc/pid))))
|
||||
|
||||
|
||||
|
|
@ -205,7 +195,7 @@
|
|||
;;; reap this special pid
|
||||
;;; return status or #f
|
||||
(define (reap-pid pid)
|
||||
(let ((status (really-wait pid wait/poll)))
|
||||
(let ((status (atomic-wait pid wait/poll)))
|
||||
(if status
|
||||
(waited-by-reap pid status))
|
||||
status))
|
||||
|
|
@ -232,8 +222,8 @@
|
|||
|
||||
(define (reap-zombies)
|
||||
(let lp ()
|
||||
(receive (pid status) (%wait-any (bitwise-ior wait/poll
|
||||
wait/stopped-children))
|
||||
(receive (pid status)
|
||||
(%wait-any (bitwise-ior wait/poll wait/stopped-children))
|
||||
(if pid
|
||||
(begin (waited-by-reap pid status)
|
||||
; (format (current-error-port)
|
||||
|
|
@ -275,32 +265,34 @@
|
|||
(define wait-lock (make-lock))
|
||||
|
||||
(define (wait pid/proc . maybe-flags)
|
||||
(with-lock
|
||||
(let* ((flags (:optional maybe-flags 0))
|
||||
(proc (->proc pid/proc))
|
||||
(win (lambda (status)
|
||||
(waited-by-wait proc status)
|
||||
status)))
|
||||
;; save the event before we check for finished
|
||||
(let ((pre-event (most-recent-sigevent)))
|
||||
(cond ((atomic-wait proc (bitwise-ior flags wait/poll)) => win)
|
||||
|
||||
((zero? (bitwise-and flags wait/poll))
|
||||
;; we have to block and hence use the event system
|
||||
(let lp ((pre-event pre-event))
|
||||
(cond ((atomic-wait proc (bitwise-ior flags wait/poll))
|
||||
=> win)
|
||||
(else
|
||||
(lp (next-sigevent pre-event interrupt/chld))))))
|
||||
(else #f)))))
|
||||
|
||||
|
||||
;;; -> process-object proc status/#f
|
||||
(define (atomic-wait proc flags)
|
||||
(with-lock
|
||||
wait-lock
|
||||
(lambda ()
|
||||
(let* ((flags (:optional maybe-flags 0))
|
||||
(proc (->proc pid/proc))
|
||||
(win (lambda (status)
|
||||
(waited-by-wait proc status)
|
||||
status)))
|
||||
;;; save the event before we check for finished
|
||||
(let ((pre-event (most-recent-sigevent)))
|
||||
(cond ((proc:finished? proc)
|
||||
(win (placeholder-value (proc:status proc))))
|
||||
|
||||
((zero? (bitwise-and flags wait/poll))
|
||||
(release-lock wait-lock)
|
||||
; we have to block and hence use the event system
|
||||
(let lp ((pre-event pre-event))
|
||||
(cond ((wait proc (bitwise-ior flags wait/poll)) => win)
|
||||
(else
|
||||
(lp (next-sigevent pre-event interrupt/chld))))))
|
||||
|
||||
((eq? wait/poll (bitwise-and flags wait/poll))
|
||||
(cond ((really-wait (proc:pid proc) flags) => win)
|
||||
(else #f)))))))))
|
||||
|
||||
|
||||
(cond ((proc:finished? proc)
|
||||
(placeholder-value (proc:status proc)))
|
||||
(else (really-wait (proc:pid proc) (bitwise-ior flags wait/poll)))))))
|
||||
|
||||
;;; This one is used, to wait on a positive pid
|
||||
;;; We NEVER do a blocking wait syscall
|
||||
(define (really-wait pid flags)
|
||||
|
|
@ -351,17 +343,17 @@
|
|||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(begin
|
||||
(receive (pid status)
|
||||
;;; before we maybe block via placeholder-value
|
||||
;;; do a really-wait-any for the ones, missed by 'late
|
||||
(really-wait-any (bitwise-ior flags wait/poll))
|
||||
(if (not pid)
|
||||
(let ((win (get-reaped-proc!)))
|
||||
(values win (placeholder-value (proc:status win))))
|
||||
(values pid status))))
|
||||
;; before we maybe block via placeholder-value
|
||||
;; do a really-wait-any for the ones, missed by 'late
|
||||
(really-wait-any (bitwise-ior flags wait/poll))
|
||||
(if (not pid)
|
||||
(let ((win (get-reaped-proc!)))
|
||||
(values win (placeholder-value (proc:status win))))
|
||||
(values pid status))))
|
||||
|
||||
;The rest of this is quite crude and can be safely ignored. -df
|
||||
;;; JMG: wait-any is crude and so its implementation
|
||||
;;; It got even worse, now that we have this fu*$#%g 'late
|
||||
;; The rest of this is quite crude and can be safely ignored. -df
|
||||
;; JMG: wait-any is crude and so its implementation
|
||||
;; It got even worse, now that we have this fu*$#%g 'late
|
||||
(if (maybe-obtain-lock reaped-proc-pop-lock)
|
||||
(if (eq? reaped-proc-head reaped-proc-tail)
|
||||
;;; due to 'late we cannot be sure, that they all have been
|
||||
|
|
@ -381,12 +373,13 @@
|
|||
(define (really-wait-any flags)
|
||||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(error "real-wait-any without wait/poll" flags))
|
||||
(receive (pid status) (%wait-any flags)
|
||||
(if pid
|
||||
(let ((proc (new-child-proc pid)))
|
||||
(waited-by-wait proc status)
|
||||
(values proc status))
|
||||
(values #f #f))))
|
||||
(receive (pid status)
|
||||
(%wait-any flags)
|
||||
(if pid
|
||||
(let ((proc (new-child-proc pid)))
|
||||
(waited-by-wait proc status)
|
||||
(values proc status))
|
||||
(values #f #f))))
|
||||
|
||||
|
||||
;;; (wait-process-group [proc-group flags]) => [proc status]
|
||||
|
|
@ -404,13 +397,28 @@
|
|||
(let ((proc-group (cond ((integer? proc-group) proc-group)
|
||||
((proc? proc-group) (proc:pid proc-group))
|
||||
(else (error "Illegal argument" wait-process-group
|
||||
proc-group)))))
|
||||
(receive (pid status) (%wait-process-group proc-group flags)
|
||||
(if pid
|
||||
(let ((proc (pid->proc pid)))
|
||||
(waited-by-wait proc status)
|
||||
(values proc status))
|
||||
(values pid status)))))) ; pid = #f -- Empty poll.
|
||||
proc-group))))
|
||||
(win (lambda (pid status)
|
||||
(let ((proc (pid->proc pid 'create)))
|
||||
(if proc (waited-by-wait proc status))
|
||||
(values proc status)))))
|
||||
;; save the event before we check for finished
|
||||
(let ((pre-event (most-recent-sigevent)))
|
||||
(receive (pid status)
|
||||
(%wait-process-group proc-group (bitwise-ior flags wait/poll))
|
||||
(cond (pid
|
||||
(win pid status))
|
||||
((zero? (bitwise-and flags wait/poll))
|
||||
;; we have to block and hence use the event system
|
||||
(let lp ((pre-event pre-event))
|
||||
(receive (pid status)
|
||||
(%wait-process-group proc-group (bitwise-ior flags wait/poll))
|
||||
(if pid
|
||||
(win pid status)
|
||||
(lp (next-sigevent pre-event interrupt/chld))))))
|
||||
(else
|
||||
(values #f status))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -432,6 +440,8 @@
|
|||
(values pid status)))))
|
||||
|
||||
(define (%wait-process-group pgrp flags)
|
||||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(error "really-wait without wait/poll"))
|
||||
(with-errno-handler
|
||||
((errno packet)
|
||||
((errno/child)
|
||||
|
|
|
|||
Loading…
Reference in New Issue