Added with-autoreaping and with-scsh-sighandlers.

Added auto-init for process-objects to flush the process table on startup.

scsh/procobj.scm

@@ -38,7 +38,25 @@
 ;; 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))
+(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 (weak-table-ref t n)
   (let ((r (table-ref t n)))
@@ -53,18 +71,14 @@
 ;  (weak-table-set! t n (weak-table-ref t n)))
 
 (define (maybe-pid->proc pid)
-  (weak-table-ref process-table pid))
+  (process-table-ref pid))
 
 (define (pid->proc pid . maybe-probe?)
   (let ((probe? (:optional maybe-probe? #f)))
     (or (maybe-pid->proc pid)
 	(case probe?
 	  ((#f)     (error "Pid has no corresponding process object" pid))
-	  ;;; TODO: call new-child-proc here 
+	  ((create) (new-child-proc pid))
-	  ((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))
 	  (else     #f)))))
 	     
 ;;; Coerce pids and procs to procs.
@@ -112,8 +126,8 @@
 ;;; I'm really tired of opening everything (i.e. events) in scsh-level-0
 ;;; this is here until someone (Olin !!!) cleans up the scsh modules
 
-(define wait-interrupt (structure-ref scsh-events wait-interrupt))
+(define next-sigevent (structure-ref scsh-events next-sigevent))
-(define most-recent-event (structure-ref scsh-events most-recent-event))
+(define most-recent-sigevent (structure-ref scsh-events most-recent-sigevent))
 
 
 (define *autoreap-policy* #f) ; Not exported from this module.
@@ -155,8 +169,8 @@
   (set! set-post/gc-handler! really-set-post/gc-handler!)
   (set-post/gc-handler! handler)
   (spawn (lambda ()
-	   (let lp ((event (most-recent-event)))
+	   (let lp ((event (most-recent-sigevent)))
-	     (let ((next-event (wait-interrupt interrupt/post-gc event)))
+	     (let ((next-event (next-sigevent event interrupt/post-gc)))
 	       (*post/gc-handler*)
 	       (lp next-event))))
 	 '*post/gc-handler*-thread))
@@ -168,14 +182,15 @@
 (define (set-sigchld-handler! handler)
   (set! *sigchld-handler* handler))
 
-(define (install-autoreaping) 
+(define (with-autoreaping thunk)
   (set! *autoreap-policy* 'early)
   (spawn (lambda ()
-	   (let lp ((event (most-recent-event)))
+	   (let lp ((event (most-recent-sigevent)))
-	     (let ((next-event (wait-interrupt interrupt/chld event)))
+	     (let ((next-event (next-sigevent event interrupt/chld)))
 	       (*sigchld-handler*)
 	       (lp next-event))))
-	 '*sigchld-handler*-thread))
+	 '*sigchld-handler*-thread)
+  (thunk))
 
 
 ;;; This list contains pids whose proc-obj were gc'd before they died
@@ -242,7 +257,7 @@
 
 (define (new-child-proc pid)
   (let ((proc (make-procobj pid)))
-    (weak-table-set! process-table pid proc)
+    (process-table-set! pid proc)
     proc))
 
 ;;; (WAIT proc/pid [flags])
@@ -262,30 +277,40 @@
 ;;; (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
+;;; If it was 'late at 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
+;;; With this lock, we ensure that only one thread may call
+;;; really-wait for a given pid
+
+(define wait-lock (make-lock))
 
 (define (wait pid/proc . maybe-flags)
-  (let* ((flags (:optional maybe-flags 0))
+  (with-lock 
-	 (proc (->proc pid/proc))
+   wait-lock
-	 (win (lambda (status)
+   (lambda ()
-		(waited-by-wait proc status)
+     (let* ((flags (:optional maybe-flags 0))
-		status)))
+	    (proc (->proc pid/proc))
-    (cond ((proc:finished? proc)   
+	    (win (lambda (status)
-	   (win (placeholder-value (proc:status proc))))
+		   (waited-by-wait proc status)
-	  
+		   status)))
-	  ((zero? (bitwise-and flags wait/poll))   
+    ;;; save the event before we check for finished
-	   (let lp ()     ; we have to block and hence use the event system
+       (let ((pre-event (most-recent-sigevent)))
-	     (wait-interrupt interrupt/chld (most-recent-event))
+	 (cond ((proc:finished? proc)   
-	     (cond ((wait proc (bitwise-ior flags wait/poll)) => win)
+		(win (placeholder-value (proc:status proc))))
-		   (else (lp)))))
+	       
-	  
+	       ((zero? (bitwise-and flags wait/poll))
-	  ((eq? wait/poll (bitwise-and flags wait/poll))
+		(release-lock wait-lock)
-	   (cond ((really-wait (proc:pid proc) flags) => win)
+		; we have to block and hence use the event system
-		 (else #f))))))
+		(let lp ((pre-event pre-event)) 
+		  (let ((event (next-sigevent pre-event interrupt/chld)))
+		    (cond ((wait proc (bitwise-ior flags wait/poll)) => win)
+			  (else (lp event))))))
+	       
+	       ((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
@@ -306,7 +331,6 @@
 		 (else (errno-error err %wait-pid pid flags)))))
   
 
-;;; TODO: These 2 have to be renamed !!!
 
 ;;; All you have to do, if pid was reaped
 ;;; proc_obj is maybe no longer alive

scsh/sighandlers.scm

@@ -166,7 +166,7 @@
 (define (interrupt-handler int)
   (interrupt-handler-ref int))
 
-(define (%install-scsh-handlers interactive?)
+(define (with-scsh-sighandlers interactive? thunk)
   (do ((int 0 (+ int 1)))
       ((= int number-of-interrupts))
     (set-interrupt-handler
@@ -197,13 +197,15 @@
 				   (structure-ref threads-internal event-type) 
 				   interrupt)
 				  (enum interrupt keyboard))))))
-    (spawn deliver-interrupts 'deliver-interrupts))
+  (spawn deliver-interrupts
+	 'deliver-interrupts)
+  (thunk))
 
 (define (deliver-interrupts)
-  (let lp ((last ((structure-ref scsh-events most-recent-event))))
+  (let lp ((last ((structure-ref scsh-events most-recent-sigevent))))
-    (let ((event ((structure-ref scsh-events wait-interrupt-set)
+    (let ((event ((structure-ref scsh-events next-sigevent-set)
-		  full-interrupt-set last)))
+		  last full-interrupt-set)))
-      (call-interrupt-handler ((structure-ref scsh-events event-type) event))
+      (call-interrupt-handler ((structure-ref scsh-events sigevent-type) event))
       (lp event))))
     
 ;;; I am ashamed to say the 33 below is completely bogus.

scsh/startup.scm

@@ -44,12 +44,15 @@
 
 (define (dump-scsh-program start filename)
   (really-dump-scsh-program (lambda (args)
-			      (install-env)	 
+			      (with-scsh-sighandlers 
-			      (%install-scsh-handlers #f)
+			       #f
-			      (install-autoreaping)
+			       (lambda ()
-			      (init-scsh-vars #f)	; Do it quietly.
+				 (with-autoreaping
-			      (start args))
+				  (lambda ()
-			    filename))
+				    (install-env)	 
+				    (init-scsh-vars #f)	; Do it quietly.
+				    (start args))))))
+				  filename))
 
 
 (define (scsh-stand-alone-resumer start)

scsh/top.scm

@@ -234,10 +234,12 @@
      (with-interaction-environment     
       (user-environment)
        (lambda ()
-       (begin
+	 (with-scsh-sighandlers 
-	 (%install-scsh-handlers (not term-switch))
+	  (not term-switch)
-	 (install-autoreaping)
+	  (lambda ()
-	 (install-env)
+	    (with-autoreaping
+	     (lambda ()
+	       (install-env)
 
 	 ;; Have to do these before calling DO-SWITCHES, because actions
 	 ;; performed while processing the switches may use these guys.
@@ -281,7 +283,7 @@
 		 
 		     ;; Otherwise, the script executed as it loaded,
 		 ;; so we're done.
-		 (else (exit 0))))))))))
+		 (else (exit 0)))))))))))))