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

Be even more thorough about releasing port locks after exceptions.

This commit is contained in:
sperber 2002-02-28 08:29:04 +00:00
parent f5d853712b
commit b4312d028c
1 changed files with 91 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

160
scheme/rts/port.scm
View File

@ -80,11 +80,7 @@
(define (one-arg-proc->handler proc signal-exception) (define (one-arg-proc->handler proc signal-exception)
(lambda (opcode reason port) (lambda (opcode reason port)
(if (= reason (enum exception buffer-full/empty)) (if (= reason (enum exception buffer-full/empty))
(begin (protect-port-op port (lambda () (proc port)))
(obtain-port-lock port)
(let ((value (proc port)))
(release-port-lock port)
value))
(signal-exception opcode reason port)))) (signal-exception opcode reason port))))
; This could combined with on-arg-... if the port were the first argument. ; This could combined with on-arg-... if the port were the first argument.
@ -92,11 +88,7 @@
(define (two-arg-proc->handler proc signal-exception) (define (two-arg-proc->handler proc signal-exception)
(lambda (opcode reason arg port) (lambda (opcode reason arg port)
(if (= reason (enum exception buffer-full/empty)) (if (= reason (enum exception buffer-full/empty))
(begin (protect-port-op port (lambda () (proc arg port)))
(obtain-port-lock port)
(let ((value (proc arg port)))
(release-port-lock port)
value))
(signal-exception opcode reason arg port)))) (signal-exception opcode reason arg port))))
; If a character is available, use it; if there is an EOF waiting, use that; ; If a character is available, use it; if there is an EOF waiting, use that;
@ -163,31 +155,42 @@
(define port-flushed? port-pending-eof?) (define port-flushed? port-pending-eof?)
(define set-port-flushed?! set-port-pending-eof?!) (define set-port-flushed?! set-port-pending-eof?!)
(define (protect-port-op port thunk)
(obtain-port-lock port)
(let ((result
(with-handler
(lambda (condition punt)
(release-port-lock port)
(punt))
thunk)))
(release-port-lock port)
result))
;---------------- ;----------------
; Closing is done with the appropriate handler. ; Closing is done with the appropriate handler.
; R4RS says that CLOSE-... is idempotent. ; R4RS says that CLOSE-... is idempotent.
(define (close-input-port port) (define (close-input-port port)
(if (input-port? port) (if (input-port? port)
(begin (protect-port-op
(obtain-port-lock port) port
(if (open-input-port? port) (lambda ()
(begin (if (open-input-port? port)
(make-input-port-closed! port) (begin
((port-handler-close (port-handler port)) (port-data port)))) (make-input-port-closed! port)
(release-port-lock port)) ((port-handler-close (port-handler port)) (port-data port))))))
(call-error "invalid argument" close-input-port port))) (call-error "invalid argument" close-input-port port)))
(define (close-output-port port) (define (close-output-port port)
(if (output-port? port) (if (output-port? port)
(begin (protect-port-op
(obtain-port-lock port) port
(if (open-output-port? port) (lambda ()
(begin (if (open-output-port? port)
(really-force-output port) (begin
(make-output-port-closed! port) (make-output-port-closed! port)
((port-handler-close (port-handler port)) (port-data port)))) (really-force-output port)
(release-port-lock port)) ((port-handler-close (port-handler port)) (port-data port))))))
(call-error "invalid argument" close-output-port port))) (call-error "invalid argument" close-output-port port)))
;---------------- ;----------------
@ -203,22 +206,12 @@
((define-port-op (?id ?args ...) ?port ?predicate ?body) ((define-port-op (?id ?args ...) ?port ?predicate ?body)
(define (?id ?args ...) (define (?id ?args ...)
(if ?predicate ; if args are okay (if ?predicate ; if args are okay
(begin (protect-port-op
(obtain-port-lock ?port) ; lock the port ?port
(lambda ()
(if (open-port? ?port) ; check that it's open (if (open-port? ?port) ; check that it's open
(let ((value ; do the work ?body
(with-handler (call-error "invalid argument" ?id ?args ...))))
(lambda (condition punt)
(release-port-lock ?port)
(punt))
(lambda ()
?body))))
(release-port-lock ?port) ; release the lock
value) ; return
(begin
(release-port-lock ?port)
(call-error "invalid argument" ?id ?args ...))))
(call-error "invalid argument" ?id ?args ...)))) (call-error "invalid argument" ?id ?args ...))))
; ?port defaults to the first argument ; ?port defaults to the first argument
@ -340,14 +333,19 @@
(call-error "invalid argument" output-port-ready? port)) (call-error "invalid argument" output-port-ready? port))
((not (maybe-obtain-port-lock port)) ((not (maybe-obtain-port-lock port))
#f) #f)
((not (open-port? port)) ; have to check again after the lock call ((not (open-port? port)) ; have to check again after the lock call
(release-port-lock port) (release-port-lock port)
(call-error "invalid argument" output-port-ready? port)) (call-error "invalid argument" output-port-ready? port))
(else (else
(let ((val ((port-handler-ready? (port-handler port)) (with-handler
port))) (lambda (condition punt)
(release-port-lock port) (release-port-lock port)
val)))) (punt))
(lambda ()
(let ((val ((port-handler-ready? (port-handler port))
port)))
(release-port-lock port)
val))))))
; Copy the bytes into the buffer if there is room, otherwise write out anything ; Copy the bytes into the buffer if there is room, otherwise write out anything
; in the buffer and then write BUFFER. ; in the buffer and then write BUFFER.
@ -390,11 +388,11 @@
(define (force-output-if-open port) (define (force-output-if-open port)
(if (output-port? port) (if (output-port? port)
(begin (protect-port-op
(obtain-port-lock port) port
(if (open-output-port? port) (lambda ()
(really-force-output port)) (if (open-output-port? port)
(release-port-lock port)) (really-force-output port))))
(call-error "invalid argument" force-output-if-open port))) (call-error "invalid argument" force-output-if-open port)))
;---------------- ;----------------
@ -608,19 +606,35 @@
(if (and (report-errors-as-warnings (if (and (report-errors-as-warnings
(lambda () (lambda ()
(if (maybe-obtain-port-lock port) (if (maybe-obtain-port-lock port)
(begin (with-handler
(really-force-output port) (lambda (condition punt)
(release-port-lock port)))) (release-port-lock port)
(punt))
(lambda ()
(really-force-output port)
(release-port-lock port)))))
"error when flushing buffer; closing port" "error when flushing buffer; closing port"
port) port)
(open-output-port? port)) (open-output-port? port))
(report-errors-as-warnings (report-errors-as-warnings
(lambda () (lambda ()
(make-output-port-closed! port) (make-output-port-closed! port)
((port-handler-close (port-handler port)) (port-data port))) ((port-handler-close (port-handler port)) (port-data port)))
"error when closing port" "error when closing port"
port)))) port))))
;----------------
; The following is used to make the REPL's input, output, and error ports
; available after a keyboard interrupt. If PORT is a locked channel port
; we save the its state and then reinitialize it. The OS is told to
; abort any pending operation on the port's channel. Finally, the owning
; thread's continuation is munged to restore the port when the thread
; resumes. Any buffered input is thrown away at that point (it could
; be saved away with the channel).
;
; If the port is locked by us or one of our ancestors there is no point in
; trying to grab it.
(define (steal-port! port) (define (steal-port! port)
(begin (begin
(disable-interrupts!) (disable-interrupts!)
@ -652,17 +666,25 @@
(interrupt-thread owner (interrupt-thread owner
(lambda results (lambda results
(obtain-port-lock port) (obtain-port-lock port)
(cond ((output-port? port) (let ((cleanup
(really-force-output port)) (lambda ()
((< (port-index port) (set-port-buffer! port buffer)
(port-limit port)) (set-port-index! port index)
(warn "dropping input from port" port))) (set-port-limit! port limit)
(set-port-buffer! port buffer) (set-port-pending-eof?! port eof?)
(set-port-index! port index) (set-port-lock! port lock))))
(set-port-limit! port limit) (with-handler
(set-port-pending-eof?! port eof?) (lambda (condition punt)
(set-port-lock! port lock) (cleanup)
(or status (apply values results)))) (punt))
(lambda ()
(cond ((output-port? port)
(really-force-output port))
((< (port-index port)
(port-limit port))
(warn "dropping input from port" port)))
(cleanup)
(or status (apply values results)))))))
; if we took OWNER off a channel-wait queue we need to make it ready to run ; if we took OWNER off a channel-wait queue we need to make it ready to run
(if status (make-ready owner)))) (if status (make-ready owner))))