scsh-0.6/scheme/env/command-level.scm

538 lines
18 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Command levels for the command processor
; The command processor's state is divided into three parts:
; 1. User context - preserved across dump commands.
; This includes the designated user and configuration environments.
; 2. Session state - one per "login"; not preserved across dump commands.
; This includes ## and the command loop's interactive ports.
; 3. Command levels - one for each different command level.
; This includes the threads being run at that level and the condition
; that caused the level to be pushed, if any.
;
; 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.
;----------------
; User context.
;
; The is a symbol table stored in a slot in the session state (see below).
; *USER-CONTEXT-INITIALIZERS* is a list of (<name> . <initial-value-thunk>)
; pairs. The <thunk>s are called to get the initial value of the <name>d
; slots.
(define (make-user-context)
(make-symbol-table))
(define (initialize-user-context!)
(let ((t (user-context)))
(for-each (lambda (name+thunk)
(table-set! t (car name+thunk) ((cdr name+thunk))))
*user-context-initializers*)
t))
(define *user-context-initializers* '())
; Add a new slot to the user context.
(define (user-context-accessor name initializer)
(set! *user-context-initializers*
(append *user-context-initializers*
(list (cons name initializer))))
(let ((context (user-context)))
(if context
(table-set! context name (initializer))))
(lambda ()
(table-ref (or (user-context)
(error "command interpreter not initialized - no user context"
name))
name)))
(define (user-context-modifier name)
(lambda (new)
(table-set! (or (user-context)
(error "command interpreter not initialized - no user context"
name))
name
new)))
; There are a few places that have alternate behavior based on this, but mostly
; it's used to detect premature uses of the user context.
(define (user-context)
(if (session-started?)
(real-user-context)
#f))
;----------------
; Session state.
; This is a record stored in the session data.
; It has the command interpreter's ports, the most recent values returned
; by a command, an exit status, and the batch-mode and break-on-warnings
; switches.
(define-record-type session :session
(make-session command-thread
user-context
input-port output-port error-port
focus-values
exit-status
batch-mode? break-on-warnings?)
session?
(command-thread session-command-thread)
(user-context session-user-context)
(input-port session-input-port)
(output-port session-output-port)
(error-port session-error-port)
(focus-values session-focus-values set-session-focus-values!)
(exit-status session-exit-status set-session-exit-status!)
(batch-mode? session-batch-mode? set-session-batch-mode?!)
(break-on-warnings? session-break-on-warnings? set-session-break-on-warnings?!))
(define session-slot (make-session-data-slot! #f))
(define (session-started?)
(session? (session-data-ref session-slot)))
(define (session-accessor accessor)
(lambda () (accessor (session-data-ref session-slot))))
(define (session-modifier modifier)
(lambda (new) (modifier (session-data-ref session-slot) new)))
(define command-thread (session-accessor session-command-thread))
(define real-user-context (session-accessor session-user-context))
(define command-input (session-accessor session-input-port))
(define command-output (session-accessor session-output-port))
(define command-error-output (session-accessor session-error-port))
(define focus-values (session-accessor session-focus-values))
(define set-focus-values! (session-modifier set-session-focus-values!))
(define batch-mode? (session-accessor session-batch-mode?))
(define set-batch-mode?! (session-modifier set-session-batch-mode?!))
(define break-on-warnings? (session-accessor session-break-on-warnings?))
(define set-break-on-warnings?! (session-modifier set-session-break-on-warnings?!))
(define exit-status (session-accessor session-exit-status))
(define set-exit-status! (session-modifier set-session-exit-status!))
; Log in
(define (start-new-session context iport oport eport resume-args batch?)
(session-data-set! session-slot
(make-session (current-thread)
context
iport oport eport
resume-args
#f ; no exit status yet
batch?
#f))) ; don't break on warnings
;----------------
; Command levels
(define-record-type command-level :command-level
(really-make-command-level queue thread-counter dynamic-env
levels throw repl-thunk repl-data 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
(repl-thunk command-level-repl-thunk) ; thunk to (re)start level
(repl-data command-level-repl-data set-command-level-repl-data!)
; data used by REPL
(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 repl-thunk repl-data dynamic-env levels throw)
(let ((level (really-make-command-level (make-queue)
1999-09-14 08:45:02 -04:00
(make-counter)
dynamic-env
levels
throw
repl-thunk
repl-data
#f ; paused thread
#f))) ; undetermined thread list
(spawn-repl-thread! level)
level))
; Add THUNK as an 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 (command-level-dynamic-env level) id)))
1999-09-14 08:45:02 -04:00
(set-thread-scheduler! thread (command-thread))
(set-thread-data! thread level)
(enqueue! (command-level-queue level) thread)
1999-09-14 08:45:02 -04:00
(increment-counter! (command-level-thread-counter level))
thread))
; Add a new REPL thread to LEVEL.
(define (spawn-repl-thread! level)
(let ((thread (spawn-on-command-level level
(command-level-repl-thunk level)
'command-loop)))
(set-command-level-repl-thread! level thread)))
; 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
(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 session,
; runs an initial thunk and then pushes a command level.
(define (start-command-levels resume-args context
start-thunk repl-thunk repl-data)
(notify-on-interrupts (current-thread))
(start-new-session (or context (make-user-context))
(current-input-port)
(current-output-port)
(current-error-port)
resume-args
(and (pair? resume-args)
(equal? (car resume-args) "batch")))
(if (not context)
(initialize-user-context!))
(start-thunk)
(let ((thunk (really-push-command-level repl-thunk
repl-data
(get-dynamic-env)
'())))
(ignore-further-interrupts)
thunk))
; If true exceptions cause a new command level to be pushed.
(define push-command-levels?
(user-context-accessor 'push-command-levels (lambda () #t)))
(define (notify-on-interrupts thread)
;;; low-interrupt registers for this interrupt
;;; sighandler will throw this event as default
; (set-interrupt-handler (enum interrupt keyboard)
; (lambda stuff
; (schedule-event thread
; (enum event-type interrupt)
; (enum interrupt keyboard))))
1999-09-14 08:45:02 -04:00
(call-before-heap-overflow!
(lambda stuff
(schedule-event thread
(enum event-type interrupt)
(enum interrupt post-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
(apply signal (cons 'interrupt stuff))))
(call-before-heap-overflow! (lambda stuff #f))
(call-when-deadlocked! #f))
; The number of milliseconds per timeslice in the command interpreter
; scheduler. Should be elsewhere?
(define command-quantum 200)
; 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.
(define (really-push-command-level repl-thunk repl-data dynamic-env levels)
((call-with-current-continuation
(lambda (throw)
(let ((*out?* #f)
(level (make-command-level repl-thunk repl-data dynamic-env
levels throw)))
(dynamic-wind
(lambda ()
(if *out?*
(error "can't throw back into a command level" level)))
(lambda ()
(run-command-level level #f))
(lambda ()
(set! *out?* #t)
(terminate-level level))))))))
(define (terminate-level level)
(let ((threads (command-level-threads level))
(queue (command-level-queue level))
(*out?* #f))
(for-each (lambda (thread)
(if (thread-continuation thread)
(terminate-level-thread thread level)))
1999-09-14 08:45:02 -04:00
threads)
(dynamic-wind
(lambda ()
(if *out?*
(error "can't throw back into a command level" level)))
(lambda ()
(run-command-level level #t))
(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? thread queue))
(enqueue! queue thread))
(terminate-thread! thread)))
1999-09-14 08:45:02 -04:00
(define (reset-command-input! level)
(let ((repl (command-level-repl-thread level)))
(if repl
(interrupt-thread repl
(lambda return-values
(signal 'reset-command-input)
(apply values return-values))))))
(define-condition-type 'reset-command-input '())
(define reset-command-input? (condition-predicate 'reset-command-input))
; Make sure the input and output ports are available and then run the threads
; on LEVEL's queue.
(define (run-command-level level terminating?)
(if (not terminating?)
(begin
(set-exit-status! #f)
1999-09-16 12:18:05 -04:00
(steal-port! (command-input))
(steal-port! (command-output))
1999-09-23 10:36:25 -04:00
(steal-port! (command-error-output))))
1999-09-14 08:45:02 -04:00
(run-threads
(round-robin-event-handler (command-level-queue level)
command-quantum
(unspecific)
(command-level-thread-counter level)
(command-level-event-handler level terminating?)
(command-level-upcall-handler level)
(command-level-wait level terminating?))))
; 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-on-command-level level (car args) (cadr args))
1999-09-14 08:45:02 -04:00
#t)
((narrowed)
(handle-narrow-event command-quantum
(command-level-dynamic-env level)
args)
#t)
1999-09-14 08:45:02 -04:00
((runnable)
(let* ((thread (car args))
(level (thread-data thread)))
(cond ((not (command-level? level))
(error "non-command-level thread restarted on a command level"
thread))
((memq level levels)
(enqueue! (command-level-queue level) thread))
1999-09-14 08:45:02 -04:00
(else
(warn "dropping thread from exited command level"
thread)))
#t))
((interrupt)
(if terminating?
(warn "Interrupted while unwinding terminated level's threads."))
(quit-or-push-level (make-condition 'interrupt args) levels)
#t)
((deadlock)
(if terminating?
(warn "Deadlocked while unwinding terminated level's threads."))
(quit-or-push-level (make-condition 'error (list 'deadlocked))
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 (command-level-repl-thunk (last levels))
condition
(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 ((< 0 (counter-value (command-level-thread-counter level)))
(wait))
((exit-status)
(exit-levels level (exit-status)))
(terminating?
#f)
(else
(warn "command interpreter has died; restarting")
(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:
; return the current command levels
; (command-levels) -> list of levels
; exit from LEVEL and calls THUNK
; (throw-to-command-level level thunk)
; push a new command level
; (push-command-level repl-thunk repl-data dynamic-env)
; stop running a repl
; (terminate-repl status)
(define (command-level-upcall-handler level)
(let ((levels (cons level (command-level-levels level))))
(lambda (thread token args)
(cond ((eq? token command-levels-token)
levels)
((eq? token throw-to-command-level-token)
; arguments are LEVEL THUNK
((command-level-throw (car args)) (cadr args)))
((eq? token push-command-level-token)
; arguments are CALLING-THREAD REPL-THUNK DYNAMIC-ENV
(set-command-level-paused-thread! level (car args))
(really-push-command-level (cadr args) (caddr args) (cadddr args)
levels))
((eq? token terminate-repl-token)
(set-exit-status! (car args))
(let ((repl-thread (command-level-repl-thread level)))
(if repl-thread
(begin
(set-command-level-repl-thread! level #f)
(terminate-level-thread repl-thread level)))))
1999-09-14 08:45:02 -04:00
((eq? token repl-data-token)
(command-level-repl-data level))
((eq? token set-repl-data!-token)
(set-command-level-repl-data! level (car args)))
(else
(propogate-upcall thread token args))))))
(define command-levels-token (list 'command-levels-token))
(define push-command-level-token (list 'push-command-level-token))
(define throw-to-command-level-token (list 'throw-to-command-level-token))
(define terminate-repl-token (list 'terminate-repl-token))
(define repl-data-token (list 'repl-data-token))
(define set-repl-data!-token (list 'set-repl-data!-token))
(define (repl-data)
(upcall repl-data-token))
(define (set-repl-data! value)
(upcall set-repl-data!-token value))
(define (terminate-command-processor! status)
(upcall terminate-repl-token status))
(define (command-levels)
(upcall command-levels-token))
(define (command-level)
(car (command-levels)))
(define (top-command-level)
(last (command-levels)))
; Command level control
(define (push-command-level thunk data)
(upcall push-command-level-token (current-thread) thunk data (get-dynamic-env)))
(define (throw-to-command-level level thunk)
(upcall throw-to-command-level-token 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-repl-thunk level)
(command-level-repl-data level)
(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))
(error "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))
(warn "level has no paused thread" level))))