From 2f7595603b87574ae9c319b59c13d0286ae03df6 Mon Sep 17 00:00:00 2001 From: eknauel Date: Fri, 3 Jun 2005 11:44:53 +0000 Subject: [PATCH] First version of the job control --- scheme/go | 4 +- scheme/gogo | 2 +- scheme/job.scm | 141 +++++++++++++++++++++++++++++++++++++++ scheme/nuit-engine.scm | 43 +++++++++++- scheme/nuit-packages.scm | 44 +++++++++++- 5 files changed, 227 insertions(+), 7 deletions(-) create mode 100644 scheme/job.scm diff --git a/scheme/go b/scheme/go index 118b62a..4dfa23a 100755 --- a/scheme/go +++ b/scheme/go @@ -1,5 +1,5 @@ #!/bin/sh -args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit" +args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit" echo "Starting scsh with options: $args" exec scsh $args -#-c "(nuit)" \ No newline at end of file +#-c "(nuit)" diff --git a/scheme/gogo b/scheme/gogo index 689c64e..280c9e7 100755 --- a/scheme/gogo +++ b/scheme/gogo @@ -1,3 +1,3 @@ #!/bin/sh -args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit" +args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit" exec scsh $args -c "(nuit)" diff --git a/scheme/job.scm b/scheme/job.scm new file mode 100644 index 0000000..12035b4 --- /dev/null +++ b/scheme/job.scm @@ -0,0 +1,141 @@ +(define-record-type job :job + (make-job name pty-in pty-out proc status) + job? + (name job-name) + (pty-in job-pty-in) + (pty-out job-pty-out) + (proc job-proc) + (status really-job-status)) + +(define (make-job name pty-in pty-out proc) + (let ((job (make-job name pty-in pty-out proc + (make-placeholder)))) + (spawn-job-status-surveillant job) + (add-job! job) + job)) + +(define (job-status-rv job) + (placeholder-value-rv (really-job-status job))) + +(define (job-status job) + (sync (job-status-rv job))) + +(define (spawn-job-status-surveillant job) + (let ((channel (make-channel))) + (spawn + (lambda () + (placeholder-set! + (really-job-status job) (wait (job-proc))))))) + +(define (signal-job signal job) + (signal-process-group signal (job-proc job))) + +(define (stop-job job) + (signal-job signal/stop job)) + +(define (continue-job job) + (signal-process-group signal/cont job)) + +;; channels for communicating with the joblist surveillant + +(define add-job-channel + (make-channel)) + +(define get-job-list-channel + (make-channel)) + +(define (add-job! job) + (send add-job-channel job)) + +(define (running-jobs) + (let ((answer-channel (make-channel))) + (send get-job-list-channel (cons 'running answer-channel)) + (receive answer-channel))) + +(define (ready-jobs) + (let ((answer-channel (make-channel))) + (send get-job-list-channel (cons 'ready answer-channel)) + (receive answer-channel))) + +(define (jobs-with-new-output) + (let ((answer-channel (make-channel))) + (send get-job-list-channel (cons 'new-output answer-channel)) + (receive answer-channel))) + +(define (jobs-waiting-for-input) + (let ((answer-channel (make-channel))) + (send get-job-list-channel (cons 'waiting-for-input answer-channel)) + (receive answer-channel))) + +(define (spawn-joblist-surveillant) + (let ((statistics-channel (make-channel))) + (spawn + (lambda () + (let lp ((running '()) + (ready '()) + (new-output '()) + (waiting-for-input '()) + (notify? #f)) + (cond + (notify? + (send statistics-channel + (list (cons 'running (length running)) + (cons 'ready (length ready)) + (cons 'new-output (length new-output)) + (cons 'waiting-for-input (length waiting-for-input)))) + (lp running ready new-output waiting-for-input #f)) + (else + (apply + select + (append + (list + (wrap (receive-rv add-job-channel) + (lambda (new-job) + (lp (cons new-job running) + ready new-output waiting-for-input #t))) + + (wrap (receive-rv get-job-list-channel) + (lambda (state.channel) + (send (cdr state.channel) + (case (car state.channel) + ((running) running) + ((ready) ready) + ((new-output) new-output) + ((waiting-for-input) waiting-for-input) + (else + (error "joblist-surveillant" state.channel)))) + (lp running ready new-output waiting-for-input #f)))) + + (map (lambda (job) + (wrap (job-status-rv job) + (lambda (ignore) + (lp (delete job running) + (cons job ready) + new-output + waiting-for-input #t)))) + running)))))))) + statistics-channel)) + +(define (initial-job-statistics) + (list (cons 'running 0) + (cons 'ready 0) + (cons 'new-output 0) + (cons 'waiting-for-input 0))) + +;; #### unfinished +(define (install-terminal/stop-handler) + (set-interrupt-handler + interrupt/tstp + (lambda args + (display args)))) + +(define-syntax run-as-background-job + (syntax-rules () + ((_ epf) + (call-with-values + (lambda () + (fork-pty-session + (lambda () + (exec-epf epf)))) + (lambda (proc pty-in pty-out tty-name) + (make-job (quote epf) pty-in pty-out proc)))))) diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 5916574..288ffb7 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -305,11 +305,20 @@ (init-windows!) (init-executables-completion-set!) + ;; init joblist + (let ((statistics-channel (spawn-joblist-surveillant))) + (spawn + (lambda () + (let lp ((stats (cml-receive statistics-channel))) + (debug-message "statistics update " stats) + (paint-command-frame-window) + (paint-job-status-list stats) + (paint-command-window-contents) + (refresh-command-window) + (lp (cml-receive statistics-channel)))))) + (set-process-group (pid) (pid)) (set-tty-process-group (current-input-port) (pid)) - (set-interrupt-handler interrupt/tstp - (lambda a - (debug-message "SIGTSTP"))) '(set-interrupt-handler interrupt/keyboard (lambda a @@ -536,8 +545,36 @@ (box (app-window-curses-win command-frame-window) (ascii->char 0) (ascii->char 0)) (paint-command-buffer-mode-indicator) + (paint-job-status-list) (wrefresh (app-window-curses-win command-frame-window))) +(define paint-job-status-list + (let ((latest-statistics (initial-job-statistics))) + (lambda args + (let-optionals args + ((statistics latest-statistics)) + (let* ((stat-item (lambda (text number) + (string-append text (number->string number)))) + (stat + (string-join + (map + (lambda (status.count) + (case (car status.count) + ((running) (stat-item "run:" (cdr status.count))) + ((ready) (stat-item "ready:" (cdr status.count))) + ((new-output) (stat-item "out:" (cdr status.count))) + ((waiting-for-input) (stat-item "in:" (cdr status.count))))) + statistics))) + (line (string-append "[ " stat " ]"))) + (set! latest-statistics statistics) + (mvwaddstr + (app-window-curses-win command-frame-window) + (- (app-window-height command-frame-window) 1) + (- (- (app-window-width command-frame-window) + (string-length line)) + 2) + line)))))) + (define (paint-command-window-contents) (set-buffer-num-lines! command-buffer (- (app-window-height command-window) 2)) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index bc18706..4aae8ed 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -329,13 +329,46 @@ thread-fluids) (files complete)) +;;; jobs and joblist + +(define-interface job-interface + (export make-job + job-status + job-status-rv + signal-job + stop-job + continue-job + (run-as-background-job :syntax))) + +(define-interface joblist-interface + (export running-jobs + ready-jobs + jobs-with-new-output + jobs-waiting-for-input + spawn-joblist-surveillant + initial-job-statistics)) + +(define-structures ((jobs job-interface) + (joblist joblist-interface)) + (open (modify scheme-with-scsh + (hide receive select)) + define-record-types + threads + srfi-1 + signals + + rendezvous + rendezvous-channels + rendezvous-placeholders) + (files job)) + ;;; nuit (define-interface nuit-interface (export nuit)) (define-structure nuit nuit-interface - (open scheme-with-scsh + (open (modify scheme-with-scsh (hide receive)) external-calls define-record-types conditions @@ -352,6 +385,13 @@ inspect-exception rt-modules tty-debug + threads + rendezvous + (modify rendezvous-channels + (rename + (send cml-send) + (receive cml-receive))) + let-opt focus-table nuit-eval/focus-table @@ -365,6 +405,8 @@ handle-fatal-error completion-sets select-list + jobs + joblist ;; the following modules are plugins dirlist-view-plugin user-group-info-plugin