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

racket/draw: fix gl-context<%> locking

Browse Source 
The optional arguments for `call-as-current' for `gl-context<%>'
were not implemented, and the locking implementation didn't match
the documentation in other ways.
This commit is contained in:
Matthew Flatt 2012-07-13 07:45:21 -06:00
parent e71cbbe7a9
commit f729c6441c
2 changed files with 56 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/racket/draw/private/gl-context.rkt
View File

@ -15,12 +15,13 @@
(define lock-ch (make-channel))
(define lock-holder-ch (make-channel))
(define (lock-manager)
(define none '#(#f #f #f))
(let loop ()
(sync (handle-evt
lock-ch
(lambda (p)
(let ([t (car p)]
[ch (cdr p)])
(let ([t (vector-ref p 0)]
[ch (vector-ref p 2)])
(let waiting-loop ()
(sync (handle-evt
(thread-dead-evt t)
@ -29,43 +30,52 @@
ch
(lambda (v) (loop)))
(handle-evt
(channel-put-evt lock-holder-ch t)
(channel-put-evt lock-holder-ch p)
(lambda (v) (waiting-loop))))))))
(handle-evt
(channel-put-evt lock-holder-ch #f)
(channel-put-evt lock-holder-ch none)
(lambda (v) (loop))))))
(define manager-t (thread/suspend-to-kill lock-manager))
(define gl-context<%>
(interface ()
[call-as-current (->*m [(-> any)] any)]
[call-as-current (->*m [(-> any)] [evt? any/c] any)]
[ok? (->m boolean?)]
[swap-buffers (->m any)]))
;; Implemented by subclasses:
(define gl-context%
(class* object% (gl-context<%>)
(define/private (with-gl-lock t)
(define/private (with-gl-lock t alternate-evt enable-break?)
(thread-resume manager-t (current-thread))
(if (eq? (current-thread) (channel-get lock-holder-ch))
(define current (channel-get lock-holder-ch))
(if (and (eq? (vector-ref current 0) (current-thread))
(eq? (vector-ref current 1) this))
(t)
((if enable-break? sync/enable-break sync)
(let ([ch (make-channel)])
(handle-evt (channel-put-evt lock-ch (vector (current-thread) this ch))
(lambda (val)
(dynamic-wind
(lambda ()
(channel-put lock-ch (cons (current-thread) ch)))
void
t
(lambda ()
(channel-put ch #t))))))
alternate-evt)))
(define/public (call-as-current t)
(define/public (call-as-current t [alternate-evt never-evt] [enable-breaks? #f])
(with-gl-lock
(lambda ()
(do-call-as-current t))))
(do-call-as-current t))
alternate-evt
enable-breaks?))
(define/public (swap-buffers)
(with-gl-lock
(lambda ()
(do-swap-buffers))))
(do-swap-buffers))
never-evt
#f))
(define/public (ok?) #t)

28
collects/tests/gracket/dc.rktl
View File

@ -569,4 +569,32 @@
;; ----------------------------------------
(let ()
(define config (new gl-config%))
(define bm1 (make-gl-bitmap 100 100 config))
(define bm2 (make-gl-bitmap 100 100 config))
(define dc1 (make-object bitmap-dc% bm1))
(define dc2 (make-object bitmap-dc% bm2))
(define gl1 (send dc1 get-gl-context))
(define gl2 (send dc2 get-gl-context))
(send gl1 call-as-current
(lambda ()
(test 5 'alt (send gl2 call-as-current
(lambda () (error "not in this context!"))
(wrap-evt always-evt (lambda (v) 5))))
(sync
(thread
(lambda ()
(test 8 'thread/alts
(send gl1 call-as-current
(lambda () (error "not in this thread!"))
(wrap-evt always-evt (lambda (v) 8)))))))
(test 8 'reenter (send gl1 call-as-current
(lambda () 8)))))
(with-handlers ([exn? void])
(send gl1 call-as-current (lambda () (error "fail"))))
(test 12 'post-exn (send gl1 call-as-current (lambda () 12))))
;; ----------------------------------------
(report-errs)