scsh-0.6/scheme/vm/prim-io.scm

455 lines
14 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; I/O primitives
; See doc/io.txt for a description of Scheme 48's I/O system.
; Argument specs
(define open-input-port->
(input-type (lambda (x)
(and (port? x)
(port-has-status? x (enum port-status-options
open-for-input))))
no-coercion))
(define open-output-port->
(input-type (lambda (x)
(and (port? x)
(port-has-status? x (enum port-status-options
open-for-output))))
no-coercion))
(define channel-> (input-type channel? no-coercion))
(define (port-has-status? port status)
(not (= 0 (bitwise-and (extract-fixnum (port-status port))
(shift-left 1 status)))))
; Check SPEC type and then call OPEN-CHANNEL.
(define-consing-primitive open-channel (any-> fixnum->)
(lambda (ignore) (+ channel-size error-string-size))
(lambda (spec mode key)
(let* ((lose (lambda (reason)
(raise-exception* reason 0 spec (enter-fixnum mode))))
(os-lose (lambda (status)
(raise-exception os-error 0
spec
(enter-fixnum mode)
(get-error-string status key))))
(win (lambda (index)
(receive (channel reason)
(make-registered-channel mode spec index key)
(cond ((false? channel)
(if (vm-string? spec)
(close-channel-index! index spec mode))
(lose reason))
(else
(goto return channel)))))))
(cond ((not (open-channel-status? mode))
(lose (enum exception wrong-type-argument)))
((fixnum? spec)
(if (<= 0 (extract-fixnum spec))
(win (extract-fixnum spec))
(lose (enum exception wrong-type-argument))))
((vm-string? spec)
(receive (channel status)
(if (or (= mode (enum channel-status-option input))
(= mode (enum channel-status-option special-input)))
(open-input-file-channel (extract-string spec))
(open-output-file-channel (extract-string spec)))
(cond ((eq? status (enum errors no-errors))
(win channel))
((eq? status (enum errors file-not-found))
(lose (enum exception cannot-open-channel)))
(else
(os-lose status)))))
(else
(lose (enum exception wrong-type-argument)))))))
(define (open-channel-status? mode)
(or (= mode (enum channel-status-option input))
(= mode (enum channel-status-option output))
(= mode (enum channel-status-option special-input))
(= mode (enum channel-status-option special-output))))
(define-consing-primitive close-channel (channel->)
(lambda (ignore) error-string-size)
(lambda (channel key)
(if (open? channel)
(let ((status (close-channel! channel)))
(if (error? status)
(raise-exception os-error 0 channel (get-error-string status key))
(goto no-result)))
(raise-exception wrong-type-argument 0 channel))))
(define-consing-primitive channel-ready? (channel->)
(lambda (ignore) error-string-size)
(lambda (channel key)
(if (open? channel)
(receive (ready? status)
(channel-ready? (extract-channel channel)
(input-channel? channel))
(if (error? status)
(raise-exception os-error 0 channel (get-error-string status key))
(goto return-boolean ready?)))
(raise-exception wrong-type-argument 0 channel))))
(define (channel-read-or-write read? proc)
(lambda (thing start count wait? channel key)
(let ((lose (lambda (reason)
(if read?
(raise-exception*
reason 0
thing
(enter-fixnum start)
(enter-fixnum count)
(enter-boolean wait?)
channel)
(raise-exception*
reason 0
thing
(enter-fixnum start)
(enter-fixnum count)
channel))))
(os-lose (lambda (status)
(if read?
(raise-exception os-error 0
thing
(enter-fixnum start)
(enter-fixnum count)
(enter-boolean wait?)
channel
(get-error-string status key))
(raise-exception os-error 0
thing
(enter-fixnum start)
(enter-fixnum count)
channel
(get-error-string status key))))))
(if (and (if read?
(and (input-channel? channel)
(not (immutable? thing)))
(output-channel? channel))
(or (vm-string? thing)
(code-vector? thing)))
(let ((length (if (vm-string? thing)
(vm-string-length thing)
(code-vector-length thing)))
(addr (address+ (address-after-header thing) start)))
(if (< length (+ start count))
(lose (enum exception index-out-of-range))
(proc channel addr count wait? lose os-lose)))
(lose (enum exception wrong-type-argument))))))
; FETCH-STRING here avoids a type warning in the C code, but is not really
; the right thing.
(define (do-channel-read channel start count wait? lose os-lose)
(receive (got eof? pending? status)
(channel-read-block (extract-channel channel) start count wait?)
(cond ((error? status)
(os-lose status))
(eof?
(goto return eof-object))
(pending?
(set-channel-os-status! channel true) ; note that we're waiting
(disable-interrupts!) ; keep the result pending for a moment
(lose (enum exception pending-channel-i/o)))
(else
(goto return-fixnum got)))))
; WAIT? is ignored when writing.
(define (do-channel-write channel start count wait? lose os-lose)
(receive (got pending? status)
(channel-write-block (extract-channel channel) start count)
(cond ((error? status)
(os-lose status))
(pending?
(set-channel-os-status! channel true) ; note that we're waiting
(disable-interrupts!) ; keep the result pending for a moment
(lose (enum exception pending-channel-i/o)))
(else
(goto return-fixnum got)))))
(define (extract-channel channel)
(extract-fixnum (channel-os-index channel)))
(let ((do-it (channel-read-or-write #t do-channel-read)))
(define-consing-primitive channel-maybe-read
(any-> fixnum-> fixnum-> boolean-> channel->)
(lambda (ignore) error-string-size)
do-it))
(let ((do-it (channel-read-or-write #f do-channel-write)))
(define-consing-primitive channel-maybe-write
(any-> fixnum-> fixnum-> channel->)
(lambda (ignore) error-string-size)
(lambda (buffer start count channel key)
(do-it buffer start count #f channel key))))
(define-primitive add-pending-channel (channel-> boolean->)
(lambda (channel input?)
(add-pending-channel (extract-channel channel) input?))
return-boolean)
(define-primitive channel-abort (channel->)
(lambda (channel)
(goto return (vm-channel-abort channel))))
(define-primitive open-channels-list ()
(lambda ()
(goto return (open-channels-list))))
; Copying error strings into the heap.
(define max-error-string-length 256)
(define error-string-size (vm-string-size max-error-string-length))
(define (get-error-string status key)
(let* ((string (error-string status))
(len (min (string-length string)
max-error-string-length))
(new (vm-make-string len key)))
(do ((i 0 (+ i 1)))
((= i len))
(vm-string-set! new i (string-ref string i)))
new))
;----------------------------------------------------------------
; Port instructions.
;
; These are only for speed. If no port was supplied by the user they have
; to look up the appropriate port in the current dynamic environments.
; This is a complete hack, also done for speed. See rts/current-port.scm
; for the other end.
(define (read-or-peek-char read?)
(lambda ()
(let ((port (if (= (code-byte 0) 0)
(val)
(get-current-port
(enter-fixnum
(enum current-port-marker current-input-port))))))
(if (and (port? port)
(port-has-status? port
(enum port-status-options open-for-input)))
(let ((i (extract-fixnum (port-index port)))
(l (extract-fixnum (port-limit port)))
(b (port-buffer port)))
(cond ((or (vm-eq? (port-locked? port) true)
(= i l))
(raise-exception buffer-full/empty 1 port))
(else
(if read?
(set-port-index! port (enter-fixnum (+ i 1))))
(goto continue-with-value
(enter-char (ascii->char (code-vector-ref b i)))
1))))
(raise-exception wrong-type-argument 1 port)))))
(let ((do-it (read-or-peek-char #t)))
(define-primitive read-char () do-it))
(let ((do-it (read-or-peek-char #f)))
(define-primitive peek-char () do-it))
(define-primitive write-char ()
(lambda ()
(receive (char port)
(if (= (code-byte 0) 0)
(values (pop)
(val))
(values (val)
(get-current-port (enter-fixnum
(enum current-port-marker
current-output-port)))))
(if (and (vm-char? char)
(port? port)
(port-has-status? port
(enum port-status-options open-for-output)))
(let ((i (extract-fixnum (port-index port)))
(b (port-buffer port)))
(cond ((or (vm-eq? (port-locked? port) true)
(= i (code-vector-length b)))
(raise-exception buffer-full/empty 1 char port))
(else
(set-port-index! port (enter-fixnum (+ i 1)))
(code-vector-set! (port-buffer port)
i
(char->ascii (extract-char char)))
(goto continue-with-value
unspecific-value
1))))
(raise-exception wrong-type-argument 1 char port)))))
; Do an ASSQ-like walk up the current dynamic environment, looking for
; MARKER.
(define (get-current-port marker)
(let ((thread (current-thread)))
(if (and (record? thread)
(< 1 (record-length thread)))
(let loop ((env (record-ref thread 1)))
(cond ((not (and (vm-pair? env)
(vm-pair? (vm-car env))))
(if (vm-eq? env null)
(error (if (eq? (extract-fixnum marker)
(enum current-port-marker
current-output-port))
"dynamic environment doesn't have current-output-port"
"dynamic environment doesn't have current-input-port"))
(error "dynamic environment is not a proper list")))
((vm-eq? marker (vm-car (vm-car env)))
(vm-cdr (vm-car env)))
(else
(loop (vm-cdr env)))))
(error "current thread is not a record"))))
;----------------
; A poor man's WRITE for use in debugging.
(define-primitive message (any->)
(lambda (stuff)
(let ((out (current-error-port)))
(let loop ((stuff stuff))
(if (vm-pair? stuff)
(begin
(message-element (vm-car stuff) out)
(loop (vm-cdr stuff)))))
(newline out)))
return-unspecific)
(define (message-element thing out)
(cond ((fixnum? thing)
(write-integer (extract-fixnum thing) out))
((vm-char? thing)
(write-string "#\\" out)
(write-char (extract-char thing) out))
((typed-record? thing)
(write-string "#{" out)
(write-string (extract-string (record-type-name thing)) out)
(write-char #\} out))
(else
(write-string (cond ((vm-string? thing)
(extract-string thing))
((vm-symbol? thing)
(extract-string (vm-symbol->string thing)))
((vm-boolean? thing)
(if (extract-boolean thing) "#t" "#f"))
((vm-eq? thing null)
"()")
((vm-pair? thing)
"(...)")
((vm-vector? thing)
"#(...)")
((closure? thing)
"#{procedure}")
(else
"???"))
out))))
(define (typed-record? thing)
(and (record? thing)
(< 0 (record-length thing))
(let ((type (record-ref thing 0)))
(and (record? type)
(< 2 (record-length type))
(vm-symbol? (record-ref type 2))))))
(define (record-type-name record)
(vm-symbol->string (record-ref (record-ref record 0) 2)))
(define-primitive copy-bytes! (any-> fixnum-> any-> fixnum-> fixnum->)
(lambda (from from-index to to-index count)
(cond ((and (or (vm-string? from)
(code-vector? from))
(or (vm-string? from)
(code-vector? from))
(<= 0 from-index)
(<= 0 to-index)
(<= 0 count)
(<= (+ from-index count)
(if (vm-string? from)
(vm-string-length from)
(code-vector-length from)))
(<= (+ to-index count)
(if (vm-string? to)
(vm-string-length to)
(code-vector-length to))))
(copy-memory! (address+ (address-after-header from) from-index)
(address+ (address-after-header to) to-index)
count)
(goto no-result))
(else
(raise-exception wrong-type-argument 0
from (enter-fixnum from-index)
to (enter-fixnum to-index)
(enter-fixnum count))))))
;----------------------------------------------------------------
; RESUME-PROC is called when the image is resumed.
; This does a garbage collection rooting from RESUME-PROC, writes the heap
; into a file, and then aborts the garbage collection (which didn't modify
; any VM registers or the stack).
; Bug: finalizers for things in the image are ignored.
(define-consing-primitive write-image (string-> any-> string->)
(lambda (ignore) error-string-size)
(lambda (filename resume-proc comment-string key)
(let* ((lose (lambda (reason status)
(raise-exception* reason 0
filename resume-proc comment-string
(get-error-string status key))))
(port-lose (lambda (reason status port)
(if (error? (close-output-port port))
(error-message "Unable to close image file"))
(lose reason status))))
(if (not (s48-image-writing-okay?))
(raise-exception unimplemented-instruction 0
filename resume-proc comment-string)
(receive (port status)
(open-output-file (extract-string filename))
(if (error? status)
(lose (enum exception cannot-open-channel) status)
(let ((status (write-string (extract-string comment-string) port)))
(if (error? status)
(port-lose (enum exception os-error) status port)
;; little hack for faster startup:
;; trigger a GC to ensure newspace is behind oldspace
;; write-image will also GC and thereby move newspace
;; to the front.
;; We can't do this in s48-write-image because it doesn't
;; know collect-saving-temp.
(let ((resume-proc
(if (s48-newspace<oldspace?)
(collect-saving-temp resume-proc)
resume-proc)))
(let ((status (s48-write-image resume-proc port)))
(if (error? status)
(port-lose (enum exception os-error) status port)
(let ((status (close-output-port port)))
(if (error? status)
(lose (enum exception os-error) status)
(receive (undumpables undumpable-count)
(s48-undumpable-records)
(if (= undumpable-count 0)
(goto no-result)
; ---------------->
(raise-exception unresumable-records-in-image 0
filename
resume-proc
comment-string
undumpables
(enter-fixnum undumpable-count)))))))))))))))))
; READ-IMAGE needs to protect some values against GCs (this can't be with
; READ-IMAGE as that is compiled separately.)
(add-gc-root! s48-initializing-gc-root)