132 lines
4.5 KiB
Racket
132 lines
4.5 KiB
Racket
(module lock mzscheme
|
|
(require (prefix wx: "kernel.ss"))
|
|
(provide (protect as-entry
|
|
as-exit
|
|
entry-point
|
|
mk-param))
|
|
|
|
;; ;;;;;;;;;;;;; Thread Safety ;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; When the user creates an object or calls a method, or when the
|
|
;; system invokes a callback, many steps may be required to initialize
|
|
;; or reset fields to maintain invariants. To ensure that other
|
|
;; threads do not call methods during a time when invariants do not
|
|
;; hold, we force all of the following code to be executed in a single
|
|
;; threaded manner, and we temporarily disable breaks. This accompiled
|
|
;; with a single monitor: all entry points into the code use
|
|
;; `entry-point' or `as-entry', and all points with this code that
|
|
;; call back out to user code uses `as-exit'.
|
|
|
|
;; If an exception is raised within an `enter'ed area, control is
|
|
;; moved back outside by the exception handler, and then the exception
|
|
;; is re-raised. The user can't tell that the exception was caught an
|
|
;; re-raised. But without the catch-and-reraise, the user's exception
|
|
;; handler might try to use GUI elements from a different thread,
|
|
;; leading to deadlock.
|
|
|
|
(define monitor-sema (make-semaphore 1))
|
|
(define monitor-owner #f)
|
|
|
|
;; 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))
|
|
(f)]
|
|
[else
|
|
(with-continuation-mark
|
|
exited-key
|
|
#f
|
|
(call-with-continuation-prompt
|
|
(lambda ()
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(wx:in-atomic-region monitor-sema)
|
|
(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)
|
|
(semaphore-post monitor-sema)
|
|
(wx:in-atomic-region #f))))
|
|
lock-tag
|
|
(lambda (t) (t))))]))
|
|
|
|
(define (as-exit f)
|
|
;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area"))
|
|
(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)
|
|
(semaphore-post monitor-sema)
|
|
(wx:in-atomic-region #f))
|
|
f
|
|
(lambda ()
|
|
(set! old-paramz paramz)
|
|
(set! old-break-paramz break-paramz)
|
|
(wx:in-atomic-region monitor-sema)
|
|
(set! monitor-owner (current-thread)))))))))))
|
|
|
|
(define-syntax entry-point
|
|
(lambda (stx)
|
|
(syntax-case stx (lambda case-lambda)
|
|
[(_ (lambda args body1 body ...))
|
|
(syntax (lambda args (as-entry (lambda () body1 body ...))))]
|
|
[(_ (case-lambda [vars body1 body ...] ...))
|
|
(syntax (case-lambda
|
|
[vars (as-entry (lambda () body1 body ...))]
|
|
...))])))
|
|
|
|
(define-syntax mk-param
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ val filter check force-redraw)
|
|
(syntax
|
|
(case-lambda
|
|
[() val]
|
|
[(v) (check v)
|
|
(let ([v2 (filter v)])
|
|
(unless (eq? v2 val)
|
|
(set! val v2)
|
|
(force-redraw)))]))]))))
|
|
|
|
|
|
|