diff --git a/scheme/vm/interfaces.scm b/scheme/vm/interfaces.scm index 0f69338..dff8bbb 100644 --- a/scheme/vm/interfaces.scm +++ b/scheme/vm/interfaces.scm @@ -330,9 +330,12 @@ output-channel? open? - channel-queue-empty? - enqueue-channel! - dequeue-channel! + input-channel-queue-empty? + output-channel-queue-empty? + enqueue-input-channel! + dequeue-input-channel! + enqueue-output-channel! + dequeue-output-channel! vm-channel-abort )) diff --git a/scheme/vm/interrupt.scm b/scheme/vm/interrupt.scm index b066cdc..f9521e7 100644 --- a/scheme/vm/interrupt.scm +++ b/scheme/vm/interrupt.scm @@ -58,10 +58,17 @@ (set! *finalize-these* null) (push (enter-fixnum *enabled-interrupts*)) 2) - ((or (eq? pending-interrupt (enum interrupt i/o-read-completion)) - (eq? pending-interrupt (enum interrupt i/o-write-completion))) - (let ((channel (dequeue-channel!))) - (if (not (channel-queue-empty?)) + ((eq? pending-interrupt (enum interrupt i/o-read-completion)) + (let ((channel (dequeue-input-channel!))) + (if (not (input-channel-queue-empty?)) + (note-interrupt! pending-interrupt)) + (push channel) + (push (channel-os-status channel)) + (push (enter-fixnum *enabled-interrupts*)) + 3)) + ((eq? pending-interrupt (enum interrupt i/o-write-completion)) + (let ((channel (dequeue-output-channel!))) + (if (not (output-channel-queue-empty?)) (note-interrupt! pending-interrupt)) (push channel) (push (channel-os-status channel)) @@ -234,10 +241,10 @@ ((eq? event (enum events keyboard-interrupt-event)) (interrupt-bit (enum interrupt keyboard))) ((eq? event (enum events io-read-completion-event)) - (enqueue-channel! channel status) + (enqueue-input-channel! channel status) (interrupt-bit (enum interrupt i/o-read-completion))) ((eq? event (enum events io-write-completion-event)) - (enqueue-channel! channel status) + (enqueue-output-channel! channel status) (interrupt-bit (enum interrupt i/o-write-completion))) ((eq? event (enum events os-signal-event)) (interrupt-bit (enum interrupt os-signal))) diff --git a/scheme/vm/vmio.scm b/scheme/vm/vmio.scm index 34f9358..46bda39 100644 --- a/scheme/vm/vmio.scm +++ b/scheme/vm/vmio.scm @@ -38,8 +38,10 @@ (output-port->channel (current-error-port))))))) (set! *vm-channels* (make-vector *number-of-channels* (input-port->channel (current-input-port)))) - (set! *pending-channels-head* false) - (set! *pending-channels-tail* false) + (set! *pending-input-channels-head* false) + (set! *pending-input-channels-tail* false) + (set! *pending-output-channels-head* false) + (set! *pending-output-channels-tail* false) (if (null-pointer? *vm-channels*) (error "out of memory, unable to continue")) (vector+length-fill! *vm-channels* *number-of-channels* false) @@ -115,7 +117,10 @@ (let ((old-index (extract-fixnum (channel-os-index channel)))) (if (vm-eq? (channel-os-status channel) true) - (enqueue-channel! old-index (channel-abort old-index))) + (if (or (= input-status (channel-status channel)) + (= special-input-status (channel-status channel))) + (enqueue-input-channel! old-index (channel-abort old-index)) + (enqueue-output-channel! old-index (channel-abort old-index)))) (vector-set! *vm-channels* old-index false) (vector-set! *vm-channels* os-index channel) (set-channel-os-index! channel (enter-fixnum os-index)) @@ -151,7 +156,10 @@ (let ((os-index (extract-fixnum (channel-os-index channel)))) (if (vm-eq? (channel-os-status channel) true) - (enqueue-channel! os-index (channel-abort os-index))) + (if (or (= input-status (channel-status channel)) + (= special-input-status (channel-status channel))) + (enqueue-input-channel! os-index (channel-abort os-index)) + (enqueue-output-channel! os-index (channel-abort os-index)))) (let ((status (if (or (= input-status (channel-status channel)) (= special-input-status (channel-status channel))) (close-input-channel os-index) @@ -221,66 +229,115 @@ ; ; WindowsNT: we will need a fancier GC or something. -; These are a queue of channels with pending interrupts +; These are queues of channels with pending interrupts -(define *pending-channels-head* false) -(define *pending-channels-tail* false) +(define *pending-input-channels-head* false) +(define *pending-input-channels-tail* false) -(define (channel-queue-empty?) - (false? *pending-channels-head*)) +(define *pending-output-channels-head* false) +(define *pending-output-channels-tail* false) -(define (enqueue-channel! index status) - (let ((channel (os-index->channel index))) - (set-channel-os-status! channel (enter-fixnum status)) - (cond ((not (false? (channel-next channel))) ; already queued (how?) - (unspecific)) ; for the type checker - ((false? *pending-channels-head*) - (set! *pending-channels-head* channel) - (set! *pending-channels-tail* channel)) - (else - (set-channel-next! *pending-channels-tail* channel) - (set! *pending-channels-tail* channel))))) +(define (input-channel-queue-empty?) + (false? *pending-input-channels-head*)) -(define (dequeue-channel!) - (let* ((channel *pending-channels-head*) - (next (channel-next channel))) - (set! *pending-channels-head* next) - (set-channel-next! channel false) - (if (false? next) - (set! *pending-channels-tail* false)) - channel)) +(define (output-channel-queue-empty?) + (false? *pending-output-channels-head*)) + +(define-syntax define-enqueue-channel! + (syntax-rules () + ((define-enqueue-channel! name *head* *tail*) + (define (name index status) + (let ((channel (os-index->channel index))) + (set-channel-os-status! channel (enter-fixnum status)) + (cond ((not (false? (channel-next channel))) ; already queued (how?) + (unspecific)) ; for the type checker + ((false? *head*) + (set! *head* channel) + (set! *tail* channel)) + (else + (set-channel-next! *tail* channel) + (set! *tail* channel)))))))) + +(define-enqueue-channel! enqueue-input-channel! + *pending-input-channels-head* + *pending-input-channels-tail*) +(define-enqueue-channel! enqueue-output-channel! + *pending-output-channels-head* + *pending-output-channels-tail*) + +(define-syntax define-dequeue-channel! + (syntax-rules () + ((define-dequeue-channel! name *head* *tail*) + (define (name) + (let* ((channel *head*) + (next (channel-next channel))) + (set! *head* next) + (set-channel-next! channel false) + (if (false? next) + (set! *tail* false)) + channel))))) + +(define-dequeue-channel! dequeue-input-channel! + *pending-input-channels-head* + *pending-input-channels-tail*) +(define-dequeue-channel! dequeue-output-channel! + *pending-output-channels-head* + *pending-output-channels-tail*) ; See if a the OS has already finished with CHANNEL and return its status ; if it has. If not, call the OS and have it abort the channel's current ; operation. (define (vm-channel-abort channel) - (let ((head *pending-channels-head*)) - (cond ((false? head) - (set-channel-os-status! channel false) ; no longer pending - (enter-fixnum (channel-abort - (extract-fixnum (channel-os-index channel))))) - ((vm-eq? channel head) - (dequeue-channel!) - (channel-os-status channel)) - (else - (let loop ((ch (channel-next head)) (prev head)) - (cond ((false? ch) - (set-channel-os-status! channel false) ; no longer pending - (enter-fixnum (channel-abort - (extract-fixnum (channel-os-index channel))))) - ((vm-eq? ch channel) - (if (vm-eq? ch *pending-channels-tail*) - (set! *pending-channels-tail* prev)) - (set-channel-next! prev (channel-next ch)) - (set-channel-next! ch false) - (channel-os-status ch)) - (else - (loop (channel-next ch) ch)))))))) + (cond ((and (false? *pending-input-channels-head*) + (false? *pending-output-channels-head*)) + (set-channel-os-status! channel false) ; no longer pending + (enter-fixnum (channel-abort + (extract-fixnum (channel-os-index channel))))) + ((vm-eq? channel *pending-input-channels-head*) + (dequeue-input-channel!) + (channel-os-status channel)) + ((vm-eq? channel *pending-output-channels-head*) + (dequeue-output-channel!) + (channel-os-status channel)) + (else + (let loop ((ch (channel-next *pending-input-channels-head*)) + (prev *pending-input-channels-head*)) + (cond ((false? ch) + (let loop ((ch (channel-next *pending-output-channels-head*)) + (prev *pending-output-channels-head*)) + (cond ((false? ch) + (set-channel-os-status! channel false) ; no longer pending + (enter-fixnum (channel-abort + (extract-fixnum (channel-os-index channel))))) + ((vm-eq? ch channel) + (if (vm-eq? ch *pending-output-channels-tail*) + (set! *pending-output-channels-tail* prev)) + (set-channel-next! prev (channel-next ch)) + (set-channel-next! ch false) + (channel-os-status ch)) + (else + (loop (channel-next ch) ch))))) + + ((vm-eq? ch channel) + (if (vm-eq? ch *pending-input-channels-tail*) + (set! *pending-input-channels-tail* prev)) + (set-channel-next! prev (channel-next ch)) + (set-channel-next! ch false) + (channel-os-status ch)) + + (else + (loop (channel-next ch) ch))))))) (define (trace-io trace-value) - (set! *pending-channels-head* (trace-value *pending-channels-head*)) - (set! *pending-channels-tail* (trace-value *pending-channels-tail*))) + (set! *pending-input-channels-head* + (trace-value *pending-input-channels-head*)) + (set! *pending-input-channels-tail* + (trace-value *pending-input-channels-tail*)) + (set! *pending-output-channels-head* + (trace-value *pending-output-channels-head*)) + (set! *pending-output-channels-tail* + (trace-value *pending-output-channels-tail*))) ;---------------------------------------------------------------- ; Automatically closing channels.