scsh-0.6/scheme/vm/vmio.scm

342 lines
12 KiB
Scheme

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file vmio.scm.
; *vm-channels* is a vector of descriptors for open channels.
(define *number-of-channels* 100)
(define *vm-channels*)
(define closed-status
(enter-fixnum (enum channel-status-option closed)))
(define input-status
(enter-fixnum (enum channel-status-option input)))
(define output-status
(enter-fixnum (enum channel-status-option output)))
(define special-input-status
(enter-fixnum (enum channel-status-option special-input)))
(define special-output-status
(enter-fixnum (enum channel-status-option special-output)))
(define (input-channel? channel)
(= (channel-status channel) input-status))
(define (output-channel? channel)
(= (channel-status channel) output-status))
(define (open? channel)
(not (= (channel-status channel) closed-status)))
(define (initialize-i/o-system+gc)
(set! *number-of-channels*
(max *number-of-channels*
(+ 1
(max (input-port->channel (current-input-port))
(max (output-port->channel (current-output-port))
(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)
(if (null-pointer? *vm-channels*)
(error "out of memory, unable to continue"))
(vector+length-fill! *vm-channels* *number-of-channels* false)
(let ((key (ensure-space (* 3 (+ channel-size
(vm-string-size
(string-length "standard output")))))))
(values (make-initial-channel (input-port->channel (current-input-port))
input-status
"standard input"
key)
(make-initial-channel (output-port->channel (current-output-port))
output-status
"standard output"
key)
(make-initial-channel (output-port->channel (current-error-port))
output-status
"standard error"
key))))
(define (make-initial-channel channel status name key)
(let ((vm-channel (make-channel status
(enter-string name key)
(enter-fixnum channel)
false ; next
false ; os-status
key)))
(vector-set! *vm-channels* channel vm-channel)
vm-channel))
(define (os-index->channel index)
(vector-ref *vm-channels* index))
; Make a new channel. The os-index is used to handle I/O-completion interrupts
; so we have to ensure that there is at most one channel using each index.
(define (make-registered-channel mode id os-index key)
(cond ((not (or (< os-index *number-of-channels*)
(add-more-channels os-index)))
(values false (enum exception out-of-memory)))
((false? (vector-ref *vm-channels* os-index))
(let ((channel (make-channel (enter-fixnum mode)
id
(enter-fixnum os-index)
false ; next
false ; os-status
key)))
(vector-set! *vm-channels* os-index channel)
(values channel
(enum exception out-of-memory)))) ; exception is ignored
(else
(values false (enum exception channel-os-index-already-in-use)))))
; Called from outside the VM. It's up to the caller to be GC-safe.
; Returns FALSE if anything goes wrong.
(define (s48-add-channel mode id os-index)
(receive (channel status)
(make-registered-channel (extract-fixnum mode)
id
os-index
(ensure-space channel-size))
(if (channel? channel)
channel
(enter-fixnum status))))
; Called from outside to change the os-index of a particular channel.
(define (s48-set-channel-os-index channel os-index)
(cond ((not (or (< os-index *number-of-channels*)
(add-more-channels os-index)))
(enter-fixnum (enum exception out-of-memory)))
((false? (vector-ref *vm-channels* os-index))
(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)))
(vector-set! *vm-channels* old-index false)
(vector-set! *vm-channels* os-index channel)
(set-channel-os-index! channel (enter-fixnum os-index))
true))
(else
(enter-fixnum (enum exception channel-os-index-already-in-use)))))
; Extend the vector of channels.
(define (add-more-channels index)
(let* ((new-count (max (+ index 1)
(+ *number-of-channels* 8)))
(old-count *number-of-channels*)
(new-vm-channels (make-vector new-count (vector-ref *vm-channels* 0))))
(cond ((null-pointer? new-vm-channels)
#f)
(else
(do ((i 0 (+ i 1)))
((= i *number-of-channels*))
(vector-set! new-vm-channels i (vector-ref *vm-channels* i)))
(do ((i *number-of-channels* (+ i 1)))
((= i new-count))
(vector-set! new-vm-channels i false))
(deallocate *vm-channels*)
(set! *vm-channels* new-vm-channels)
(set! *number-of-channels* new-count)
#t))))
; We abort any operation pending on the channel and then close it, freeing
; up the index. The status from the OS's close function is returned.
(define (close-channel! channel)
(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)))
(let ((status (if (or (= input-status (channel-status channel))
(= special-input-status (channel-status channel)))
(close-input-channel os-index)
(close-output-channel os-index))))
(vector-set! *vm-channels* os-index false)
(set-channel-status! channel closed-status)
status)))
; Called from outside the VM. Closes the channel at OS-INDEX, should we have
; such.
(define (s48-close-channel os-index)
(if (and (<= 0 os-index)
(< os-index *number-of-channels*)
(channel? (os-index->channel os-index)))
(close-channel! (os-index->channel os-index)))
(unspecific))
; Called to close an OS channel when we have been unable to make the
; corresponding Scheme channel.
(define (close-channel-index! index name mode)
(let ((status (if (input-channel-status? mode)
(close-input-channel index)
(close-output-channel index))))
(if (error? status)
(channel-close-error status index name))))
(define (input-channel-status? mode)
(or (= mode (enum channel-status-option input))
(= mode (enum channel-status-option special-input))))
(define (channel-close-error status index id)
(write-error-string "Error: ")
(write-error-string (error-string status))
(write-error-newline)
(write-error-string " while closing port ")
(if (vm-string? id)
(write-error-string (extract-string id))
(write-error-integer (extract-fixnum index)))
(write-error-newline))
; Return a list of the open channels, for the opcode of the same name.
; Not that it's important, but the list has the channels in order of
; their os-indexes.
(define (open-channels-list)
(let ((key (ensure-space (* vm-pair-size *number-of-channels*))))
(do ((i (- *number-of-channels* 1) (- i 1))
(res null
(let ((channel (vector-ref *vm-channels* i)))
(if (channel? channel)
(vm-cons channel res key)
res))))
((= i -1)
res))))
;----------------------------------------------------------------
; Handling i/o-{read,write}-completion interrupts
; Currently, because the GC may move buffers, strings, etc. around, the OS
; must buffer the data while waiting for i/o to complete.
;
; Unix: the i/o completion just means that the channel is ready; no characters
; are ever transfered asynchronously.
;
; DOS/Windows: no non-blocking i/o of any kind.
;
; WindowsNT: we will need a fancier GC or something.
; These are a queue of channels with pending interrupts
(define *pending-channels-head* false)
(define *pending-channels-tail* false)
(define (channel-queue-empty?)
(false? *pending-channels-head*))
(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 (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))
; 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))))))))
(define (trace-io trace-value)
(set! *pending-channels-head* (trace-value *pending-channels-head*))
(set! *pending-channels-tail* (trace-value *pending-channels-tail*)))
;----------------------------------------------------------------
; Automatically closing channels.
; The following is called after the GC finishes.
(define (close-untraced-channels!)
(do ((i 0 (+ i 1)))
((= i *number-of-channels*) #f)
(let ((channel (vector-ref *vm-channels* i)))
(if (not (false? channel))
(let* ((header (stob-header channel))
(new (cond ((stob? header) ; channel was copied
header)
((open? channel) ; channel was not copied
(close-channel-noisily! channel)
false)
(else
false))))
(vector-set! *vm-channels* i new))))))
(define (close-channel-noisily! channel)
(let ((status (close-channel! channel))
(id (let ((id (channel-id channel)))
(cond ((fixnum? id)
id)
((stob? (stob-header id))
(stob-header id))
(else
id)))))
(if (error? status)
(channel-close-error status (channel-os-index channel) id))
(write-error-string "Channel closed: ")
(if (fixnum? id)
(write-error-integer (extract-fixnum id))
(write-error-string (extract-string id)))
(write-error-string " ")
(write-error-integer (extract-fixnum (channel-os-index channel)))
(write-error-newline)))
; Mark channels in about-to-be-dumped heaps as closed.
(define (s48-mark-traced-channels-closed!)
(do ((i 0 (+ i 1)))
((= i *number-of-channels*))
(let ((channel (vector-ref *vm-channels* i)))
(if (not (false? channel))
(let ((header (stob-header channel)))
(if (stob? header) ; channel was copied
(begin
(write-error-string "Channel closed in dumped image: ")
(if (fixnum? (channel-id channel))
(write-error-integer (extract-fixnum (channel-id channel)))
(write-error-string (extract-string (channel-id channel))))
(write-error-newline)
(set-channel-status! header closed-status)
(set-channel-os-index! header (enter-fixnum -1))))))))
(unspecific))