From 54efae2318e6586481f0be76739fd4d09cedd2e7 Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Wed, 13 Feb 2002 14:56:11 +0000
Subject: [PATCH] + Lock for the process table + Use wait-lock to glue waiting
 and the process object together + Delete the pid/weak-pointer pair in the
 process table if the process object   gets finalized

---
 scsh/procobj.scm | 97 ++++++++++++++++++++++++++++++------------------
 1 file changed, 60 insertions(+), 37 deletions(-)

diff --git a/scsh/procobj.scm b/scsh/procobj.scm
index e520973..b30d7f0 100644
--- a/scsh/procobj.scm
+++ b/scsh/procobj.scm
@@ -42,11 +42,16 @@
 (make-reinitializer (lambda ()
 		      (set! process-table (make-integer-table))))
 
+(define process-table-lock (make-lock))
 (define (process-table-ref n)
-  (weak-table-ref process-table n))
+  (with-lock process-table-lock
+	     (lambda ()
+	       (weak-table-ref process-table n))))
 
 (define (process-table-set! n val)
-  (weak-table-set! process-table n val))
+  (with-lock process-table-lock
+	     (lambda ()
+	       (weak-table-set! process-table n val))))
 
 (define (maybe-pid->proc pid)
   (process-table-ref pid))
@@ -150,9 +155,9 @@
 	   (let lp ((event (most-recent-sigevent)))
 	     (let ((next-event (next-sigevent event interrupt/post-gc)))
 	       (*post/gc-handler*)
-	       (lp next-event))))
-	 '*post/gc-handler*-thread))
-  
+ 	       (lp next-event))))
+ 	 '*post/gc-handler*-thread))
+
 (define set-post/gc-handler! start-set-post/gc-handler!)
 
 
@@ -195,10 +200,13 @@
 ;;; reap this special pid
 ;;; return status or #f 
 (define (reap-pid pid)
-  (let ((status (atomic-wait pid wait/poll)))
-    (if status 
-	(waited-by-reap pid status))
-    status))
+  (with-lock 
+   wait-lock
+   (lambda ()
+     (let ((status (atomic-wait pid wait/poll)))
+       (if status 
+	   (waited-by-reap pid status))
+       status))))
 	
 ;;; Handler for SIGCHLD according policy
 (define (late-sigchld-handler) #f)
@@ -212,6 +220,7 @@
 ;;; Finalizer for procobjs
 ;;; 
 (define (procobj-finalizer procobj)
+  (process-table-set! (proc:pid procobj) #f)
   (if (not (proc:finished? procobj))
       (need-reaping-add! (proc:pid procobj))))
 
@@ -222,14 +231,18 @@
 
 (define (reap-zombies)
   (let lp ()
-    (receive (pid status) 
+    (obtain-lock wait-lock)
+    (receive (pid status)
       (%wait-any (bitwise-ior wait/poll wait/stopped-children))
       (if pid
 	  (begin (waited-by-reap pid status)
+		 (release-lock wait-lock)
 ;		 (format (current-error-port)
 ;			 "Reaping ~d[~d]~%" pid status)
 		 (lp))
-	  status))))
+	  (begin 
+	    (release-lock wait-lock)
+	    status)))))
 
 
 
@@ -260,7 +273,7 @@
 
 
 ;;; With this lock, we ensure that only one thread may call
-;;; really-wait for a given pid
+;;; really-wait for a given pid and manipulates the associated process object
 
 (define wait-lock (make-lock))
 
@@ -272,26 +285,29 @@
 		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)))))
+      (with-lock 
+       wait-lock
+       (lambda () 
+	 (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
+			 (release-lock wait-lock)
+			 (let ((next-event (next-sigevent pre-event interrupt/chld)))
+			   (obtain-lock wait-lock)
+			   (lp next-event))))))
+	       (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)))))))
+  (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 
@@ -315,7 +331,8 @@
   (cond ((maybe-pid->proc pid) =>
 	 (lambda (proc) 
 	   (obituary proc status)
-	   (push-reaped-proc proc)))))
+	   (push-reaped-proc proc)
+	   ))))
 
 
 ;;; All you have to do, if a wait on proc was successful
@@ -373,13 +390,16 @@
 (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))))
+  (with-lock
+   wait-lock
+   (lambda ()
+     (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]
@@ -424,7 +444,10 @@
 
 ;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Direct interfaces to waitpid(2) call.
+;;; Direct interfaces to waitpid(2) call. As opposed to %wait-pid this
+;;; waits on any child (using -1) and gets along if no child is alive
+;;; at all (i.e. catches errno/child).
+
 ;;; [#f #f] means no processes ready on a non-blocking wait.
 ;;; [#f #t] means no waitable process on wait-any.