+ reworked wait

+ wait-process-group does no longer a blocking wait(2)

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
+(define process-table (make-integer-table))
-  (really-make-auto-init value init-thunk)
+(make-reinitializer (lambda ()
-  (value auto-init-value set-auto-init-value!)
+		      (set! process-table (make-integer-table))))
-  (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))
+  (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 
+    (receive (pid status) 
-						  wait/stopped-children))
+      (%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)
-  (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
+    ;; save the event before we check for finished
     (let ((pre-event (most-recent-sigevent)))
-	 (cond ((proc:finished? proc)   
+      (cond ((atomic-wait proc (bitwise-ior flags wait/poll)) => win)
-		(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
-		; 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)
+	       (cond ((atomic-wait proc (bitwise-ior flags wait/poll)) 
+		      => win)
 		     (else 
 		      (lp (next-sigevent pre-event interrupt/chld))))))
+	    (else #f)))))
 		
-	       ((eq? wait/poll (bitwise-and flags wait/poll))
-		(cond ((really-wait (proc:pid proc) flags) => win)
-		      (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 
@@ -351,17 +343,17 @@
     (if (zero? (bitwise-and flags wait/poll))
 	(begin
 	  (receive (pid status) 
-		   ;;; before we maybe block via placeholder-value
+	     ;; before we maybe block via placeholder-value
-		   ;;; do a really-wait-any for the ones, missed by 'late
+	     ;; 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
+	;; The rest of this is quite crude and can be safely ignored. -df
-	;;; JMG: wait-any is crude and so its implementation
+	;; JMG: wait-any is crude and so its implementation
-	;;; It got even worse, now that we have this fu*$#%g 'late
+	;; 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,7 +373,8 @@
 (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)
+    (receive (pid status) 
+       (%wait-any flags)
        (if pid
 	   (let ((proc (new-child-proc pid)))
 	     (waited-by-wait 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)))))
+					  proc-group))))
-      (receive (pid status) (%wait-process-group proc-group flags)
+	  (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
-	    (let ((proc (pid->proc pid)))
+			  (win pid status)
-	      (waited-by-wait proc status)
+			  (lp (next-sigevent pre-event interrupt/chld))))))
-	      (values proc status))
+		(else 
-	    (values pid status))))))		; pid = #f -- Empty poll.
+		 (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)