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:
parent
2a302178e6
commit
1d35626709
|
@ -355,6 +355,11 @@
|
||||||
((spawned)
|
((spawned)
|
||||||
(spawn-on-command-level level (car args) (cadr args))
|
(spawn-on-command-level level (car args) (cadr args))
|
||||||
#t)
|
#t)
|
||||||
|
((narrowed)
|
||||||
|
(handle-narrow-event command-quantum
|
||||||
|
(command-level-dynamic-env level)
|
||||||
|
args)
|
||||||
|
#t)
|
||||||
((runnable)
|
((runnable)
|
||||||
(let* ((thread (car args))
|
(let* ((thread (car args))
|
||||||
(level (thread-data thread)))
|
(level (thread-data thread)))
|
||||||
|
|
|
@ -553,7 +553,7 @@
|
||||||
(export thread?
|
(export thread?
|
||||||
thread-name thread-uid ;for debugging
|
thread-name thread-uid ;for debugging
|
||||||
|
|
||||||
spawn
|
spawn narrow
|
||||||
relinquish-timeslice
|
relinquish-timeslice
|
||||||
sleep
|
sleep
|
||||||
terminate-current-thread))
|
terminate-current-thread))
|
||||||
|
@ -601,6 +601,7 @@
|
||||||
(export run-threads
|
(export run-threads
|
||||||
run-threads-with-housekeeper
|
run-threads-with-housekeeper
|
||||||
round-robin-event-handler
|
round-robin-event-handler
|
||||||
|
handle-narrow-event
|
||||||
|
|
||||||
make-counter ; for thread counts
|
make-counter ; for thread counts
|
||||||
counter-value
|
counter-value
|
||||||
|
|
|
@ -256,7 +256,8 @@
|
||||||
(files (rts thread) (rts sleep)))
|
(files (rts thread) (rts sleep)))
|
||||||
|
|
||||||
(define-structure scheduler scheduler-interface
|
(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
|
debug-messages
|
||||||
signals) ;error
|
signals) ;error
|
||||||
(files (rts scheduler)))
|
(files (rts scheduler)))
|
||||||
|
|
|
@ -101,6 +101,8 @@
|
||||||
(make-thread (car event-data)
|
(make-thread (car event-data)
|
||||||
dynamic-env
|
dynamic-env
|
||||||
(cadr event-data))))
|
(cadr event-data))))
|
||||||
|
((narrowed)
|
||||||
|
(handle-narrow-event quantum dynamic-env event-data))
|
||||||
((no-event)
|
((no-event)
|
||||||
(values))
|
(values))
|
||||||
(else
|
(else
|
||||||
|
@ -126,6 +128,34 @@
|
||||||
|
|
||||||
thread-event-handler)
|
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
|
; Simple counting cell
|
||||||
|
|
||||||
(define (make-counter)
|
(define (make-counter)
|
||||||
|
|
|
@ -226,6 +226,7 @@
|
||||||
;; asynchronous events
|
;; asynchronous events
|
||||||
runnable ; <thread> <args> <thread> is now runnable
|
runnable ; <thread> <args> <thread> is now runnable
|
||||||
spawned ; <thunk> <id> ... spawn <thunk> as a new thread
|
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
|
interrupt ; <type> . <stuff> an interrupt has occured
|
||||||
deadlock ; no one can run
|
deadlock ; no one can run
|
||||||
|
|
||||||
|
@ -586,6 +587,12 @@
|
||||||
thunk
|
thunk
|
||||||
(if (null? id) #f (car id))))
|
(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.
|
; Enqueue a RUNNABLE for THREAD's scheduler.
|
||||||
|
|
||||||
(define (make-ready thread . args)
|
(define (make-ready thread . args)
|
||||||
|
|
|
@ -283,12 +283,15 @@
|
||||||
usual-resumer ; usual-resumer
|
usual-resumer ; usual-resumer
|
||||||
environments ; with-interaction-environment
|
environments ; with-interaction-environment
|
||||||
fluids-internal ; JMG: get-dynamic-env
|
fluids-internal ; JMG: get-dynamic-env
|
||||||
|
threads threads-internal scheduler
|
||||||
|
structure-refs
|
||||||
scsh-utilities
|
scsh-utilities
|
||||||
interrupts
|
interrupts
|
||||||
low-interrupt
|
low-interrupt
|
||||||
sigevents
|
sigevents
|
||||||
primitives
|
primitives
|
||||||
scheme)
|
scheme)
|
||||||
|
(access threads-internal)
|
||||||
(files startup))
|
(files startup))
|
||||||
|
|
||||||
(define-structure scsh-top-package (export parse-switches-and-execute
|
(define-structure scsh-top-package (export parse-switches-and-execute
|
||||||
|
|
|
@ -922,23 +922,23 @@
|
||||||
|
|
||||||
(define (fork-1 clear-interactive? . rest)
|
(define (fork-1 clear-interactive? . rest)
|
||||||
(let-optionals rest ((maybe-thunk #f)
|
(let-optionals rest ((maybe-thunk #f)
|
||||||
(no-new-command-level? #f))
|
(dont-narrow? #f))
|
||||||
(really-fork clear-interactive?
|
(really-fork clear-interactive?
|
||||||
(not no-new-command-level?)
|
(not dont-narrow?)
|
||||||
maybe-thunk)))
|
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
|
(with-env-aligned* ; not neccessary here but doing it on exec
|
||||||
; genereates no cache in the parent
|
; genereates no cache in the parent
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((proc #f)
|
(let ((proc #f)
|
||||||
(maybe-push
|
(maybe-narrow
|
||||||
(if new-command-level?
|
(if narrow?
|
||||||
(lambda (thunk)
|
(lambda (thunk)
|
||||||
(push-command-level (preserve-thread-fluids thunk)
|
(narrow (preserve-thread-fluids thunk)
|
||||||
'forking))
|
'forking))
|
||||||
(lambda (thunk) (thunk)))))
|
(lambda (thunk) (thunk)))))
|
||||||
(maybe-push
|
(maybe-narrow
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; There was an atomicity problem/race condition -- if a child
|
;; There was an atomicity problem/race condition -- if a child
|
||||||
;; process died after it was forked, but before the scsh fork
|
;; process died after it was forked, but before the scsh fork
|
||||||
|
@ -958,17 +958,12 @@
|
||||||
(if (and (session-started?) clear-interactive?)
|
(if (and (session-started?) clear-interactive?)
|
||||||
(set-batch-mode?! #t)) ; Children are non-interactive.
|
(set-batch-mode?! #t)) ; Children are non-interactive.
|
||||||
(if maybe-thunk
|
(if maybe-thunk
|
||||||
(call-terminally maybe-thunk)
|
(call-terminally maybe-thunk)))
|
||||||
(if new-command-level?
|
|
||||||
(proceed-with-command-level
|
|
||||||
(cadr (command-levels))))))
|
|
||||||
;; Parent
|
;; Parent
|
||||||
(begin
|
(begin
|
||||||
(set! proc (new-child-proc pid))
|
(set! proc (new-child-proc pid))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(if new-command-level?
|
(values))))))))))
|
||||||
(proceed-with-command-level
|
|
||||||
(cadr (command-levels)))))))))))))
|
|
||||||
proc))))
|
proc))))
|
||||||
|
|
||||||
(define (exit . maybe-status)
|
(define (exit . maybe-status)
|
||||||
|
|
|
@ -171,11 +171,11 @@
|
||||||
(set-interrupt-handler
|
(set-interrupt-handler
|
||||||
i
|
i
|
||||||
#t))))
|
#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
|
;; Note: this will prevent any other system to work, since it pushes
|
||||||
;; a new command level !
|
;; a new command level !
|
||||||
|
@ -183,7 +183,7 @@
|
||||||
(set-interrupt-handler interrupt/keyboard
|
(set-interrupt-handler interrupt/keyboard
|
||||||
(lambda stuff
|
(lambda stuff
|
||||||
((structure-ref threads-internal schedule-event)
|
((structure-ref threads-internal schedule-event)
|
||||||
scheduler-initial-thread
|
scsh-initial-thread
|
||||||
(enum
|
(enum
|
||||||
(structure-ref threads-internal event-type)
|
(structure-ref threads-internal event-type)
|
||||||
interrupt)
|
interrupt)
|
||||||
|
|
|
@ -67,7 +67,8 @@
|
||||||
|
|
||||||
|
|
||||||
(define (scsh-stand-alone-resumer start)
|
(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.
|
(lambda (args) ; VM gives us our args, but not our program.
|
||||||
(init-fdports!)
|
(init-fdports!)
|
||||||
(call-with-current-continuation
|
(call-with-current-continuation
|
||||||
|
@ -77,8 +78,29 @@
|
||||||
(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)
|
(define %vm-prog-args #f)
|
||||||
|
|
Loading…
Reference in New Issue