Redo the forking-without-the-threads fix in a way not involving

command levels (as there *are* no command levels for things like scsh
-c):

There's now a new asynchronous event, similar to SPAWN, called NARROW.
It spawns off a new scheduler with just one thread (which runs the
thunk provided as an argument to NARROW) and blocks the current one
until the narrowed scheduler finishes.

For this to work, two schedulers need to be in place: the root
scheduler which performs the housekeeping, and another one inside that
which is the one the program uses---otherwise it's the root scheduler
that's blocked, and that means no housekeeping gets done.  This is
trivially the case for interactive mode, as the command-levels all
have their own schedulers, but we also need to make sure scsh's entry
point fires up its own initial scheduler.

scheme/env/command-level.scm

@@ -355,6 +355,11 @@
 	((spawned)
 	 (spawn-on-command-level level (car args) (cadr args))
 	 #t)
+	((narrowed)
+	 (handle-narrow-event command-quantum
+			      (command-level-dynamic-env level)
+			      args)
+	 #t)
 	((runnable)
 	 (let* ((thread (car args))
 		(level (thread-data thread)))

scheme/interfaces.scm

@@ -553,7 +553,7 @@
   (export thread?
 	  thread-name thread-uid        ;for debugging
 
-	  spawn
+	  spawn narrow
 	  relinquish-timeslice
 	  sleep
 	  terminate-current-thread))
@@ -601,6 +601,7 @@
   (export run-threads
 	  run-threads-with-housekeeper
 	  round-robin-event-handler
+	  handle-narrow-event
  
 	  make-counter            ; for thread counts
 	  counter-value

scheme/rts-packages.scm

@@ -256,7 +256,8 @@
   (files (rts thread) (rts sleep)))
 
 (define-structure scheduler scheduler-interface
-  (open scheme-level-1 threads threads-internal enumerated enum-case
+  (open scheme-level-1 threads threads-internal locks
+	enumerated enum-case
 	debug-messages
 	signals)       		;error
   (files (rts scheduler)))

scheme/rts/scheduler.scm

@@ -101,6 +101,8 @@
 			    (make-thread (car event-data)
 					 dynamic-env
 					 (cadr event-data))))
+ 	  ((narrowed)
+	   (handle-narrow-event quantum dynamic-env event-data))
 	  ((no-event)
 	   (values))
 	  (else
@@ -126,6 +128,34 @@
 
   thread-event-handler)
 
+(define (handle-narrow-event quantum dynamic-env event-data)
+  (let ((thread (current-thread))
+	(lock (make-lock)))
+    (obtain-lock lock)
+    (spawn
+     (lambda ()
+       (let ((runnable (make-thread-queue))
+	     (thread (make-thread (car event-data)
+				  dynamic-env
+				  (cadr event-data)))
+	     (thread-count (make-counter)))
+       
+	 (enqueue-thread! runnable thread)
+	 (increment-counter! thread-count)
+       
+	 (run-threads
+	  (round-robin-event-handler runnable quantum dynamic-env thread-count
+				     (lambda args #f)
+				     (lambda (thread token args) ; upcall handler
+				       (propogate-upcall thread token args))
+				     (lambda ()
+				       (if (positive? (counter-value thread-count))
+					   (wait)
+					   #f))))
+	 (release-lock lock)))
+     'narrowed-scheduler)
+    (obtain-lock lock)))
+
 ; Simple counting cell
 
 (define (make-counter)

scheme/rts/thread.scm

@@ -226,6 +226,7 @@
   ;; asynchronous events
    runnable       ; <thread> <args>     <thread> is now runnable
    spawned        ; <thunk> <id> ...    spawn <thunk> as a new thread
+   narrowed       ; <thunk> <id> ...    narrow to <thunk> as a new thread
    interrupt      ; <type> . <stuff>    an interrupt has occured
    deadlock       ;                     no one can run
  
@@ -586,6 +587,12 @@
 		  thunk
 		  (if (null? id) #f (car id))))
 
+(define (narrow thunk . id)
+  (schedule-event (thread-scheduler (current-thread))
+		  (enum event-type narrowed)
+		  thunk
+		  (if (null? id) #f (car id))))
+
 ; Enqueue a RUNNABLE for THREAD's scheduler.
 
 (define (make-ready thread . args)

scsh/scsh-package.scm

@@ -283,12 +283,15 @@
 	usual-resumer           ; usual-resumer
 	environments            ; with-interaction-environment
 	fluids-internal            ; JMG: get-dynamic-env 
+	threads threads-internal scheduler
+	structure-refs
 	scsh-utilities
 	interrupts
 	low-interrupt
 	sigevents
 	primitives
 	scheme)
+  (access threads-internal)
   (files startup))
 
 (define-structure scsh-top-package (export parse-switches-and-execute 

scsh/scsh.scm

@@ -922,23 +922,23 @@
 
 (define (fork-1 clear-interactive? . rest)
   (let-optionals rest ((maybe-thunk #f)
-		       (no-new-command-level? #f))
+		       (dont-narrow? #f))
     (really-fork clear-interactive?
-		 (not no-new-command-level?)
+		 (not dont-narrow?)
 		 maybe-thunk)))
 
-(define (really-fork clear-interactive? new-command-level? maybe-thunk)
+(define (really-fork clear-interactive? narrow? maybe-thunk)
   (with-env-aligned*			; not neccessary here but doing it on exec
 					; genereates no cache in the parent
    (lambda ()
      (let ((proc #f)
-	   (maybe-push
+	   (maybe-narrow
-	    (if new-command-level?
+	    (if narrow?
 		(lambda (thunk)
-		  (push-command-level (preserve-thread-fluids thunk)
+		  (narrow (preserve-thread-fluids thunk)
-				      'forking))
+			  'forking))
 		(lambda (thunk) (thunk)))))
-       (maybe-push
+       (maybe-narrow
 	(lambda ()
 	  ;; There was an atomicity problem/race condition -- if a child
 	  ;; process died after it was forked, but before the scsh fork
@@ -958,17 +958,12 @@
 		      (if (and (session-started?) clear-interactive?)
 			  (set-batch-mode?! #t)) ; Children are non-interactive.
 		      (if maybe-thunk
-			  (call-terminally maybe-thunk)
+			  (call-terminally maybe-thunk)))
-			  (if new-command-level?
-			    (proceed-with-command-level
-			     (cadr (command-levels))))))
 		    ;; Parent
 		    (begin
 		      (set! proc (new-child-proc pid))
 		      (lambda ()
-			(if new-command-level?
+			(values))))))))))
-			    (proceed-with-command-level
-			     (cadr (command-levels)))))))))))))
        proc))))
 
 (define (exit . maybe-status)

scsh/sighandlers.scm

@@ -171,11 +171,11 @@
 	  (set-interrupt-handler 
 	   i
 	   #t))))
-  (let ((scheduler-initial-thread  (current-thread)))
+  (let ((scsh-initial-thread  (current-thread)))
-    (if (not (eq? (thread-name scheduler-initial-thread)
+    (if (not (eq? (thread-name scsh-initial-thread)
-		  'scheduler-initial-thread))
+		  'scsh-initial-thread))
-	(error "sighandler did not find scheduler-initial-thread, but"
+	(error "sighandler did not find scsh-initial-thread, but"
-	       scheduler-initial-thread))
+	       scsh-initial-thread))
     
     ;; Note: this will prevent any other system to work, since it pushes
     ;; a new command level !
@@ -183,7 +183,7 @@
 	(set-interrupt-handler interrupt/keyboard
 			       (lambda stuff
 				 ((structure-ref threads-internal schedule-event) 
-				  scheduler-initial-thread
+				  scsh-initial-thread
 				  (enum  
 				   (structure-ref threads-internal event-type) 
 				   interrupt)

scsh/startup.scm

@@ -67,18 +67,40 @@
 
 
 (define (scsh-stand-alone-resumer start)
-  (usual-resumer  ;sets up exceptions, interrupts, and current input & output
+  (usual-resumer			; sets up exceptions, interrupts,
-   (lambda (args)	; VM gives us our args, but not our program.
+					; and current input & output
+   (lambda (args)			; VM gives us our args, but not our program.
      (init-fdports!)
      (call-with-current-continuation
-       (lambda (halt)
+      (lambda (halt)
-	 (set! %vm-prog-args (cons "scsh" args))	; WRONG -- use image.
+	(set! %vm-prog-args (cons "scsh" args))	; WRONG -- use image.
-	 (set-command-line-args! %vm-prog-args)
+	(set-command-line-args! %vm-prog-args)
-	 (with-handler 
+	(with-handler 
-	  (simple-condition-handler halt (current-error-port))
+	 (simple-condition-handler halt (current-error-port))
-	  (lambda ()
+	 (lambda ()
-	    (let ((exit-val (start (command-line))))
+	   (let ((dynamic-env (get-dynamic-env))
-	      (if (integer? exit-val) exit-val 0))))))))) ; work around bug.
+		 (*result* 4711))
+	     (let ((runnable (make-thread-queue))
+		   (thread (make-thread (lambda ()
+					  (set! *result*
+						(start (command-line))))
+					dynamic-env
+					'scsh-initial-thread))
+		   (thread-count (make-counter)))
+	      
+	       (enqueue-thread! runnable thread)
+	       (increment-counter! thread-count)
+	      
+	       (run-threads
+		(round-robin-event-handler runnable 200 dynamic-env thread-count
+					   (lambda args #f)
+					   (lambda (thread token args) ; upcall handler
+					     (propogate-upcall thread token args))
+					   (lambda ()
+					     (if (positive? (counter-value thread-count))
+						 ((structure-ref threads-internal wait))
+						 #f))))
+	       (if (integer? *result*) *result* 0)))))))))) ; work around bug.
 
 (define %vm-prog-args #f)