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.
This commit is contained in:
sperber 2002-05-03 13:42:36 +00:00
parent 2a302178e6
commit 1d35626709
9 changed files with 97 additions and 33 deletions

View File

@ -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)))

View File

@ -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

View File

@ -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)))

View File

@ -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)

View File

@ -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)

View File

@ -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

View File

@ -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
(if new-command-level?
(maybe-narrow
(if narrow?
(lambda (thunk)
(push-command-level (preserve-thread-fluids thunk)
(narrow (preserve-thread-fluids thunk)
'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)
(if new-command-level?
(proceed-with-command-level
(cadr (command-levels))))))
(call-terminally maybe-thunk)))
;; Parent
(begin
(set! proc (new-child-proc pid))
(lambda ()
(if new-command-level?
(proceed-with-command-level
(cadr (command-levels)))))))))))))
(values))))))))))
proc))))
(define (exit . maybe-status)

View File

@ -171,11 +171,11 @@
(set-interrupt-handler
i
#t))))
(let ((scheduler-initial-thread (current-thread)))
(if (not (eq? (thread-name scheduler-initial-thread)
'scheduler-initial-thread))
(error "sighandler did not find scheduler-initial-thread, but"
scheduler-initial-thread))
(let ((scsh-initial-thread (current-thread)))
(if (not (eq? (thread-name scsh-initial-thread)
'scsh-initial-thread))
(error "sighandler did not find scsh-initial-thread, but"
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)

View File

@ -67,7 +67,8 @@
(define (scsh-stand-alone-resumer start)
(usual-resumer ;sets up exceptions, interrupts, and current input & output
(usual-resumer ; sets up exceptions, interrupts,
; and current input & output
(lambda (args) ; VM gives us our args, but not our program.
(init-fdports!)
(call-with-current-continuation
@ -77,8 +78,29 @@
(with-handler
(simple-condition-handler halt (current-error-port))
(lambda ()
(let ((exit-val (start (command-line))))
(if (integer? exit-val) exit-val 0))))))))) ; work around bug.
(let ((dynamic-env (get-dynamic-env))
(*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)