123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611 |
- ; Part of Scheme 48 1.9. See file COPYING for notices and license.
- ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
- ; Command levels for the command processor
- ;
- ; Each command level has its own threads and scheduling queues. Only one
- ; command level is running at any time. An exception stops the current
- ; level and all its threads.
- ;
- ; A command level also has the condition that caused the level to be pushed,
- ; if any.
- ;----------------------------------------------------------------
- ; Command levels
- (define-record-type command-level :command-level
- (really-make-command-level queue thread-counter dynamic-env
- levels throw terminated?
- condition menu menu-position value-stack
- paused threads)
- command-level?
- (queue command-level-queue) ; queue of runnable threads
- (thread-counter command-level-thread-counter) ; count of extant threads
- (dynamic-env command-level-dynamic-env) ; used for spawns
- (levels command-level-levels) ; levels above this one
- (throw command-level-throw) ; exit from this level
- (terminated? command-level-terminated? set-command-level-terminated?!)
- ; true if unwinds already run
- (condition command-level-condition) ; condition which caused this
- ; level to be pushed
- (menu command-level-menu set-command-level-menu!)
- (menu-position command-level-menu-position set-command-level-menu-position!)
- (value-stack command-level-value-stack set-command-level-value-stack!)
- (repl-thread command-level-repl-thread set-command-level-repl-thread!)
- ; thread running the REPL
- (paused command-level-paused-thread set-command-level-paused-thread!)
- ; thread that pushed next level
- (threads x-command-level-threads set-command-level-threads!))
- ; lazily generated list of this level's threads
- (define (make-command-level condition inspecting? dynamic-env levels throw)
- (let ((level (really-make-command-level (make-queue)
- (make-counter)
- dynamic-env
- levels
- throw
- #f ; not yet terminated
- condition
- #f ; no menu
- #f ; no menu position
- (if inspecting? ; value stack
- '()
- #f)
- #f ; paused thread
- #f))) ; undetermined thread list
- (if (user-session-script-mode? (user-session))
- (spawn-script-thread! level)
- (spawn-repl-thread! level))
- level))
- ; Add THUNK as a thread to LEVEL. The level is stored in the thread so
- ; that when it is rescheduled after blocking it can be put on the correct
- ; run queue.
- (define (spawn-on-command-level level thunk id)
- (let ((thread (make-thread thunk id)))
- (spawn-thread-on-command-level level thread)
- thread))
- (define (spawn-thread-on-command-level level thread)
- (set-thread-dynamic-env! thread (command-level-dynamic-env level))
- (set-thread-scheduler! thread (command-thread))
- (set-thread-data! thread level)
- (enqueue! (command-level-queue level) thread)
- (increment-counter! (command-level-thread-counter level)))
- ; Add a new REPL thread to LEVEL.
- (define (spawn-repl-thread! level)
- (let ((thread (spawn-on-command-level level
- (user-session-repl-thunk (user-session))
- 'command-loop)))
- (set-command-level-repl-thread! level thread)))
- ; Add a script thread to LEVEL
- (define (spawn-script-thread! level)
- (spawn-on-command-level level
- (let ((thunk
- (user-session-script-thunk (user-session))))
- (lambda ()
- (set-exit-status! (thunk))))
- 'script))
- ; Find all of the threads belonging to LEVEL. This may be expensive to call
- ; and may not return the correct value if LEVEL is currently running.
- (define (command-level-threads level)
- (cond ((and (x-command-level-threads level)
- (weak-pointer-ref (x-command-level-threads level)))
- => (lambda (x) x))
- ((= 1 (counter-value (command-level-thread-counter level)))
- (list (command-level-repl-thread level)))
- (else
- (exact-command-level-threads level))))
- ; Use this when you really have to know. It's still somewhat
- ; imprecise as we may get threads that are already dead, but at least
- ; it doesn't leave anything out.
- (define (exact-command-level-threads level)
- (let ((threads (all-threads)))
- (do ((i 0 (+ i 1))
- (es '() (let ((thread (vector-ref threads i)))
- (if (and (thread-continuation thread)
- (eq? level (thread-data thread)))
- (cons thread es)
- es))))
- ((= i (vector-length threads))
- (set-command-level-threads! level (make-weak-pointer es))
- es))))
- ;----------------------------------------------------------------
- ; Entry point
- ; Starting the command processor. This arranges for an interrupt if the heap
- ; begins to fill up or when a keyboard interrupts occurs, starts a new user
- ; session, runs an initial thunk and then pushes a command level.
- (define (start-command-levels resume-args context
- greeting-thunk start-thunk
- repl-thunk script-thunk
- condition inspector-state
- input-port output-port error-port)
- ;(debug-message "[Starting levels]")
- (notify-on-interrupts (current-thread))
- (let ((dynamic-env (get-dynamic-env))
- (session (make-user-session (current-thread)
- (or context (make-user-context))
- repl-thunk script-thunk
- input-port
- output-port
- error-port
- resume-args ; focus values
- #f ; exit status
- (and (pair? resume-args)
- (string=? (os-string->string (car resume-args)) "batch"))
- (and (pair? resume-args)
- (string=? (os-string->string (car resume-args)) "run-script")))))
- (with-handler command-levels-condition-handler
- (lambda ()
- (let-fluids $command-level-thread? #t
- $user-session session
- (lambda ()
- (with-translations (translations)
- (lambda ()
- (if (not (or (user-session-batch-mode? session)
- (user-session-script-mode? session)))
- (greeting-thunk))
- ;;(debug-message "[start-thunk]")
- (start-thunk)
- (let ((thunk (really-push-command-level condition
- inspector-state
- dynamic-env
- '())))
- (ignore-further-interrupts)
- thunk)))))))))
- ; A fluid to tell us when we are in the command level thread (used to
- ; avoid sending upcalls to whomever is running us).
- (define $command-level-thread? (make-fluid #f))
- (define (on-command-level-thread?)
- (fluid $command-level-thread?))
- (define $user-session (make-fluid #f))
- ; If true exceptions cause a new command level to be pushed.
- (define push-command-levels?
- (user-context-accessor 'push-command-levels (lambda () #t)))
- (define set-push-command-levels?!
- (user-context-modifier 'push-command-levels))
- ; Have THREAD be sent an event when an interrupt occurs.
- (define (notify-on-interrupts thread)
- (set-interrupt-handler! (enum interrupt keyboard)
- (lambda stuff
- (schedule-event thread
- (enum event-type interrupt)
- (enum interrupt keyboard))))
- (call-before-heap-overflow!
- (lambda stuff
- (schedule-event thread
- (enum event-type interrupt)
- (enum interrupt post-major-gc))))
- (call-when-deadlocked!
- (lambda stuff
- (schedule-event thread
- (enum event-type deadlock)))))
- (define (ignore-further-interrupts)
- (set-interrupt-handler! (enum interrupt keyboard)
- (lambda stuff
- (signal-condition
- (condition
- (make-interrupt-condition (enum interrupt keyboard))
- (make-irritants-condition stuff)
- (make-who-condition 'ignore-further-interrupts)))))
- (call-before-heap-overflow! (lambda stuff #f))
- (call-when-deadlocked! #f))
- ; Handler for the command-levels thread. Warnings and notes are printed,
- ; errors cause an exit. This handler is used to catch errors before they
- ; go to the
- (define (command-levels-condition-handler c next-handler)
- (cond ((or (warning? c)
- (note? c))
- (force-output (current-output-port)) ; keep synchronous
- (display-condition c (current-error-port)
- (condition-writing-depth) (condition-writing-length))
- (unspecific)) ; proceed
- ((serious-condition? c)
- (force-output (current-output-port)) ; keep synchronous
- (display-condition c (current-error-port)
- (condition-writing-depth) (condition-writing-length))
- (scheme-exit-now 1))
- (else
- (next-handler))))
- ;----------------------------------------------------------------
- ; Grab the current continuation, then make a command level and run it.
- ;
- ; The double-paren around the CWCC is because it returns a continuation which
- ; is the thing to do after the command level exits.
- ;
- ; Should this detect the difference between normal termination and a throw
- ; out?
- (define (really-push-command-level condition inspecting? dynamic-env levels)
- ((call-with-current-continuation
- (lambda (throw)
- (let ((level (make-command-level condition
- inspecting?
- (preserve-interaction-env dynamic-env)
- levels
- throw)))
- (let-fluid $current-level level
- (lambda ()
- (dynamic-wind
- (lambda ()
- (if (command-level-terminated? level)
- (assertion-violation 'really-push-command-level
- "trying to throw back into a command level"
- level)))
- (lambda ()
- (run-command-level level #f))
- (lambda ()
- (if (command-level-terminated? level)
- (warning 'really-push-command-level
- "abandoning failed level-termination unwinds."
- level)
- (begin
- (set-command-level-terminated?! level #t)
- (terminate-level level))))))))))))
- ; Rebind the interaction environment so that side-effects to it are local
- ; to a command level.
- (define (preserve-interaction-env dynamic-env)
- (let ((old (get-dynamic-env)))
- (set-dynamic-env! dynamic-env)
- (let ((new (with-interaction-environment (interaction-environment)
- get-dynamic-env)))
- (set-dynamic-env! old)
- new)))
- ; Fluid to tell us what the current level is. This is only visible in the
- ; command-levels thread.
- (define $current-level (make-fluid #f))
- (define (terminate-level level)
- (let ((threads (exact-command-level-threads level))
- (*out?* #f))
- (for-each (lambda (thread)
- (if (thread-continuation thread)
- (terminate-level-thread thread level)))
- threads)
- (dynamic-wind
- (lambda ()
- (if *out?*
- (assertion-violation 'terminate-level
- "trying to throw back into a command level" level)))
- (lambda ()
- (run-command-level level (length threads)))
- (lambda ()
- (set! *out?* #t)
- (let ((levels (command-level-levels level)))
- (if (not (null? levels))
- (reset-command-input! (car levels))))))))
- ; Put the thread on the runnable queue if it is not already there and then
- ; terminate it. Termination removes the thread from any blocking queues
- ; and interrupts with a throw that will run any pending dynamic-winds.
- (define (terminate-level-thread thread level)
- (let ((queue (command-level-queue level)))
- (if (not (on-queue? queue thread))
- (enqueue! queue thread))
- (terminate-thread! thread)))
- (define (reset-command-input! level)
- (let ((repl (command-level-repl-thread level)))
- (if repl
- (interrupt-thread repl
- (lambda return-values
- (signal-condition the-reset-command-input-condition)
- (apply values return-values))))))
- (define-condition-type &reset-command-input &condition
- make-reset-command-input-condition
- reset-command-input-condition?)
- (define the-reset-command-input-condition
- (make-reset-command-input-condition))
- ; Make sure the input and output ports are available and then run the threads
- ; on LEVEL's queue.
- ; TERMINATE-COUNT is a number if we're terminating, indicating the
- ; exact number of threads that must still terminate. Note that the
- ; current value of the thread counter is not a good indication, as it
- ; includes threads that have died a quiet death by garbage collection:
- ; We'll never see them again, but if they were included in the count,
- ; the thread system would falsely detect deadlock.
- (define (run-command-level level terminate-count)
- (let ((counter (command-level-thread-counter level))
- (terminating? (and terminate-count #t)))
- (if terminating?
- (set-counter! counter terminate-count)
- (set-exit-status! #f))
- (run-threads
- (round-robin-event-handler (command-level-queue level)
- command-quantum
- (unspecific)
- counter
- (command-level-event-handler level terminating?)
- command-level-upcall-handler
- (command-level-wait level terminating?)))))
- ; The number of milliseconds per timeslice in the command interpreter
- ; scheduler. Should be elsewhere?
- (define command-quantum 200)
- ; Handling events.
- ; SPAWNED and RUNNABLE events require putting the job on the correct queue.
- ; A keyboard interrupt exits when in batch mode and pushes a new command
- ; level otherwise.
- (define (command-level-event-handler level terminating?)
- (let ((levels (cons level (command-level-levels level))))
- (lambda (event args)
- (enum-case event-type event
- ((spawned)
- (spawn-thread-on-command-level level (car args))
- #t)
- ((runnable)
- (let* ((thread (car args))
- (level (thread-data thread)))
- (cond ((not (command-level? level))
- (assertion-violation
- 'command-level-event-handler
- "non-command-level thread restarted on a command level"
- level thread))
- ((memq level levels)
- (enqueue! (command-level-queue level) thread))
- (else
- (warning 'command-level-event-handler
- "dropping thread from exited command level"
- level thread)))
- #t))
- ((interrupt)
- (if terminating?
- (warning 'command-level-event-handler
- "Interrupted while unwinding terminated level's threads."
- level))
- (let ((int (car args)))
- (quit-or-push-level
- (condition
- (make-message-condition
- (enum-case interrupt int
- ((keyboard) "keyboard interrupt")
- ((post-major-gc) "insufficient memory after major GC")
- (else "interrupt")))
- (make-interrupt-condition int)
- (make-who-condition 'command-level-event-handler)
- (make-irritants-condition
- (list
- (enumerand->name int interrupt))))
- levels))
- #t)
- ((deadlock)
- (if terminating?
- (warning 'command-level-event-handler
- "Deadlocked while unwinding terminated level's threads."
- level))
- (quit-or-push-level (make-deadlock-condition) levels)
- #t)
- (else
- #f)))))
- (define (quit-or-push-level condition levels)
- (if (batch-mode?)
- ((command-level-throw (last levels)) (lambda () (lambda () 0)))
- (really-push-command-level condition
- #f
- (command-level-dynamic-env (car levels))
- levels)))
- ; Wait for events if there are blocked threads, otherwise add a new REPL
- ; thread if we aren't on the way out.
- (define (command-level-wait level terminating?)
- (lambda ()
- (cond ((positive? (counter-value (command-level-thread-counter level)))
- (wait-for-event)
- #t)
- (terminating?
- #f)
- ((exit-status)
- (exit-levels level (exit-status)))
- (else
- (warning 'command-level-wait
- "command interpreter has died; restarting" level)
- (spawn-repl-thread! level)
- #t))))
- ; Leave the command-level system with STATUS.
- (define (exit-levels level status)
- (let ((top-level (last (cons level (command-level-levels level)))))
- ((command-level-throw top-level)
- (lambda () (lambda () status)))))
- ;----------------------------------------------------------------
- ; Upcalls
- ; The tokens are records which have contain the upcall procedure.
- (define command-level-upcall-handler
- (lambda (thread token args)
- (if (upcall? token)
- (apply (upcall-procedure token) args)
- (begin
- (propogate-upcall thread token args)))))
- (define-record-type upcall :upcall
- (make-upcall procedure id)
- upcall?
- (procedure upcall-procedure)
- (id upcall-id))
- (define-record-discloser :upcall
- (lambda (upcall)
- (list 'upcall-token (upcall-id upcall))))
- ; If we are already in the command-level thread we just make the call;
- ; if not, we have to actually do the upcall.
- (define-syntax define-upcall
- (syntax-rules ()
- ((define-upcall (id args ...) . body)
- (define id
- (let ((token (make-upcall (lambda (args ...) . body)
- 'id)))
- (lambda (args ...)
- (if (on-command-level-thread?)
- ((upcall-procedure token) args ...)
- (upcall token args ...))))))))
- ;----------------
- ; The current command level and friends
- ; Return the current command level.
- (define-upcall (command-level)
- (fluid $current-level))
- ; Return the current list of command levels.
- (define (command-levels)
- (let ((current-level (command-level)))
- (cons current-level
- (command-level-levels current-level))))
- ; Top-most command level.
- (define (top-command-level)
- (last (command-levels)))
- ;----------------
- ; Menus and the value stack.
- (define (maybe-menu)
- (command-level-menu (command-level)))
- (define (set-menu! value)
- (set-command-level-menu! (command-level) value))
- (define (menu-position)
- (command-level-menu-position (command-level)))
- (define (set-menu-position! value)
- (set-command-level-menu-position! (command-level) value))
- (define (value-stack)
- (command-level-value-stack (command-level)))
- (define (set-value-stack! value)
- (set-command-level-value-stack! (command-level) value))
- ;----------------
- ; User session
- (define-upcall (user-session)
- (fluid $user-session))
- ;----------------
- ; Command-level control
- (define-upcall (terminate-command-processor! status)
- (set-exit-status! status)
- (let* ((level (command-level))
- (repl-thread (command-level-repl-thread level)))
- (if repl-thread
- (begin
- (set-command-level-repl-thread! level #f)
- (terminate-thread! repl-thread)))))
- (define-upcall (push-command-level-upcall condition inspecting?
- thread dynamic-env)
- (set-command-level-paused-thread! (command-level) thread)
- (really-push-command-level condition
- inspecting?
- dynamic-env
- (command-levels)))
- ; Have to grab the current thread and dynamic environment before making the
- ; upcall.
- (define (push-command-level condition inspecting?)
- (push-command-level-upcall condition
- inspecting?
- (current-thread)
- (get-dynamic-env)))
- (define-upcall (throw-to-command-level level thunk)
- ((command-level-throw level) thunk))
- ; This makes a new level just like the old one.
- (define (restart-command-level level)
- (throw-to-command-level
- level
- (lambda ()
- (really-push-command-level (command-level-condition level)
- #f ; drop the old value stack
- (command-level-dynamic-env level)
- (command-level-levels level)))))
- ; Proceed with LEVEL causing RETURN-VALUES to be returned from the
- ; PUSH-COMMAND-LEVELS call that started LEVEL.
- (define (proceed-with-command-level level . return-values)
- (throw-to-command-level (level-pushed-from level)
- (lambda ()
- (apply values return-values))))
- ; Find the level that was pushed from LEVEL.
- (define (level-pushed-from level)
- (let loop ((levels (command-levels)))
- (cond ((null? (cdr levels))
- (assertion-violation 'level-pushed-from "level not found" level))
- ((eq? level (cadr levels))
- (car levels))
- (else
- (loop (cdr levels))))))
- ; Kill the thread on LEVEL that caused a new level to be pushed. This is
- ; used when the user wants to continue running the rest of LEVEL's threads.
- ; We enqueue the paused thread so that its dynamic-winds will be run.
- (define (kill-paused-thread! level)
- (let ((paused (command-level-paused-thread level)))
- (if paused
- (begin
- (if (eq? paused (command-level-repl-thread level))
- (spawn-repl-thread! level))
- (terminate-thread! paused) ; it's already running, so no enqueue
- (set-command-level-paused-thread! level #f))
- (warning 'kill-paused-thread! "level has no paused thread" level))))
|