consolidate lock implementation and fix custodian problem
This commit is contained in:
Matthew Flatt
parent
d34d3969d9
commit
8ad33f15ab
|
|
@ -228,7 +228,7 @@
|
|||
(begin
|
||||
(retain evt)
|
||||
(queue-event e (lambda ()
|
||||
(call-as-unfreeze-point
|
||||
(call-as-nonatomic-retry-point
|
||||
(lambda ()
|
||||
(tellv app sendEvent: evt)
|
||||
(release evt))))))
|
||||
|
|
|
|||
|
|
@ -1,41 +1,10 @@
|
|||
#lang scheme/base
|
||||
(require scheme/foreign
|
||||
racket/draw/hold
|
||||
"utils.rkt"
|
||||
"queue.rkt"
|
||||
ffi/unsafe/atomic)
|
||||
(unsafe!)
|
||||
(require ffi/unsafe/try-atomic
|
||||
"queue.rkt")
|
||||
|
||||
(provide call-as-unfreeze-point
|
||||
(provide call-as-nonatomic-retry-point
|
||||
constrained-reply)
|
||||
|
||||
(define-mz scheme_abort_continuation_no_dws (_fun _scheme _scheme -> _scheme))
|
||||
(define-mz scheme_call_with_composable_no_dws (_fun _scheme _scheme -> _scheme))
|
||||
(define-mz scheme_set_on_atomic_timeout (_fun (_fun -> _void) -> _pointer))
|
||||
(define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer)
|
||||
#:c-id scheme_set_on_atomic_timeout)
|
||||
|
||||
(define freezer-box (make-parameter #f))
|
||||
(define freeze-tag (make-continuation-prompt-tag))
|
||||
|
||||
;; Runs `thunk' atomically, but cooperates with
|
||||
;; `constrained-reply' to continue a frozen
|
||||
;; computation in non-atomic mode.
|
||||
(define (call-as-unfreeze-point thunk)
|
||||
(let ([b (box null)])
|
||||
(parameterize ([freezer-box b])
|
||||
;; In atomic mode:
|
||||
(call-as-atomic (lambda () (thunk)))
|
||||
;; Out of atomic mode:
|
||||
(let ([l (unbox b)])
|
||||
(for ([k (in-list (reverse l))])
|
||||
(call-with-continuation-prompt ; to catch aborts
|
||||
(lambda ()
|
||||
(call-with-continuation-prompt
|
||||
k
|
||||
freeze-tag)))))
|
||||
(void))))
|
||||
|
||||
(define (internal-error str)
|
||||
(log-error
|
||||
(apply string-append
|
||||
|
|
@ -64,56 +33,18 @@
|
|||
|
||||
;; FIXME: waiting 200msec is not a good enough rule.
|
||||
(define (constrained-reply es thunk default
|
||||
[should-give-up?
|
||||
(let ([now (current-inexact-milliseconds)])
|
||||
(lambda ()
|
||||
((current-inexact-milliseconds) . > . (+ now 200))))]
|
||||
#:fail-result [fail-result default])
|
||||
(let ([b (freezer-box)])
|
||||
(cond
|
||||
[(not b)
|
||||
;; Ideally, this would count as an error that we can fix. It seems that we
|
||||
;; don't always have enough control to use the right eventspace with an
|
||||
;; unfreeze point, though, so just bail out with the default.
|
||||
#;
|
||||
(internal-error (format "constrained-reply not within an unfreeze point for ~s"
|
||||
thunk))
|
||||
fail-result]
|
||||
[(not (eq? (current-thread) (eventspace-handler-thread es)))
|
||||
(internal-error "wrong eventspace for constrained event handling\n")
|
||||
default]
|
||||
[(pair? (unbox b))
|
||||
;; already suspended, so push this work completely:
|
||||
(set-box! b (cons thunk (unbox b)))
|
||||
default]
|
||||
[else
|
||||
;; try to do some work:
|
||||
(let* ([prev #f]
|
||||
[ready? #f]
|
||||
[handler (lambda ()
|
||||
(when (and ready? (should-give-up?))
|
||||
(scheme_call_with_composable_no_dws
|
||||
(lambda (proc)
|
||||
(set-box! b (cons proc (unbox b)))
|
||||
(scheme_restore_on_atomic_timeout prev)
|
||||
(scheme_abort_continuation_no_dws
|
||||
freeze-tag
|
||||
(lambda () default)))
|
||||
freeze-tag)
|
||||
(void)))])
|
||||
(with-holding
|
||||
handler
|
||||
(call-with-continuation-prompt ; to catch aborts
|
||||
(lambda ()
|
||||
(call-with-continuation-prompt ; for composable continuation
|
||||
(lambda ()
|
||||
(set! prev (scheme_set_on_atomic_timeout handler))
|
||||
(set! ready? #t)
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(parameterize ([freezer-box #f])
|
||||
(thunk)))
|
||||
(lambda ()
|
||||
(scheme_restore_on_atomic_timeout prev))))
|
||||
freeze-tag)))))])))
|
||||
(cond
|
||||
[(not (can-try-atomic?))
|
||||
;; Ideally, this would count as an error that we can fix. It seems that we
|
||||
;; don't always have enough control to use the right eventspace with a
|
||||
;; retry point, though, so just bail out with the default.
|
||||
#;
|
||||
(internal-error (format "constrained-reply not within an unfreeze point for ~s"
|
||||
thunk))
|
||||
fail-result]
|
||||
[(not (eq? (current-thread) (eventspace-handler-thread es)))
|
||||
(internal-error "wrong eventspace for constrained event handling\n")
|
||||
fail-result]
|
||||
[else
|
||||
(try-atomic thunk default)]))
|
||||
|
|
|
|||
|
|
@ -140,15 +140,17 @@
|
|||
[(< am bm) -1]
|
||||
[else 1]))))
|
||||
|
||||
(define current-cb-box (make-parameter #f))
|
||||
|
||||
(define-mz scheme_add_managed (_fun _racket ; custodian
|
||||
_racket ; object
|
||||
(_fun #:atomic? #t _racket _pointer -> _void)
|
||||
_pointer ; data
|
||||
(_fun #:atomic? #t #:keep (lambda (v) (set-box! (current-cb-box) v))
|
||||
_racket _racket -> _void)
|
||||
_racket ; data
|
||||
_int ; strong?
|
||||
-> _pointer))
|
||||
|
||||
(define (shutdown-eventspace! e ignored-data)
|
||||
(define (shutdown-eventspace! e ignored)
|
||||
(unless (eventspace-shutdown? e)
|
||||
(set-eventspace-shutdown?! e #t)
|
||||
(semaphore-post (eventspace-done-sema e))
|
||||
|
|
@ -268,12 +270,14 @@
|
|||
frames
|
||||
(semaphore-peek-evt done-sema)
|
||||
#f
|
||||
done-sema)])
|
||||
(scheme_add_managed (current-custodian)
|
||||
e
|
||||
shutdown-eventspace!
|
||||
#f
|
||||
1)
|
||||
done-sema)]
|
||||
[cb-box (box #f)])
|
||||
(parameterize ([current-cb-box cb-box])
|
||||
(scheme_add_managed (current-custodian)
|
||||
e
|
||||
shutdown-eventspace!
|
||||
cb-box ; retain callback until it's called
|
||||
1))
|
||||
e)))
|
||||
|
||||
(define main-eventspace (make-eventspace* (current-thread)))
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@
|
|||
=> (lambda (e)
|
||||
(let ([evt (gdk_event_copy evt)])
|
||||
(queue-event e (lambda ()
|
||||
(call-as-unfreeze-point
|
||||
(call-as-nonatomic-retry-point
|
||||
(lambda ()
|
||||
(gtk_main_do_event evt)
|
||||
(gdk_event_free evt)))))))]
|
||||
|
|
|
|||
|
|
@ -4,10 +4,7 @@
|
|||
|
||||
(provide (protect-out as-entry
|
||||
as-exit
|
||||
entry-point
|
||||
|
||||
inside-lock?
|
||||
any-lock?))
|
||||
entry-point))
|
||||
|
||||
;; We need atomic mode for a couple of reasons:
|
||||
;;
|
||||
|
|
@ -33,87 +30,9 @@
|
|||
;; handler might try to use GUI elements from a different thread, or
|
||||
;; other such things, leading to deadlock.
|
||||
|
||||
(define monitor-owner #f)
|
||||
(define as-entry call-as-atomic)
|
||||
|
||||
;; An exception may be constructed while we're entered:
|
||||
(define entered-err-string-handler
|
||||
(lambda (s n)
|
||||
(as-exit
|
||||
(lambda ()
|
||||
((error-value->string-handler) s n)))))
|
||||
|
||||
(define old-paramz #f)
|
||||
(define old-break-paramz #f)
|
||||
|
||||
(define exited-key (gensym 'as-exit))
|
||||
(define lock-tag (make-continuation-prompt-tag 'lock))
|
||||
|
||||
(define (as-entry f)
|
||||
(cond
|
||||
[(eq? monitor-owner (current-thread))
|
||||
;; Need to increment atomicity level for cooperation with
|
||||
;; freezing speculative computations (in mred/private/wx/common/freeze)
|
||||
(dynamic-wind
|
||||
start-atomic
|
||||
f
|
||||
end-atomic)]
|
||||
[else
|
||||
(with-continuation-mark
|
||||
exited-key
|
||||
#f
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(start-atomic)
|
||||
(set! monitor-owner (current-thread)))
|
||||
(lambda ()
|
||||
(set! old-paramz (current-parameterization))
|
||||
(set! old-break-paramz (current-break-parameterization))
|
||||
(parameterize ([error-value->string-handler entered-err-string-handler])
|
||||
(parameterize-break
|
||||
#f
|
||||
(call-with-exception-handler
|
||||
(lambda (exn)
|
||||
;; Get out of atomic region before letting
|
||||
;; an exception handler work
|
||||
(if (continuation-mark-set-first #f exited-key)
|
||||
exn ; defer to previous exn handler
|
||||
(abort-current-continuation
|
||||
lock-tag
|
||||
(lambda () (raise exn)))))
|
||||
f))))
|
||||
(lambda ()
|
||||
(set! monitor-owner #f)
|
||||
(set! old-paramz #f)
|
||||
(set! old-break-paramz #f)
|
||||
(end-atomic))))
|
||||
lock-tag
|
||||
(lambda (t) (t))))]))
|
||||
|
||||
(define (as-exit f)
|
||||
(unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area for ~e" f))
|
||||
(let ([paramz old-paramz]
|
||||
[break-paramz old-break-paramz])
|
||||
(with-continuation-mark
|
||||
exited-key
|
||||
#t ; disables special exception handling
|
||||
(call-with-parameterization
|
||||
paramz
|
||||
(lambda ()
|
||||
(call-with-break-parameterization
|
||||
break-paramz
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! monitor-owner #f)
|
||||
(end-atomic))
|
||||
f
|
||||
(lambda ()
|
||||
(set! old-paramz paramz)
|
||||
(set! old-break-paramz break-paramz)
|
||||
(start-atomic)
|
||||
(set! monitor-owner (current-thread)))))))))))
|
||||
(define as-exit call-as-nonatomic)
|
||||
|
||||
(define-syntax entry-point
|
||||
(lambda (stx)
|
||||
|
|
@ -126,8 +45,3 @@
|
|||
(syntax (case-lambda
|
||||
[vars (as-entry (lambda () body1 body ...))]
|
||||
...))])))
|
||||
|
||||
;; For debugging:
|
||||
(define (inside-lock?) (eq? monitor-owner (current-thread)))
|
||||
(define (any-lock?) (and monitor-owner #t))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user