suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

consolidate lock implementation and fix custodian problem

Browse Source 
original commit: 8ad33f15ab876d83bdc2e38041870f5e29317266
This commit is contained in:
Matthew Flatt 2010-08-07 12:43:19 -06:00
parent d4de5ceb8e
commit ae649f506b
4 changed files with 32 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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))))))

103
collects/mred/private/wx/common/freeze.rkt
View File

@ -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)]))

22
collects/mred/private/wx/common/queue.rkt
View File

@ -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)))

2
collects/mred/private/wx/gtk/queue.rkt
View File

@ -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)))))))]