Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv18216
Modified Files:
procobj.scm
Log Message:
+ reworked wait
+ wait-process-group does no longer a blocking wait(2)
Index: procobj.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/procobj.scm,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -r1.15 -r1.16
*** procobj.scm 2001/11/08 08:14:37 1.15
--- procobj.scm 2001/12/05 14:45:35 1.16
***************
*** 39,61 ****
;; 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-ref n)
! (weak-table-ref (auto-init-value process-table) n))
(define (process-table-set! n val)
! (weak-table-set! (auto-init-value process-table) n val))
(define (maybe-pid->proc pid)
--- 39,51 ----
;; nothing but a deadlock
! (define process-table (make-integer-table))
! (make-reinitializer (lambda ()
! (set! process-table (make-integer-table))))
(define (process-table-ref n)
! (weak-table-ref process-table n))
(define (process-table-set! n val)
! (weak-table-set! process-table n val))
(define (maybe-pid->proc pid)
***************
*** 75,79 ****
(cond ((proc? proc/pid) proc/pid)
((and (integer? proc/pid) (>= proc/pid 0))
! (pid->proc proc/pid))
(else (error "Illegal parameter" ->proc proc/pid))))
--- 65,69 ----
(cond ((proc? proc/pid) proc/pid)
((and (integer? proc/pid) (>= proc/pid 0))
! (pid->proc proc/pid 'create))
(else (error "Illegal parameter" ->proc proc/pid))))
***************
*** 206,210 ****
;;; return status or #f
(define (reap-pid pid)
! (let ((status (really-wait pid wait/poll)))
(if status
(waited-by-reap pid status))
--- 196,200 ----
;;; return status or #f
(define (reap-pid pid)
! (let ((status (atomic-wait pid wait/poll)))
(if status
(waited-by-reap pid status))
***************
*** 233,238 ****
(define (reap-zombies)
(let lp ()
! (receive (pid status) (%wait-any (bitwise-ior wait/poll
! wait/stopped-children))
(if pid
(begin (waited-by-reap pid status)
--- 223,228 ----
(define (reap-zombies)
(let lp ()
! (receive (pid status)
! (%wait-any (bitwise-ior wait/poll wait/stopped-children))
(if pid
(begin (waited-by-reap pid status)
***************
*** 276,305 ****
(define (wait pid/proc . maybe-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)))))))))
!
!
;;; This one is used, to wait on a positive pid
;;; We NEVER do a blocking wait syscall
--- 266,297 ----
(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 ()
! (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
***************
*** 352,366 ****
(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))))
!
! ;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)
--- 344,358 ----
(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))))
!
! ;; 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)
***************
*** 382,391 ****
(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))))
--- 374,384 ----
(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))))
***************
*** 405,418 ****
((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.
;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- 398,426 ----
((proc? proc-group) (proc:pid proc-group))
(else (error "Illegal argument" wait-process-group
! 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))))))))
+
;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
***************
*** 433,436 ****
--- 441,446 ----
(define (%wait-process-group pgrp flags)
+ (if (zero? (bitwise-and flags wait/poll))
+ (error "really-wait without wait/poll"))
(with-errno-handler
((errno packet)
|