From ae649f506b811319f656274906a21b70e037597f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 7 Aug 2010 12:43:19 -0600 Subject: [PATCH] consolidate lock implementation and fix custodian problem original commit: 8ad33f15ab876d83bdc2e38041870f5e29317266 --- collects/mred/private/wx/cocoa/queue.rkt | 2 +- collects/mred/private/wx/common/freeze.rkt | 103 ++++----------------- collects/mred/private/wx/common/queue.rkt | 22 +++-- collects/mred/private/wx/gtk/queue.rkt | 2 +- 4 files changed, 32 insertions(+), 97 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 940acca5..d22745d9 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -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)))))) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index d84cd487..28b3fecc 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -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)])) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e7d5bd63..3f22945e 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -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))) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index ef552b4c..7f633906 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -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)))))))]