scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Keep separate queues for input and output channels, so the VM doesn't 

get confused handling events/interrupts.
I despise myself.
This commit is contained in:
sperber 2002-09-18 14:56:31 +00:00
parent 45388f2c12
commit d21334de83
3 changed files with 128 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
scheme/vm/interfaces.scm
View File

@ -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
))

19
scheme/vm/interrupt.scm
View File

@ -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)))

161
scheme/vm/vmio.scm
View File

@ -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.