From 1d35626709162ca6058d9fc9f060819ab42e0ae1 Mon Sep 17 00:00:00 2001 From: sperber Date: Fri, 3 May 2002 13:42:36 +0000 Subject: [PATCH] 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 | 5 +++++ scheme/interfaces.scm | 3 ++- scheme/rts-packages.scm | 3 ++- scheme/rts/scheduler.scm | 30 ++++++++++++++++++++++++++ scheme/rts/thread.scm | 7 ++++++ scsh/scsh-package.scm | 3 +++ scsh/scsh.scm | 25 +++++++++------------ scsh/sighandlers.scm | 12 +++++------ scsh/startup.scm | 42 +++++++++++++++++++++++++++--------- 9 files changed, 97 insertions(+), 33 deletions(-) diff --git a/scheme/env/command-level.scm b/scheme/env/command-level.scm index 4841462..ce1cc26 100644 --- a/scheme/env/command-level.scm +++ b/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))) diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index cbc5f96..99be3a0 100644 --- a/scheme/interfaces.scm +++ b/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 diff --git a/scheme/rts-packages.scm b/scheme/rts-packages.scm index f6df07c..9e314e2 100644 --- a/scheme/rts-packages.scm +++ b/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))) diff --git a/scheme/rts/scheduler.scm b/scheme/rts/scheduler.scm index 0eabbb6..5bb76cb 100644 --- a/scheme/rts/scheduler.scm +++ b/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) diff --git a/scheme/rts/thread.scm b/scheme/rts/thread.scm index 2f90099..d648dcc 100644 --- a/scheme/rts/thread.scm +++ b/scheme/rts/thread.scm @@ -226,6 +226,7 @@ ;; asynchronous events runnable ; is now runnable spawned ; ... spawn as a new thread + narrowed ; ... narrow to as a new thread interrupt ; . 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) diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index 63afa44..bd6c4eb 100644 --- a/scsh/scsh-package.scm +++ b/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 diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 589be74..2639a4a 100644 --- a/scsh/scsh.scm +++ b/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 - (if new-command-level? + (maybe-narrow + (if narrow? (lambda (thunk) - (push-command-level (preserve-thread-fluids thunk) - 'forking)) + (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) diff --git a/scsh/sighandlers.scm b/scsh/sighandlers.scm index ba9028a..0ee0ea1 100644 --- a/scsh/sighandlers.scm +++ b/scsh/sighandlers.scm @@ -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) diff --git a/scsh/startup.scm b/scsh/startup.scm index a318338..0bf6a41 100644 --- a/scsh/startup.scm +++ b/scsh/startup.scm @@ -67,18 +67,40 @@ (define (scsh-stand-alone-resumer start) - (usual-resumer ;sets up exceptions, interrupts, and current input & output - (lambda (args) ; VM gives us our args, but not our program. + (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 - (lambda (halt) - (set! %vm-prog-args (cons "scsh" args)) ; WRONG -- use image. - (set-command-line-args! %vm-prog-args) - (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. + (lambda (halt) + (set! %vm-prog-args (cons "scsh" args)) ; WRONG -- use image. + (set-command-line-args! %vm-prog-args) + (with-handler + (simple-condition-handler halt (current-error-port)) + (lambda () + (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) \ No newline at end of file