[plt-scheme] Cleanup on Servlet Timeout (Again)

A while ago I started a thread on the automatic releasing of resource
locks on servlet termination in the web server:

http://list.cs.brown.edu/pipermail/plt-scheme/2008-July/026121.html

The problem is that individual threads acquire read/write locks on the
database, but they may be terminated at any time due to timeout. In
the worst case, a thread with a write lock is terminated, and then no
other threads can get a read lock until the web server is restarted.
Robby pointed me to a paper on implementing kill-safe shared
resources:

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. In my
case, my database monitor has the following interface:

(call-as-retryable-job thunk)
Waits to acquire a read lock and runs the thunk. Returns the result of
the thunk. Releases any read/write locks obtained when returning.

(aquire-write-lock)
Called only within a thunk given to call-as-retryable-job. Tries to
acquire a write lock by blocking new readers and waiting for existing
readers to finish. If there is another thread already waiting for a
write lock, an escape continuation is used to retry the thunk from
scratch as a new reader.

(has-read-lock?)
(has-write-lock?)
Kinda obvious.

Now, if my servlet is terminated during the execution of thunk, my
read/write locks are not released, and new readers/writers may have
trouble getting into the database. I can't see how the techniques
described in the above paper will help me solve this. Would
"scheme_add_managed" help me with this problem? I get the idea this
function was designed only to handle C-level cleanup, but I'm not sure
what else to do.

Any help would be appreciated,
    Henk Boom

Monitor implementation:

#lang scheme/base

(provide call-as-retryable-job
         acquire-write-lock
         has-read-lock?
         has-write-lock?)

(define read-s (make-semaphore 1))
(define write-s (make-semaphore 1))
(define reader-counter 0)
(define reader-counter-s (make-semaphore 1))

(define *lock-type* (make-parameter #f))
(define *retry-proc* (make-parameter 'no-retry))

(define (has-read-lock?)
  (and (*lock-type*) #t))

(define (has-write-lock?)
  (eq? (*lock-type*) 'write))

(define-syntax with-semaphore
  (syntax-rules ()
    ((with-semaphore s . body)
     (call-with-semaphore s
       (lambda () . body)))))

(define (start-read)
  ; don't go until there are no writers waiting, to make sure they go first
  (sync (semaphore-peek-evt write-s))
  ; acquire read-lock if necessary
  (with-semaphore reader-counter-s
    (when (= 0 reader-counter)
      (semaphore-wait read-s))
    (set! reader-counter (+ reader-counter 1))
    (printf "reader-counter=~a after increment~n" reader-counter))
  ; we can now read
  (*lock-type* 'read))

(define (finish-read)
  ; prohibit access
  (*lock-type* #f)
  ; release read-lock if necessary
  (with-semaphore reader-counter-s
    (set! reader-counter (- reader-counter 1))
    (printf "reader-counter=~a after decrement~n" reader-counter)
    (when (= 0 reader-counter)
      (semaphore-post read-s))))

(define (acquire-write-lock)
  ; see if we are the first waiting to write
  (if (semaphore-try-wait? write-s)
    ; we are, go ahead
    (begin
      (finish-read)
      ; get the read lock to ensure all readers have left
      (semaphore-wait read-s)
      (*lock-type* 'write))
    ; we aren't, so retry the transaction from the start to give the other
    ; writer a chance
    ((*retry-proc*))))

(define (finish-write)
  ; prohibit access
  (*lock-type* #f)
  (semaphore-post read-s)
  (semaphore-post write-s))

(define (call-as-retryable-job thunk)
  (let/ec success
    (let loop ()
      (let/ec retry
        (call-with-continuation-barrier
          (lambda ()
            (start-read)
            (parameterize ((*retry-proc* retry))
              (dynamic-wind
                void
                (lambda () (success (thunk)))
                (lambda ()
                  (if (eq? (*lock-type*) 'write)
                    (finish-write)
                    (finish-read))))))))
      (loop))))