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

; 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)
					  (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)))
    (set-thread-scheduler! thread (command-thread))
    (set-thread-data! thread level)
    (enqueue! (command-level-queue level) thread)
    (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))))
  (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)))
	      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)))

(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)
	(steal-port! (command-input))
	(steal-port! (command-output))
	(steal-port! (command-error-output))))
  (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))
	 #t)
	((narrowed)
	 (handle-narrow-event command-quantum
			      (command-level-dynamic-env level)
			      args)
	 #t)
	((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))
		 (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)))))
 	    ((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))))