+ 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,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))
+     (cond ((proc:finished? proc)
-	    (proc (->proc pid/proc))
+	    (placeholder-value (proc:status proc)))
-	    (win (lambda (status)
+	   (else (really-wait (proc:pid proc) (bitwise-ior flags wait/poll)))))))
-		   (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 
 (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
+	     ;; 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))
+	    (really-wait-any (bitwise-ior flags  wait/poll))
-		   (if (not pid)
+	    (if (not pid)
-		       (let ((win (get-reaped-proc!)))
+		(let ((win (get-reaped-proc!)))
-			 (values win (placeholder-value (proc:status win))))
+		  (values win (placeholder-value (proc:status win))))
-		       (values pid status))))
+		(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,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)
+    (receive (pid status) 
-			   (if pid
+       (%wait-any flags)
-			       (let ((proc (new-child-proc pid)))
+       (if pid
-				 (waited-by-wait proc status)
+	   (let ((proc (new-child-proc pid)))
-				 (values proc status))
+	     (waited-by-wait proc status)
-			       (values #f #f))))
+	     (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)))))
+					  proc-group))))
-      (receive (pid status) (%wait-process-group proc-group flags)
+	  (win (lambda (pid status)
-	(if pid
+		 (let ((proc (pid->proc pid 'create)))
-	    (let ((proc (pid->proc pid)))
+		   (if proc (waited-by-wait proc status))
-	      (waited-by-wait proc status)
+		   (values proc status)))))
-	      (values proc status))
+      ;; save the event before we check for finished
-	    (values pid status))))))		; pid = #f -- Empty poll.
+      (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)