[plt-scheme] Cleanup on Servlet Timeout (Again)
Matthew Flatt
mflatt at cs.utah.edu
Thu Aug 21 11:58:54 EDT 2008
At Wed, 20 Aug 2008 22:48:55 -0400, "Henk Boom" wrote:
>
> http://www.cs.utah.edu/plt/kill-safe/
>
> Now that I finally have time to devote to this, I've taken a look.
> From what I understand, though, this technique only helps when your
> lock lasts only for the duration of your call to the resource.
Forget locks. Make a process that's in charge of the resource.
[The process is effectively an implementation of a readers+writer lock,
but this characterization is probably useful only if you're trained to
think in terms of locks instead of processes. The key is that you get
to implement the "lock" instead of trying to juggle primitive locks.]
The process representing the resource accepts reader requests and lets
them run them in parallel; when a reader asks to become a writer, then
the managing process waits for all the other readers to finish before
granting the conversion; if there's already a pending writer, then all
new writer-conversion requests are rejected. The process can see when a
reader/writer terminates, and it can adjust accordingly. The enclosed
"rwlock.ss" illustrates this implementation.
Depending on the domain, though, there's one more problem beyond
granting read and write access in a kill-safe way. What if a thread is
terminated while it's in write mode? The "rwlock.ss" implementation
treats termination the same as the completion, but that's valid only if
each atomic step in writing keeps the relevant data consistent.
Otherwise, you need some way to ensure that the write completes so that
the data is consistent.
If all you have is locks, then you're stuck on this second problem. If
you have a process, though, the solution is pretty easy: delegate the
writing work to the process that handles read and write access. (The
writing work has to be trusted in this case, in the sense that it won't
raise unexpected exceptions or things like that.) The enclosed
"rwlock-complete-write.ss" illustrates the generalization or
"rwlock.ss" to solve that problem.
BEWARE: a version of the enclosed code exposed a bug in `sync'. (An
array was improperly re-used when, for a non-zero N, `sync' receives N
`choice-evt's that contain no non-choice events plus M `choice-evts'
that contain a total of N+M non-choice events.) The bug is fixed in
SVN, and the enclosed code contains a dummy semaphore to work around
the bug.
Matthew
-------------- next part --------------
#lang scheme
;; To send messages to server:
(define read-req-ch (make-channel))
(define write-req-ch (make-channel))
;; A message to the server:
(define-struct req (accept-ch done-sema th))
;; Internal to server:
(define-struct reader (done-sema th))
(define-struct writer (accept-ch done-sema th))
(define temporary-workaround-evt (make-semaphore)) ;; avoids a bug in version prior to v4.1.0.2-svn11367
(define (serve readers pending-writer)
(sync
;; Handle reqeusst to become writer:
(handle-evt
write-req-ch
(lambda (r)
(cond
[pending-writer
;; Reject request, because someone else has asked
;; to become a writer
(reply (req-accept-ch r) #f)
(serve readers pending-writer)]
[else
;; Accept the writer and remove it from the readers,
;; but don't let the writer continue until we're
;; out of readers
(serve (remove r readers (lambda (a b)
(eq? (req-th a) (reader-th b))))
(make-writer (req-accept-ch r)
(req-done-sema r)
(req-th r)))])))
;; If a pending writer and no readers, let writer continue:
(if (and pending-writer (null? readers))
(choice-evt
(handle-evt (channel-put-evt (writer-accept-ch pending-writer) #t)
(lambda (v)
;; Writer has accepted and is now running. Wait for it
;; to finish (without accepting reject reader requests meanwhile).
;; If it dies we release the lock --- MAYBE WITH A PARTIAL WRITE!
(sync
(writer-done-sema pending-writer)
(thread-dead-evt (writer-th pending-writer)))
;; Demote the writer back to a reader:
(serve (list (make-reader (writer-done-sema pending-writer)
(writer-th pending-writer)))
#f)))
(handle-evt (thread-dead-evt (writer-th pending-writer))
(lambda (v)
;; Writer died before continuing
(serve null #f))))
never-evt)
;; Handle requests to become a reader
(if pending-writer
never-evt ; don't allow if there's a pending writer
(handle-evt
read-req-ch
(lambda (r)
;; Accept new reader
(reply (req-accept-ch r) #t)
(serve (cons (make-reader (req-done-sema r) (req-th r))
readers)
#f))))
;; Handle reader completion/termination by removing it from our list
(apply
choice-evt
temporary-workaround-evt
(map (lambda (r)
(handle-evt
(choice-evt (reader-done-sema r)
(thread-dead-evt (reader-th r)))
(lambda (v)
(serve (remq r readers) pending-writer))))
readers))))
(define (reply ch v)
(or
;; Reply immediately, if possible; this is an optimization
(sync/timeout 0 (channel-put-evt ch v))
;; Reply eventually
(thread-resume
(thread (lambda () (channel-put ch v)))
(current-thread))))
;; Start the server:
(define serve-thread (thread (lambda () (serve null #f))))
;; ----------------------------------------
(define retry (make-continuation-prompt-tag 'retry))
;; call-as-retryable : (((-> beta) -> beta) -> alpha) -> alpha
;; Given function acts as reader. When the reader is called, it's given
;; a function that takes a thunk to apply in write mode (but write mode
;; also continues after the thunk returns)
(define (call-as-retryable read-proc)
;; Ensure that server is running:
(thread-resume serve-thread (current-thread))
;; Set up a prompt for abort and retry:
(call-with-continuation-prompt
(lambda ()
(let ([accept-ch (make-channel)]
[done-sema (make-semaphore)])
(channel-put read-req-ch (make-req accept-ch done-sema (current-thread)))
(channel-get accept-ch) ;; wait until accepted as a reader
(call-with-continuation-barrier
(lambda ()
(dynamic-wind
void
(lambda ()
;; read...
(read-proc
(lambda (write-thunk)
;; shift into write mode
(let ([accept-ch (make-channel)])
(channel-put write-req-ch (make-req accept-ch done-sema (current-thread)))
(if (channel-get accept-ch)
;; allowed to write:
(write-thunk)
;; can't write, so abort (and abort handler will retry)
(abort-current-continuation retry))))))
(lambda ()
(semaphore-post done-sema)))))))
retry
;; On abort, retry:
(lambda () (call-as-retryable read-proc))))
;; ----------------------------------------
;; Example use
(define x 0)
(for ([i (in-range 100)])
(thread
(lambda ()
(printf
"~s\n"
(call-as-retryable (lambda (call-write)
(when (zero? (random 3)) ; randomly become writer
(call-write (lambda ()
(let ([v x])
(set! x #f) ; simulate inconsistency
(sleep) ; what if the thread is killed here?
(set! x (add1 v))))))
(when (zero? (random (add1 i))) ; randomly die
(kill-thread (current-thread)))
;; x should never be #f (i.e., inconsistent):
x)))
;; pretend to continue with other work...
(sleep 1000))))
-------------- next part --------------
#lang scheme
;; To send messages to server:
(define read-req-ch (make-channel))
(define write-req-ch (make-channel))
;; A message to the server:
(define-struct req (accept-ch done-sema th))
;; Internal to server:
(define-struct reader (done-sema th))
(define-struct writer (accept-ch done-sema th))
(define temporary-workaround-evt (make-semaphore)) ;; avoids a bug in version prior to v4.1.0.2-svn11367
(define (serve readers pending-writer)
(sync
;; Handle reqeusst to become writer:
(handle-evt
write-req-ch
(lambda (r)
(cond
[pending-writer
;; Reject request, because someone else has asked
;; to become a writer
(reply (req-accept-ch r) #f)
(serve readers pending-writer)]
[else
;; Accept the writer and remove it from the readers,
;; but don't let the writer continue until we're
;; out of readers
(serve (remove r readers (lambda (a b)
(eq? (req-th a) (reader-th b))))
(make-writer (req-accept-ch r)
(req-done-sema r)
(req-th r)))])))
;; If a pending writer and no readers, let writer continue:
(if (and pending-writer (null? readers))
(choice-evt
(let ([completed-sema (make-semaphore)])
(handle-evt (channel-put-evt (writer-accept-ch pending-writer) completed-sema)
(lambda (v)
;; Writer has accepted and should now provide the (trusted!)
;; writing thunk
(sync
;; handle provided thunk:
(handle-evt (writer-accept-ch pending-writer)
(lambda (write-thunk) (write-thunk)))
;; No problem if the writer dies before supplying the thunk:
(thread-dead-evt (writer-th pending-writer)))
;; Tell writing thread that the thunk completed:
(semaphore-post completed-sema)
;; Demote the writer back to a reader:
(serve (list (make-reader (writer-done-sema pending-writer)
(writer-th pending-writer)))
#f))))
(handle-evt (thread-dead-evt (writer-th pending-writer))
(lambda (v)
;; Writer died before continuing
(serve null #f))))
never-evt)
;; Handle requests to become a reader
(if pending-writer
never-evt ; don't allow if there's a pending writer
(handle-evt
read-req-ch
(lambda (r)
;; Accept new reader
(reply (req-accept-ch r) #t)
(serve (cons (make-reader (req-done-sema r) (req-th r))
readers)
#f))))
;; Handle reader completion/termination by removing it from our list
(apply
choice-evt
temporary-workaround-evt
(map (lambda (r)
(handle-evt
(choice-evt (reader-done-sema r)
(thread-dead-evt (reader-th r)))
(lambda (v)
(serve (remq r readers) pending-writer))))
readers))))
(define (reply ch v)
(or
;; Reply immediately, if possible; this is an optimization
(sync/timeout 0 (channel-put-evt ch v))
;; Reply eventually
(thread-resume
(thread (lambda () (channel-put ch v)))
(current-thread))))
;; Start the server:
(define serve-thread (thread (lambda () (serve null #f))))
;; ----------------------------------------
(define retry (make-continuation-prompt-tag 'retry))
;; call-as-retryable : (((-> beta) -> beta) -> alpha) -> alpha
;; Given function acts as reader. When the reader is called, it's given
;; a function that takes a thunk to apply in write mode (but write mode
;; also continues after the thunk returns)
(define (call-as-retryable read-proc)
;; Ensure that server is running:
(thread-resume serve-thread (current-thread))
;; Set up a prompt for abort and retry:
(call-with-continuation-prompt
(lambda ()
(let ([accept-ch (make-channel)]
[done-sema (make-semaphore)])
(channel-put read-req-ch (make-req accept-ch done-sema (current-thread)))
(channel-get accept-ch) ;; wait until accepted as a reader
(call-with-continuation-barrier
(lambda ()
(dynamic-wind
void
(lambda ()
;; read...
(read-proc
(lambda (write-thunk)
;; shift into write mode
(let ([accept-ch (make-channel)])
(channel-put write-req-ch (make-req accept-ch done-sema (current-thread)))
(let ([completed-sema (channel-get accept-ch)])
(if completed-sema
;; allowed to write:
(begin
(channel-put accept-ch write-thunk)
(semaphore-wait completed-sema))
;; can't write, so abort (and abort handler will retry)
(abort-current-continuation retry)))))))
(lambda ()
(semaphore-post done-sema)))))))
retry
;; On abort, retry:
(lambda () (call-as-retryable read-proc))))
;; ----------------------------------------
;; Example use
(define x 0)
(for ([i (in-range 100)])
(thread
(lambda ()
(printf
"~s\n"
(call-as-retryable (lambda (call-write)
(when (zero? (random 3)) ; randomly become writer
(call-write (lambda ()
(let ([v x])
(set! x #f) ; simulate inconsistency
(sleep)
;; if the server thread is killed here, it will get resumed
;; by any future read attempt, and so the write action will
;; finish
(set! x (add1 v))))))
(when (zero? (random (add1 i))) ; randomly die
(kill-thread (current-thread)))
;; x should never be #f (i.e., inconsistent):
x)))
;; pretend to continue with other work...
(sleep 1000))))
More information about the plt-scheme
mailing list