+ reworked wait

+ wait-process-group does no longer a blocking wait(2)
This commit is contained in:
mainzelm 2001-12-05 14:45:35 +00:00
parent 3620d702f0
commit 69adcc41ba
1 changed files with 76 additions and 66 deletions

View File

@ -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,31 +265,33 @@
(define wait-lock (make-lock))
(define (wait pid/proc . maybe-flags)
(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
@ -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)