From 349fff06c1167548c77eeac77ed6ad7584b483ba Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Wed, 10 Apr 2002 15:03:02 +0000
Subject: [PATCH] Basic FORK and and %FORK now start a new command level inside
 the child process, thus preventing other threads from continuing to run.

Both take an additional optional argument that, when true, reverts the
old behavior of continuing all threads.

Moreover, use WITH-CONTINUATION NULL-CONTINUATION in CALL-TERMINALLY
to get us more space.
---
 scsh/scsh.scm | 89 +++++++++++++++++++++++++++++++++------------------
 1 file changed, 57 insertions(+), 32 deletions(-)

diff --git a/scsh/scsh.scm b/scsh/scsh.scm
index 49fe571..eef2181 100644
--- a/scsh/scsh.scm
+++ b/scsh/scsh.scm
@@ -6,15 +6,17 @@
 ;;; A clever definition in a clever implementation allows the caller's stack
 ;;; and dynamic env to be gc'd away, since this procedure never returns.
 
-;;;(define (call-terminally thunk)
-;;;  (with-continuation (lambda () #f) (lambda () (thunk) (exit 0))))
-;;;  ;; Alternatively: (with-continuation #f thunk)
-
-;;; More portably, but less usefully:
-;;; New version of s48 requires with-continuation to take a continuation
 (define (call-terminally thunk)
-  (thunk)
-  (exit 0))
+  (with-continuation
+   null-continuation
+   (lambda ()
+     (dynamic-wind
+      (lambda () (values))
+      thunk
+      (lambda () (exit 0))))))
+
+;; from shift-reset.scm:
+(define null-continuation #f)
 
 ;;; Like FORK, but the parent and child communicate via a pipe connecting
 ;;; the parent's stdin to the child's stdout. This function side-effects
@@ -904,36 +906,59 @@
 
 ;;; Assumes niladic primitive %%FORK.
 
-(define (fork . maybe-thunk)
+(define (fork . stuff)
   (flush-all-ports)
-  (really-fork #t maybe-thunk))
+  (apply fork-1 #t stuff))
 
-(define (%fork . maybe-thunk)
-  (really-fork #f maybe-thunk))
+(define (%fork . stuff)
+  (apply fork-1 #f stuff))
 
+(define (fork-1 clear-interactive? . rest)
+  (let-optionals rest ((maybe-thunk #f)
+		       (no-new-command-level? #f))
+    (really-fork clear-interactive?
+		 (not no-new-command-level?)
+		 maybe-thunk)))
 
-(define (really-fork clear-interactive? maybe-thunk)
-  (with-env-aligned* ; not neccessary here but doing it on exec
-                     ; genereates no cache in the parent
+(define (really-fork clear-interactive? new-command-level? maybe-thunk)
+  (with-env-aligned*			; not neccessary here but doing it on exec
+					; genereates no cache in the parent
    (lambda ()
-   (((structure-ref interrupts with-interrupts-inhibited) (lambda ()
-     (let ((pid (%%fork)))
-       (if (zero? pid)				
-
-	   ;; Child
-	   (lambda ()	; Do all this outside the WITH-INTERRUPTS.
-;	     (set! reaped-procs '())
-
-	     ;;; There is no session if parent was started in batch-mode
-	     (if (and (session-started?) clear-interactive?)
-		 (set-batch-mode?! #t))	; Children are non-interactive.
-	     (and (pair? maybe-thunk)
-		  (call-terminally (car maybe-thunk))))
-
-	   ;; Parent
-	   (let ((proc (new-child-proc pid)))
-	     (lambda () proc))))))))))
+     (let ((proc 'uninitialized)
+	   (maybe-push
+	    (if new-command-level?
+		(lambda (thunk)
+		  (push-command-level thunk 'forking))
+		(lambda (thunk) (thunk)))))
+       (maybe-push
+	(lambda ()
+	  ;; There was an atomicity problem/race condition -- if a child
+	  ;; process died after it was forked, but before the scsh fork
+	  ;; procedure could register the child's procobj in the
+	  ;; pid/procobj table, then when the SIGCHLD signal-handler reaped
+	  ;; the process, there would be no procobj for it.  We now lock
+	  ;; out interrupts across the %%FORK and NEW-CHILD-PROC
+	  ;; operations.
 
+	  (((structure-ref interrupts with-interrupts-inhibited)
+	    (lambda ()
+	      (let ((pid (%%fork)))
+		(if (zero? pid)				
+		    ;; Child
+		    (lambda ()		; Do all this outside the WITH-INTERRUPTS.
+		      ;; There is no session if parent was started in batch-mode
+		      (if (and (session-started?) clear-interactive?)
+			  (set-batch-mode?! #t)) ; Children are non-interactive.
+		      (if maybe-thunk
+			  (call-terminally maybe-thunk)))
+		    ;; Parent
+		    (begin
+		      (set! proc (new-child-proc pid))
+		      (lambda ()
+			(if new-command-level?
+			    (proceed-with-command-level
+			     (cadr (command-levels)))))))))))))
+       proc))))
 
 (define (exit . maybe-status)
   (flush-all-ports)