wait-any should run now. no tests about race-conditions and the code is very ugly at the moment. I wonder if this ever will change

scsh/procobj.scm

@@ -19,11 +19,24 @@
   (zombie #t)                   ; Misnomer.  Whether or not the process has
                                 ; (not) been waited on.
   ;; Make proc objects print like #{proc 2318}.
-  ((disclose p) (list "proc" (proc:pid p))))
+  ((disclose p) (list "proc" (proc:pid p) (proc:finished? p))))
+
+;; Unfortunately there is no way to specify the name of the constructor-
+;; function in Olins define-record macro, so I had to do this...
+(define (make-procobj pid)
+  (let ((procobj (make-proc pid)))
+    (add-finalizer! procobj procobj-finalizer)
+    procobj))
+
 
 ;; Weak pointer tables.  Much more efficient than populations.
 ;; Maps pids to processes.  Unexited processes are strong pointers, exited
 ;; procs are weak pointers (to allow gc'ing).
+;; 
+;; JMG: whyever unexited processes were strong pointer, this won't work 
+;; with (autoreap-policy 'late), since then gc waits for the strong pointer
+;; until it wait(2)s and the strong pointer waits for wait(2) which is 
+;; nothing but a deadlock
 
 (define process-table (make-integer-table))
 
@@ -31,13 +44,13 @@
   (let ((r (table-ref t n)))
     (if (weak-pointer? r)
 	(weak-pointer-ref r)
-	r)))
+	(error "there was a non-weak-pointer" r))))
 
 (define (weak-table-set! t n s)
   (table-set! t n (make-weak-pointer s)))
 
-(define (weaken-table-ref! t n)
+;(define (weaken-table-ref! t n)
-  (weak-table-set! t n (weak-table-ref t n)))
+;  (weak-table-set! t n (weak-table-ref t n)))
 
 (define (maybe-pid->proc pid)
   (weak-table-ref process-table pid))
@@ -47,7 +60,7 @@
     (or (maybe-pid->proc pid)
 	(case probe?
 	  ((#f)     (error "Pid has no corresponding process object" pid))
-	  ((create) (let ((p (make-proc pid))) 	; Install a new one.
+	  ((create) (let ((p (make-procobj pid))) 	; Install a new one.
 		      ;; Weak because we don't know what's up with this thing.
 		      (weak-table-set! process-table pid p)
 		      p))
@@ -102,20 +115,85 @@
 	(let ((new-policy (car maybe-policy)))
 	  (cond ((pair? (cdr maybe-policy))
 		 (error "Too many args to autoreap-policy" maybe-policy))
-		((not (memq new-policy '(early #f)))
+		((not (memq new-policy '(early late #f)))
 		 (error "Illegal autoreap policy." new-policy))
 		(else (set! *autoreap-policy* new-policy)
-		      (if (eq? new-policy 'early)
+		      (cond ((eq? new-policy 'early)
-			  (set! procobj-handler
+			     (sigchld-setter early-sigchld-handler)
-			    (lambda (enabled-ints) (reap-zombies))))))))
+			     (post/gc-setter (lambda a (reap-need-reaping))))
+			    
+			    ((eq? new-policy 'late)
+			     (sigchld-setter late-sigchld-handler)
+			     (post/gc-setter (lambda a (reap-need-reaping))))
+
+			    (else 
+			     (sigchld-setter noauto-sigchld-handler)
+			     (post/gc-setter 
+			      (lambda (enabled-ints)
+				(display "won't reap on gc since #f")))))))))
     old-policy))
 
-;;; New (scsh 0.6)
 
+(define sigchld-setter 
+  (lambda a (error "procobj setter was not defined")))
+
+(define (post/gc-setter handler)
+   (set! post/gc-setter 
+	    (low-interrupt-register interrupt/post-gc
+				handler)))
+  
+  
+
+;;; New (scsh 0.6)
+;;; we register the post/gc-handler not until the first police change
 (define (install-autoreaping)
-  (set! procobj-handler
+  (let ((setter (low-interrupt-register interrupt/chld early-sigchld-handler)))
-    (lambda (enabled-ints)
+    (set! *autoreap-policy* 'early)
-      (reap-zombies))))
+    (set! sigchld-setter setter)))
+      
+
+
+;;; This list contains pids whose proc-obj were gc'd before they died
+;;; We try to reap them after every gc and maybe on every SIGCHLD
+(define need-reaping '())
+
+(define (need-reaping-add! pid)
+  (set! need-reaping (cons pid need-reaping)))
+
+(define (need-reaping-remove! pid)
+  (set! need-reaping (del pid need-reaping)))
+
+(define (reap-need-reaping)
+ (set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping)))
+
+;;; reap this special pid
+;;; return status or #f 
+(define (reap-pid pid)
+  (let ((status (really-wait pid wait/poll)))
+    (if status 
+	(dead_by_reap pid status))
+    status))
+	
+;;; Handler for SIGCHLD according policy
+(define (late-sigchld-handler enabled-ints)
+  (display "late sigchld handler"))
+
+(define (early-sigchld-handler enabled-ints)
+  (reap-zombies))
+
+(define (noauto-sigchld-handler enabled-ints)
+  (display "won't on chld reap since #f")
+  #f)
+
+
+;;; Finalizer for procobjs
+;;; 
+(define (procobj-finalizer procobj)
+  (display "procobj finalizer called")
+  (if (not (proc:finished? procobj))
+      (need-reaping-add! (proc:pid procobj))
+      (display "but was already finished")))
+
 
 ;;; (reap-zombies)  => bool
 ;;;   Move any zombies from the kernel process table into scsh.
@@ -125,21 +203,21 @@
   (display "reap-zombies was called" (current-error-port))
   (newline)
   (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 (add-reaped-proc! pid status)
+	  (begin (dead_by_reap pid status)
-;		 (format (current-error-port)
+		 (format (current-error-port)
-;			 "Reaping ~d[~d]~%" pid status)
+			 "Reaping ~d[~d]~%" pid status)
 		 (lp))
 	  status))))
 
-(define (new-child-proc pid)
-  (let ((proc (make-proc pid)))
-    (table-set! process-table pid proc)
-    proc))
 
-(define (mark-proc-exited proc)
+
-  (weaken-table-ref! process-table (proc:pid proc)))
+(define (new-child-proc pid)
+  (let ((proc (make-procobj pid)))
+    (weak-table-set! process-table pid proc)
+    proc))
 
 ;;; (WAIT proc/pid [flags])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -157,16 +235,52 @@
 ;;; 	is set) and wait/poll is set, return #f.
 ;;; (I'm working on the flags -df)
 
+;;; JMG: We have to be careful about wait/poll and autoreap-policy:
+;;; If it was 'late to anytime, we may missed the exit of pid/proc
+;;; So we cannot just block and hope reap-zombies will give us the status
+
+
+;;; TODO: add a jetzt-wart-i lock
+
 (define (wait pid/proc . maybe-flags)
+  ;;; I'm really tired of opening everything in scsh-level-0
+  (let ((wait-interrupt (structure-ref events wait-interrupt))
+	(most-recent-event (structure-ref events most-recent-event)))
   (let* ((flags (:optional maybe-flags 0))
 	 (proc (->proc pid/proc))
 	 (win (lambda (status)
-		(mark-proc-waited! proc) ; Not eligible for a WAIT-ANY
+		(dead_by_wait proc status)
 		status)))
-    (if (or (zero? (bitwise-and flags wait/poll))
+    (cond ((proc:finished? proc)   
-	    (proc:finished? proc)) 
+	   (win (placeholder-value (proc:status proc))))
-	(win (placeholder-value (proc:status proc)))
+	  
-	(proc:finished? proc))))
+	  ((zero? (bitwise-and flags wait/poll))   
+	   (let lp ()     ; we have to block and hence use the event system
+	      (wait-interrupt interrupt/chld (most-recent-event))
+	      (cond ((wait proc (bitwise-ior flags wait/poll)) => win)
+		    (else (lp)))))
+
+	  ((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)
+  (if (zero? (bitwise-and flags wait/poll))   
+      (error "really-wait without wait/poll"))
+  (if (< pid 1)
+      (error "really-wait on nonpos pid" pid))
+  (receive (err return_pid status) (%wait-pid/errno pid flags)
+	   (cond ((not err)		
+		  (cond ((zero? return_pid) #f)      ; failed wait/poll
+			((= pid return_pid) status)  ; made it
+			(else (error "mismatch in really-wait" 
+				     return_pid pid))))
+		 ((= err errno/intr) 
+		  (really-wait pid flags))
+		 (else (errno-error err %wait-pid pid flags)))))
   
 ;;; Another way to do it:
 ;;; Every time we reap a process, we pop out of our SIGCHLD
@@ -185,12 +299,32 @@
 
 ;Generally correct idea, tho
 
-(define (cache-wait-status proc status)
+
-  (cond ((and (integer? status)
+;;; TODO: These 2 have to be renamed !!!
-	      (not (status:stop-sig status)))	; He's dead, Jim.
+
-	 (placeholder-set! (proc:status proc) status)	; Cache exit status.
+;;; All you have to do, if pid was reaped
-	 (mark-proc-exited proc)))	; We're now gc'able.
+;;; proc_obj is maybe no longer alive
-  status)
+(define (dead_by_reap pid status)
+  (cond ((maybe-pid->proc pid) =>
+	 (lambda (proc) 
+	   (obituary proc status)
+	   (push-reaped-proc proc)))
+	(else (warn "reaped pid had no procobj" pid))))
+
+
+;;; All you have to do, if a wait on proc was successful
+(define (dead_by_wait proc status)
+  (obituary proc status)
+  (mark-proc-waited! proc))
+
+;;; we know from somewhere that proc is dead
+(define (obituary proc status)
+  (if (not (proc? proc))
+      (error "proc was not a proc" proc))
+  (need-reaping-remove! (proc:pid proc))     ; in case it started during 'late
+  (placeholder-set! (proc:status proc) status)
+  (set-proc:finished? proc #t))
+
 
 
 ;;; (wait-any [flags]) => [proc status]
@@ -201,24 +335,45 @@
 (define (wait-any . maybe-flags)
   (let ((flags (:optional maybe-flags 0)))
     (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))))
 
 	;The rest of this is quite crude and can be safely ignored. -df
-
+	;;; JMG: wait-any is crude and so it's 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
+		;;; reaped
 		(begin
 		  (release-lock reaped-proc-pop-lock)
-		  (values #f #f))
+		  (really-wait-any flags))
 		(let* ((retnode (placeholder-value reaped-proc-head))
 		       (retval (weak-pointer-ref (reaped-proc:proc retnode))))
 		  (set! reaped-proc-head (reaped-proc:next retnode))
 		  (release-lock reaped-proc-pop-lock)
 		  (if retval
 		      (values retval (placeholder-value (proc:status retval)))
-		      (values #f #f))
+		      (values #f #f))))
-	    (values #f #f)))))))
+	    (values #f #f)))))
+
+(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)))
+				 (dead_by_wait proc status)
+				 (values proc status))
+			       (values #f #f))))
+      
 	     
 ;;; (wait-process-group [proc-group flags]) => [proc status]
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -239,7 +394,7 @@
       (receive (pid status) (%wait-process-group proc-group flags)
 	(if pid
 	    (let ((proc (pid->proc pid)))
-	      (cache-wait-status proc status)
+	      (dead_by_wait proc status)
 	      (values proc status))
 	    (values pid status))))))		; pid = #f -- Empty poll.
 
@@ -336,14 +491,7 @@
     (release-lock reaped-proc-pop-lock)
     (weak-pointer-ref (reaped-proc:proc pop-me))))
 
-(define (add-reaped-proc! pid status)
+
-  (cond ((maybe-pid->proc pid) =>
-	 (lambda (proc)
-	   (placeholder-set! (proc:status proc) status)
-	   (set-proc:finished? proc #t)
-	   (push-reaped-proc proc)
-	   (mark-proc-exited proc))
-	 (else (warn "Exiting child pid has no proc object." pid status)))))
 
 ;;; Pop one off the list.
 (define (get-reaped-proc!)